← Back to branch summary

~ubuntu-branches/ubuntu/precise/pristine-tar/precise-proposed

« back to all changes in this revision

Viewing changes to pristine-bz2

  • Committer: Bazaar Package Importer
  • Author(s): Joey Hess
  • Date: 2010-08-19 16:36:25 UTC
  • Revision ID: james.westby@ubuntu.com-20100819163625-y78g4vegbjm1n7mw
Tags: 1.10
http://bugs.debian.org/498760
* pristine-gz gengz: Bugfix: Always remove uncompressed input file.
* Large refactoring and modularization. (Thanks Gabriel de Perthuis
  for inspiration for this.))
* Remove environment variables used by tar, gz, and bzip2, to avoid
  local environment settings possibly breaking things.
  Closes: #498760 (probably; thanks Ralph Lange for analysis)
* Lintian fixes.

Show diffs side-by-side

added added

removed removed

Lines of Context:
pristine-bz2
82
82
 
83
83
use warnings;
84
84
use strict;
85
 
use File::Temp;
86
 
use Getopt::Long;
 
85
use Pristine::Tar;
 
86
use Pristine::Tar::Delta;
 
87
use Pristine::Tar::Formats;
87
88
use File::Basename qw/basename/;
88
 
use IPC::Open2;
89
89
use IO::Handle;
90
90
 
91
 
use constant BZIP2_DEBUG         => 1;
92
 
 
93
 
# magic identification
94
 
use constant BZIP2_ID1           => 0x42;
95
 
use constant BZIP2_ID2           => 0x5a;
96
 
 
97
 
# compression methods, 'h' for Bzip2 ('H'uffman coding), '0' for Bzip1 (deprecated)
98
 
use constant BZIP2_METHOD_HUFFMAN => 0x68;
 
91
delete $ENV{BZIP};
 
92
delete $ENV{BZIP2};
99
93
 
100
94
my @supported_bzip2_programs = qw(bzip2 pbzip2 zgz);
101
95
 
102
 
my $verbose=0;
103
 
my $debug=0;
104
 
my $keep=0;
105
96
my $try=0;
106
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
 
107
109
sub usage {
108
110
        print STDERR "Usage: pristine-bz2 [-vdkt] gendelta file.bz2 delta\n";
109
111
        print STDERR "       pristine-bz2 [-vdkt] genbz2 delta file\n";
110
112
}
111
113
 
112
 
sub debug {
113
 
        print STDERR "debug: @_\n" if $debug;
114
 
}
115
 
 
116
 
sub vprint {
117
 
        print STDERR "pristine-bz2: @_\n" if $verbose;
118
 
}
119
 
 
120
 
sub doit {
121
 
        vprint(@_);
122
 
        if (system(@_) != 0) {
123
 
                die "command failed: @_\n";
124
 
        }
125
 
}
126
 
 
127
 
sub doit_redir {
128
 
        no warnings 'once';
129
 
        my ($in, $out, @args) = @_;
130
 
        vprint(@args, "<", $in, ">", $out);
131
 
        open INFILE, "<", $in or die("Could not open '$in' for reading: $!\n");
132
 
        open OUTFILE, ">", $out or die("Could not open '$out' for reading: $!\n");
133
 
        my $pid = open2(">&OUTFILE", "<&INFILE", @args);
134
 
        waitpid $pid, 0;
135
 
}
136
 
 
137
 
sub tempdir {
138
 
        return File::Temp::tempdir("pristine-bz2.XXXXXXXXXX",
139
 
                TMPDIR => 1, CLEANUP => !$keep);
140
 
}
141
 
 
142
114
sub readbzip2 {
143
115
        my $filename = shift;
144
 
        my $chars;
 
116
 
 
117
        if (! is_bz2($filename)) {
 
118
                error "This is not a valid BZip2 archive.";
 
119
        }
145
120
 
146
121
        open(BZIP2, "< $filename")
147
122
                or die("Could not open '$filename' for reading: $!\n");
148
123
 
 
124
        my $chars;
149
125
        if (read(BZIP2, $chars, 4) != 4) {
150
126
                die("Unable to read from input\n");
151
127
        }
155
131
        # we actually want the value, not the ascii position
156
132
        $level-=48;
157
133
 
158
 
        if ($id1 != BZIP2_ID1 || $id2 != BZIP2_ID2 || $method != BZIP2_METHOD_HUFFMAN || $level !~ /^[1-9]$/) {
159
 
                die("This is not a valid BZip2 archive.\n");
 
134
        if ($level !~ /^[1-9]$/) {
 
135
                error "Unknown compression level $level\n";
160
136
        }
161
137
 
162
138
        close(BZIP2);
217
193
}
218
194
 
219
195
sub reproducebzip2 {
220
 
        my ($wd, $orig) = (shift, shift);
 
196
        my $orig=shift;
 
197
 
 
198
        my $wd=tempdir();
221
199
        
222
200
        my $tmpin="$wd/test";
223
201
        doit_redir($orig, "$tmpin.bak", "bzip2", "-dc");
268
246
}
269
247
 
270
248
sub genbz2 {
271
 
        my $delta=shift;
 
249
        my $deltafile=shift;
272
250
        my $file=shift;
273
251
 
274
 
        my $tempdir=tempdir();
275
 
 
276
 
        if ($delta eq "-") {
277
 
                $delta="$tempdir/in";
278
 
                open (OUT, ">", $delta) || die "$delta: $!";
279
 
                while (<STDIN>) {
280
 
                        print OUT $_;
281
 
                }
282
 
                close OUT;
283
 
        }
284
 
 
285
 
        doit("tar", "xf", File::Spec->rel2abs($delta), "-C", $tempdir);
286
 
        if (! -e "$tempdir/type") {
287
 
                die "failed to genbz2 delta $delta\n";
288
 
        }
289
 
 
290
 
        open (IN, "$tempdir/version") || die "delta lacks version number ($!)";
291
 
        my $version=<IN>;
292
 
        if ($version >= 3) {
293
 
                die "delta is version $version, not supported\n";
294
 
        }
295
 
        close IN;
296
 
        if (open (IN, "$tempdir/type")) {
297
 
                my $type=<IN>;
298
 
                chomp $type;
299
 
                if ($type ne "bz2") {
300
 
                        die "delta is for a $type, not a bz2\n";
301
 
                }
302
 
                close IN;
303
 
        }
304
 
 
305
 
        open (IN, "$tempdir/params") || die "delta lacks params file ($!)";
306
 
        my $params=<IN>;
307
 
        chomp $params;
308
 
        my @params=split(' ', $params);
309
 
        while (@params) {
310
 
                $_=shift @params;
311
 
                next if /^(-[1-9])$/;
312
 
                next if $_ eq '--old-bzip2';
313
 
                die "paranoia check failed on params file from delta ($params)";
314
 
        }
315
 
        @params=split(' ', $params);
316
 
        close IN;
317
 
 
318
 
        open (IN, "$tempdir/program") || die "delta lacks program file ($!)";
319
 
        my $program=<IN>;
320
 
        chomp $program;
 
252
        my $delta=Pristine::Tar::Delta::read(Tarball => $deltafile);
 
253
        Pristine::Tar::Delta::assert($delta, type => "bz2", maxversion => 2, 
 
254
                fields => [qw{params program}]);
 
255
 
 
256
        my @params=split(' ', $delta->{params});
 
257
        foreach my $param (@params) {
 
258
                next if $param=~/^(-[1-9])$/;
 
259
                next if $param eq '--old-bzip2';
 
260
                die "paranoia check failed on params from delta (@params)";
 
261
        }
 
262
 
 
263
        my $program=$delta->{program};
321
264
        if (! grep { $program eq $_ } @supported_bzip2_programs) {
322
 
                die "paranoia check failed on program file from delta ($program)";
 
265
                die "paranoia check failed on program from delta ($program)";
323
266
        }
324
 
        close IN;
325
267
 
326
268
        if ($program eq 'zgz') {
327
269
                # unlike bzip2, zgz only uses sdio
335
277
 
336
278
sub gendelta {
337
279
        my $bzip2file=shift;
338
 
        my $delta=shift;
339
 
 
340
 
        my $tempdir=tempdir();
341
 
 
342
 
        my $stdout=0;
343
 
        if ($delta eq "-") {
344
 
                $stdout=1;
345
 
                $delta="$tempdir/out";
346
 
        }
347
 
 
348
 
        my @files=qw(version type params program);
349
 
 
350
 
        my ($program, @params)=
351
 
                reproducebzip2($tempdir, $bzip2file);
352
 
 
353
 
        open(OUT, ">", "$tempdir/version") || die "$!";
354
 
        print OUT "2.0\n";
355
 
        close OUT;
356
 
        open(OUT, ">", "$tempdir/type") || die "$!";
357
 
        print OUT "bz2\n";
358
 
        close OUT;
359
 
        open(OUT, ">", "$tempdir/params") || die "$!";
360
 
        print OUT "@params\n";
361
 
        close OUT;
362
 
        open(OUT, ">", "$tempdir/program") || die "$!";
363
 
        print OUT "$program\n";
364
 
        close OUT;
365
 
 
366
 
        doit("tar", "czf", $delta, "-C", $tempdir, @files);
367
 
 
368
 
        if ($stdout) {
369
 
                doit("cat", $delta);
370
 
        }
371
 
}
372
 
 
373
 
Getopt::Long::Configure("bundling");
374
 
if (! GetOptions(
375
 
        "v|verbose!" => \$verbose,
376
 
        "d|debug!" => \$debug,
377
 
        "k|keep!" => \$keep,
378
 
        "t|try!" => \$try,
379
 
   ) || @ARGV != 3) {
380
 
        usage();
381
 
        exit 1;
382
 
}
383
 
 
384
 
my $command=shift;
385
 
if ($command eq 'genbz2') {
386
 
        genbz2(@ARGV);
387
 
}
388
 
elsif ($command eq 'gendelta') {
389
 
        gendelta(@ARGV);
390
 
}
391
 
else {
392
 
        print STDERR "Unknown subcommand \"$command\"\n";
393
 
        usage();
394
 
        exit 1;
 
280
        my $deltafile=shift;
 
281
 
 
282
        my ($program, @params) = reproducebzip2($bzip2file);
 
283
 
 
284
        Pristine::Tar::Delta::write(Tarball => $deltafile, {
 
285
                version => '2.0',
 
286
                type => 'bz2',
 
287
                params => "@params",
 
288
                program => $program,
 
289
        });
395
290
}