diff options
Diffstat (limited to 'scripts/debdiff.pl')
| -rwxr-xr-x | scripts/debdiff.pl | 1208 |
1 files changed, 1208 insertions, 0 deletions
diff --git a/scripts/debdiff.pl b/scripts/debdiff.pl new file mode 100755 index 0000000..c6900c5 --- /dev/null +++ b/scripts/debdiff.pl @@ -0,0 +1,1208 @@ +#!/usr/bin/perl + +# Original shell script version: +# Copyright 1998,1999 Yann Dirson <dirson@debian.org> +# Perl version: +# Copyright 1999,2000,2001 by Julian Gilbey <jdg@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License, version 2 ONLY, +# as published by the Free Software Foundation. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +use 5.006_000; +use strict; +use warnings; +use Cwd; +use Dpkg::IPC; +use File::Copy qw(cp move); +use File::Basename; +use File::Spec; +use File::Path qw/ rmtree /; +use File::Temp qw/ tempdir tempfile /; +use Devscripts::Compression; +use Devscripts::Versort; + +# Predeclare functions +sub wdiff_control_files($$$$$); +sub process_debc($$); +sub process_debI($); +sub mktmpdirs(); +sub fatal(@); + +my $progname = basename($0); +my $modified_conf_msg; +my $exit_status = 0; +my $dummyname = "---DUMMY---"; + +my $compression_re = compression_get_file_extension_regex(); + +sub usage { + print <<"EOF"; +Usage: $progname [option] + or: $progname [option] ... deb1 deb2 + or: $progname [option] ... changes1 changes2 + or: $progname [option] ... dsc1 dsc2 + or: $progname [option] ... --from deb1a deb1b ... --to deb2a deb2b ... +Valid options are: + --no-conf, --noconf + Don\'t read devscripts config files; + must be the first option given + --help, -h Display this message + --version, -v Display version and copyright info + --move FROM TO, The prefix FROM in first packages has + -m FROM TO been renamed TO in the new packages + only affects comparing binary packages + (multiple permitted) + --move-regex FROM TO, The prefix FROM in first packages has + been renamed TO in the new packages + only affects comparing binary packages + (multiple permitted), using regexp substitution + --dirs, -d Note changes in directories as well as files + --nodirs Do not note changes in directories (default) + --nocontrol Skip comparing control files + --control Do compare control files + --controlfiles FILE,FILE,... + Which control files to compare; default is just + control; could include preinst, etc, config or + ALL to compare all control files present + --wp, --wl, --wt Pass the option -p, -l, -t respectively to wdiff + (only one should be used) + --wdiff-source-control When processing source packages, compare control + files as with --control for binary packages + --no-wdiff-source-control + Do not do so (default) + --show-moved Indicate also all files which have moved + between packages + --noshow-moved Do not also indicate all files which have moved + between packages (default) + --renamed FROM TO The package formerly called FROM has been + renamed TO; only of interest with --show-moved + (multiple permitted) + --quiet, -q Be quiet if no differences were found + --exclude PATTERN Exclude files that match PATTERN + --ignore-space, -w Ignore whitespace in diffs + --diffstat Include the result of diffstat before the diff + --no-diffstat Do not do so (default) + --auto-ver-sort When comparing source packages, ensure the + comparison is performed in version order + --no-auto-ver-sort Do not do so (default) + --unpack-tarballs Unpack tarballs found in the top level source + directory (default) + --no-unpack-tarballs Do not do so + +Default settings modified by devscripts configuration files: +$modified_conf_msg + +Use the diffoscope package for deeper comparisons of .deb files. +EOF +} + +my $version = <<"EOF"; +This is $progname, from the Debian devscripts package, version ###VERSION### +This code is copyright 1999,2000,2001 by Julian Gilbey <jdg\@debian.org>, +based on original code which is copyright 1998,1999 by +Yann Dirson <dirson\@debian.org> +This program comes with ABSOLUTELY NO WARRANTY. +You are free to redistribute this code under the terms of the +GNU General Public License, version 2 ONLY. +EOF + +# Start by setting default values + +my $debsdir; +my $debsdir_warning; +my $ignore_dirs = 1; +my $compare_control = 1; +my $controlfiles = 'control'; +my $show_moved = 0; +my $wdiff_opt = ''; +my @diff_opts = (); +my $show_diffstat = 0; +my $wdiff_source_control = 0; +my $auto_ver_sort = 0; +my $unpack_tarballs = 1; + +my $quiet = 0; + +# Next, read read configuration files and then command line +# The next stuff is boilerplate + +if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) { + $modified_conf_msg = " (no configuration files read)"; + shift; +} else { + my @config_files = ('/etc/devscripts.conf', '~/.devscripts'); + my %config_vars = ( + 'DEBDIFF_DIRS' => 'no', + 'DEBDIFF_CONTROL' => 'yes', + 'DEBDIFF_CONTROLFILES' => 'control', + 'DEBDIFF_SHOW_MOVED' => 'no', + 'DEBDIFF_WDIFF_OPT' => '', + 'DEBDIFF_SHOW_DIFFSTAT' => 'no', + 'DEBDIFF_WDIFF_SOURCE_CONTROL' => 'no', + 'DEBDIFF_AUTO_VER_SORT' => 'no', + 'DEBDIFF_UNPACK_TARBALLS' => 'yes', + 'DEBRELEASE_DEBS_DIR' => '..', + ); + my %config_default = %config_vars; + + my $shell_cmd; + # Set defaults + foreach my $var (keys %config_vars) { + $shell_cmd .= "$var='$config_vars{$var}';\n"; + } + $shell_cmd .= 'for file in ' . join(" ", @config_files) . "; do\n"; + $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n"; + # Read back values + foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" } + my $shell_out = `/bin/bash -c '$shell_cmd'`; + @config_vars{ keys %config_vars } = split /\n/, $shell_out, -1; + + # Check validity + $config_vars{'DEBDIFF_DIRS'} =~ /^(yes|no)$/ + or $config_vars{'DEBDIFF_DIRS'} = 'no'; + $config_vars{'DEBDIFF_CONTROL'} =~ /^(yes|no)$/ + or $config_vars{'DEBDIFF_CONTROL'} = 'yes'; + $config_vars{'DEBDIFF_SHOW_MOVED'} =~ /^(yes|no)$/ + or $config_vars{'DEBDIFF_SHOW_MOVED'} = 'no'; + $config_vars{'DEBDIFF_SHOW_DIFFSTAT'} =~ /^(yes|no)$/ + or $config_vars{'DEBDIFF_SHOW_DIFFSTAT'} = 'no'; + $config_vars{'DEBDIFF_WDIFF_SOURCE_CONTROL'} =~ /^(yes|no)$/ + or $config_vars{'DEBDIFF_WDIFF_SOURCE_CONTROL'} = 'no'; + $config_vars{'DEBDIFF_AUTO_VER_SORT'} =~ /^(yes|no)$/ + or $config_vars{'DEBDIFF_AUTO_VER_SORT'} = 'no'; + $config_vars{'DEBDIFF_UNPACK_TARBALLS'} =~ /^(yes|no)$/ + or $config_vars{'DEBDIFF_UNPACK_TARBALLS'} = 'yes'; + # We do not replace this with a default directory to avoid accidentally + # installing a broken package + $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%/+%/%; + $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%(.)/$%$1%; + $debsdir_warning + = "config file specified DEBRELEASE_DEBS_DIR directory $config_vars{'DEBRELEASE_DEBS_DIR'} does not exist!"; + + foreach my $var (sort keys %config_vars) { + if ($config_vars{$var} ne $config_default{$var}) { + $modified_conf_msg .= " $var=$config_vars{$var}\n"; + } + } + $modified_conf_msg ||= " (none)\n"; + chomp $modified_conf_msg; + + $debsdir = $config_vars{'DEBRELEASE_DEBS_DIR'}; + $ignore_dirs = $config_vars{'DEBDIFF_DIRS'} eq 'yes' ? 0 : 1; + $compare_control = $config_vars{'DEBDIFF_CONTROL'} eq 'no' ? 0 : 1; + $controlfiles = $config_vars{'DEBDIFF_CONTROLFILES'}; + $show_moved = $config_vars{'DEBDIFF_SHOW_MOVED'} eq 'yes' ? 1 : 0; + $wdiff_opt = $config_vars{'DEBDIFF_WDIFF_OPT'} =~ /^-([plt])$/ ? $1 : ''; + $show_diffstat = $config_vars{'DEBDIFF_SHOW_DIFFSTAT'} eq 'yes' ? 1 : 0; + $wdiff_source_control + = $config_vars{'DEBDIFF_WDIFF_SOURCE_CONTROL'} eq 'yes' ? 1 : 0; + $auto_ver_sort = $config_vars{'DEBDIFF_AUTO_VER_SORT'} eq 'yes' ? 1 : 0; + $unpack_tarballs + = $config_vars{'DEBDIFF_UNPACK_TARBALLS'} eq 'yes' ? 1 : 0; + +} + +# Are they a pair of debs, changes or dsc files, or a list of debs? +my $type = ''; +my @excludes = (); +my @move = (); +my %renamed = (); +my $opt_debsdir; + +# handle command-line options + +while (@ARGV) { + if ($ARGV[0] =~ /^(--help|-h)$/) { usage(); exit 0; } + if ($ARGV[0] =~ /^(--version|-v)$/) { print $version; exit 0; } + if ($ARGV[0] =~ /^(--move(-regex)?|-m)$/) { + fatal +"Malformed command-line option $ARGV[0]; run $progname --help for more info" + unless @ARGV >= 3; + + my $regex = $ARGV[0] eq '--move-regex' ? 1 : 0; + shift @ARGV; + + # Ensure from and to values all begin with a slash + # dpkg -c produces filenames such as ./usr/lib/filename + my $from = shift; + my $to = shift; + $from =~ s%^\./%/%; + $to =~ s%^\./%/%; + + if ($regex) { + # quote ':' in the from and to patterns; + # used later as a pattern delimiter + $from =~ s/:/\\:/g; + $to =~ s/:/\\:/g; + } + push @move, [$regex, $from, $to]; + } elsif ($ARGV[0] eq '--renamed') { + fatal +"Malformed command-line option $ARGV[0]; run $progname --help for more info" + unless @ARGV >= 3; + shift @ARGV; + + my $from = shift; + my $to = shift; + $renamed{$from} = $to; + } elsif ($ARGV[0] eq '--exclude') { + fatal +"Malformed command-line option $ARGV[0]; run $progname --help for more info" + unless @ARGV >= 2; + shift @ARGV; + + my $exclude = shift; + push @excludes, $exclude; + } elsif ($ARGV[0] =~ s/^--exclude=//) { + my $exclude = shift; + push @excludes, $exclude; + } elsif ($ARGV[0] eq '--controlfiles') { + fatal +"Malformed command-line option $ARGV[0]; run $progname --help for more info" + unless @ARGV >= 2; + shift @ARGV; + + $controlfiles = shift; + } elsif ($ARGV[0] =~ s/^--controlfiles=//) { + $controlfiles = shift; + } elsif ($ARGV[0] eq '--debs-dir') { + fatal +"Malformed command-line option $ARGV[0]; run $progname --help for more info" + unless @ARGV >= 2; + shift @ARGV; + + $opt_debsdir = shift; + } elsif ($ARGV[0] =~ s/^--debs-dir=//) { + $opt_debsdir = shift; + } elsif ($ARGV[0] =~ /^(--dirs|-d)$/) { + $ignore_dirs = 0; + shift; + } elsif ($ARGV[0] eq '--nodirs') { + $ignore_dirs = 1; + shift; + } elsif ($ARGV[0] =~ /^(--quiet|-q)$/) { + $quiet = 1; + shift; + } elsif ($ARGV[0] =~ /^(--show-moved|-s)$/) { + $show_moved = 1; + shift; + } elsif ($ARGV[0] eq '--noshow-moved') { + $show_moved = 0; + shift; + } elsif ($ARGV[0] eq '--nocontrol') { + $compare_control = 0; + shift; + } elsif ($ARGV[0] eq '--control') { + $compare_control = 1; + shift; + } elsif ($ARGV[0] eq '--from') { + $type = 'debs'; + last; + } elsif ($ARGV[0] =~ /^--w([plt])$/) { + $wdiff_opt = "-$1"; + shift; + } elsif ($ARGV[0] =~ /^(--ignore-space|-w)$/) { + push @diff_opts, "-w"; + shift; + } elsif ($ARGV[0] eq '--diffstat') { + $show_diffstat = 1; + shift; + } elsif ($ARGV[0] =~ /^--no-?diffstat$/) { + $show_diffstat = 0; + shift; + } elsif ($ARGV[0] eq '--wdiff-source-control') { + $wdiff_source_control = 1; + shift; + } elsif ($ARGV[0] =~ /^--no-?wdiff-source-control$/) { + $wdiff_source_control = 0; + shift; + } elsif ($ARGV[0] eq '--auto-ver-sort') { + $auto_ver_sort = 1; + shift; + } elsif ($ARGV[0] =~ /^--no-?auto-ver-sort$/) { + $auto_ver_sort = 0; + shift; + } elsif ($ARGV[0] eq '--unpack-tarballs') { + $unpack_tarballs = 1; + shift; + } elsif ($ARGV[0] =~ /^--no-?unpack-tarballs$/) { + $unpack_tarballs = 0; + shift; + } elsif ($ARGV[0] =~ /^--no-?conf$/) { + fatal "--no-conf is only acceptable as the first command-line option!"; + } + + # Not a recognised option + elsif ($ARGV[0] =~ /^-/) { + fatal +"Unrecognised command-line option $ARGV[0]; run $progname --help for more info"; + } else { + # End of command line options + last; + } +} + +my $guessed_version = 0; + +if ($opt_debsdir) { + $opt_debsdir =~ s%^/+%/%; + $opt_debsdir =~ s%(.)/$%$1%; + $debsdir_warning = "--debs-dir directory $opt_debsdir does not exist!"; + $debsdir = $opt_debsdir; +} + +# If no file is given, assume that we are in a source directory +# and try to create a diff with the previous version +if (@ARGV == 0) { + my $namepat = qr/[-+0-9a-z.]/i; + + fatal $debsdir_warning unless -d $debsdir; + + fatal "Can't read file: debian/changelog" unless -r "debian/changelog"; + open CHL, "debian/changelog"; + while (<CHL>) { + if (/^(\w$namepat*)\s\((\d+:)?(.+)\)((\s+$namepat+)+)\;\surgency=.+$/) + { + unshift @ARGV, $debsdir . "/" . $1 . "_" . $3 . ".dsc"; + $guessed_version++; + } + last if $guessed_version > 1; + } + close CHL; +} + +if (!$type) { + # we need 2 deb files or changes files to compare + fatal "Need exactly two deb files or changes files to compare" + unless @ARGV == 2; + + foreach my $i (0, 1) { + fatal "Can't read file: $ARGV[$i]" unless -r $ARGV[$i]; + } + + if ($ARGV[0] =~ /\.deb$/) { $type = 'deb'; } + elsif ($ARGV[0] =~ /\.udeb$/) { $type = 'deb'; } + elsif ($ARGV[0] =~ /\.changes$/) { $type = 'changes'; } + elsif ($ARGV[0] =~ /\.dsc$/) { $type = 'dsc'; } + else { + fatal +"Could not recognise files; the names should end .deb, .udeb, .changes or .dsc"; + } + if ($ARGV[1] !~ /\.$type$/ && ($type ne 'deb' || $ARGV[1] !~ /\.udeb$/)) { + fatal +"The two filenames must have the same suffix, either .deb, .udeb, .changes or .dsc"; + } +} + +# We collect up the individual deb information in the hashes +# %debs1 and %debs2, each key of which is a .deb name and each value is +# a list ref. Note we need to use our, not my, as we will be symbolically +# referencing these variables +my @CommonDebs = (); +my @singledeb; +our ( + %debs1, %debs2, %files1, %files2, @D1, + @D2, $dir1, $dir2, %DebPaths1, %DebPaths2 +); + +if ($type eq 'deb') { + no strict 'refs'; + foreach my $i (1, 2) { + my $deb = shift; + my ($debc, $debI) = ('', ''); + my %dpkg_env = (LC_ALL => 'C'); + eval { + spawn( + exec => ['dpkg-deb', '-c', $deb], + env => \%dpkg_env, + to_string => \$debc, + wait_child => 1 + ); + }; + if ($@) { + fatal "dpkg-deb -c $deb failed!"; + } + + eval { + spawn( + exec => ['dpkg-deb', '-I', $deb], + env => \%dpkg_env, + to_string => \$debI, + wait_child => 1 + ); + }; + if ($@) { + fatal "dpkg-deb -I $deb failed!"; + } + # Store the name for later + $singledeb[$i] = $deb; + # get package name itself + $deb =~ s,.*/,,; + $deb =~ s/_.*//; + @{"D$i"} = @{ process_debc($debc, $i) }; + push @{"D$i"}, @{ process_debI($debI) }; + } +} elsif ($type eq 'changes' or $type eq 'debs') { + # Have to parse .changes files or remaining arguments + my $pwd = cwd; + foreach my $i (1, 2) { + my (@debs) = (); + if ($type eq 'debs') { + if (@ARGV < 2) { + # Oops! There should be at least --from|--to deb ... + fatal +"Missing .deb names or missing --to! (Run debdiff -h for help)\n"; + } + shift; # get rid of --from or --to + while (@ARGV and $ARGV[0] ne '--to') { + push @debs, shift; + } + + # Is there only one .deb listed? + if (@debs == 1) { + $singledeb[$i] = $debs[0]; + } + } else { + my $changes = shift; + open CHANGES, $changes + or fatal "Couldn't open $changes: $!"; + my $infiles = 0; + while (<CHANGES>) { + last if $infiles and /^[^ ]/; + /^Files:/ and $infiles = 1, next; + next unless $infiles; + if (/ (\S*.u?deb)$/) { + my $file = $1; + $file !~ m,[/\x00], + or fatal "File name contains invalid characters: $file"; + push @debs, dirname($changes) . '/' . $file; + } + } + close CHANGES + or fatal "Problem reading $changes: $!"; + + # Is there only one .deb listed? + if (@debs == 1) { + $singledeb[$i] = $debs[0]; + } + } + + foreach my $deb (@debs) { + no strict 'refs'; + fatal "Can't read file: $deb" unless -r $deb; + my ($debc, $debI) = ('', ''); + my %dpkg_env = (LC_ALL => 'C'); + eval { + spawn( + exec => ['dpkg-deb', '-c', $deb], + to_string => \$debc, + env => \%dpkg_env, + wait_child => 1 + ); + }; + if ($@) { + fatal "dpkg-deb -c $deb failed!"; + } + eval { + spawn( + exec => ['dpkg-deb', '-I', $deb], + to_string => \$debI, + env => \%dpkg_env, + wait_child => 1 + ); + }; + if ($@) { + fatal "dpkg-deb -I $deb failed!"; + } + my $debpath = $deb; + # get package name itself + $deb =~ s,.*/,,; + $deb =~ s/_.*//; + $deb = $renamed{$deb} if $i == 1 and exists $renamed{$deb}; + if (exists ${"debs$i"}{$deb}) { + warn +"Same package name appears more than once (possibly due to renaming): $deb\n"; + } else { + ${"debs$i"}{$deb} = 1; + } + ${"DebPaths$i"}{$deb} = $debpath; + foreach my $file (@{ process_debc($debc, $i) }) { + ${"files$i"}{$file} ||= ""; + ${"files$i"}{$file} .= "$deb:"; + } + foreach my $control (@{ process_debI($debI) }) { + ${"files$i"}{$control} ||= ""; + ${"files$i"}{$control} .= "$deb:"; + } + } + no strict 'refs'; + @{"D$i"} = keys %{"files$i"}; + # Go back again + chdir $pwd or fatal "Couldn't chdir $pwd: $!"; + } +} elsif ($type eq 'dsc') { + # Compare source packages + my $pwd = cwd; + + my (@origs, @diffs, @dscs, @dscformats, @versions); + foreach my $i (1, 2) { + my $dsc = shift; + chdir dirname($dsc) + or fatal "Couldn't chdir ", dirname($dsc), ": $!"; + + $dscs[$i] = cwd() . '/' . basename($dsc); + + open DSC, basename($dsc) or fatal "Couldn't open $dsc: $!"; + + my $infiles = 0; + while (<DSC>) { + if (/^Files:/) { + $infiles = 1; + next; + } elsif (/^Format: (.*)$/) { + $dscformats[$i] = $1; + } elsif (/^Version: (.*)$/) { + $versions[$i - 1] = [$1, $i]; + } + next unless $infiles; + last if /^\s*$/; + last if /^[-\w]+:/; # don't expect this, but who knows? + chomp; + + # This had better match + if (/^\s+[0-9a-f]{32}\s+\d+\s+(\S+)$/) { + my $file = $1; + $file !~ m,[/\x00], + or fatal "File name contains invalid characters: $file"; + if ($file =~ /\.diff\.gz$/) { + $diffs[$i] = cwd() . '/' . $file; + } elsif ($file =~ /((?:\.orig)?\.tar\.$compression_re|\.git)$/) + { + $origs[$i] = $file; + } + } else { + warn "Unrecognised file line in .dsc:\n$_\n"; + } + } + + close DSC or fatal "Problem closing $dsc: $!"; + # Go back again + chdir $pwd or fatal "Couldn't chdir $pwd: $!"; + } + + @versions = Devscripts::Versort::versort(@versions); + # If the versions are currently out of order, should we swap them? + if ( $auto_ver_sort + and !$guessed_version + and $versions[0][1] == 1 + and $versions[0][0] ne $versions[1][0]) { + foreach my $var ((\@origs, \@diffs, \@dscs, \@dscformats)) { + my $temp = @{$var}[1]; + @{$var}[1] = @{$var}[2]; + @{$var}[2] = $temp; + } + } + + # Do we have interdiff? + system("command -v interdiff >/dev/null 2>&1"); + my $use_interdiff = ($? == 0) ? 1 : 0; + system("command -v diffstat >/dev/null 2>&1"); + my $have_diffstat = ($? == 0) ? 1 : 0; + system("command -v wdiff >/dev/null 2>&1"); + my $have_wdiff = ($? == 0) ? 1 : 0; + + my ($fh, $filename) = tempfile( + "debdiffXXXXXX", + SUFFIX => ".diff", + DIR => File::Spec->tmpdir, + UNLINK => 1 + ); + + # When wdiffing source control files we always fully extract both source + # packages as it's the easiest way of getting the debian/control file, + # particularly if the orig tar ball contains one which is patched in the + # diffs + if ( $origs[1] eq $origs[2] + and defined $diffs[1] + and defined $diffs[2] + and scalar(@excludes) == 0 + and $use_interdiff + and !$wdiff_source_control) { + # same orig tar ball, interdiff exists and not wdiffing + + my $tmpdir = tempdir(CLEANUP => 1); + eval { + spawn( + exec => ['interdiff', '-z', @diff_opts, $diffs[1], $diffs[2]], + to_file => $filename, + wait_child => 1, + # Make interdiff put its tempfiles in $tmpdir, so they're + # automatically cleaned up + env => { TMPDIR => $tmpdir }); + }; + + # If interdiff fails for some reason, we'll fall back to our manual + # diffing. + unless ($@) { + if ($have_diffstat and $show_diffstat) { + my $header + = "diffstat for " + . basename($diffs[1]) . " " + . basename($diffs[2]) . "\n\n"; + $header =~ s/\.diff\.gz//g; + print $header; + spawn( + exec => ['diffstat', $filename], + wait_child => 1 + ); + print "\n"; + } + + if (-s $filename) { + open(INTERDIFF, '<', $filename); + while (<INTERDIFF>) { + print $_; + } + close INTERDIFF; + + $exit_status = 1; + } + exit $exit_status; + } + } + + # interdiff ran and failed, or any other situation + if (!$use_interdiff) { + warn +"Warning: You do not seem to have interdiff (in the patchutils package)\ninstalled; this program would use it if it were available.\n"; + } + # possibly different orig tarballs, or no interdiff installed, + # or wdiffing debian/control + our ($sdir1, $sdir2); + mktmpdirs(); + for my $i (1, 2) { + no strict 'refs'; + my @opts = ('-x'); + push(@opts, '--skip-patches') if $dscformats[$i] eq '3.0 (quilt)'; + my $diri = ${"dir$i"}; + eval { + spawn( + exec => ['dpkg-source', @opts, $dscs[$i]], + to_file => '/dev/null', + chdir => $diri, + wait_child => 1 + ); + }; + if ($@) { + my $dir = dirname $dscs[1] if $i == 2; + $dir = dirname $dscs[2] if $i == 1; + cp "$dir/$origs[$i]", + $diri || fatal "copy $dir/$origs[$i] $diri: $!"; + my $dscx = basename $dscs[$i]; + cp $diffs[$i], $diri || fatal "copy $diffs[$i] $diri: $!"; + cp $dscs[$i], $diri || fatal "copy $dscs[$i] $diri: $!"; + spawn( + exec => ['dpkg-source', @opts, $dscx], + to_file => '/dev/null', + chdir => $diri, + wait_child => 1 + ); + } + opendir DIR, $diri; + while ($_ = readdir(DIR)) { + next if $_ eq '.' || $_ eq '..' || !-d "$diri/$_"; + ${"sdir$i"} = $_; + last; + } + closedir(DIR); + my $sdiri = ${"sdir$i"}; + +# also unpack tarballs found in the top level source directory so we can compare their contents too + next unless $unpack_tarballs; + opendir DIR, $diri . '/' . $sdiri; + + my $tarballs = 1; + while ($_ = readdir(DIR)) { + my $unpacked = "=unpacked-tar" . $tarballs . "="; + my $filename = $_; + if ($filename =~ s/\.tar\.$compression_re$//) { + my $comp = compression_guess_from_filename($_); + $tarballs++; + spawn( + exec => ['tar', "--$comp", '-xf', $_], + to_file => '/dev/null', + wait_child => 1, + chdir => "$diri/$sdiri", + nocheck => 1 + ); + if (-d "$diri/$sdiri/$filename") { + move "$diri/$sdiri/$filename", "$diri/$sdiri/$unpacked"; + } + } + } + closedir(DIR); + } + + my @command = ("diff", "-Nru", @diff_opts); + for my $exclude (@excludes) { + push @command, ("--exclude", $exclude); + } + push @command, ("$dir1/$sdir1", "$dir2/$sdir2"); + +# Execute diff and remove the common prefixes $dir1/$dir2, so the patch can be used with -p1, +# as if when interdiff would have been used: + spawn( + exec => \@command, + to_file => $filename, + wait_child => 1, + nocheck => 1 + ); + + if ($have_diffstat and $show_diffstat) { + print "diffstat for $sdir1 $sdir2\n\n"; + spawn( + exec => ['diffstat', $filename], + wait_child => 1 + ); + print "\n"; + } + + if ($have_wdiff and $wdiff_source_control) { + # Abuse global variables slightly to create some temporary directories + my $tempdir1 = $dir1; + my $tempdir2 = $dir2; + mktmpdirs(); + our $wdiffdir1 = $dir1; + our $wdiffdir2 = $dir2; + $dir1 = $tempdir1; + $dir2 = $tempdir2; + our @cf; + + if ($controlfiles eq 'ALL') { + @cf = ('control'); + } else { + @cf = split /,/, $controlfiles; + } + + no strict 'refs'; + for my $i (1, 2) { + foreach my $file (@cf) { + cp ${"dir$i"} . '/' . ${"sdir$i"} . "/debian/$file", + ${"wdiffdir$i"}; + } + } + use strict 'refs'; + + # We don't support "ALL" for source packages as that would + # wdiff debian/* + $exit_status = wdiff_control_files($wdiffdir1, $wdiffdir2, $dummyname, + $controlfiles eq 'ALL' ? 'control' : $controlfiles, $exit_status); + print "\n"; + + # Clean up + rmtree([$wdiffdir1, $wdiffdir2]); + } + + if (!-f $filename) { + fatal "Creation of diff file $filename failed!"; + } elsif (-s $filename) { + open(DIFF, '<', $filename) + or fatal "Opening diff file $filename failed!"; + + while (<DIFF>) { + s/^--- $dir1\//--- /; + s/^\+\+\+ $dir2\//+++ /; + s/^(diff .*) $dir1\/\Q$sdir1\E/$1 $sdir1/; + s/^(diff .*) $dir2\/\Q$sdir2\E/$1 $sdir2/; + print; + } + close DIFF; + + $exit_status = 1; + } + + exit $exit_status; +} else { + fatal "Internal error: \$type = $type unrecognised"; +} + +# Compare +# Start by a piece of common code to set up the @CommonDebs list and the like + +my (@deblosses, @debgains); + +{ + my %debs; + grep $debs{$_}--, keys %debs1; + grep $debs{$_}++, keys %debs2; + + @deblosses = sort grep $debs{$_} < 0, keys %debs; + @debgains = sort grep $debs{$_} > 0, keys %debs; + @CommonDebs = sort grep $debs{$_} == 0, keys %debs; +} + +if ($show_moved and $type ne 'deb') { + if (@debgains) { + my $msg + = "Warning: these package names were in the second list but not in the first:"; + print $msg, "\n", '-' x length $msg, "\n"; + print join("\n", @debgains), "\n\n"; + } + + if (@deblosses) { + print "\n" if @debgains; + my $msg + = "Warning: these package names were in the first list but not in the second:"; + print $msg, "\n", '-' x length $msg, "\n"; + print join("\n", @deblosses), "\n\n"; + } + + # We start by determining which files are in the first set of debs, the + # second set of debs or both. + my %files; + grep $files{$_}--, @D1; + grep $files{$_}++, @D2; + + my @old = sort grep $files{$_} < 0, keys %files; + my @new = sort grep $files{$_} > 0, keys %files; + my @same = sort grep $files{$_} == 0, keys %files; + + # We store any changed files in a hash of hashes %changes, where + # $changes{$from}{$to} is an array of files which have moved + # from package $from to package $to; $from or $to is '-' if + # the files have appeared or disappeared + + my %changes; + my @funny; # for storing changed files which appear in multiple debs + + foreach my $file (@old) { + my @firstdebs = split /:/, $files1{$file}; + foreach my $firstdeb (@firstdebs) { + push @{ $changes{$firstdeb}{'-'} }, $file; + } + } + + foreach my $file (@new) { + my @seconddebs = split /:/, $files2{$file}; + foreach my $seconddeb (@seconddebs) { + push @{ $changes{'-'}{$seconddeb} }, $file; + } + } + + foreach my $file (@same) { + # Are they identical? + next if $files1{$file} eq $files2{$file}; + + # Ah, they're not the same. If the file has moved from one deb + # to another, we'll put a note in that pair. But if the file + # was in more than one deb or ends up in more than one deb, we'll + # list it separately. + my @fdebs1 = split(/:/, $files1{$file}); + my @fdebs2 = split(/:/, $files2{$file}); + + if (@fdebs1 == 1 && @fdebs2 == 1) { + push @{ $changes{ $fdebs1[0] }{ $fdebs2[0] } }, $file; + } else { + # two packages to one or vice versa, or something like that + push @funny, [$file, \@fdebs1, \@fdebs2]; + } + } + + # This is not a very efficient way of doing things if there are + # lots of debs involved, but since that is highly unlikely, it + # shouldn't be much of an issue + my $changed = 0; + + for my $deb1 (sort(keys %debs1), '-') { + next unless exists $changes{$deb1}; + for my $deb2 ('-', sort keys %debs2) { + next unless exists $changes{$deb1}{$deb2}; + my $msg; + if (!$changed) { + print +"[The following lists of changes regard files as different if they have\ndifferent names, permissions or owners.]\n\n"; + } + if ($deb1 eq '-') { + $msg + = "New files in second set of .debs, found in package $deb2"; + } elsif ($deb2 eq '-') { + $msg + = "Files only in first set of .debs, found in package $deb1"; + } else { + $msg = "Files moved from package $deb1 to package $deb2"; + } + print $msg, "\n", '-' x length $msg, "\n"; + print join("\n", @{ $changes{$deb1}{$deb2} }), "\n\n"; + $changed = 1; + } + } + + if (@funny) { + my $msg + = "Files moved or copied from at least TWO packages or to at least TWO packages"; + print $msg, "\n", '-' x length $msg, "\n"; + for my $funny (@funny) { + print $$funny[0], "\n"; # filename and details + print "From package", (@{ $$funny[1] } > 1 ? "s" : ""), ": "; + print join(", ", @{ $$funny[1] }), "\n"; + print "To package", (@{ $$funny[2] } > 1 ? "s" : ""), ": "; + print join(", ", @{ $$funny[2] }), "\n"; + } + $changed = 1; + } + + if (!$quiet && !$changed) { + print + "File lists identical on package level (after any substitutions)\n"; + } + $exit_status = 1 if $changed; +} else { + my %files; + grep $files{$_}--, @D1; + grep $files{$_}++, @D2; + + my @losses = sort grep $files{$_} < 0, keys %files; + my @gains = sort grep $files{$_} > 0, keys %files; + + if (@losses == 0 && @gains == 0) { + print "File lists identical (after any substitutions)\n" + unless $quiet; + } else { + print +"[The following lists of changes regard files as different if they have\ndifferent names, permissions or owners.]\n\n"; + } + + if (@gains) { + my $msg; + if ($type eq 'debs') { + $msg = "Files in second set of .debs but not in first"; + } else { + $msg = sprintf "Files in second .%s but not in first", + $type eq 'deb' ? 'deb' : 'changes'; + } + print $msg, "\n", '-' x length $msg, "\n"; + print join("\n", @gains), "\n"; + $exit_status = 1; + } + + if (@losses) { + print "\n" if @gains; + my $msg; + if ($type eq 'debs') { + $msg = "Files in first set of .debs but not in second"; + } else { + $msg = sprintf "Files in first .%s but not in second", + $type eq 'deb' ? 'deb' : 'changes'; + } + print $msg, "\n", '-' x length $msg, "\n"; + print join("\n", @losses), "\n"; + $exit_status = 1; + } +} + +# We compare the control files (at least the dependency fields) +if (defined $singledeb[1] and defined $singledeb[2]) { + @CommonDebs = ($dummyname); + $DebPaths1{$dummyname} = $singledeb[1]; + $DebPaths2{$dummyname} = $singledeb[2]; +} + +exit $exit_status unless (@CommonDebs > 0) and $compare_control; + +unless (system("command -v wdiff >/dev/null 2>&1") == 0) { + warn "Can't compare control files; wdiff package not installed\n"; + exit $exit_status; +} + +for my $debname (@CommonDebs) { + no strict 'refs'; + mktmpdirs(); + + for my $i (1, 2) { + my $debpath = "${\"DebPaths$i\"}{$debname}"; + my $diri = ${"dir$i"}; + eval { + spawn( + exec => ['dpkg-deb', '-e', $debpath, $diri], + wait_child => 1 + ); + }; + if ($@) { + my $msg = "dpkg-deb -e ${\"DebPaths$i\"}{$debname} failed!"; + rmtree([$dir1, $dir2]); + fatal $msg; + } + } + + use strict 'refs'; + $exit_status = wdiff_control_files($dir1, $dir2, $debname, $controlfiles, + $exit_status); + + # Clean up + rmtree([$dir1, $dir2]); +} + +exit $exit_status; + +###### Subroutines + +# This routine takes the output of dpkg-deb -c and returns +# a processed listref +sub process_debc($$) { + my ($data, $number) = @_; + my (@filelist); + + # Format of dpkg-deb -c output: + # permissions owner/group size date time name ['->' link destination] + $data =~ s/^(\S+)\s+(\S+)\s+(\S+\s+){3}/$1 $2 /mg; + $data =~ s, \./, /,mg; + @filelist = grep !m| /$|, split /\n/, $data; # don't bother keeping '/' + + # Are we keeping directory names in our filelists? + if ($ignore_dirs) { + @filelist = grep !m|/$|, @filelist; + } + + # Do the "move" substitutions in the order received for the first debs + if ($number == 1 and @move) { + my @split_filelist + = map { m/^(\S+) (\S+) (.*)/ && [$1, $2, $3] } @filelist; + for my $move (@move) { + my $regex = $$move[0]; + my $from = $$move[1]; + my $to = $$move[2]; + map { + if ($regex) { eval "\$\$_[2] =~ s:$from:$to:g"; } + else { $$_[2] =~ s/\Q$from\E/$to/; } + } @split_filelist; + } + @filelist = map { "$$_[0] $$_[1] $$_[2]" } @split_filelist; + } + + return \@filelist; +} + +# This does the same for dpkg-deb -I +sub process_debI($) { + my ($data) = @_; + my (@filelist); + + # Format of dpkg-deb -c output: + # 2 (always?) header lines + # nnnn bytes, nnn lines [*] filename [interpreter] + # Package: ... + # rest of control file + + foreach (split /\n/, $data) { + last if /^Package:/; + next unless /^\s+\d+\s+bytes,\s+\d+\s+lines\s+(\*)?\s+([\-\w]+)/; + my $control = $2; + my $perms = ($1 ? "-rwxr-xr-x" : "-rw-r--r--"); + push @filelist, "$perms root/root DEBIAN/$control"; + } + + return \@filelist; +} + +sub wdiff_control_files($$$$$) { + my ($dir1, $dir2, $debname, $controlfiles, $origstatus) = @_; + return + unless defined $dir1 + and defined $dir2 + and defined $debname + and defined $controlfiles; + my @cf; + my $status = $origstatus; + if ($controlfiles eq 'ALL') { + # only need to list one directory as we are only comparing control + # files in both packages + @cf = grep { !/md5sums/ } map { basename($_); } glob("$dir1/*"); + } else { + @cf = split /,/, $controlfiles; + } + + foreach my $cf (@cf) { + next unless -f "$dir1/$cf" and -f "$dir2/$cf"; + if ($cf eq 'control' or $cf eq 'conffiles' or $cf eq 'shlibs') { + for my $file ("$dir1/$cf", "$dir2/$cf") { + my ($fd, @hdrs); + open $fd, '<', $file or fatal "Cannot read $file: $!"; + while (<$fd>) { + if (/^\s/ and @hdrs > 0) { + $hdrs[$#hdrs] .= $_; + } else { + push @hdrs, $_; + } + } + close $fd; + chmod 0644, $file; + open $fd, '>', $file or fatal "Cannot write $file: $!"; + print $fd sort @hdrs; + close $fd; + } + } + my $usepkgname = $debname eq $dummyname ? "" : " of package $debname"; + my @opts = ('-n'); + push @opts, $wdiff_opt if $wdiff_opt; + my ($wdiff, $wdiff_error) = ('', ''); + spawn( + exec => ['wdiff', @opts, "$dir1/$cf", "$dir2/$cf"], + to_string => \$wdiff, + error_to_string => \$wdiff_error, + wait_child => 1, + nocheck => 1 + ); + if ($? && ($? >> 8) != 1) { + print "$wdiff_error\n"; + warn "wdiff failed\n"; + } else { + if (!$?) { + if (!$quiet) { + print +"\nNo differences were encountered between the $cf files$usepkgname\n"; + } + } elsif ($wdiff_opt) { + # Don't try messing with control codes + my $msg = ucfirst($cf) . " files$usepkgname: wdiff output"; + print "\n", $msg, "\n", '-' x length $msg, "\n"; + print $wdiff; + $status = 1; + } else { + my @output; + @output = split /\n/, $wdiff; + @output = grep /(\[-|\{\+)/, @output; + my $msg = ucfirst($cf) + . " files$usepkgname: lines which differ (wdiff format)"; + print "\n", $msg, "\n", '-' x length $msg, "\n"; + print join("\n", @output), "\n"; + $status = 1; + } + } + } + + return $status; +} + +sub mktmpdirs () { + no strict 'refs'; + + for my $i (1, 2) { + ${"dir$i"} = tempdir(CLEANUP => 1); + fatal "Couldn't create temp directory" + if not defined ${"dir$i"}; + } +} + +sub fatal(@) { + my ($pack, $file, $line); + ($pack, $file, $line) = caller(); + (my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d; + $msg =~ s/\n\n$/\n/; + die $msg; +} |