File Coverage

lib/CPAN/Tarzip.pm
Criterion Covered Total %
statement 90 188 47.9
branch 34 114 29.8
condition 6 15 40.0
subroutine 11 14 78.6
pod 0 6 0.0
total 141 337 41.8


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
2             package CPAN::Tarzip;
3 6     6   87 use strict;
  6         83  
  6         87  
4 6     6   91 use vars qw($VERSION @ISA $BUGHUNTING);
  6         57  
  6         85  
5 6     6   89 use CPAN::Debug;
  6         52  
  6         127  
6 6     6   99 use File::Basename ();
  6         106  
  6         174  
7             $VERSION = sprintf "%.6f", substr(q$Rev: 858 $,4)/1000000 + 5.4;
8             # module is internal to CPAN.pm
9              
10             @ISA = qw(CPAN::Debug);
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 23     23 0 390   my($class,$file) = @_;
16 23 50       285   $CPAN::Frontend->mydie("new called without arg") unless defined $file;
17 23         194   if (0) {
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;
21               }
22 23         341   my $me = { FILE => $file };
23 23 50       539   if (0) {
24               } elsif ($file =~ /\.bz2$/i) {
25 0 0       0     unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
26 0         0       my $bzip2;
27 0 0       0       if ($CPAN::META->has_inst("File::Which")) {
28 0         0         $bzip2 = File::Which::which("bzip2");
29                   }
30 0 0       0       if ($bzip2) {
31 0   0     0         $me->{UNGZIPPRG} = $bzip2 || "bzip2";
32                   } else {
33 0         0         $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
36             program.
37             });
38                   }
39                 }
40               } else {
41             # yes, we let gzip figure it out in *any* other case
42 23   100     394     $me->{UNGZIPPRG} = $CPAN::Config->{gzip} || "gzip";
43               }
44 23         1891   bless $me, $class;
45             }
46              
47             sub gzip {
48 0     0 0 0   my($self,$read) = @_;
49 0         0   my $write = $self->{FILE};
50 0 0       0   if ($CPAN::META->has_inst("Compress::Zlib")) {
51 0         0     my($buffer,$fhw);
52 0 0       0     $fhw = FileHandle->new($read)
53             or $CPAN::Frontend->mydie("Could not open $read: $!");
54 0         0 my $cwd = `pwd`;
55 0 0       0     my $gz = Compress::Zlib::gzopen($write, "wb")
56             or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
57 0         0     $gz->gzwrite($buffer)
58             while read($fhw,$buffer,4096) > 0 ;
59 0         0     $gz->gzclose() ;
60 0         0     $fhw->close;
61 0         0     return 1;
62               } else {
63 0         0     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
64 0         0     system(qq{$command -c "$read" > "$write"})==0;
65               }
66             }
67              
68              
69             sub gunzip {
70 0     0 0 0   my($self,$write) = @_;
71 0         0   my $read = $self->{FILE};
72 0 0       0   if ($CPAN::META->has_inst("Compress::Zlib")) {
73 0         0     my($buffer,$fhw);
74 0 0       0     $fhw = FileHandle->new(">$write")
75             or $CPAN::Frontend->mydie("Could not open >$write: $!");
76 0 0       0     my $gz = Compress::Zlib::gzopen($read, "rb")
77             or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
78 0         0     $fhw->print($buffer)
79             while $gz->gzread($buffer) > 0 ;
80 0 0       0     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
81             if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
82 0         0     $gz->gzclose() ;
83 0         0     $fhw->close;
84 0         0     return 1;
85               } else {
86 0         0     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
87 0         0     system(qq{$command -dc "$read" > "$write"})==0;
88               }
89             }
90              
91              
92             sub gtest {
93 28     28 0 272   my($self) = @_;
94 28 100       309   return $self->{GTEST} if exists $self->{GTEST};
95 22 50       248   my $read = $self->{FILE} or die;
96 22         324   my $success;
97             # After I had reread the documentation in zlib.h, I discovered that
98             # uncompressed files do not lead to an gzerror (anymore?).
99 22 50       338   if ( $CPAN::META->has_inst("Compress::Zlib") ) {
100 22         200     my($buffer,$len);
101 22         435     $len = 0;
102 22 50       667     my $gz = Compress::Zlib::gzopen($read, "rb")
103             or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
104                                                       $read,
105                                                       $Compress::Zlib::gzerrno));
106 22         346     while ($gz->gzread($buffer) > 0 ){
107 66         564         $len += length($buffer);
108 66         810         $buffer = "";
109                 }
110 22         447     my $err = $gz->gzerror;
111 22   66     294     $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
112 22 100       1277     if ($len == -s $read){
113 10         84         $success = 0;
114 10 50       107         CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
115                 }
116 22         275     $gz->gzclose();
117 22 50       248     CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
118               } else {
119 0         0     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
120 0         0     $success = 0==system(qq{$command -qdt "$read"});
121               }
122 22         638   return $self->{GTEST} = $success;
123             }
124              
125              
126             sub TIEHANDLE {
127 16     16   285   my($class,$file) = @_;
128 16         514   my $ret;
129 16         578   $class->debug("file[$file]");
130 16         574   my $self = $class->new($file);
131 16 100       314   if (0) {
    50          
132               } elsif (!$self->gtest) {
133 10 50       2707     my $fh = FileHandle->new($file) or die "Could not open file[$file]: $!";
134 10         1673     binmode $fh;
135 10         1224     $self->{FH} = $fh;
136               } elsif ($CPAN::META->has_inst("Compress::Zlib")) {
137 6 50       71     my $gz = Compress::Zlib::gzopen($file,"rb") or
138             die "Could not gzopen $file";
139 6         235     $self->{GZ} = $gz;
140               } else {
141 0         0     my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
142 0         0     my $pipe = "$gzip -dc $file |";
143 0 0       0     my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
144 0         0     binmode $fh;
145 0         0     $self->{FH} = $fh;
146               }
147 16         227   $self;
148             }
149              
150              
151             sub READLINE {
152 306     306   2658   my($self) = @_;
153 306 50       4672   if (exists $self->{GZ}) {
154 0         0     my $gz = $self->{GZ};
155 0         0     my($line,$bytesread);
156 0         0     $bytesread = $gz->gzreadline($line);
157 0 0       0     return undef if $bytesread <= 0;
158 0         0     return $line;
159               } else {
160 306         2695     my $fh = $self->{FH};
161 306         5371     return scalar <$fh>;
162               }
163             }
164              
165              
166             sub READ {
167 0     0   0   my($self,$ref,$length,$offset) = @_;
168 0 0       0   die "read with offset not implemented" if defined $offset;
169 0 0       0   if (exists $self->{GZ}) {
170 0         0     my $gz = $self->{GZ};
171 0         0     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
172 0         0     return $byteread;
173               } else {
174 0         0     my $fh = $self->{FH};
175 0         0     return read($fh,$$ref,$length);
176               }
177             }
178              
179              
180             sub DESTROY {
181 23     23   478     my($self) = @_;
182 23 100       333     if (exists $self->{GZ}) {
183 6         60         my $gz = $self->{GZ};
184 6 50       91         $gz->gzclose() if defined $gz; # hard to say if it is allowed
185             # to be undef ever. AK, 2000-09
186                 } else {
187 17         209         my $fh = $self->{FH};
188 17 100       357         $fh->close if defined $fh;
189                 }
190 23         451     undef $self;
191             }
192              
193              
194             sub untar {
195 6     6 0 61   my($self) = @_;
196 6         125   my $file = $self->{FILE};
197 6         55   my($prefer) = 0;
198              
199 6 50 33     641   if (0) { # makes changing order easier
    50 0        
    0          
200               } elsif ($BUGHUNTING){
201 0         0     $prefer=2;
202               } elsif (MM->maybe_command($self->{UNGZIPPRG})
203                        &&
204                        MM->maybe_command($CPAN::Config->{tar})) {
205             # should be default until Archive::Tar handles bzip2
206 0         0     $prefer = 1;
207               } elsif (
208                        $CPAN::META->has_inst("Archive::Tar")
209                        &&
210                        $CPAN::META->has_inst("Compress::Zlib") ) {
211 0         0     $prefer = 2;
212               } else {
213 0         0     $CPAN::Frontend->mydie(qq{
214             CPAN.pm needs either the external programs tar, gzip and bzip2
215             installed. Can't continue.
216             });
217               }
218 6 50       69   if ($prefer==1) { # 1 => external gzip+tar
    0          
219 6         50     my($system);
220 6         69     my $is_compressed = $self->gtest();
221 6   50     329     my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar";
222 6 50       60     if ($is_compressed) {
223 6         146       my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
224 6         105       $system = qq{$command -dc }.
225                       qq{< "$file" | $tarcommand xvf -};
226                 } else {
227 0         0       $system = qq{$tarcommand xvf "$file"};
228                 }
229 6 50       421458     if (system($system) != 0) {
230             # people find the most curious tar binaries that cannot handle
231             # pipes
232 0 0       0       if ($is_compressed) {
233 0         0         (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
234 0         0         $ungzf = File::Basename::basename($ungzf);
235 0         0         my $ct = CPAN::Tarzip->new($file);
236 0 0       0         if ($ct->gunzip($ungzf)) {
237 0         0           $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
238                     } else {
239 0         0           $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
240                     }
241 0         0         $file = $ungzf;
242                   }
243 0         0       $system = qq{$tarcommand xvf "$file"};
244 0         0       $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
245 0 0       0       if (system($system)==0) {
246 0         0         $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
247                   } else {
248 0         0         $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
249                   }
250 0         0       return 1;
251                 } else {
252 6         2259       return 1;
253                 }
254               } elsif ($prefer==2) { # 2 => modules
255 0 0       0     unless ($CPAN::META->has_inst("Archive::Tar")) {
256 0         0       $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
257                 }
258 0         0     my $tar = Archive::Tar->new($file,1);
259 0         0     my $af; # archive file
260 0         0     my @af;
261 0 0       0     if ($BUGHUNTING) {
262             # RCS 1.337 had this code, it turned out unacceptable slow but
263             # it revealed a bug in Archive::Tar. Code is only here to hunt
264             # the bug again. It should never be enabled in published code.
265             # GDGraph3d-0.53 was an interesting case according to Larry
266             # Virden.
267 0         0       warn(">>>Bughunting code enabled<<< " x 20);
268 0         0       for $af ($tar->list_files) {
269 0 0       0         if ($af =~ m!^(/|\.\./)!) {
270 0         0           $CPAN::Frontend->mydie("ALERT: Archive contains ".
271                                              "illegal member [$af]");
272                     }
273 0         0         $CPAN::Frontend->myprint("$af\n");
274 0         0         $tar->extract($af); # slow but effective for finding the bug
275 0 0       0         return if $CPAN::Signal;
276                   }
277                 } else {
278 0         0       for $af ($tar->list_files) {
279 0 0       0         if ($af =~ m!^(/|\.\./)!) {
280 0         0           $CPAN::Frontend->mydie("ALERT: Archive contains ".
281                                              "illegal member [$af]");
282                     }
283 0         0         $CPAN::Frontend->myprint("$af\n");
284 0         0         push @af, $af;
285 0 0       0         return if $CPAN::Signal;
286                   }
287 0 0       0       $tar->extract(@af) or
288                       $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
289                 }
290              
291 0 0       0     Mac::BuildTools::convert_files([$tar->list_files], 1)
292                       if ($^O eq 'MacOS');
293              
294 0         0     return 1;
295               }
296             }
297              
298