| Current File : //bin/debdiff |
#!/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-unpack-tarballs 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 2.22.1ubuntu1
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;
}