summaryrefslogtreecommitdiffstats
path: root/scripts/debdiff.pl
diff options
context:
space:
mode:
Diffstat (limited to '')
-rwxr-xr-xscripts/debdiff.pl1239
1 files changed, 1239 insertions, 0 deletions
diff --git a/scripts/debdiff.pl b/scripts/debdiff.pl
new file mode 100755
index 0000000..4bcffc1
--- /dev/null
+++ b/scripts/debdiff.pl
@@ -0,0 +1,1239 @@
+#!/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 whose basenames 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
+ --apply-patches If either old or new package is in 3.0 (quilt)
+ format, apply the patch series and remove .pc
+ before comparison
+ --no-apply-patches Do not do so (default)
+
+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 $apply_patches = 0;
+
+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',
+ 'DEBDIFF_APPLY_PATCHES' => 'no',
+ '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';
+ $config_vars{'DEBDIFF_APPLY_PATCHES'} =~ /^(yes|no)$/
+ or $config_vars{'DEBDIFF_APPLY_PATCHES'} = 'no';
+ # 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;
+ $apply_patches = $config_vars{'DEBDIFF_APPLY_PATCHES'} 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] eq '--apply-patches') {
+ $apply_patches = 1;
+ shift;
+ } elsif ($ARGV[0] =~ /^--no-?apply-patches$/) {
+ $apply_patches = 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;
+ }
+}
+
+for my $exclude (@excludes) {
+ if ($exclude =~ m{/}) {
+ print STDERR
+"$progname: warning: --exclude patterns are matched against the basename, so --exclude='$exclude' will not exclude anything\n";
+ }
+}
+
+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');
+ if ($dscformats[$i] eq '3.0 (quilt)' && !$apply_patches) {
+ push @opts, '--skip-patches';
+ }
+ 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);
+ if ($dscformats[$i] eq '3.0 (quilt)' && $apply_patches) {
+ spawn(
+ exec => ['rm', '-fr', "$diri/$sdiri/.pc"],
+ wait_child => 1
+ );
+ }
+ }
+
+ 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;
+}