« back to all changes in this revision
Viewing changes to scripts/debdiff.pl
- browse files at revision 11
- compare with another revision
- download diff
- download tarball
- view history from revision 11
- Committer: Bazaar Package Importer
- Author(s): Adam D. Barratt
- Date: 2008-07-26 21:57:20 UTC
- Revision ID: james.westby@ubuntu.com-20080726215720-u8oe2p6c7hxixfq8
Tags: 2.10.35
* checkbashisms: Only flag "local x y" and "local foo=bar" when --posix is
used, as the use of the constructs is likely to become policy compliant
in the near future (see Policy bug #473019)
* debcommit: When --diff is used, don't open an editor to confirm commit
messages
* po4a/po/fr.po: Update French manpage translations; thanks Nicolas FRANCOIS
(Closes: #491001)
* who-uploads: Call "gpg --verify" with LC_ALL set to C to ensure that
the output is in the expected format (Closes: #492474)
used, as the use of the constructs is likely to become policy compliant
in the near future (see Policy bug #473019)
* debcommit: When --diff is used, don't open an editor to confirm commit
messages
* po4a/po/fr.po: Update French manpage translations; thanks Nicolas FRANCOIS
(Closes: #491001)
* who-uploads: Call "gpg --verify" with LC_ALL set to C to ensure that
the output is in the expected format (Closes: #492474)
- files added:
- Devscripts/Debbugs.pm
- debian/bug
- examples
- scripts
- files removed:
- annotate-output.1
- files modified:
- COPYING
added
removed
scripts/debdiff.pl
1
#! /usr/bin/perl -w
2
3
# Original shell script version:
4
# Copyright 1998,1999 Yann Dirson <dirson@debian.org>
5
# Perl version:
6
# Copyright 1999,2000,2001 by Julian Gilbey <jdg@debian.org>
7
#
8
# This program is free software; you can redistribute it and/or modify
9
# it under the terms of the GNU General Public License, version 2 ONLY,
10
# as published by the Free Software Foundation.
11
#
12
# This program is distributed in the hope that it will be useful,
13
# but WITHOUT ANY WARRANTY; without even the implied warranty of
14
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15
# GNU General Public License for more details.
16
17
use 5.006_000;
18
use strict;
19
use Cwd;
20
use File::Basename;
21
use File::Temp qw/ tempdir tempfile /;
22
23
# Predeclare functions
24
sub process_debc($$);
25
sub process_debI($);
26
sub mktmpdirs();
27
sub fatal(@);
28
29
my $progname = basename($0);
30
my $modified_conf_msg;
31
my $exit_status = 0;
32
33
sub usage {
34
print <<"EOF";
35
Usage: $progname [option]
36
or: $progname [option] ... deb1 deb2
37
or: $progname [option] ... changes1 changes2
38
or: $progname [option] ... dsc1 dsc2
39
or: $progname [option] ... --from deb1a deb1b ... --to deb2a deb2b ...
40
Valid options are:
41
--no-conf, --noconf
42
Don\'t read devscripts config files;
43
must be the first option given
44
--help, -h Display this message
45
--version, -v Display version and copyright info
46
--move FROM TO, The prefix FROM in first packages has
47
-m FROM TO been renamed TO in the new packages
48
(multiple permitted)
49
--move-regex FROM TO, The prefix FROM in first packages has
50
been renamed TO in the new packages
51
(multiple permitted), using regexp substitution
52
--dirs, -d Note changes in directories as well as files
53
--nodirs Do not note changes in directories (default)
54
--nocontrol Skip comparing control files
55
--control Do compare control files
56
--controlfiles FILE,FILE,...
57
Which control files to compare; default is just
58
control; could include preinst, etc, config or
59
ALL to compare all control files present
60
--wp, --wl, --wt Pass the option -p, -l, -t respectively to wdiff
61
(only one should be used)
62
--show-moved Indicate also all files which have moved
63
between packages
64
--noshow-moved Do not also indicate all files which have moved
65
between packages (default)
66
--renamed FROM TO The package formerly called FROM has been
67
renamed TO; only of interest with --show-moved
68
(multiple permitted)
69
--quiet, -q Be quiet if no differences were found
70
--exclude PATTERN Exclude files that match PATTERN
71
--ignore-space, -w Ignore whitespace in diffs
72
73
Default settings modified by devscripts configuration files:
74
$modified_conf_msg
75
EOF
76
}
77
78
my $version = <<"EOF";
79
This is $progname, from the Debian devscripts package, version ###VERSION###
80
This code is copyright 1999,2000,2001 by Julian Gilbey <jdg\@debian.org>,
81
based on original code which is copyright 1998,1999 by
82
Yann Dirson <dirson\@debian.org>
83
This program comes with ABSOLUTELY NO WARRANTY.
84
You are free to redistribute this code under the terms of the
85
GNU General Public License, version 2 ONLY.
86
EOF
87
88
# Start by setting default values
89
90
my $ignore_dirs = 1;
91
my $compare_control = 1;
92
my $controlfiles = 'control';
93
my $show_moved = 0;
94
my $wdiff_opt = '';
95
my @diff_opts = ();
96
my $show_diffstat = 0;
97
98
my $quiet = 0;
99
100
# Next, read read configuration files and then command line
101
# The next stuff is boilerplate
102
103
if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
104
$modified_conf_msg = " (no configuration files read)";
105
shift;
106
} else {
107
my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
108
my %config_vars = (
109
'DEBDIFF_DIRS' => 'no',
110
'DEBDIFF_CONTROL' => 'yes',
111
'DEBDIFF_CONTROLFILES' => 'control',
112
'DEBDIFF_SHOW_MOVED' => 'no',
113
'DEBDIFF_WDIFF_OPT' => '',
114
'DEBDIFF_SHOW_DIFFSTAT' => '',
115
);
116
my %config_default = %config_vars;
117
118
my $shell_cmd;
119
# Set defaults
120
foreach my $var (keys %config_vars) {
121
$shell_cmd .= "$var='$config_vars{$var}';\n";
122
}
123
$shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
124
$shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
125
# Read back values
126
foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
127
my $shell_out = `/bin/bash -c '$shell_cmd'`;
128
@config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
129
130
# Check validity
131
$config_vars{'DEBDIFF_DIRS'} =~ /^(yes|no)$/
132
or $config_vars{'DEBDIFF_DIRS'}='no';
133
$config_vars{'DEBDIFF_CONTROL'} =~ /^(yes|no)$/
134
or $config_vars{'DEBDIFF_CONTROL'}='yes';
135
$config_vars{'DEBDIFF_SHOW_MOVED'} =~ /^(yes|no)$/
136
or $config_vars{'DEBDIFF_SHOW_MOVED'}='no';
137
$config_vars{'DEBDIFF_SHOW_DIFFSTAT'} =~ /^(yes|no)$/
138
or $config_vars{'DEBDIFF_SHOW_DIFFSTAT'}='no';
139
140
foreach my $var (sort keys %config_vars) {
141
if ($config_vars{$var} ne $config_default{$var}) {
142
$modified_conf_msg .= " $var=$config_vars{$var}\n";
143
}
144
}
145
$modified_conf_msg ||= " (none)\n";
146
chomp $modified_conf_msg;
147
148
$ignore_dirs = $config_vars{'DEBDIFF_DIRS'} eq 'yes' ? 0 : 1;
149
$compare_control = $config_vars{'DEBDIFF_CONTROL'} eq 'no' ? 0 : 1;
150
$controlfiles = $config_vars{'DEBDIFF_CONTROLFILES'};
151
$show_moved = $config_vars{'DEBDIFF_SHOW_MOVED'} eq 'yes' ? 1 : 0;
152
$wdiff_opt = $config_vars{'DEBDIFF_WDIFF_OPT'} =~ /^-([plt])$/ ? $1 : '';
153
$show_diffstat = $config_vars{'DEBDIFF_SHOW_DIFFSTAT'} eq 'yes' ? 1 : 0;
154
}
155
156
# Are they a pair of debs, changes or dsc files, or a list of debs?
157
my $type = '';
158
my @excludes = ();
159
my @move = ();
160
my %renamed = ();
161
162
163
# handle command-line options
164
165
while (@ARGV) {
166
if ($ARGV[0] =~ /^(--help|-h)$/) { usage(); exit 0; }
167
if ($ARGV[0] =~ /^(--version|-v)$/) { print $version; exit 0; }
168
if ($ARGV[0] =~ /^(--move(-regex)?|-m)$/) {
169
fatal "Malformed command-line option $ARGV[0]; run $progname --help for more info"
170
unless @ARGV >= 3;
171
172
my $regex = $ARGV[0] eq '--move-regex' ? 1 : 0;
173
shift @ARGV;
174
175
# Ensure from and to values all begin with a slash
176
# dpkg -c produces filenames such as ./usr/lib/filename
177
my $from = shift;
178
my $to = shift;
179
$from =~ s%^\./%/%;
180
$to =~ s%^\./%/%;
181
182
if ($regex) {
183
# quote ':' in the from and to patterns;
184
# used later as a pattern delimiter
185
$from =~ s/:/\\:/g;
186
$to =~ s/:/\\:/g;
187
}
188
push @move, [$regex, $from, $to];
189
}
190
elsif ($ARGV[0] eq '--renamed') {
191
fatal "Malformed command-line option $ARGV[0]; run $progname --help for more info"
192
unless @ARGV >= 3;
193
shift @ARGV;
194
195
my $from = shift;
196
my $to = shift;
197
$renamed{$from} = $to;
198
}
199
elsif ($ARGV[0] eq '--exclude') {
200
fatal "Malformed command-line option $ARGV[0]; run $progname --help for more info"
201
unless @ARGV >= 2;
202
shift @ARGV;
203
204
my $exclude = shift;
205
push @excludes, $exclude;
206
}
207
elsif ($ARGV[0] =~ s/^--exclude=//) {
208
my $exclude = shift;
209
push @excludes, $exclude;
210
}
211
elsif ($ARGV[0] eq '--controlfiles') {
212
fatal "Malformed command-line option $ARGV[0]; run $progname --help for more info"
213
unless @ARGV >= 2;
214
shift @ARGV;
215
216
$controlfiles = shift;
217
}
218
elsif ($ARGV[0] =~ s/^--controlfiles=//) {
219
$controlfiles = shift;
220
}
221
elsif ($ARGV[0] =~ /^(--dirs|-d)$/) { $ignore_dirs = 0; shift; }
222
elsif ($ARGV[0] eq '--nodirs') { $ignore_dirs = 1; shift; }
223
elsif ($ARGV[0] =~ /^(--quiet|-q)$/) { $quiet = 1; shift; }
224
elsif ($ARGV[0] =~ /^(--show-moved|-s)$/) { $show_moved = 1; shift; }
225
elsif ($ARGV[0] eq '--noshow-moved') { $show_moved = 0; shift; }
226
elsif ($ARGV[0] eq '--nocontrol') { $compare_control = 0; shift; }
227
elsif ($ARGV[0] eq '--control') { $compare_control = 1; shift; }
228
elsif ($ARGV[0] eq '--from') { $type = 'debs'; last; }
229
elsif ($ARGV[0] =~ /^--w([plt])$/) { $wdiff_opt = "-$1"; shift; }
230
elsif ($ARGV[0] =~ /^(--ignore-space|-w)$/) {
231
push @diff_opts, "-w";
232
shift;
233
}
234
elsif ($ARGV[0] eq '--diffstat') { $show_diffstat = 1; shift; }
235
elsif ($ARGV[0] =~ /^--no-?diffstat$/) { $show_diffstat = 0; shift; }
236
elsif ($ARGV[0] =~ /^--no-?conf$/) {
237
fatal "--no-conf is only acceptable as the first command-line option!";
238
}
239
240
# Not a recognised option
241
elsif ($ARGV[0] =~ /^-/) {
242
fatal "Unrecognised command-line option $ARGV[0]; run $progname --help for more info";
243
}
244
else {
245
# End of command line options
246
last;
247
}
248
}
249
250
my $guessed_version = 0;
251
252
# If no file is given, assume that we are in a source directory
253
# and try to create a diff with the previous version
254
if(@ARGV == 0) {
255
fatal "Can't read file: debian/changelog" unless -r "debian/changelog";
256
open CHL, "debian/changelog";
257
while(<CHL>) {
258
if(/^(.+)\s\((\d+:)?(.+)\)\s(\w+)\;\surgency=.+$/) {
259
unshift @ARGV, "../".$1."_".$3.".dsc";
260
$guessed_version++;
261
}
262
last if $guessed_version > 1;
263
}
264
close CHL;
265
}
266
267
if (! $type) {
268
# we need 2 deb files or changes files to compare
269
fatal "Need exactly two deb files or changes files to compare"
270
unless @ARGV == 2;
271
272
foreach my $i (0,1) {
273
fatal "Can't read file: $ARGV[$i]" unless -r $ARGV[$i];
274
}
275
276
if ($ARGV[0] =~ /\.deb$/) { $type = 'deb'; }
277
elsif ($ARGV[0] =~ /\.udeb$/) { $type = 'deb'; }
278
elsif ($ARGV[0] =~ /\.changes$/) { $type = 'changes'; }
279
elsif ($ARGV[0] =~ /\.dsc$/) { $type = 'dsc'; }
280
elsif (`file $ARGV[0]` =~ /Debian/) { $type = 'deb'; }
281
else {
282
fatal "Could not recognise files; the names should end .deb, .udeb, .changes or .dsc";
283
}
284
if ($ARGV[1] !~ /\.$type$/) {
285
unless ($type eq 'deb' and `file $ARGV[0]` =~ /Debian/) {
286
fatal "The two filenames must have the same suffix, either .deb, .udeb, .changes or .dsc";
287
}
288
}
289
}
290
291
# We collect up the individual deb information in the hashes
292
# %deb1 and %deb2, each key of which is a .deb name and each value is
293
# a list ref. Note we need to use our, not my, as we will be symbolically
294
# referencing these variables
295
my @CommonDebs = ();
296
my @singledeb;
297
our (%debs1, %debs2, %files1, %files2, @D1, @D2, $dir1, $dir2, %DebPaths1, %DebPaths2);
298
299
if ($type eq 'deb') {
300
no strict 'refs';
301
foreach my $i (1,2) {
302
my $deb = shift;
303
my $debc = `env LC_ALL=C dpkg-deb -c $deb`;
304
$? == 0 or fatal "dpkg-deb -c $deb failed!";
305
my $debI = `env LC_ALL=C dpkg-deb -I $deb`;
306
$? == 0 or fatal "dpkg-deb -I $deb failed!";
307
# Store the name for later
308
$singledeb[$i] = $deb;
309
# get package name itself
310
$deb =~ s,.*/,,; $deb =~ s/_.*//;
311
@{"D$i"} = @{process_debc($debc,$i)};
312
push @{"D$i"}, @{process_debI($debI)};
313
}
314
}
315
elsif ($type eq 'changes' or $type eq 'debs') {
316
# Have to parse .changes files or remaining arguments
317
my $pwd = cwd;
318
foreach my $i (1,2) {
319
my (@debs) = ();
320
if ($type eq 'debs') {
321
if (@ARGV < 2) {
322
# Oops! There should be at least --from|--to deb ...
323
fatal "Missing .deb names or missing --to! (Run debdiff -h for help)\n";
324
}
325
shift; # get rid of --from or --to
326
while (@ARGV and $ARGV[0] ne '--to') {
327
push @debs, shift;
328
}
329
330
# Is there only one .deb listed?
331
if (@debs == 1) {
332
$singledeb[$i] = $debs[0];
333
}
334
} else {
335
my $changes = shift;
336
open CHANGES, $changes
337
or fatal "Couldn't open $changes: $!";
338
my $infiles = 0;
339
while (<CHANGES>) {
340
last if $infiles and /^[^ ]/;
341
/^Files:/ and $infiles=1, next;
342
next unless $infiles;
343
/ (\S*.u?deb)$/ and push @debs, dirname($changes) . '/' . $1;
344
}
345
close CHANGES
346
or fatal "Problem reading $changes: $!";
347
348
# Is there only one .deb listed?
349
if (@debs == 1) {
350
$singledeb[$i] = $debs[0];
351
}
352
}
353
354
foreach my $deb (@debs) {
355
no strict 'refs';
356
fatal "Can't read file: $deb" unless -r $deb;
357
my $debc = `env LC_ALL=C dpkg-deb -c $deb`;
358
$? == 0 or fatal "dpkg-deb -c $deb failed!";
359
my $debI = `env LC_ALL=C dpkg-deb -I $deb`;
360
$? == 0 or fatal "dpkg-deb -I $deb failed!";
361
my $debpath = $deb;
362
# get package name itself
363
$deb =~ s,.*/,,; $deb =~ s/_.*//;
364
$deb = $renamed{$deb} if $i == 1 and exists $renamed{$deb};
365
if (exists ${"debs$i"}{$deb}) {
366
warn "Same package name appears more than once (possibly due to renaming): $deb\n";
367
} else {
368
${"debs$i"}{$deb} = 1;
369
}
370
${"DebPaths$i"}{$deb} = $debpath;
371
foreach my $file (@{process_debc($debc,$i)}) {
372
${"files$i"}{$file} ||= "";
373
${"files$i"}{$file} .= "$deb:";
374
}
375
foreach my $control (@{process_debI($debI)}) {
376
${"files$i"}{$control} ||= "";
377
${"files$i"}{$control} .= "$deb:";
378
}
379
}
380
no strict 'refs';
381
@{"D$i"} = keys %{"files$i"};
382
# Go back again
383
chdir $pwd or fatal "Couldn't chdir $pwd: $!";
384
}
385
}
386
elsif ($type eq 'dsc') {
387
# Compare source packages
388
my $pwd = cwd;
389
390
my (@origs, @diffs, @dscs, @dscformats);
391
foreach my $i (1,2) {
392
my $dsc = shift;
393
chdir dirname($dsc)
394
or fatal "Couldn't chdir ", dirname($dsc), ": $!";
395
396
$dscs[$i] = cwd() . '/' . basename($dsc);
397
398
open DSC, basename($dsc) or fatal "Couldn't open $dsc: $!";
399
400
my $infiles=0;
401
while(<DSC>) {
402
if (/^Files:/) {
403
$infiles=1;
404
next;
405
} elsif (/^Format: (.*)$/) {
406
$dscformats[$i] = $1;
407
}
408
next unless $infiles;
409
last if /^\s*$/;
410
last if /^[-\w]+:/; # don't expect this, but who knows?
411
chomp;
412
413
# This had better match
414
if (/^\s+[0-9a-f]{32}\s+\d+\s+(\S+)$/) {
415
my $file = $1;
416
if ($file =~ /\.diff\.gz$/) {
417
$diffs[$i] = cwd() . '/' . $file;
418
}
419
elsif ($file =~ /(\.orig)?\.tar\.gz$/) {
420
$origs[$i] = $file;
421
}
422
} else {
423
warn "Unrecognised file line in .dsc:\n$_\n";
424
}
425
}
426
427
close DSC or fatal "Problem closing $dsc: $!";
428
# Go back again
429
chdir $pwd or fatal "Couldn't chdir $pwd: $!";
430
}
431
432
# Do we have interdiff?
433
system("command -v interdiff >/dev/null 2>&1");
434
my $use_interdiff = ($?==0) ? 1 : 0;
435
system("command -v diffstat >/dev/null 2>&1");
436
my $have_diffstat = ($?==0) ? 1 : 0;
437
438
my ($fh, $filename) = tempfile("debdiffXXXXXX",
439
SUFFIX => ".diff",
440
DIR => File::Spec->tmpdir,
441
UNLINK => 1);
442
443
if ($origs[1] eq $origs[2] and defined $diffs[1] and defined $diffs[2]
444
and scalar(@excludes) == 0 and $use_interdiff) {
445
# same orig tar ball and interdiff exists
446
447
my $command = join( " ", ("interdiff", "-z", @diff_opts, "'$diffs[1]'",
448
"'$diffs[2]'", ">", $filename) );
449
my $rv = system($command);
450
if ($rv) {
451
fatal "interdiff -z $diffs[1] $diffs[2] failed!";
452
} else {
453
if ($have_diffstat and $show_diffstat) {
454
my $header = "diffstat for " . basename($diffs[1])
455
. " " . basename($diffs[2]) . "\n\n";
456
$header =~ s/\.diff\.gz//g;
457
print $header;
458
system("diffstat $filename");
459
print "\n";
460
}
461
open( INTERDIFF, '<', $filename );
462
while( <INTERDIFF> ) {
463
print $_;
464
}
465
close INTERDIFF;
466
}
467
} else {
468
# Any other situation
469
if ($origs[1] eq $origs[2] and
470
defined $diffs[1] and defined $diffs[2] and
471
scalar(@excludes) == 0) {
472
warn "Warning: You do not seem to have interdiff (in the patchutils package)\ninstalled; this program would use it if it were available.\n";
473
}
474
# possibly different orig tarballs, or no interdiff installed
475
our ($sdir1, $sdir2);
476
mktmpdirs();
477
for my $i (1,2) {
478
no strict 'refs';
479
my @opts = ('-x');
480
push (@opts, '--skip-patches') if $dscformats[$i] eq '3.0 (quilt)';
481
my $cmd = qq(cd ${"dir$i"} && dpkg-source @opts $dscs[$i] >/dev/null);
482
system $cmd;
483
if ($? != 0) {
484
my $dir = dirname $dscs[1] if $i == 2;
485
$dir = dirname $dscs[2] if $i == 1;
486
my $cmdx = qq(cp $dir/$origs[$i] ${"dir$i"} >/dev/null);
487
system $cmdx;
488
fatal "$cmd failed" if $? != 0;
489
my $dscx = basename $dscs[$i];
490
$cmdx = qq(cp $diffs[$i] ${"dir$i"} && cp $dscs[$i] ${"dir$i"} && cd ${"dir$i"} && dpkg-source @opts $dscx > /dev/null);
491
system $cmdx;
492
fatal "$cmd failed" if $? != 0;
493
}
494
opendir DIR,${"dir$i"};
495
while ($_ = readdir(DIR)) {
496
next if $_ eq '.' || $_ eq '..' || ! -d ${"dir$i"}."/$_";
497
${"sdir$i"} = $_;
498
last;
499
}
500
closedir(DIR);
501
opendir DIR,${"dir$i"}.'/'.${"sdir$i"};
502
503
my $tarballs = 1;
504
while ($_ = readdir(DIR)) {
505
my $unpacked = "=unpacked-tar" . $tarballs . "=";
506
my $filename = $_;
507
if ($_ =~ /tar.gz$/) {
508
$filename =~ s%(.*)\.tar\.gz$%$1%;
509
$tarballs++;
510
system qq(cd ${"dir$i"}/${"sdir$i"} && tar zxf $_ >/dev/null && test -d $filename && mv $filename $unpacked);
511
}
512
if ($_ =~ /tar.bz$/ || $_ =~ /tar.bz2$/) {
513
$filename =~ s%(.*)\.tar\.bz2?$%$1%;
514
$tarballs++;
515
system qq(cd ${"dir$i"}/${"sdir$i"} && tar jxf $_ >/dev/null && test -d $filename && mv $filename $unpacked);
516
}
517
}
518
closedir(DIR);
519
}
520
521
my @command = ("diff", "-Nru", @diff_opts);
522
for my $exclude (@excludes) {
523
push @command, ("--exclude", "'$exclude'");
524
}
525
push @command, ("'$dir1/$sdir1'", "'$dir2/$sdir2'");
526
push @command, (">", $filename);
527
528
# Execute diff and remove the common prefixes $dir1/$dir2, so the patch can be used with -p1,
529
# as if when interdiff would have been used:
530
system(join(" ", @command)) || fatal "Failed to execute @command!";
531
532
if ($have_diffstat and $show_diffstat) {
533
print "diffstat for $sdir1 $sdir2\n\n";
534
system("diffstat $filename");
535
print "\n";
536
}
537
538
open( DIFF, '<', $filename );
539
540
while(<DIFF>) {
541
s/^--- $dir1\//--- /;
542
s/^\+\+\+ $dir2\//+++ /;
543
s/^(diff .*) $dir1\/\Q$sdir1\E/$1 $sdir1/;
544
s/^(diff .*) $dir2\/\Q$sdir2\E/$1 $sdir2/;
545
print;
546
}
547
close DIFF;
548
}
549
550
exit 0;
551
}
552
else {
553
fatal "Internal error: \$type = $type unrecognised";
554
}
555
556
557
# Compare
558
# Start by a piece of common code to set up the @CommonDebs list and the like
559
560
my (@deblosses, @debgains);
561
562
{
563
my %debs;
564
grep $debs{$_}--, keys %debs1;
565
grep $debs{$_}++, keys %debs2;
566
567
@deblosses = sort grep $debs{$_} < 0, keys %debs;
568
@debgains = sort grep $debs{$_} > 0, keys %debs;
569
@CommonDebs= sort grep $debs{$_} == 0, keys %debs;
570
}
571
572
if ($show_moved and $type ne 'deb') {
573
if (@debgains) {
574
my $msg = "Warning: these package names were in the second list but not in the first:";
575
print $msg, "\n", '-' x length $msg, "\n";
576
print join("\n",@debgains), "\n\n";
577
}
578
579
if (@deblosses) {
580
print "\n" if @debgains;
581
my $msg = "Warning: these package names were in the first list but not in the second:";
582
print $msg, "\n", '-' x length $msg, "\n";
583
print join("\n",@deblosses), "\n\n";
584
}
585
586
# We start by determining which files are in the first set of debs, the
587
# second set of debs or both.
588
my %files;
589
grep $files{$_}--, @D1;
590
grep $files{$_}++, @D2;
591
592
my @old = sort grep $files{$_} < 0, keys %files;
593
my @new = sort grep $files{$_} > 0, keys %files;
594
my @same = sort grep $files{$_} == 0, keys %files;
595
596
# We store any changed files in a hash of hashes %changes, where
597
# $changes{$from}{$to} is an array of files which have moved
598
# from package $from to package $to; $from or $to is '-' if
599
# the files have appeared or disappeared
600
601
my %changes;
602
my @funny; # for storing changed files which appear in multiple debs
603
604
foreach my $file (@old) {
605
my @firstdebs = split /:/, $files1{$file};
606
foreach my $firstdeb (@firstdebs) {
607
push @{$changes{$firstdeb}{'-'}}, $file;
608
}
609
}
610
611
foreach my $file (@new) {
612
my @seconddebs = split /:/, $files2{$file};
613
foreach my $seconddeb (@seconddebs) {
614
push @{$changes{'-'}{$seconddeb}}, $file;
615
}
616
}
617
618
foreach my $file (@same) {
619
# Are they identical?
620
next if $files1{$file} eq $files2{$file};
621
622
# Ah, they're not the same. If the file has moved from one deb
623
# to another, we'll put a note in that pair. But if the file
624
# was in more than one deb or ends up in more than one deb, we'll
625
# list it separately.
626
my @fdebs1 = split (/:/, $files1{$file});
627
my @fdebs2 = split (/:/, $files2{$file});
628
629
if (@fdebs1 == 1 && @fdebs2 == 1) {
630
push @{$changes{$fdebs1[0]}{$fdebs2[0]}}, $file;
631
} else {
632
# two packages to one or vice versa, or something like that
633
push @funny, [$file, \@fdebs1, \@fdebs2];
634
}
635
}
636
637
# This is not a very efficient way of doing things if there are
638
# lots of debs involved, but since that is highly unlikely, it
639
# shouldn't be much of an issue
640
my $changed = 0;
641
642
for my $deb1 (sort(keys %debs1), '-') {
643
next unless exists $changes{$deb1};
644
for my $deb2 ('-', sort keys %debs2) {
645
next unless exists $changes{$deb1}{$deb2};
646
my $msg;
647
if (! $changed) {
648
print "[The following lists of changes regard files as different if they have\ndifferent names, permissions or owners.]\n\n";
649
}
650
if ($deb1 eq '-') {
651
$msg = "New files in second set of .debs, found in package $deb2";
652
} elsif ($deb2 eq '-') {
653
$msg = "Files only in first set of .debs, found in package $deb1";
654
} else {
655
$msg = "Files moved from package $deb1 to package $deb2";
656
}
657
print $msg, "\n", '-' x length $msg, "\n";
658
print join("\n",@{$changes{$deb1}{$deb2}}), "\n\n";
659
$changed = 1;
660
}
661
}
662
663
if (@funny) {
664
my $msg = "Files moved or copied from at least TWO packages or to at least TWO packages";
665
print $msg, "\n", '-' x length $msg, "\n";
666
for my $funny (@funny) {
667
print $$funny[0], "\n"; # filename and details
668
print "From package", (@{$$funny[1]} > 1 ? "s" : ""), ": ";
669
print join(", ", @{$$funny[1]}), "\n";
670
print "To package", (@{$$funny[2]} > 1 ? "s" : ""), ": ";
671
print join(", ", @{$$funny[2]}), "\n";
672
}
673
$changed = 1;
674
}
675
676
if (! $quiet && ! $changed) {
677
print "File lists identical on package level (after any substitutions)\n";
678
}
679
$exit_status = 1 if $changed;
680
} else {
681
my %files;
682
grep $files{$_}--, @D1;
683
grep $files{$_}++, @D2;
684
685
my @losses = sort grep $files{$_} < 0, keys %files;
686
my @gains = sort grep $files{$_} > 0, keys %files;
687
688
if (@losses == 0 && @gains == 0) {
689
print "File lists identical (after any substitutions)\n"
690
unless $quiet;
691
} else {
692
print "[The following lists of changes regard files as different if they have\ndifferent names, permissions or owners.]\n\n";
693
}
694
695
if (@gains) {
696
my $msg;
697
if ($type eq 'debs') {
698
$msg = "Files in second set of .debs but not in first";
699
} else {
700
$msg = sprintf "Files in second .%s but not in first",
701
$type eq 'deb' ? 'deb' : 'changes';
702
}
703
print $msg, "\n", '-' x length $msg, "\n";
704
print join("\n",@gains), "\n";
705
$exit_status = 1;
706
}
707
708
if (@losses) {
709
print "\n" if @gains;
710
my $msg;
711
if ($type eq 'debs') {
712
$msg = "Files in first set of .debs but not in second";
713
} else {
714
$msg = sprintf "Files in first .%s but not in second",
715
$type eq 'deb' ? 'deb' : 'changes';
716
}
717
print $msg, "\n", '-' x length $msg, "\n";
718
print join("\n",@losses), "\n";
719
$exit_status = 1;
720
}
721
}
722
723
# We compare the control files (at least the dependency fields)
724
my $dummyname = "---DUMMY---";
725
if (defined $singledeb[1] and defined $singledeb[2]) {
726
@CommonDebs = ( $dummyname );
727
$DebPaths1{$dummyname} = $singledeb[1];
728
$DebPaths2{$dummyname} = $singledeb[2];
729
}
730
731
exit $exit_status unless (@CommonDebs > 0) and $compare_control;
732
733
unless (system ("command -v wdiff >/dev/null 2>&1") == 0) {
734
warn "Can't compare control files; wdiff package not installed\n";
735
exit $exit_status;
736
}
737
738
for my $debname (@CommonDebs) {
739
no strict 'refs';
740
mktmpdirs();
741
742
for my $i (1,2) {
743
if (system('dpkg-deb', '-e', "${\"DebPaths$i\"}{$debname}", ${"dir$i"})) {
744
my $msg = "dpkg-deb -e ${\"DebPaths$i\"}{$debname} failed!";
745
system ("rm", "-rf", $dir1, $dir2);
746
fatal $msg;
747
}
748
}
749
750
use strict 'refs';
751
752
my @cf;
753
if ($controlfiles eq 'ALL') {
754
# only need to list one directory as we are only comparing control
755
# files in both packages
756
@cf = grep { ! /md5sums/ } map { basename($_); } glob("$dir1/*");
757
} else {
758
@cf = split /,/, $controlfiles;
759
}
760
761
foreach my $cf (@cf) {
762
next unless -f "$dir1/$cf" and -f "$dir2/$cf";
763
if ($cf eq 'control' or $cf eq 'conffiles') {
764
for my $file ("$dir1/$cf", "$dir2/$cf") {
765
my ($fd, @hdrs);
766
open $fd, '<', $file or fatal "Cannot read $file: $!";
767
while (<$fd>) {
768
if (/^\s/ and @hdrs > 0) {
769
$hdrs[$#hdrs] .= $_;
770
} else {
771
push @hdrs, $_;
772
}
773
}
774
close $fd;
775
open $fd, '>', $file or fatal "Cannot write $file: $!";
776
print $fd sort @hdrs;
777
close $fd;
778
}
779
}
780
my $wdiff = `wdiff -n $wdiff_opt $dir1/$cf $dir2/$cf`;
781
my $usepkgname = $debname eq $dummyname ? "" : " of package $debname";
782
if ($? >> 8 == 0) {
783
if (! $quiet) {
784
print "\nNo differences were encountered between the $cf files$usepkgname\n";
785
}
786
} elsif ($? >> 8 == 1) {
787
print "\n";
788
if ($wdiff_opt) {
789
# Don't try messing with control codes
790
my $msg = ucfirst($cf) . " files$usepkgname: wdiff output";
791
print $msg, "\n", '-' x length $msg, "\n";
792
print $wdiff;
793
} else {
794
my @output;
795
@output = split /\n/, $wdiff;
796
@output = grep /(\[-|\{\+)/, @output;
797
my $msg = ucfirst($cf) . " files$usepkgname: lines which differ (wdiff format)";
798
print $msg, "\n", '-' x length $msg, "\n";
799
print join("\n",@output), "\n";
800
}
801
$exit_status = 1;
802
} else {
803
warn "wdiff failed (exit status " . ($? >> 8) .
804
(($? & 0x7f) ? " with signal " . ($? & 0x7f) : "") . ")\n";
805
}
806
}
807
# Clean up
808
system ("rm", "-rf", $dir1, $dir2);
809
}
810
811
exit $exit_status;
812
813
###### Subroutines
814
815
# This routine takes the output of dpkg-deb -c and returns
816
# a processed listref
817
sub process_debc($$)
818
{
819
my ($data,$number) = @_;
820
my (@filelist);
821
822
# Format of dpkg-deb -c output:
823
# permissions owner/group size date time name ['->' link destination]
824
$data =~ s/^(\S+)\s+(\S+)\s+(\S+\s+){3}/$1 $2 /mg;
825
$data =~ s, \./, /,mg;
826
@filelist = grep ! m| /$|, split /\n/, $data; # don't bother keeping '/'
827
828
# Are we keeping directory names in our filelists?
829
if ($ignore_dirs) {
830
@filelist = grep ! m|/$|, @filelist;
831
}
832
833
# Do the "move" substitutions in the order received for the first debs
834
if ($number == 1 and @move) {
835
my @split_filelist = map { m/^(\S+) (\S+) (.*)/ && [$1, $2, $3] }
836
@filelist;
837
for my $move (@move) {
838
my $regex = $$move[0];
839
my $from = $$move[1];
840
my $to = $$move[2];
841
map { if ($regex) { eval "\$\$_[2] =~ s:$from:$to:g"; }
842
else { $$_[2] =~ s/\Q$from\E/$to/; } } @split_filelist;
843
}
844
@filelist = map { "$$_[0] $$_[1] $$_[2]" } @split_filelist;
845
}
846
847
return \@filelist;
848
}
849
850
# This does the same for dpkg-deb -I
851
sub process_debI($)
852
{
853
my ($data) = @_;
854
my (@filelist);
855
856
# Format of dpkg-deb -c output:
857
# 2 (always?) header lines
858
# nnnn bytes, nnn lines [*] filename [interpreter]
859
# Package: ...
860
# rest of control file
861
862
foreach (split /\n/, $data) {
863
last if /^Package:/;
864
next unless /^\s+\d+\s+bytes,\s+\d+\s+lines\s+(\*)?\s+([\-\w]+)/;
865
my $control = $2;
866
my $perms = ($1 ? "-rwxr-xr-x" : "-rw-r--r--");
867
push @filelist, "$perms root/root DEBIAN/$control";
868
}
869
870
return \@filelist;
871
}
872
873
sub mktmpdirs ()
874
{
875
no strict 'refs';
876
877
for my $i (1,2) {
878
${"dir$i"}=tempdir( CLEANUP => 1 );
879
fatal "Couldn't create temp directory"
880
if not defined ${"dir$i"};
881
}
882
}
883
884
sub fatal(@)
885
{
886
my ($pack,$file,$line);
887
($pack,$file,$line) = caller();
888
(my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d;
889
$msg =~ s/\n\n$/\n/;
890
die $msg;
891
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1