pristine-bz2

   1 #!/usr/bin/perl
   2
   3 =head1 NAME
   4
   5 pristine-bz2 - regenerate pristine bz2 files
   6
   7 =head1 SYNOPSIS
   8
   9 B<pristine-bz2> [-vdk] gendelta I<file.bz2> I<delta>
  10
  11 B<pristine-bz2> [-vdk] genbz2 I<delta> I<file>
  12
  13 =head1 DESCRIPTION
  14
  15 This is a complement to the pristine-tar(1) command. Normally you
  16 don't need to run it by hand, since pristine-tar calls it as necessary
  17 to handle .tar.bz2 files.
  18
  19 pristine-bz2 gendelta takes the specified I<bz2> file, and generates a
  20 small binary I<delta> file that can later be used by pristine-bz2 genbz2
  21 to recreate the original file.
  22
  23 pristine-bz2 genbz2 takes the specified I<delta> file, and compresses the
  24 specified input I<file> (which must be identical to the contents of the
  25 original bz2 file). The resulting file will be identical to
  26 the original gz file used to create the delta.
  27
  28 The approach used to regenerate the original bz2 file is to figure out
  29 how it was produced -- what compression level was used, whether it was
  30 built with bzip2(1) or with pbzip2(1).
  31
  32 Note that other tools exist, like bzip2smp or dbzip2, but they are
  33 said to be bit-identical with bzip2. Anyway, bzip2 looks like the most
  34 widespread implementation, so it's hard to find bzip2 files that make
  35 pristine-bz2 fail. Please report!
  36
  37 The deprecated bzip1 compression method hasn't been implemented.
  38
  39 If the delta filename is "-", pristine-bz2 reads or writes it to stdio.
  40
  41 =head1 OPTIONS
  42
  43 =over 4
  44
  45 =item -v
  46
  47 Verbose mode, show each command that is run.
  48
  49 =item -d
  50
  51 Debug mode.
  52
  53 =item -k
  54
  55 Don't clean up the temporary directory on exit.
  56
  57 =item -t
  58
  59 Try harder to determine how to generate deltas of difficult bz2 files.
  60
  61 =back
  62
  63 =head1 ENVIRONMENT
  64
  65 =over 4
  66
  67 =item B<TMPDIR>
  68
  69 Specifies a location to place temporary files, other than the default.
  70
  71 =back
  72
  73 =head1 AUTHOR
  74
  75 Joey Hess <joeyh@debian.org>,
  76 Faidon Liambotis <paravoid@debian.org>,
  77 Cyril Brulebois <cyril.brulebois@enst-bretagne.fr>
  78
  79 Licensed under the GPL, version 2.
  80
  81 =cut
  82
  83 use warnings;
  84 use strict;
  85 use Pristine::Tar;
  86 use Pristine::Tar::Delta;
  87 use Pristine::Tar::Formats;
  88 use File::Basename qw/basename/;
  89 use IO::Handle;
  90
  91 delete $ENV{BZIP};
  92 delete $ENV{BZIP2};
  93
  94 my @supported_bzip2_programs = qw(bzip2 pbzip2 zgz);
  95
  96 my $try=0;
  97
  98 dispatch(
  99         commands => {
 100                 usage => [\&usage],
 101                 genbz2 => [\&genbz2, 2],
 102                 gendelta => [\&gendelta, 2],
 103         },
 104         options => {
 105                 "t|try!" => \$try,
 106         },
 107 );
 108
 109 sub usage {
 110         print STDERR "Usage: pristine-bz2 [-vdkt] gendelta file.bz2 delta\n";
 111         print STDERR "       pristine-bz2 [-vdkt] genbz2 delta file\n";
 112 }
 113
 114 sub readbzip2 {
 115         my $filename = shift;
 116
 117         if (! is_bz2($filename)) {
 118                 error "This is not a valid BZip2 archive.";
 119         }
 120
 121         open(BZIP2, "< $filename")
 122                 or die("Could not open '$filename' for reading: $!\n");
 123
 124         my $chars;
 125         if (read(BZIP2, $chars, 4) != 4) {
 126                 die("Unable to read from input\n");
 127         }
 128
 129         my ($id1, $id2, $method, $level)
 130                 = unpack("CCCC", $chars);
 131         # we actually want the value, not the ascii position
 132         $level-=48;
 133
 134         if ($level !~ /^[1-9]$/) {
 135                 error "Unknown compression level $level\n";
 136         }
 137
 138         close(BZIP2);
 139
 140         return ($level);
 141 }
 142
 143 sub predictbzip2args {
 144         my ($level, $program) = @_;
 145
 146         my @args=["-$level"];
 147
 148         if ($program eq 'zgz') {
 149                 @args=["-$level", "--old-bzip2"];
 150                 push @args, ["-$level", "--suse-bzip2"];
 151                 push @args, ["-$level", "--suse-pbzip2"];
 152         }
 153
 154         return @args;
 155 }
 156
 157 sub testvariant {
 158         my ($old, $tmpin, $bzip2_program, @args) = @_;
 159
 160         # some compressors eat the uncompressed file, some
 161         # do not; restore as needed. (Note that file name,
 162         # mode, mtime do not matter to bzip2.)
 163         if (! -e $tmpin) {
 164                 doit("cp", "$tmpin.bak", "$tmpin");
 165         }
 166
 167         my $new=$tmpin.'.bz2';
 168         unlink($new);
 169
 170         # try bzip2'ing with the arguments passed
 171         if ($bzip2_program ne 'zgz') {
 172                 doit($bzip2_program, @args, $tmpin);
 173         }
 174         else {
 175                 doit_redir($tmpin, $new, $bzip2_program, @args);
 176         }
 177         unless (-e $new) {
 178                 die("$bzip2_program failed, aborting");
 179         }
 180
 181         # and compare the generated with the original
 182         return !comparefiles($old, $new);
 183 }
 184
 185 sub reproducebzip2 {
 186         my $orig=shift;
 187
 188         my $wd=tempdir();
 189
 190         my $tmpin="$wd/test";
 191         doit_redir($orig, "$tmpin.bak", "bzip2", "-dc");
 192
 193         # read fields from bzip2 headers
 194         my ($level) = readbzip2($orig);
 195         debug("level: $level");
 196
 197         foreach my $program (@supported_bzip2_programs) {
 198                 # try to guess the bzip2 arguments that are needed by the
 199                 # header information
 200                 foreach my $args (predictbzip2args($level, $program)) {
 201                         testvariant($orig, $tmpin, $program, @$args)
 202                                 && return $program, @$args;
 203                 }
 204         }
 205
 206         # 7z has a weird syntax, not supported yet, as not seen in the wild
 207         #testvariant($orig, $tmpin, "7z", "-mx$level", "a", "$tmpin.bz2")
 208         #       && return "7z", "-mx$level", "a" ; # XXX need to include outfile
 209
 210         # pbzip2 -b option affects output, but cannot be detected from a
 211         # header.
 212         if ($try) {
 213                 my @args = @{predictbzip2args($level, "pbzip2")->[0]};
 214                 print STDERR "pristine-bz2 will have to try especially hard to reproduce $orig\n";
 215                 print STDERR "(This could take a long time.)\n";
 216                 my %tried;
 217                 $tried{9}=1; # default
 218                 # Try searching for likely candidates first, and fill in.
 219                 # It could go higher than 100, but have to stop somewhere.
 220                 STDERR->autoflush(1);
 221                 foreach my $try (1..10,
 222                                  15, 20, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95,
 223                                  1..100) {
 224                         next if $tried{$try};
 225                         $tried{$try}=1;
 226                         print STDERR "\r\tblock size: $try   ";
 227                         testvariant($orig, $tmpin, "pbzip2", "-b${try}", @args) &&
 228                                 return "pbzip2", "-b${try}", @args;
 229                 }
 230                 print STDERR "\n";
 231         }
 232
 233         print STDERR "pristine-bz2 failed to reproduce build of $orig\n";
 234         print STDERR "(Please file a bug report.)\n";
 235         exit 1;
 236 }
 237
 238 sub genbz2 {
 239         my $deltafile=shift;
 240         my $file=shift;
 241
 242         my $delta=Pristine::Tar::Delta::read(Tarball => $deltafile);
 243         Pristine::Tar::Delta::assert($delta, type => "bz2", maxversion => 2,
 244                 fields => [qw{params program}]);
 245
 246         my @params=split(' ', $delta->{params});
 247         while (@params) {
 248                 my $param=shift @params;
 249
 250                 next if $param=~/^(-[1-9])$/;
 251                 next if $param eq '--old-bzip2';
 252                 next if $param eq '--suse-bzip2';
 253                 next if $param eq '--suse-pbzip2';
 254                 die "paranoia check failed on params from delta (@params)";
 255         }
 256         @params=split(' ', $delta->{params});
 257
 258         my $program=$delta->{program};
 259         if (! grep { $program eq $_ } @supported_bzip2_programs) {
 260                 die "paranoia check failed on program from delta ($program)";
 261         }
 262
 263         if ($program eq 'zgz') {
 264                 # unlike bzip2, zgz only uses stdio
 265                 doit_redir($file, "$file.bz2", $program, @params);
 266         }
 267         else {
 268                 doit($program, @params, $file);
 269         }
 270         doit("rm", "-f", $file);
 271 }
 272
 273 sub gendelta {
 274         my $bzip2file=shift;
 275         my $deltafile=shift;
 276
 277         my ($program, @params) = reproducebzip2($bzip2file);
 278
 279         Pristine::Tar::Delta::write(Tarball => $deltafile, {
 280                 version => '2.0',
 281                 type => 'bz2',
 282                 params => "@params",
 283                 program => $program,
 284         });
 285 }