1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 use vars qw($VERSION @ISA $BUGHUNTING);
7 $VERSION = sprintf "%.6f", substr(q$Rev: 2213 $,4)/1000000 + 5.4;
8 # module is internal to CPAN.pm
10 @ISA = qw(CPAN::Debug);
11 $BUGHUNTING ||= 0; # released code must have turned off
13 # it's ok if file doesn't exist, it just matters if it is .gz or .bz2
15 my($class,$file) = @_;
16 $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
18 # nonono, we get e.g. 01mailrc.txt uncompressed if only wget is available
19 $CPAN::Frontend->mydie("file[$file] doesn't match /\\.(bz2|gz|zip|tgz)\$/")
20 unless $file =~ /\.(bz2|gz|zip|tgz)$/i;
22 my $me = { FILE => $file };
24 } elsif ($file =~ /\.bz2$/i) {
25 unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
27 if ($CPAN::META->has_inst("File::Which")) {
28 $bzip2 = File::Which::which("bzip2");
31 $me->{UNGZIPPRG} = $bzip2 || "bzip2";
33 $CPAN::Frontend->mydie(qq{
34 CPAN.pm needs the external program bzip2 in order to handle '$file'.
35 Please install it now and run 'o conf init' to register it as external
41 # yes, we let gzip figure it out in *any* other case
42 $me->{UNGZIPPRG} = $CPAN::Config->{gzip} || "gzip";
49 my $write = $self->{FILE};
50 if ($CPAN::META->has_inst("Compress::Zlib")) {
52 $fhw = FileHandle->new($read)
53 or $CPAN::Frontend->mydie("Could not open $read: $!");
55 my $gz = Compress::Zlib::gzopen($write, "wb")
56 or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
58 while read($fhw,$buffer,4096) > 0 ;
63 my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
64 system(qq{$command -c "$read" > "$write"})==0;
70 my($self,$write) = @_;
71 my $read = $self->{FILE};
72 if ($CPAN::META->has_inst("Compress::Zlib")) {
74 $fhw = FileHandle->new(">$write")
75 or $CPAN::Frontend->mydie("Could not open >$write: $!");
76 my $gz = Compress::Zlib::gzopen($read, "rb")
77 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
79 while $gz->gzread($buffer) > 0 ;
80 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
81 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
86 my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
87 system(qq{$command -dc "$read" > "$write"})==0;
94 return $self->{GTEST} if exists $self->{GTEST};
95 defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
96 my $read = $self->{FILE};
98 # After I had reread the documentation in zlib.h, I discovered that
99 # uncompressed files do not lead to an gzerror (anymore?).
100 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
103 my $gz = Compress::Zlib::gzopen($read, "rb")
104 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
106 $Compress::Zlib::gzerrno));
107 while ($gz->gzread($buffer) > 0 ) {
108 $len += length($buffer);
111 my $err = $gz->gzerror;
112 $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
113 if ($len == -s $read) {
115 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
118 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
120 my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
121 $success = 0==system(qq{$command -qdt "$read"});
123 return $self->{GTEST} = $success;
128 my($class,$file) = @_;
130 $class->debug("file[$file]");
131 my $self = $class->new($file);
133 } elsif (!$self->gtest) {
134 my $fh = FileHandle->new($file)
135 or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
138 $class->debug("via uncompressed FH");
139 } elsif ($CPAN::META->has_inst("Compress::Zlib")) {
140 my $gz = Compress::Zlib::gzopen($file,"rb") or
141 $CPAN::Frontend->mydie("Could not gzopen $file");
143 $class->debug("via Compress::Zlib");
145 my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
146 my $pipe = "$gzip -dc $file |";
147 my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
150 $class->debug("via external gzip");
158 if (exists $self->{GZ}) {
159 my $gz = $self->{GZ};
160 my($line,$bytesread);
161 $bytesread = $gz->gzreadline($line);
162 return undef if $bytesread <= 0;
165 my $fh = $self->{FH};
172 my($self,$ref,$length,$offset) = @_;
173 $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
174 if (exists $self->{GZ}) {
175 my $gz = $self->{GZ};
176 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
179 my $fh = $self->{FH};
180 return read($fh,$$ref,$length);
187 if (exists $self->{GZ}) {
188 my $gz = $self->{GZ};
189 $gz->gzclose() if defined $gz; # hard to say if it is allowed
190 # to be undef ever. AK, 2000-09
192 my $fh = $self->{FH};
193 $fh->close if defined $fh;
201 my $file = $self->{FILE};
204 if (0) { # makes changing order easier
205 } elsif ($BUGHUNTING) {
207 } elsif (MM->maybe_command($self->{UNGZIPPRG})
209 MM->maybe_command($CPAN::Config->{tar})) {
210 # should be default until Archive::Tar handles bzip2
213 $CPAN::META->has_usable("Archive::Tar")
215 $CPAN::META->has_inst("Compress::Zlib") ) {
218 $CPAN::Frontend->mydie(qq{
219 CPAN.pm needs either the external programs tar, gzip and bzip2
220 installed. Can't continue.
224 if (defined $CPAN::Config->{tar_verbosity}) {
225 $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
226 $CPAN::Config->{tar_verbosity};
228 if ($prefer==1) { # 1 => external gzip+tar
230 my $is_compressed = $self->gtest();
231 my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar";
232 if ($is_compressed) {
233 my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
234 $system = qq{$command -dc }.
235 qq{< "$file" | $tarcommand x${tar_verb}f -};
237 $system = qq{$tarcommand x${tar_verb}f "$file"};
239 if (system($system) != 0) {
240 # people find the most curious tar binaries that cannot handle
242 if ($is_compressed) {
243 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
244 $ungzf = File::Basename::basename($ungzf);
245 my $ct = CPAN::Tarzip->new($file);
246 if ($ct->gunzip($ungzf)) {
247 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
249 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
253 $system = qq{$tarcommand x${tar_verb}f "$file"};
254 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
255 if (system($system)==0) {
256 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
258 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
264 } elsif ($prefer==2) { # 2 => modules
265 unless ($CPAN::META->has_usable("Archive::Tar")) {
266 $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
268 my $tar = Archive::Tar->new($file,1);
269 my $af; # archive file
272 # RCS 1.337 had this code, it turned out unacceptable slow but
273 # it revealed a bug in Archive::Tar. Code is only here to hunt
274 # the bug again. It should never be enabled in published code.
275 # GDGraph3d-0.53 was an interesting case according to Larry
277 warn(">>>Bughunting code enabled<<< " x 20);
278 for $af ($tar->list_files) {
279 if ($af =~ m!^(/|\.\./)!) {
280 $CPAN::Frontend->mydie("ALERT: Archive contains ".
281 "illegal member [$af]");
283 $CPAN::Frontend->myprint("$af\n");
284 $tar->extract($af); # slow but effective for finding the bug
285 return if $CPAN::Signal;
288 for $af ($tar->list_files) {
289 if ($af =~ m!^(/|\.\./)!) {
290 $CPAN::Frontend->mydie("ALERT: Archive contains ".
291 "illegal member [$af]");
293 if ($tar_verb eq "v" || $tar_verb eq "vv") {
294 $CPAN::Frontend->myprint("$af\n");
297 return if $CPAN::Signal;
299 $tar->extract(@af) or
300 $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
303 Mac::BuildTools::convert_files([$tar->list_files], 1)
312 my $file = $self->{FILE};
313 if ($CPAN::META->has_inst("Archive::Zip")) {
314 # blueprint of the code from Archive::Zip::Tree::extractTree();
315 my $zip = Archive::Zip->new();
317 $status = $zip->read($file);
318 $CPAN::Frontend->mydie("Read of file[$file] failed\n")
319 if $status != Archive::Zip::AZ_OK();
320 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
321 my @members = $zip->members();
322 for my $member ( @members ) {
323 my $af = $member->fileName();
324 if ($af =~ m!^(/|\.\./)!) {
325 $CPAN::Frontend->mydie("ALERT: Archive contains ".
326 "illegal member [$af]");
328 $status = $member->extractToFileNamed( $af );
329 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
330 $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
331 $status != Archive::Zip::AZ_OK();
332 return if $CPAN::Signal;
336 my $unzip = $CPAN::Config->{unzip} or
337 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
338 my @system = ($unzip, $file);
339 return system(@system) == 0;
349 This program is free software; you can redistribute it and/or
350 modify it under the same terms as Perl itself.