File Coverage

blib/lib/CPAN/Tarzip.pm
Criterion Covered Total %
statement 93 263 35.3
branch 35 178 19.6
condition 8 40 20.0
subroutine 12 15 80.0
pod 0 6 0.0
total 148 502 29.4


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