1#!/usr/bin/perl 2 3# Original shell script version: 4# Copyright 1998,1999 Yann Dirson <dirson@debian.org> 5# Perl version: 6# Copyright 1999,2000,2001 by Julian Gilbey <jdg@debian.org> 7# 8# This program is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License, version 2 ONLY, 10# as published by the Free Software Foundation. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16 17use 5.006_000; 18use strict; 19use warnings; 20use Cwd; 21use Dpkg::IPC; 22use File::Copy qw(cp move); 23use File::Basename; 24use File::Spec; 25use File::Path qw/ rmtree /; 26use File::Temp qw/ tempdir tempfile /; 27use Devscripts::Compression; 28use Devscripts::Versort; 29 30# Predeclare functions 31sub wdiff_control_files($$$$$); 32sub process_debc($$); 33sub process_debI($); 34sub mktmpdirs(); 35sub fatal(@); 36 37my $progname = basename($0); 38my $modified_conf_msg; 39my $exit_status = 0; 40my $dummyname = "---DUMMY---"; 41 42my $compression_re = compression_get_file_extension_regex(); 43 44sub usage { 45 print <<"EOF"; 46Usage: $progname [option] 47 or: $progname [option] ... deb1 deb2 48 or: $progname [option] ... changes1 changes2 49 or: $progname [option] ... dsc1 dsc2 50 or: $progname [option] ... --from deb1a deb1b ... --to deb2a deb2b ... 51Valid options are: 52 --no-conf, --noconf 53 Don\'t read devscripts config files; 54 must be the first option given 55 --help, -h Display this message 56 --version, -v Display version and copyright info 57 --move FROM TO, The prefix FROM in first packages has 58 -m FROM TO been renamed TO in the new packages 59 only affects comparing binary packages 60 (multiple permitted) 61 --move-regex FROM TO, The prefix FROM in first packages has 62 been renamed TO in the new packages 63 only affects comparing binary packages 64 (multiple permitted), using regexp substitution 65 --dirs, -d Note changes in directories as well as files 66 --nodirs Do not note changes in directories (default) 67 --nocontrol Skip comparing control files 68 --control Do compare control files 69 --controlfiles FILE,FILE,... 70 Which control files to compare; default is just 71 control; could include preinst, etc, config or 72 ALL to compare all control files present 73 --wp, --wl, --wt Pass the option -p, -l, -t respectively to wdiff 74 (only one should be used) 75 --wdiff-source-control When processing source packages, compare control 76 files as with --control for binary packages 77 --no-wdiff-source-control 78 Do not do so (default) 79 --show-moved Indicate also all files which have moved 80 between packages 81 --noshow-moved Do not also indicate all files which have moved 82 between packages (default) 83 --renamed FROM TO The package formerly called FROM has been 84 renamed TO; only of interest with --show-moved 85 (multiple permitted) 86 --quiet, -q Be quiet if no differences were found 87 --exclude PATTERN Exclude files whose basenames match PATTERN 88 --ignore-space, -w Ignore whitespace in diffs 89 --diffstat Include the result of diffstat before the diff 90 --no-diffstat Do not do so (default) 91 --auto-ver-sort When comparing source packages, ensure the 92 comparison is performed in version order 93 --no-auto-ver-sort Do not do so (default) 94 --unpack-tarballs Unpack tarballs found in the top level source 95 directory (default) 96 --no-unpack-tarballs Do not do so 97 98Default settings modified by devscripts configuration files: 99$modified_conf_msg 100 101Use the diffoscope package for deeper comparisons of .deb files. 102EOF 103} 104 105my $version = <<"EOF"; 106This is $progname, from the Debian devscripts package, version ###VERSION### 107This code is copyright 1999,2000,2001 by Julian Gilbey <jdg\@debian.org>, 108based on original code which is copyright 1998,1999 by 109Yann Dirson <dirson\@debian.org> 110This program comes with ABSOLUTELY NO WARRANTY. 111You are free to redistribute this code under the terms of the 112GNU General Public License, version 2 ONLY. 113EOF 114 115# Start by setting default values 116 117my $debsdir; 118my $debsdir_warning; 119my $ignore_dirs = 1; 120my $compare_control = 1; 121my $controlfiles = 'control'; 122my $show_moved = 0; 123my $wdiff_opt = ''; 124my @diff_opts = (); 125my $show_diffstat = 0; 126my $wdiff_source_control = 0; 127my $auto_ver_sort = 0; 128my $unpack_tarballs = 1; 129 130my $quiet = 0; 131 132# Next, read read configuration files and then command line 133# The next stuff is boilerplate 134 135if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) { 136 $modified_conf_msg = " (no configuration files read)"; 137 shift; 138} else { 139 my @config_files = ('/etc/devscripts.conf', '~/.devscripts'); 140 my %config_vars = ( 141 'DEBDIFF_DIRS' => 'no', 142 'DEBDIFF_CONTROL' => 'yes', 143 'DEBDIFF_CONTROLFILES' => 'control', 144 'DEBDIFF_SHOW_MOVED' => 'no', 145 'DEBDIFF_WDIFF_OPT' => '', 146 'DEBDIFF_SHOW_DIFFSTAT' => 'no', 147 'DEBDIFF_WDIFF_SOURCE_CONTROL' => 'no', 148 'DEBDIFF_AUTO_VER_SORT' => 'no', 149 'DEBDIFF_UNPACK_TARBALLS' => 'yes', 150 'DEBRELEASE_DEBS_DIR' => '..', 151 ); 152 my %config_default = %config_vars; 153 154 my $shell_cmd; 155 # Set defaults 156 foreach my $var (keys %config_vars) { 157 $shell_cmd .= "$var='$config_vars{$var}';\n"; 158 } 159 $shell_cmd .= 'for file in ' . join(" ", @config_files) . "; do\n"; 160 $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n"; 161 # Read back values 162 foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" } 163 my $shell_out = `/bin/bash -c '$shell_cmd'`; 164 @config_vars{ keys %config_vars } = split /\n/, $shell_out, -1; 165 166 # Check validity 167 $config_vars{'DEBDIFF_DIRS'} =~ /^(yes|no)$/ 168 or $config_vars{'DEBDIFF_DIRS'} = 'no'; 169 $config_vars{'DEBDIFF_CONTROL'} =~ /^(yes|no)$/ 170 or $config_vars{'DEBDIFF_CONTROL'} = 'yes'; 171 $config_vars{'DEBDIFF_SHOW_MOVED'} =~ /^(yes|no)$/ 172 or $config_vars{'DEBDIFF_SHOW_MOVED'} = 'no'; 173 $config_vars{'DEBDIFF_SHOW_DIFFSTAT'} =~ /^(yes|no)$/ 174 or $config_vars{'DEBDIFF_SHOW_DIFFSTAT'} = 'no'; 175 $config_vars{'DEBDIFF_WDIFF_SOURCE_CONTROL'} =~ /^(yes|no)$/ 176 or $config_vars{'DEBDIFF_WDIFF_SOURCE_CONTROL'} = 'no'; 177 $config_vars{'DEBDIFF_AUTO_VER_SORT'} =~ /^(yes|no)$/ 178 or $config_vars{'DEBDIFF_AUTO_VER_SORT'} = 'no'; 179 $config_vars{'DEBDIFF_UNPACK_TARBALLS'} =~ /^(yes|no)$/ 180 or $config_vars{'DEBDIFF_UNPACK_TARBALLS'} = 'yes'; 181 # We do not replace this with a default directory to avoid accidentally 182 # installing a broken package 183 $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%/+%/%; 184 $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%(.)/$%$1%; 185 $debsdir_warning 186 = "config file specified DEBRELEASE_DEBS_DIR directory $config_vars{'DEBRELEASE_DEBS_DIR'} does not exist!"; 187 188 foreach my $var (sort keys %config_vars) { 189 if ($config_vars{$var} ne $config_default{$var}) { 190 $modified_conf_msg .= " $var=$config_vars{$var}\n"; 191 } 192 } 193 $modified_conf_msg ||= " (none)\n"; 194 chomp $modified_conf_msg; 195 196 $debsdir = $config_vars{'DEBRELEASE_DEBS_DIR'}; 197 $ignore_dirs = $config_vars{'DEBDIFF_DIRS'} eq 'yes' ? 0 : 1; 198 $compare_control = $config_vars{'DEBDIFF_CONTROL'} eq 'no' ? 0 : 1; 199 $controlfiles = $config_vars{'DEBDIFF_CONTROLFILES'}; 200 $show_moved = $config_vars{'DEBDIFF_SHOW_MOVED'} eq 'yes' ? 1 : 0; 201 $wdiff_opt = $config_vars{'DEBDIFF_WDIFF_OPT'} =~ /^-([plt])$/ ? $1 : ''; 202 $show_diffstat = $config_vars{'DEBDIFF_SHOW_DIFFSTAT'} eq 'yes' ? 1 : 0; 203 $wdiff_source_control 204 = $config_vars{'DEBDIFF_WDIFF_SOURCE_CONTROL'} eq 'yes' ? 1 : 0; 205 $auto_ver_sort = $config_vars{'DEBDIFF_AUTO_VER_SORT'} eq 'yes' ? 1 : 0; 206 $unpack_tarballs 207 = $config_vars{'DEBDIFF_UNPACK_TARBALLS'} eq 'yes' ? 1 : 0; 208 209} 210 211# Are they a pair of debs, changes or dsc files, or a list of debs? 212my $type = ''; 213my @excludes = (); 214my @move = (); 215my %renamed = (); 216my $opt_debsdir; 217 218# handle command-line options 219 220while (@ARGV) { 221 if ($ARGV[0] =~ /^(--help|-h)$/) { usage(); exit 0; } 222 if ($ARGV[0] =~ /^(--version|-v)$/) { print $version; exit 0; } 223 if ($ARGV[0] =~ /^(--move(-regex)?|-m)$/) { 224 fatal 225"Malformed command-line option $ARGV[0]; run $progname --help for more info" 226 unless @ARGV >= 3; 227 228 my $regex = $ARGV[0] eq '--move-regex' ? 1 : 0; 229 shift @ARGV; 230 231 # Ensure from and to values all begin with a slash 232 # dpkg -c produces filenames such as ./usr/lib/filename 233 my $from = shift; 234 my $to = shift; 235 $from =~ s%^\./%/%; 236 $to =~ s%^\./%/%; 237 238 if ($regex) { 239 # quote ':' in the from and to patterns; 240 # used later as a pattern delimiter 241 $from =~ s/:/\\:/g; 242 $to =~ s/:/\\:/g; 243 } 244 push @move, [$regex, $from, $to]; 245 } elsif ($ARGV[0] eq '--renamed') { 246 fatal 247"Malformed command-line option $ARGV[0]; run $progname --help for more info" 248 unless @ARGV >= 3; 249 shift @ARGV; 250 251 my $from = shift; 252 my $to = shift; 253 $renamed{$from} = $to; 254 } elsif ($ARGV[0] eq '--exclude') { 255 fatal 256"Malformed command-line option $ARGV[0]; run $progname --help for more info" 257 unless @ARGV >= 2; 258 shift @ARGV; 259 260 my $exclude = shift; 261 push @excludes, $exclude; 262 } elsif ($ARGV[0] =~ s/^--exclude=//) { 263 my $exclude = shift; 264 push @excludes, $exclude; 265 } elsif ($ARGV[0] eq '--controlfiles') { 266 fatal 267"Malformed command-line option $ARGV[0]; run $progname --help for more info" 268 unless @ARGV >= 2; 269 shift @ARGV; 270 271 $controlfiles = shift; 272 } elsif ($ARGV[0] =~ s/^--controlfiles=//) { 273 $controlfiles = shift; 274 } elsif ($ARGV[0] eq '--debs-dir') { 275 fatal 276"Malformed command-line option $ARGV[0]; run $progname --help for more info" 277 unless @ARGV >= 2; 278 shift @ARGV; 279 280 $opt_debsdir = shift; 281 } elsif ($ARGV[0] =~ s/^--debs-dir=//) { 282 $opt_debsdir = shift; 283 } elsif ($ARGV[0] =~ /^(--dirs|-d)$/) { 284 $ignore_dirs = 0; 285 shift; 286 } elsif ($ARGV[0] eq '--nodirs') { 287 $ignore_dirs = 1; 288 shift; 289 } elsif ($ARGV[0] =~ /^(--quiet|-q)$/) { 290 $quiet = 1; 291 shift; 292 } elsif ($ARGV[0] =~ /^(--show-moved|-s)$/) { 293 $show_moved = 1; 294 shift; 295 } elsif ($ARGV[0] eq '--noshow-moved') { 296 $show_moved = 0; 297 shift; 298 } elsif ($ARGV[0] eq '--nocontrol') { 299 $compare_control = 0; 300 shift; 301 } elsif ($ARGV[0] eq '--control') { 302 $compare_control = 1; 303 shift; 304 } elsif ($ARGV[0] eq '--from') { 305 $type = 'debs'; 306 last; 307 } elsif ($ARGV[0] =~ /^--w([plt])$/) { 308 $wdiff_opt = "-$1"; 309 shift; 310 } elsif ($ARGV[0] =~ /^(--ignore-space|-w)$/) { 311 push @diff_opts, "-w"; 312 shift; 313 } elsif ($ARGV[0] eq '--diffstat') { 314 $show_diffstat = 1; 315 shift; 316 } elsif ($ARGV[0] =~ /^--no-?diffstat$/) { 317 $show_diffstat = 0; 318 shift; 319 } elsif ($ARGV[0] eq '--wdiff-source-control') { 320 $wdiff_source_control = 1; 321 shift; 322 } elsif ($ARGV[0] =~ /^--no-?wdiff-source-control$/) { 323 $wdiff_source_control = 0; 324 shift; 325 } elsif ($ARGV[0] eq '--auto-ver-sort') { 326 $auto_ver_sort = 1; 327 shift; 328 } elsif ($ARGV[0] =~ /^--no-?auto-ver-sort$/) { 329 $auto_ver_sort = 0; 330 shift; 331 } elsif ($ARGV[0] eq '--unpack-tarballs') { 332 $unpack_tarballs = 1; 333 shift; 334 } elsif ($ARGV[0] =~ /^--no-?unpack-tarballs$/) { 335 $unpack_tarballs = 0; 336 shift; 337 } elsif ($ARGV[0] =~ /^--no-?conf$/) { 338 fatal "--no-conf is only acceptable as the first command-line option!"; 339 } 340 341 # Not a recognised option 342 elsif ($ARGV[0] =~ /^-/) { 343 fatal 344"Unrecognised command-line option $ARGV[0]; run $progname --help for more info"; 345 } else { 346 # End of command line options 347 last; 348 } 349} 350 351for my $exclude (@excludes) { 352 if ($exclude =~ m{/}) { 353 print STDERR 354"$progname: warning: --exclude patterns are matched against the basename, so --exclude='$exclude' will not exclude anything\n"; 355 } 356} 357 358my $guessed_version = 0; 359 360if ($opt_debsdir) { 361 $opt_debsdir =~ s%^/+%/%; 362 $opt_debsdir =~ s%(.)/$%$1%; 363 $debsdir_warning = "--debs-dir directory $opt_debsdir does not exist!"; 364 $debsdir = $opt_debsdir; 365} 366 367# If no file is given, assume that we are in a source directory 368# and try to create a diff with the previous version 369if (@ARGV == 0) { 370 my $namepat = qr/[-+0-9a-z.]/i; 371 372 fatal $debsdir_warning unless -d $debsdir; 373 374 fatal "Can't read file: debian/changelog" unless -r "debian/changelog"; 375 open CHL, "debian/changelog"; 376 while (<CHL>) { 377 if (/^(\w$namepat*)\s\((\d+:)?(.+)\)((\s+$namepat+)+)\;\surgency=.+$/) 378 { 379 unshift @ARGV, $debsdir . "/" . $1 . "_" . $3 . ".dsc"; 380 $guessed_version++; 381 } 382 last if $guessed_version > 1; 383 } 384 close CHL; 385} 386 387if (!$type) { 388 # we need 2 deb files or changes files to compare 389 fatal "Need exactly two deb files or changes files to compare" 390 unless @ARGV == 2; 391 392 foreach my $i (0, 1) { 393 fatal "Can't read file: $ARGV[$i]" unless -r $ARGV[$i]; 394 } 395 396 if ($ARGV[0] =~ /\.deb$/) { $type = 'deb'; } 397 elsif ($ARGV[0] =~ /\.udeb$/) { $type = 'deb'; } 398 elsif ($ARGV[0] =~ /\.changes$/) { $type = 'changes'; } 399 elsif ($ARGV[0] =~ /\.dsc$/) { $type = 'dsc'; } 400 else { 401 fatal 402"Could not recognise files; the names should end .deb, .udeb, .changes or .dsc"; 403 } 404 if ($ARGV[1] !~ /\.$type$/ && ($type ne 'deb' || $ARGV[1] !~ /\.udeb$/)) { 405 fatal 406"The two filenames must have the same suffix, either .deb, .udeb, .changes or .dsc"; 407 } 408} 409 410# We collect up the individual deb information in the hashes 411# %debs1 and %debs2, each key of which is a .deb name and each value is 412# a list ref. Note we need to use our, not my, as we will be symbolically 413# referencing these variables 414my @CommonDebs = (); 415my @singledeb; 416our ( 417 %debs1, %debs2, %files1, %files2, @D1, 418 @D2, $dir1, $dir2, %DebPaths1, %DebPaths2 419); 420 421if ($type eq 'deb') { 422 no strict 'refs'; 423 foreach my $i (1, 2) { 424 my $deb = shift; 425 my ($debc, $debI) = ('', ''); 426 my %dpkg_env = (LC_ALL => 'C'); 427 eval { 428 spawn( 429 exec => ['dpkg-deb', '-c', $deb], 430 env => \%dpkg_env, 431 to_string => \$debc, 432 wait_child => 1 433 ); 434 }; 435 if ($@) { 436 fatal "dpkg-deb -c $deb failed!"; 437 } 438 439 eval { 440 spawn( 441 exec => ['dpkg-deb', '-I', $deb], 442 env => \%dpkg_env, 443 to_string => \$debI, 444 wait_child => 1 445 ); 446 }; 447 if ($@) { 448 fatal "dpkg-deb -I $deb failed!"; 449 } 450 # Store the name for later 451 $singledeb[$i] = $deb; 452 # get package name itself 453 $deb =~ s,.*/,,; 454 $deb =~ s/_.*//; 455 @{"D$i"} = @{ process_debc($debc, $i) }; 456 push @{"D$i"}, @{ process_debI($debI) }; 457 } 458} elsif ($type eq 'changes' or $type eq 'debs') { 459 # Have to parse .changes files or remaining arguments 460 my $pwd = cwd; 461 foreach my $i (1, 2) { 462 my (@debs) = (); 463 if ($type eq 'debs') { 464 if (@ARGV < 2) { 465 # Oops! There should be at least --from|--to deb ... 466 fatal 467"Missing .deb names or missing --to! (Run debdiff -h for help)\n"; 468 } 469 shift; # get rid of --from or --to 470 while (@ARGV and $ARGV[0] ne '--to') { 471 push @debs, shift; 472 } 473 474 # Is there only one .deb listed? 475 if (@debs == 1) { 476 $singledeb[$i] = $debs[0]; 477 } 478 } else { 479 my $changes = shift; 480 open CHANGES, $changes 481 or fatal "Couldn't open $changes: $!"; 482 my $infiles = 0; 483 while (<CHANGES>) { 484 last if $infiles and /^[^ ]/; 485 /^Files:/ and $infiles = 1, next; 486 next unless $infiles; 487 if (/ (\S*.u?deb)$/) { 488 my $file = $1; 489 $file !~ m,[/\x00], 490 or fatal "File name contains invalid characters: $file"; 491 push @debs, dirname($changes) . '/' . $file; 492 } 493 } 494 close CHANGES 495 or fatal "Problem reading $changes: $!"; 496 497 # Is there only one .deb listed? 498 if (@debs == 1) { 499 $singledeb[$i] = $debs[0]; 500 } 501 } 502 503 foreach my $deb (@debs) { 504 no strict 'refs'; 505 fatal "Can't read file: $deb" unless -r $deb; 506 my ($debc, $debI) = ('', ''); 507 my %dpkg_env = (LC_ALL => 'C'); 508 eval { 509 spawn( 510 exec => ['dpkg-deb', '-c', $deb], 511 to_string => \$debc, 512 env => \%dpkg_env, 513 wait_child => 1 514 ); 515 }; 516 if ($@) { 517 fatal "dpkg-deb -c $deb failed!"; 518 } 519 eval { 520 spawn( 521 exec => ['dpkg-deb', '-I', $deb], 522 to_string => \$debI, 523 env => \%dpkg_env, 524 wait_child => 1 525 ); 526 }; 527 if ($@) { 528 fatal "dpkg-deb -I $deb failed!"; 529 } 530 my $debpath = $deb; 531 # get package name itself 532 $deb =~ s,.*/,,; 533 $deb =~ s/_.*//; 534 $deb = $renamed{$deb} if $i == 1 and exists $renamed{$deb}; 535 if (exists ${"debs$i"}{$deb}) { 536 warn 537"Same package name appears more than once (possibly due to renaming): $deb\n"; 538 } else { 539 ${"debs$i"}{$deb} = 1; 540 } 541 ${"DebPaths$i"}{$deb} = $debpath; 542 foreach my $file (@{ process_debc($debc, $i) }) { 543 ${"files$i"}{$file} ||= ""; 544 ${"files$i"}{$file} .= "$deb:"; 545 } 546 foreach my $control (@{ process_debI($debI) }) { 547 ${"files$i"}{$control} ||= ""; 548 ${"files$i"}{$control} .= "$deb:"; 549 } 550 } 551 no strict 'refs'; 552 @{"D$i"} = keys %{"files$i"}; 553 # Go back again 554 chdir $pwd or fatal "Couldn't chdir $pwd: $!"; 555 } 556} elsif ($type eq 'dsc') { 557 # Compare source packages 558 my $pwd = cwd; 559 560 my (@origs, @diffs, @dscs, @dscformats, @versions); 561 foreach my $i (1, 2) { 562 my $dsc = shift; 563 chdir dirname($dsc) 564 or fatal "Couldn't chdir ", dirname($dsc), ": $!"; 565 566 $dscs[$i] = cwd() . '/' . basename($dsc); 567 568 open DSC, basename($dsc) or fatal "Couldn't open $dsc: $!"; 569 570 my $infiles = 0; 571 while (<DSC>) { 572 if (/^Files:/) { 573 $infiles = 1; 574 next; 575 } elsif (/^Format: (.*)$/) { 576 $dscformats[$i] = $1; 577 } elsif (/^Version: (.*)$/) { 578 $versions[$i - 1] = [$1, $i]; 579 } 580 next unless $infiles; 581 last if /^\s*$/; 582 last if /^[-\w]+:/; # don't expect this, but who knows? 583 chomp; 584 585 # This had better match 586 if (/^\s+[0-9a-f]{32}\s+\d+\s+(\S+)$/) { 587 my $file = $1; 588 $file !~ m,[/\x00], 589 or fatal "File name contains invalid characters: $file"; 590 if ($file =~ /\.diff\.gz$/) { 591 $diffs[$i] = cwd() . '/' . $file; 592 } elsif ($file =~ /((?:\.orig)?\.tar\.$compression_re|\.git)$/) 593 { 594 $origs[$i] = $file; 595 } 596 } else { 597 warn "Unrecognised file line in .dsc:\n$_\n"; 598 } 599 } 600 601 close DSC or fatal "Problem closing $dsc: $!"; 602 # Go back again 603 chdir $pwd or fatal "Couldn't chdir $pwd: $!"; 604 } 605 606 @versions = Devscripts::Versort::versort(@versions); 607 # If the versions are currently out of order, should we swap them? 608 if ( $auto_ver_sort 609 and !$guessed_version 610 and $versions[0][1] == 1 611 and $versions[0][0] ne $versions[1][0]) { 612 foreach my $var ((\@origs, \@diffs, \@dscs, \@dscformats)) { 613 my $temp = @{$var}[1]; 614 @{$var}[1] = @{$var}[2]; 615 @{$var}[2] = $temp; 616 } 617 } 618 619 # Do we have interdiff? 620 system("command -v interdiff >/dev/null 2>&1"); 621 my $use_interdiff = ($? == 0) ? 1 : 0; 622 system("command -v diffstat >/dev/null 2>&1"); 623 my $have_diffstat = ($? == 0) ? 1 : 0; 624 system("command -v wdiff >/dev/null 2>&1"); 625 my $have_wdiff = ($? == 0) ? 1 : 0; 626 627 my ($fh, $filename) = tempfile( 628 "debdiffXXXXXX", 629 SUFFIX => ".diff", 630 DIR => File::Spec->tmpdir, 631 UNLINK => 1 632 ); 633 634 # When wdiffing source control files we always fully extract both source 635 # packages as it's the easiest way of getting the debian/control file, 636 # particularly if the orig tar ball contains one which is patched in the 637 # diffs 638 if ( $origs[1] eq $origs[2] 639 and defined $diffs[1] 640 and defined $diffs[2] 641 and scalar(@excludes) == 0 642 and $use_interdiff 643 and !$wdiff_source_control) { 644 # same orig tar ball, interdiff exists and not wdiffing 645 646 my $tmpdir = tempdir(CLEANUP => 1); 647 eval { 648 spawn( 649 exec => ['interdiff', '-z', @diff_opts, $diffs[1], $diffs[2]], 650 to_file => $filename, 651 wait_child => 1, 652 # Make interdiff put its tempfiles in $tmpdir, so they're 653 # automatically cleaned up 654 env => { TMPDIR => $tmpdir }); 655 }; 656 657 # If interdiff fails for some reason, we'll fall back to our manual 658 # diffing. 659 unless ($@) { 660 if ($have_diffstat and $show_diffstat) { 661 my $header 662 = "diffstat for " 663 . basename($diffs[1]) . " " 664 . basename($diffs[2]) . "\n\n"; 665 $header =~ s/\.diff\.gz//g; 666 print $header; 667 spawn( 668 exec => ['diffstat', $filename], 669 wait_child => 1 670 ); 671 print "\n"; 672 } 673 674 if (-s $filename) { 675 open(INTERDIFF, '<', $filename); 676 while (<INTERDIFF>) { 677 print $_; 678 } 679 close INTERDIFF; 680 681 $exit_status = 1; 682 } 683 exit $exit_status; 684 } 685 } 686 687 # interdiff ran and failed, or any other situation 688 if (!$use_interdiff) { 689 warn 690"Warning: You do not seem to have interdiff (in the patchutils package)\ninstalled; this program would use it if it were available.\n"; 691 } 692 # possibly different orig tarballs, or no interdiff installed, 693 # or wdiffing debian/control 694 our ($sdir1, $sdir2); 695 mktmpdirs(); 696 for my $i (1, 2) { 697 no strict 'refs'; 698 my @opts = ('-x'); 699 push(@opts, '--skip-patches') if $dscformats[$i] eq '3.0 (quilt)'; 700 my $diri = ${"dir$i"}; 701 eval { 702 spawn( 703 exec => ['dpkg-source', @opts, $dscs[$i]], 704 to_file => '/dev/null', 705 chdir => $diri, 706 wait_child => 1 707 ); 708 }; 709 if ($@) { 710 my $dir = dirname $dscs[1] if $i == 2; 711 $dir = dirname $dscs[2] if $i == 1; 712 cp "$dir/$origs[$i]", 713 $diri || fatal "copy $dir/$origs[$i] $diri: $!"; 714 my $dscx = basename $dscs[$i]; 715 cp $diffs[$i], $diri || fatal "copy $diffs[$i] $diri: $!"; 716 cp $dscs[$i], $diri || fatal "copy $dscs[$i] $diri: $!"; 717 spawn( 718 exec => ['dpkg-source', @opts, $dscx], 719 to_file => '/dev/null', 720 chdir => $diri, 721 wait_child => 1 722 ); 723 } 724 opendir DIR, $diri; 725 while ($_ = readdir(DIR)) { 726 next if $_ eq '.' || $_ eq '..' || !-d "$diri/$_"; 727 ${"sdir$i"} = $_; 728 last; 729 } 730 closedir(DIR); 731 my $sdiri = ${"sdir$i"}; 732 733# also unpack tarballs found in the top level source directory so we can compare their contents too 734 next unless $unpack_tarballs; 735 opendir DIR, $diri . '/' . $sdiri; 736 737 my $tarballs = 1; 738 while ($_ = readdir(DIR)) { 739 my $unpacked = "=unpacked-tar" . $tarballs . "="; 740 my $filename = $_; 741 if ($filename =~ s/\.tar\.$compression_re$//) { 742 my $comp = compression_guess_from_filename($_); 743 $tarballs++; 744 spawn( 745 exec => ['tar', "--$comp", '-xf', $_], 746 to_file => '/dev/null', 747 wait_child => 1, 748 chdir => "$diri/$sdiri", 749 nocheck => 1 750 ); 751 if (-d "$diri/$sdiri/$filename") { 752 move "$diri/$sdiri/$filename", "$diri/$sdiri/$unpacked"; 753 } 754 } 755 } 756 closedir(DIR); 757 } 758 759 my @command = ("diff", "-Nru", @diff_opts); 760 for my $exclude (@excludes) { 761 push @command, ("--exclude", $exclude); 762 } 763 push @command, ("$dir1/$sdir1", "$dir2/$sdir2"); 764 765# Execute diff and remove the common prefixes $dir1/$dir2, so the patch can be used with -p1, 766# as if when interdiff would have been used: 767 spawn( 768 exec => \@command, 769 to_file => $filename, 770 wait_child => 1, 771 nocheck => 1 772 ); 773 774 if ($have_diffstat and $show_diffstat) { 775 print "diffstat for $sdir1 $sdir2\n\n"; 776 spawn( 777 exec => ['diffstat', $filename], 778 wait_child => 1 779 ); 780 print "\n"; 781 } 782 783 if ($have_wdiff and $wdiff_source_control) { 784 # Abuse global variables slightly to create some temporary directories 785 my $tempdir1 = $dir1; 786 my $tempdir2 = $dir2; 787 mktmpdirs(); 788 our $wdiffdir1 = $dir1; 789 our $wdiffdir2 = $dir2; 790 $dir1 = $tempdir1; 791 $dir2 = $tempdir2; 792 our @cf; 793 794 if ($controlfiles eq 'ALL') { 795 @cf = ('control'); 796 } else { 797 @cf = split /,/, $controlfiles; 798 } 799 800 no strict 'refs'; 801 for my $i (1, 2) { 802 foreach my $file (@cf) { 803 cp ${"dir$i"} . '/' . ${"sdir$i"} . "/debian/$file", 804 ${"wdiffdir$i"}; 805 } 806 } 807 use strict 'refs'; 808 809 # We don't support "ALL" for source packages as that would 810 # wdiff debian/* 811 $exit_status = wdiff_control_files($wdiffdir1, $wdiffdir2, $dummyname, 812 $controlfiles eq 'ALL' ? 'control' : $controlfiles, $exit_status); 813 print "\n"; 814 815 # Clean up 816 rmtree([$wdiffdir1, $wdiffdir2]); 817 } 818 819 if (!-f $filename) { 820 fatal "Creation of diff file $filename failed!"; 821 } elsif (-s $filename) { 822 open(DIFF, '<', $filename) 823 or fatal "Opening diff file $filename failed!"; 824 825 while (<DIFF>) { 826 s/^--- $dir1\//--- /; 827 s/^\+\+\+ $dir2\//+++ /; 828 s/^(diff .*) $dir1\/\Q$sdir1\E/$1 $sdir1/; 829 s/^(diff .*) $dir2\/\Q$sdir2\E/$1 $sdir2/; 830 print; 831 } 832 close DIFF; 833 834 $exit_status = 1; 835 } 836 837 exit $exit_status; 838} else { 839 fatal "Internal error: \$type = $type unrecognised"; 840} 841 842# Compare 843# Start by a piece of common code to set up the @CommonDebs list and the like 844 845my (@deblosses, @debgains); 846 847{ 848 my %debs; 849 grep $debs{$_}--, keys %debs1; 850 grep $debs{$_}++, keys %debs2; 851 852 @deblosses = sort grep $debs{$_} < 0, keys %debs; 853 @debgains = sort grep $debs{$_} > 0, keys %debs; 854 @CommonDebs = sort grep $debs{$_} == 0, keys %debs; 855} 856 857if ($show_moved and $type ne 'deb') { 858 if (@debgains) { 859 my $msg 860 = "Warning: these package names were in the second list but not in the first:"; 861 print $msg, "\n", '-' x length $msg, "\n"; 862 print join("\n", @debgains), "\n\n"; 863 } 864 865 if (@deblosses) { 866 print "\n" if @debgains; 867 my $msg 868 = "Warning: these package names were in the first list but not in the second:"; 869 print $msg, "\n", '-' x length $msg, "\n"; 870 print join("\n", @deblosses), "\n\n"; 871 } 872 873 # We start by determining which files are in the first set of debs, the 874 # second set of debs or both. 875 my %files; 876 grep $files{$_}--, @D1; 877 grep $files{$_}++, @D2; 878 879 my @old = sort grep $files{$_} < 0, keys %files; 880 my @new = sort grep $files{$_} > 0, keys %files; 881 my @same = sort grep $files{$_} == 0, keys %files; 882 883 # We store any changed files in a hash of hashes %changes, where 884 # $changes{$from}{$to} is an array of files which have moved 885 # from package $from to package $to; $from or $to is '-' if 886 # the files have appeared or disappeared 887 888 my %changes; 889 my @funny; # for storing changed files which appear in multiple debs 890 891 foreach my $file (@old) { 892 my @firstdebs = split /:/, $files1{$file}; 893 foreach my $firstdeb (@firstdebs) { 894 push @{ $changes{$firstdeb}{'-'} }, $file; 895 } 896 } 897 898 foreach my $file (@new) { 899 my @seconddebs = split /:/, $files2{$file}; 900 foreach my $seconddeb (@seconddebs) { 901 push @{ $changes{'-'}{$seconddeb} }, $file; 902 } 903 } 904 905 foreach my $file (@same) { 906 # Are they identical? 907 next if $files1{$file} eq $files2{$file}; 908 909 # Ah, they're not the same. If the file has moved from one deb 910 # to another, we'll put a note in that pair. But if the file 911 # was in more than one deb or ends up in more than one deb, we'll 912 # list it separately. 913 my @fdebs1 = split(/:/, $files1{$file}); 914 my @fdebs2 = split(/:/, $files2{$file}); 915 916 if (@fdebs1 == 1 && @fdebs2 == 1) { 917 push @{ $changes{ $fdebs1[0] }{ $fdebs2[0] } }, $file; 918 } else { 919 # two packages to one or vice versa, or something like that 920 push @funny, [$file, \@fdebs1, \@fdebs2]; 921 } 922 } 923 924 # This is not a very efficient way of doing things if there are 925 # lots of debs involved, but since that is highly unlikely, it 926 # shouldn't be much of an issue 927 my $changed = 0; 928 929 for my $deb1 (sort(keys %debs1), '-') { 930 next unless exists $changes{$deb1}; 931 for my $deb2 ('-', sort keys %debs2) { 932 next unless exists $changes{$deb1}{$deb2}; 933 my $msg; 934 if (!$changed) { 935 print 936"[The following lists of changes regard files as different if they have\ndifferent names, permissions or owners.]\n\n"; 937 } 938 if ($deb1 eq '-') { 939 $msg 940 = "New files in second set of .debs, found in package $deb2"; 941 } elsif ($deb2 eq '-') { 942 $msg 943 = "Files only in first set of .debs, found in package $deb1"; 944 } else { 945 $msg = "Files moved from package $deb1 to package $deb2"; 946 } 947 print $msg, "\n", '-' x length $msg, "\n"; 948 print join("\n", @{ $changes{$deb1}{$deb2} }), "\n\n"; 949 $changed = 1; 950 } 951 } 952 953 if (@funny) { 954 my $msg 955 = "Files moved or copied from at least TWO packages or to at least TWO packages"; 956 print $msg, "\n", '-' x length $msg, "\n"; 957 for my $funny (@funny) { 958 print $$funny[0], "\n"; # filename and details 959 print "From package", (@{ $$funny[1] } > 1 ? "s" : ""), ": "; 960 print join(", ", @{ $$funny[1] }), "\n"; 961 print "To package", (@{ $$funny[2] } > 1 ? "s" : ""), ": "; 962 print join(", ", @{ $$funny[2] }), "\n"; 963 } 964 $changed = 1; 965 } 966 967 if (!$quiet && !$changed) { 968 print 969 "File lists identical on package level (after any substitutions)\n"; 970 } 971 $exit_status = 1 if $changed; 972} else { 973 my %files; 974 grep $files{$_}--, @D1; 975 grep $files{$_}++, @D2; 976 977 my @losses = sort grep $files{$_} < 0, keys %files; 978 my @gains = sort grep $files{$_} > 0, keys %files; 979 980 if (@losses == 0 && @gains == 0) { 981 print "File lists identical (after any substitutions)\n" 982 unless $quiet; 983 } else { 984 print 985"[The following lists of changes regard files as different if they have\ndifferent names, permissions or owners.]\n\n"; 986 } 987 988 if (@gains) { 989 my $msg; 990 if ($type eq 'debs') { 991 $msg = "Files in second set of .debs but not in first"; 992 } else { 993 $msg = sprintf "Files in second .%s but not in first", 994 $type eq 'deb' ? 'deb' : 'changes'; 995 } 996 print $msg, "\n", '-' x length $msg, "\n"; 997 print join("\n", @gains), "\n"; 998 $exit_status = 1; 999 } 1000 1001 if (@losses) { 1002 print "\n" if @gains; 1003 my $msg; 1004 if ($type eq 'debs') { 1005 $msg = "Files in first set of .debs but not in second"; 1006 } else { 1007 $msg = sprintf "Files in first .%s but not in second", 1008 $type eq 'deb' ? 'deb' : 'changes'; 1009 } 1010 print $msg, "\n", '-' x length $msg, "\n"; 1011 print join("\n", @losses), "\n"; 1012 $exit_status = 1; 1013 } 1014} 1015 1016# We compare the control files (at least the dependency fields) 1017if (defined $singledeb[1] and defined $singledeb[2]) { 1018 @CommonDebs = ($dummyname); 1019 $DebPaths1{$dummyname} = $singledeb[1]; 1020 $DebPaths2{$dummyname} = $singledeb[2]; 1021} 1022 1023exit $exit_status unless (@CommonDebs > 0) and $compare_control; 1024 1025unless (system("command -v wdiff >/dev/null 2>&1") == 0) { 1026 warn "Can't compare control files; wdiff package not installed\n"; 1027 exit $exit_status; 1028} 1029 1030for my $debname (@CommonDebs) { 1031 no strict 'refs'; 1032 mktmpdirs(); 1033 1034 for my $i (1, 2) { 1035 my $debpath = "${\"DebPaths$i\"}{$debname}"; 1036 my $diri = ${"dir$i"}; 1037 eval { 1038 spawn( 1039 exec => ['dpkg-deb', '-e', $debpath, $diri], 1040 wait_child => 1 1041 ); 1042 }; 1043 if ($@) { 1044 my $msg = "dpkg-deb -e ${\"DebPaths$i\"}{$debname} failed!"; 1045 rmtree([$dir1, $dir2]); 1046 fatal $msg; 1047 } 1048 } 1049 1050 use strict 'refs'; 1051 $exit_status = wdiff_control_files($dir1, $dir2, $debname, $controlfiles, 1052 $exit_status); 1053 1054 # Clean up 1055 rmtree([$dir1, $dir2]); 1056} 1057 1058exit $exit_status; 1059 1060###### Subroutines 1061 1062# This routine takes the output of dpkg-deb -c and returns 1063# a processed listref 1064sub process_debc($$) { 1065 my ($data, $number) = @_; 1066 my (@filelist); 1067 1068 # Format of dpkg-deb -c output: 1069 # permissions owner/group size date time name ['->' link destination] 1070 $data =~ s/^(\S+)\s+(\S+)\s+(\S+\s+){3}/$1 $2 /mg; 1071 $data =~ s, \./, /,mg; 1072 @filelist = grep !m| /$|, split /\n/, $data; # don't bother keeping '/' 1073 1074 # Are we keeping directory names in our filelists? 1075 if ($ignore_dirs) { 1076 @filelist = grep !m|/$|, @filelist; 1077 } 1078 1079 # Do the "move" substitutions in the order received for the first debs 1080 if ($number == 1 and @move) { 1081 my @split_filelist 1082 = map { m/^(\S+) (\S+) (.*)/ && [$1, $2, $3] } @filelist; 1083 for my $move (@move) { 1084 my $regex = $$move[0]; 1085 my $from = $$move[1]; 1086 my $to = $$move[2]; 1087 map { 1088 if ($regex) { eval "\$\$_[2] =~ s:$from:$to:g"; } 1089 else { $$_[2] =~ s/\Q$from\E/$to/; } 1090 } @split_filelist; 1091 } 1092 @filelist = map { "$$_[0] $$_[1] $$_[2]" } @split_filelist; 1093 } 1094 1095 return \@filelist; 1096} 1097 1098# This does the same for dpkg-deb -I 1099sub process_debI($) { 1100 my ($data) = @_; 1101 my (@filelist); 1102 1103 # Format of dpkg-deb -c output: 1104 # 2 (always?) header lines 1105 # nnnn bytes, nnn lines [*] filename [interpreter] 1106 # Package: ... 1107 # rest of control file 1108 1109 foreach (split /\n/, $data) { 1110 last if /^Package:/; 1111 next unless /^\s+\d+\s+bytes,\s+\d+\s+lines\s+(\*)?\s+([\-\w]+)/; 1112 my $control = $2; 1113 my $perms = ($1 ? "-rwxr-xr-x" : "-rw-r--r--"); 1114 push @filelist, "$perms root/root DEBIAN/$control"; 1115 } 1116 1117 return \@filelist; 1118} 1119 1120sub wdiff_control_files($$$$$) { 1121 my ($dir1, $dir2, $debname, $controlfiles, $origstatus) = @_; 1122 return 1123 unless defined $dir1 1124 and defined $dir2 1125 and defined $debname 1126 and defined $controlfiles; 1127 my @cf; 1128 my $status = $origstatus; 1129 if ($controlfiles eq 'ALL') { 1130 # only need to list one directory as we are only comparing control 1131 # files in both packages 1132 @cf = grep { !/md5sums/ } map { basename($_); } glob("$dir1/*"); 1133 } else { 1134 @cf = split /,/, $controlfiles; 1135 } 1136 1137 foreach my $cf (@cf) { 1138 next unless -f "$dir1/$cf" and -f "$dir2/$cf"; 1139 if ($cf eq 'control' or $cf eq 'conffiles' or $cf eq 'shlibs') { 1140 for my $file ("$dir1/$cf", "$dir2/$cf") { 1141 my ($fd, @hdrs); 1142 open $fd, '<', $file or fatal "Cannot read $file: $!"; 1143 while (<$fd>) { 1144 if (/^\s/ and @hdrs > 0) { 1145 $hdrs[$#hdrs] .= $_; 1146 } else { 1147 push @hdrs, $_; 1148 } 1149 } 1150 close $fd; 1151 chmod 0644, $file; 1152 open $fd, '>', $file or fatal "Cannot write $file: $!"; 1153 print $fd sort @hdrs; 1154 close $fd; 1155 } 1156 } 1157 my $usepkgname = $debname eq $dummyname ? "" : " of package $debname"; 1158 my @opts = ('-n'); 1159 push @opts, $wdiff_opt if $wdiff_opt; 1160 my ($wdiff, $wdiff_error) = ('', ''); 1161 spawn( 1162 exec => ['wdiff', @opts, "$dir1/$cf", "$dir2/$cf"], 1163 to_string => \$wdiff, 1164 error_to_string => \$wdiff_error, 1165 wait_child => 1, 1166 nocheck => 1 1167 ); 1168 if ($? && ($? >> 8) != 1) { 1169 print "$wdiff_error\n"; 1170 warn "wdiff failed\n"; 1171 } else { 1172 if (!$?) { 1173 if (!$quiet) { 1174 print 1175"\nNo differences were encountered between the $cf files$usepkgname\n"; 1176 } 1177 } elsif ($wdiff_opt) { 1178 # Don't try messing with control codes 1179 my $msg = ucfirst($cf) . " files$usepkgname: wdiff output"; 1180 print "\n", $msg, "\n", '-' x length $msg, "\n"; 1181 print $wdiff; 1182 $status = 1; 1183 } else { 1184 my @output; 1185 @output = split /\n/, $wdiff; 1186 @output = grep /(\[-|\{\+)/, @output; 1187 my $msg = ucfirst($cf) 1188 . " files$usepkgname: lines which differ (wdiff format)"; 1189 print "\n", $msg, "\n", '-' x length $msg, "\n"; 1190 print join("\n", @output), "\n"; 1191 $status = 1; 1192 } 1193 } 1194 } 1195 1196 return $status; 1197} 1198 1199sub mktmpdirs () { 1200 no strict 'refs'; 1201 1202 for my $i (1, 2) { 1203 ${"dir$i"} = tempdir(CLEANUP => 1); 1204 fatal "Couldn't create temp directory" 1205 if not defined ${"dir$i"}; 1206 } 1207} 1208 1209sub fatal(@) { 1210 my ($pack, $file, $line); 1211 ($pack, $file, $line) = caller(); 1212 (my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d; 1213 $msg =~ s/\n\n$/\n/; 1214 die $msg; 1215} 1216