File Coverage

blib/lib/CPAN/Tarzip.pm
Criterion Covered Total %
statement 95 265 35.8
branch 36 180 20.0
condition 8 40 20.0
subroutine 13 16 81.2
pod 0 6 0.0
total 152 507 29.9


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