This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PAUSE] CPAN Upload: A/AN/ANDK/CPAN-1.87_55.tar.gz
[perl5.git] / lib / CPAN / Tarzip.pm
1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
2 package CPAN::Tarzip;
3 use strict;
4 use vars qw($VERSION @ISA $BUGHUNTING);
5 use CPAN::Debug;
6 use File::Basename ();
7 $VERSION = sprintf "%.6f", substr(q$Rev: 714 $,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   my($class,$file) = @_;
16   $CPAN::Frontend->mydie("new called without arg") unless defined $file;
17   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   my $me = { FILE => $file };
23   if (0) {
24   } elsif ($file =~ /\.bz2$/i) {
25     unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
26       my $bzip2;
27       if ($CPAN::META->has_inst("File::Which")) {
28         $bzip2 = File::Which::which("bzip2");
29       }
30       if ($bzip2) {
31         $me->{UNGZIPPRG} = $bzip2 || "bzip2";
32       } else {
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
36 program.
37 });
38       }
39     }
40   } else {
41     # yes, we let gzip figure it out in *any* other case
42     $me->{UNGZIPPRG} = $CPAN::Config->{gzip} || "gzip";
43   }
44   bless $me, $class;
45 }
46
47 sub gzip {
48   my($self,$read) = @_;
49   my $write = $self->{FILE};
50   if ($CPAN::META->has_inst("Compress::Zlib")) {
51     my($buffer,$fhw);
52     $fhw = FileHandle->new($read)
53         or $CPAN::Frontend->mydie("Could not open $read: $!");
54         my $cwd = `pwd`;
55     my $gz = Compress::Zlib::gzopen($write, "wb")
56         or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
57     $gz->gzwrite($buffer)
58         while read($fhw,$buffer,4096) > 0 ;
59     $gz->gzclose() ;
60     $fhw->close;
61     return 1;
62   } else {
63     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
64     system(qq{$command -c "$read" > "$write"})==0;
65   }
66 }
67
68
69 sub gunzip {
70   my($self,$write) = @_;
71   my $read = $self->{FILE};
72   if ($CPAN::META->has_inst("Compress::Zlib")) {
73     my($buffer,$fhw);
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");
78     $fhw->print($buffer)
79         while $gz->gzread($buffer) > 0 ;
80     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
81         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
82     $gz->gzclose() ;
83     $fhw->close;
84     return 1;
85   } else {
86     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
87     system(qq{$command -dc "$read" > "$write"})==0;
88   }
89 }
90
91
92 sub gtest {
93   my($self) = @_;
94   return $self->{GTEST} if exists $self->{GTEST};
95   my $read = $self->{FILE} or die;
96   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   if ( $CPAN::META->has_inst("Compress::Zlib") ) {
100     my($buffer,$len);
101     $len = 0;
102     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     while ($gz->gzread($buffer) > 0 ){
107         $len += length($buffer);
108         $buffer = "";
109     }
110     my $err = $gz->gzerror;
111     $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
112     if ($len == -s $read){
113         $success = 0;
114         CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
115     }
116     $gz->gzclose();
117     CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
118   } else {
119     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
120     $success = 0==system(qq{$command -qdt "$read"});
121   }
122   return $self->{GTEST} = $success;
123 }
124
125
126 sub TIEHANDLE {
127   my($class,$file) = @_;
128   my $ret;
129   $class->debug("file[$file]");
130   my $self = $class->new($file);
131   if (0) {
132   } elsif (!$self->gtest) {
133     my $fh = FileHandle->new($file) or die "Could not open file[$file]: $!";
134     binmode $fh;
135     $self->{FH} = $fh;
136   } elsif ($CPAN::META->has_inst("Compress::Zlib")) {
137     my $gz = Compress::Zlib::gzopen($file,"rb") or
138         die "Could not gzopen $file";
139     $self->{GZ} = $gz;
140   } else {
141     my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
142     my $pipe = "$gzip -dc $file |";
143     my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
144     binmode $fh;
145     $self->{FH} = $fh;
146   }
147   $self;
148 }
149
150
151 sub READLINE {
152   my($self) = @_;
153   if (exists $self->{GZ}) {
154     my $gz = $self->{GZ};
155     my($line,$bytesread);
156     $bytesread = $gz->gzreadline($line);
157     return undef if $bytesread <= 0;
158     return $line;
159   } else {
160     my $fh = $self->{FH};
161     return scalar <$fh>;
162   }
163 }
164
165
166 sub READ {
167   my($self,$ref,$length,$offset) = @_;
168   die "read with offset not implemented" if defined $offset;
169   if (exists $self->{GZ}) {
170     my $gz = $self->{GZ};
171     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
172     return $byteread;
173   } else {
174     my $fh = $self->{FH};
175     return read($fh,$$ref,$length);
176   }
177 }
178
179
180 sub DESTROY {
181     my($self) = @_;
182     if (exists $self->{GZ}) {
183         my $gz = $self->{GZ};
184         $gz->gzclose() if defined $gz; # hard to say if it is allowed
185                                        # to be undef ever. AK, 2000-09
186     } else {
187         my $fh = $self->{FH};
188         $fh->close if defined $fh;
189     }
190     undef $self;
191 }
192
193
194 sub untar {
195   my($self) = @_;
196   my $file = $self->{FILE};
197   my($prefer) = 0;
198
199   if (0) { # makes changing order easier
200   } elsif ($BUGHUNTING){
201     $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     $prefer = 1;
207   } elsif (
208            $CPAN::META->has_inst("Archive::Tar")
209            &&
210            $CPAN::META->has_inst("Compress::Zlib") ) {
211     if ($file =~ /\.bz2$/) {
212       $CPAN::Frontend->mydie(qq{
213 Archive::Tar lacks support for bz2. Can't continue.
214 });
215     }
216     $prefer = 2;
217   } else {
218     $CPAN::Frontend->mydie(qq{
219 CPAN.pm needs either the external programs tar, gzip and bzip2
220 installed. Can't continue.
221 });
222   }
223   if ($prefer==1) { # 1 => external gzip+tar
224     my($system);
225     my $is_compressed = $self->gtest();
226     my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar";
227     if ($is_compressed) {
228       my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
229       $system = qq{$command -dc }.
230           qq{< "$file" | $tarcommand xvf -};
231     } else {
232       $system = qq{$tarcommand xvf "$file"};
233     }
234     if (system($system) != 0) {
235       # people find the most curious tar binaries that cannot handle
236       # pipes
237       if ($is_compressed) {
238         (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
239         $ungzf = File::Basename::basename($ungzf);
240         my $ct = CPAN::Tarzip->new($file);
241         if ($ct->gunzip($ungzf)) {
242           $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
243         } else {
244           $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
245         }
246         $file = $ungzf;
247       }
248       $system = qq{$tarcommand xvf "$file"};
249       $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
250       if (system($system)==0) {
251         $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
252       } else {
253         $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
254       }
255       return 1;
256     } else {
257       return 1;
258     }
259   } elsif ($prefer==2) { # 2 => modules
260     my $tar = Archive::Tar->new($file,1);
261     my $af; # archive file
262     my @af;
263     if ($BUGHUNTING) {
264       # RCS 1.337 had this code, it turned out unacceptable slow but
265       # it revealed a bug in Archive::Tar. Code is only here to hunt
266       # the bug again. It should never be enabled in published code.
267       # GDGraph3d-0.53 was an interesting case according to Larry
268       # Virden.
269       warn(">>>Bughunting code enabled<<< " x 20);
270       for $af ($tar->list_files) {
271         if ($af =~ m!^(/|\.\./)!) {
272           $CPAN::Frontend->mydie("ALERT: Archive contains ".
273                                  "illegal member [$af]");
274         }
275         $CPAN::Frontend->myprint("$af\n");
276         $tar->extract($af); # slow but effective for finding the bug
277         return if $CPAN::Signal;
278       }
279     } else {
280       for $af ($tar->list_files) {
281         if ($af =~ m!^(/|\.\./)!) {
282           $CPAN::Frontend->mydie("ALERT: Archive contains ".
283                                  "illegal member [$af]");
284         }
285         $CPAN::Frontend->myprint("$af\n");
286         push @af, $af;
287         return if $CPAN::Signal;
288       }
289       $tar->extract(@af) or
290           $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
291     }
292
293     Mac::BuildTools::convert_files([$tar->list_files], 1)
294           if ($^O eq 'MacOS');
295
296     return 1;
297   }
298 }
299
300 sub unzip {
301   my($self) = @_;
302   my $file = $self->{FILE};
303   if ($CPAN::META->has_inst("Archive::Zip")) {
304     # blueprint of the code from Archive::Zip::Tree::extractTree();
305     my $zip = Archive::Zip->new();
306     my $status;
307     $status = $zip->read($file);
308     die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
309     $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
310     my @members = $zip->members();
311     for my $member ( @members ) {
312       my $af = $member->fileName();
313       if ($af =~ m!^(/|\.\./)!) {
314         $CPAN::Frontend->mydie("ALERT: Archive contains ".
315                                "illegal member [$af]");
316       }
317       $status = $member->extractToFileNamed( $af );
318       $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
319       die "Extracting of file[$af] from zipfile[$file] failed\n" if
320           $status != Archive::Zip::AZ_OK();
321       return if $CPAN::Signal;
322     }
323     return 1;
324   } else {
325     my $unzip = $CPAN::Config->{unzip} or
326         $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
327     my @system = ($unzip, $file);
328     return system(@system) == 0;
329   }
330 }
331
332 1;
333