This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade CPAN from 1.94_55 to 1.94_56
[perl5.git] / cpan / CPAN / lib / CPAN / Tarzip.pm
1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 package CPAN::Tarzip;
3 use strict;
4 use vars qw($VERSION @ISA $BUGHUNTING);
5 use CPAN::Debug;
6 use File::Basename qw(basename);
7 $VERSION = "5.5011";
8 # module is internal to CPAN.pm
9
10 @ISA = qw(CPAN::Debug); ## no critic
11 $BUGHUNTING ||= 0; # released code must have turned off
12
13 # it's ok if file doesn't exist, it just matters if it is .gz or .bz2
14 sub new {
15     my($class,$file) = @_;
16     $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
17     my $me = { FILE => $file };
18     if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
19         $me->{ISCOMPRESSED} = 1;
20     } else {
21         $me->{ISCOMPRESSED} = 0;
22     }
23     if (0) {
24     } elsif ($file =~ /\.(?:bz2|tbz)$/i) {
25         unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
26             my $bzip2 = _my_which("bzip2");
27             if ($bzip2) {
28                 $me->{UNGZIPPRG} = $bzip2;
29             } else {
30                 $CPAN::Frontend->mydie(qq{
31 CPAN.pm needs the external program bzip2 in order to handle '$file'.
32 Please install it now and run 'o conf init bzip2' from the
33 CPAN shell prompt to register it as external program.
34 });
35             }
36         }
37     } else {
38         $me->{UNGZIPPRG} = _my_which("gzip");
39     }
40     $me->{TARPRG} = _my_which("tar") || _my_which("gtar");
41     bless $me, $class;
42 }
43
44 sub _my_which {
45     my($what) = @_;
46     if ($CPAN::Config->{$what}) {
47         return $CPAN::Config->{$what};
48     }
49     if ($CPAN::META->has_inst("File::Which")) {
50         return File::Which::which($what);
51     }
52     my @cand = MM->maybe_command($what);
53     return $cand[0] if @cand;
54     require File::Spec;
55     my $component;
56   PATH_COMPONENT: foreach $component (File::Spec->path()) {
57         next unless defined($component) && $component;
58         my($abs) = File::Spec->catfile($component,$what);
59         if (MM->maybe_command($abs)) {
60             return $abs;
61         }
62     }
63     return;
64 }
65
66 sub gzip {
67     my($self,$read) = @_;
68     my $write = $self->{FILE};
69     if ($CPAN::META->has_inst("Compress::Zlib")) {
70         my($buffer,$fhw);
71         $fhw = FileHandle->new($read)
72             or $CPAN::Frontend->mydie("Could not open $read: $!");
73         my $cwd = `pwd`;
74         my $gz = Compress::Zlib::gzopen($write, "wb")
75             or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
76         $gz->gzwrite($buffer)
77             while read($fhw,$buffer,4096) > 0 ;
78         $gz->gzclose() ;
79         $fhw->close;
80         return 1;
81     } else {
82         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
83         system(qq{$command -c "$read" > "$write"})==0;
84     }
85 }
86
87
88 sub gunzip {
89     my($self,$write) = @_;
90     my $read = $self->{FILE};
91     if ($CPAN::META->has_inst("Compress::Zlib")) {
92         my($buffer,$fhw);
93         $fhw = FileHandle->new(">$write")
94             or $CPAN::Frontend->mydie("Could not open >$write: $!");
95         my $gz = Compress::Zlib::gzopen($read, "rb")
96             or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
97         $fhw->print($buffer)
98         while $gz->gzread($buffer) > 0 ;
99         $CPAN::Frontend->mydie("Error reading from $read: $!\n")
100             if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
101         $gz->gzclose() ;
102         $fhw->close;
103         return 1;
104     } else {
105         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
106         system(qq{$command -dc "$read" > "$write"})==0;
107     }
108 }
109
110
111 sub gtest {
112     my($self) = @_;
113     return $self->{GTEST} if exists $self->{GTEST};
114     defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
115     my $read = $self->{FILE};
116     my $success;
117     if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
118         my($buffer,$len);
119         $len = 0;
120         my $gz = Compress::Bzip2::bzopen($read, "rb")
121             or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
122                                               $read,
123                                               $Compress::Bzip2::bzerrno));
124         while ($gz->bzread($buffer) > 0 ) {
125             $len += length($buffer);
126             $buffer = "";
127         }
128         my $err = $gz->bzerror;
129         $success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END();
130         if ($len == -s $read) {
131             $success = 0;
132             CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
133         }
134         $gz->gzclose();
135         CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
136     } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) {
137         # After I had reread the documentation in zlib.h, I discovered that
138         # uncompressed files do not lead to an gzerror (anymore?).
139         my($buffer,$len);
140         $len = 0;
141         my $gz = Compress::Zlib::gzopen($read, "rb")
142             or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
143                                               $read,
144                                               $Compress::Zlib::gzerrno));
145         while ($gz->gzread($buffer) > 0 ) {
146             $len += length($buffer);
147             $buffer = "";
148         }
149         my $err = $gz->gzerror;
150         $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
151         if ($len == -s $read) {
152             $success = 0;
153             CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
154         }
155         $gz->gzclose();
156         CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
157     } elsif (!$self->{ISCOMPRESSED}) {
158         $success = 0;
159     } else {
160         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
161         $success = 0==system(qq{$command -qdt "$read"});
162     }
163     return $self->{GTEST} = $success;
164 }
165
166
167 sub TIEHANDLE {
168     my($class,$file) = @_;
169     my $ret;
170     $class->debug("file[$file]");
171     my $self = $class->new($file);
172     if (0) {
173     } elsif (!$self->gtest) {
174         my $fh = FileHandle->new($file)
175             or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
176         binmode $fh;
177         $self->{FH} = $fh;
178         $class->debug("via uncompressed FH");
179     } elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
180         my $gz = Compress::Bzip2::bzopen($file,"rb") or
181             $CPAN::Frontend->mydie("Could not bzopen $file");
182         $self->{GZ} = $gz;
183         $class->debug("via Compress::Bzip2");
184     } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) {
185         my $gz = Compress::Zlib::gzopen($file,"rb") or
186             $CPAN::Frontend->mydie("Could not gzopen $file");
187         $self->{GZ} = $gz;
188         $class->debug("via Compress::Zlib");
189     } else {
190         my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
191         my $pipe = "$gzip -dc $file |";
192         my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
193         binmode $fh;
194         $self->{FH} = $fh;
195         $class->debug("via external $gzip");
196     }
197     $self;
198 }
199
200
201 sub READLINE {
202     my($self) = @_;
203     if (exists $self->{GZ}) {
204         my $gz = $self->{GZ};
205         my($line,$bytesread);
206         $bytesread = $gz->gzreadline($line);
207         return undef if $bytesread <= 0;
208         return $line;
209     } else {
210         my $fh = $self->{FH};
211         return scalar <$fh>;
212     }
213 }
214
215
216 sub READ {
217     my($self,$ref,$length,$offset) = @_;
218     $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
219     if (exists $self->{GZ}) {
220         my $gz = $self->{GZ};
221         my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
222         return $byteread;
223     } else {
224         my $fh = $self->{FH};
225         return read($fh,$$ref,$length);
226     }
227 }
228
229
230 sub DESTROY {
231     my($self) = @_;
232     if (exists $self->{GZ}) {
233         my $gz = $self->{GZ};
234         $gz->gzclose() if defined $gz; # hard to say if it is allowed
235                                        # to be undef ever. AK, 2000-09
236     } else {
237         my $fh = $self->{FH};
238         $fh->close if defined $fh;
239     }
240     undef $self;
241 }
242
243 sub untar {
244     my($self) = @_;
245     my $file = $self->{FILE};
246     my($prefer) = 0;
247
248     my $exttar = $self->{TARPRG} || "";
249     $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
250     my $extgzip = $self->{UNGZIPPRG} || "";
251     $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
252
253     if (0) { # makes changing order easier
254     } elsif ($BUGHUNTING) {
255         $prefer=2;
256     } elsif ($exttar && $extgzip && $file =~ /\.(?:bz2|tbz)$/i) {
257         # until Archive::Tar handles bzip2
258         $prefer = 1;
259     } elsif (
260              $CPAN::META->has_usable("Archive::Tar")
261              &&
262              $CPAN::META->has_inst("Compress::Zlib") ) {
263         $prefer = 2;
264     } elsif ($exttar && $extgzip) {
265         # no modules and not bz2
266         $prefer = 1;
267         # but solaris binary tar is a problem
268         if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
269             $CPAN::Frontend->mywarn(<< 'END_WARN');
270
271 WARNING: Many CPAN distributions were archived with GNU tar and some of
272 them may be incompatible with Solaris tar.  We respectfully suggest you
273 configure CPAN to use a GNU tar instead ("o conf init tar") or install
274 a recent Archive::Tar instead;
275
276 END_WARN
277         }
278     } else {
279         my $foundtar = $exttar ? "'$exttar'" : "nothing";
280         my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
281         my $foundAT;
282         if ($CPAN::META->has_usable("Archive::Tar")) {
283             $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
284         } else {
285             $foundAT = "nothing";
286         }
287         my $foundCZ;
288         if ($CPAN::META->has_inst("Compress::Zlib")) {
289             $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
290         } elsif ($foundAT) {
291             $foundCZ = "nothing";
292         } else {
293             $foundCZ = "also nothing";
294         }
295         $CPAN::Frontend->mydie(qq{
296
297 CPAN.pm needs either the external programs tar and gzip -or- both
298 modules Archive::Tar and Compress::Zlib installed.
299
300 For tar I found $foundtar, for gzip $foundzip.
301
302 For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
303
304 Can't continue cutting file '$file'.
305 });
306     }
307     my $tar_verb = "v";
308     if (defined $CPAN::Config->{tar_verbosity}) {
309         $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
310             $CPAN::Config->{tar_verbosity};
311     }
312     if ($prefer==1) { # 1 => external gzip+tar
313         my($system);
314         my $is_compressed = $self->gtest();
315         my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
316         if ($is_compressed) {
317             my $command = CPAN::HandleConfig->safe_quote($extgzip);
318             $system = qq{$command -dc }.
319                 qq{< "$file" | $tarcommand x${tar_verb}f -};
320         } else {
321             $system = qq{$tarcommand x${tar_verb}f "$file"};
322         }
323         if (system($system) != 0) {
324             # people find the most curious tar binaries that cannot handle
325             # pipes
326             if ($is_compressed) {
327                 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
328                 $ungzf = basename $ungzf;
329                 my $ct = CPAN::Tarzip->new($file);
330                 if ($ct->gunzip($ungzf)) {
331                     $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
332                 } else {
333                     $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
334                 }
335                 $file = $ungzf;
336             }
337             $system = qq{$tarcommand x${tar_verb}f "$file"};
338             $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
339             if (system($system)==0) {
340                 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
341             } else {
342                 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
343             }
344             return 1;
345         } else {
346             return 1;
347         }
348     } elsif ($prefer==2) { # 2 => modules
349         unless ($CPAN::META->has_usable("Archive::Tar")) {
350             $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
351         }
352         # Make sure AT does not use uid/gid/permissions in the archive
353         # This leaves it to the user's umask instead
354         local $Archive::Tar::CHMOD = 1;
355         local $Archive::Tar::SAME_PERMISSIONS = 0;
356         # Make sure AT leaves current user as owner
357         local $Archive::Tar::CHOWN = 0;
358         my $tar = Archive::Tar->new($file,1);
359         my $af; # archive file
360         my @af;
361         if ($BUGHUNTING) {
362             # RCS 1.337 had this code, it turned out unacceptable slow but
363             # it revealed a bug in Archive::Tar. Code is only here to hunt
364             # the bug again. It should never be enabled in published code.
365             # GDGraph3d-0.53 was an interesting case according to Larry
366             # Virden.
367             warn(">>>Bughunting code enabled<<< " x 20);
368             for $af ($tar->list_files) {
369                 if ($af =~ m!^(/|\.\./)!) {
370                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
371                                            "illegal member [$af]");
372                 }
373                 $CPAN::Frontend->myprint("$af\n");
374                 $tar->extract($af); # slow but effective for finding the bug
375                 return if $CPAN::Signal;
376             }
377         } else {
378             for $af ($tar->list_files) {
379                 if ($af =~ m!^(/|\.\./)!) {
380                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
381                                            "illegal member [$af]");
382                 }
383                 if ($tar_verb eq "v" || $tar_verb eq "vv") {
384                     $CPAN::Frontend->myprint("$af\n");
385                 }
386                 push @af, $af;
387                 return if $CPAN::Signal;
388             }
389             $tar->extract(@af) or
390                 $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
391         }
392
393         Mac::BuildTools::convert_files([$tar->list_files], 1)
394             if ($^O eq 'MacOS');
395
396         return 1;
397     }
398 }
399
400 sub unzip {
401     my($self) = @_;
402     my $file = $self->{FILE};
403     if ($CPAN::META->has_inst("Archive::Zip")) {
404         # blueprint of the code from Archive::Zip::Tree::extractTree();
405         my $zip = Archive::Zip->new();
406         my $status;
407         $status = $zip->read($file);
408         $CPAN::Frontend->mydie("Read of file[$file] failed\n")
409             if $status != Archive::Zip::AZ_OK();
410         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
411         my @members = $zip->members();
412         for my $member ( @members ) {
413             my $af = $member->fileName();
414             if ($af =~ m!^(/|\.\./)!) {
415                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
416                                        "illegal member [$af]");
417             }
418             $status = $member->extractToFileNamed( $af );
419             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
420             $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
421                 $status != Archive::Zip::AZ_OK();
422             return if $CPAN::Signal;
423         }
424         return 1;
425     } elsif ( my $unzip = $CPAN::Config->{unzip}  ) {
426         my @system = ($unzip, $file);
427         return system(@system) == 0;
428     }
429     else {
430             $CPAN::Frontend->mydie(<<"END");
431
432 Can't unzip '$file':
433
434 You have not configured an 'unzip' program and do not have Archive::Zip
435 installed.  Please either install Archive::Zip or else configure 'unzip'
436 by running the command 'o conf init unzip' from the CPAN shell prompt.
437
438 END
439     }
440 }
441
442 1;
443
444 __END__
445
446 =head1 LICENSE
447
448 This program is free software; you can redistribute it and/or
449 modify it under the same terms as Perl itself.
450
451 =cut