Commit | Line | Data |
547d3dfd |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
e82b9348 |
2 | package CPAN::Tarzip; |
3 | use strict; |
4 | use vars qw($VERSION @ISA $BUGHUNTING); |
5 | use CPAN::Debug; |
5254b38e |
6 | use File::Basename qw(basename); |
7 | $VERSION = "5.5"; |
e82b9348 |
8 | # module is internal to CPAN.pm |
9 | |
f9916dde |
10 | @ISA = qw(CPAN::Debug); ## no critic |
2ccf00a7 |
11 | $BUGHUNTING ||= 0; # released code must have turned off |
e82b9348 |
12 | |
13 | # it's ok if file doesn't exist, it just matters if it is .gz or .bz2 |
14 | sub new { |
547d3dfd |
15 | my($class,$file) = @_; |
16 | $CPAN::Frontend->mydie("CPAN::Tarzip->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}) { |
5254b38e |
26 | my $bzip2 = _my_which("bzip2"); |
547d3dfd |
27 | if ($bzip2) { |
5254b38e |
28 | $me->{UNGZIPPRG} = $bzip2; |
547d3dfd |
29 | } else { |
30 | $CPAN::Frontend->mydie(qq{ |
e82b9348 |
31 | CPAN.pm needs the external program bzip2 in order to handle '$file'. |
32 | Please install it now and run 'o conf init' to register it as external |
33 | program. |
34 | }); |
547d3dfd |
35 | } |
36 | } |
37 | } else { |
5254b38e |
38 | $me->{UNGZIPPRG} = _my_which("gzip"); |
e82b9348 |
39 | } |
5254b38e |
40 | $me->{TARPRG} = _my_which("tar") || _my_which("gtar"); |
547d3dfd |
41 | bless $me, $class; |
e82b9348 |
42 | } |
43 | |
5254b38e |
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 | |
e82b9348 |
66 | sub gzip { |
547d3dfd |
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 | } |
e82b9348 |
85 | } |
86 | |
87 | |
88 | sub gunzip { |
547d3dfd |
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 | } |
e82b9348 |
108 | } |
109 | |
110 | |
111 | sub gtest { |
547d3dfd |
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 | # After I had reread the documentation in zlib.h, I discovered that |
118 | # uncompressed files do not lead to an gzerror (anymore?). |
119 | if ( $CPAN::META->has_inst("Compress::Zlib") ) { |
120 | my($buffer,$len); |
121 | $len = 0; |
122 | my $gz = Compress::Zlib::gzopen($read, "rb") |
123 | or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n", |
124 | $read, |
125 | $Compress::Zlib::gzerrno)); |
126 | while ($gz->gzread($buffer) > 0 ) { |
127 | $len += length($buffer); |
128 | $buffer = ""; |
129 | } |
130 | my $err = $gz->gzerror; |
131 | $success = ! $err || $err == Compress::Zlib::Z_STREAM_END(); |
132 | if ($len == -s $read) { |
133 | $success = 0; |
134 | CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG; |
135 | } |
136 | $gz->gzclose(); |
137 | CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG; |
138 | } else { |
139 | my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); |
140 | $success = 0==system(qq{$command -qdt "$read"}); |
e82b9348 |
141 | } |
547d3dfd |
142 | return $self->{GTEST} = $success; |
e82b9348 |
143 | } |
144 | |
145 | |
146 | sub TIEHANDLE { |
547d3dfd |
147 | my($class,$file) = @_; |
148 | my $ret; |
149 | $class->debug("file[$file]"); |
150 | my $self = $class->new($file); |
151 | if (0) { |
152 | } elsif (!$self->gtest) { |
153 | my $fh = FileHandle->new($file) |
154 | or $CPAN::Frontend->mydie("Could not open file[$file]: $!"); |
155 | binmode $fh; |
156 | $self->{FH} = $fh; |
157 | $class->debug("via uncompressed FH"); |
158 | } elsif ($CPAN::META->has_inst("Compress::Zlib")) { |
159 | my $gz = Compress::Zlib::gzopen($file,"rb") or |
160 | $CPAN::Frontend->mydie("Could not gzopen $file"); |
161 | $self->{GZ} = $gz; |
162 | $class->debug("via Compress::Zlib"); |
163 | } else { |
164 | my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); |
165 | my $pipe = "$gzip -dc $file |"; |
166 | my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!"); |
167 | binmode $fh; |
168 | $self->{FH} = $fh; |
169 | $class->debug("via external gzip"); |
170 | } |
171 | $self; |
e82b9348 |
172 | } |
173 | |
174 | |
175 | sub READLINE { |
547d3dfd |
176 | my($self) = @_; |
177 | if (exists $self->{GZ}) { |
178 | my $gz = $self->{GZ}; |
179 | my($line,$bytesread); |
180 | $bytesread = $gz->gzreadline($line); |
181 | return undef if $bytesread <= 0; |
182 | return $line; |
183 | } else { |
184 | my $fh = $self->{FH}; |
185 | return scalar <$fh>; |
186 | } |
e82b9348 |
187 | } |
188 | |
189 | |
190 | sub READ { |
547d3dfd |
191 | my($self,$ref,$length,$offset) = @_; |
192 | $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset; |
193 | if (exists $self->{GZ}) { |
194 | my $gz = $self->{GZ}; |
195 | my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8 |
196 | return $byteread; |
197 | } else { |
198 | my $fh = $self->{FH}; |
199 | return read($fh,$$ref,$length); |
200 | } |
e82b9348 |
201 | } |
202 | |
203 | |
204 | sub DESTROY { |
205 | my($self) = @_; |
206 | if (exists $self->{GZ}) { |
207 | my $gz = $self->{GZ}; |
208 | $gz->gzclose() if defined $gz; # hard to say if it is allowed |
209 | # to be undef ever. AK, 2000-09 |
210 | } else { |
211 | my $fh = $self->{FH}; |
212 | $fh->close if defined $fh; |
213 | } |
214 | undef $self; |
215 | } |
216 | |
e82b9348 |
217 | sub untar { |
547d3dfd |
218 | my($self) = @_; |
219 | my $file = $self->{FILE}; |
220 | my($prefer) = 0; |
e82b9348 |
221 | |
5254b38e |
222 | my $exttar = $self->{TARPRG} || ""; |
223 | $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it |
224 | my $extgzip = $self->{UNGZIPPRG} || ""; |
225 | $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it |
547d3dfd |
226 | if (0) { # makes changing order easier |
227 | } elsif ($BUGHUNTING) { |
228 | $prefer=2; |
c1413a7f |
229 | } elsif ($exttar && $extgzip && $file =~ /\.bz2$/i) { |
230 | # until Archive::Tar handles bzip2 |
547d3dfd |
231 | $prefer = 1; |
232 | } elsif ( |
233 | $CPAN::META->has_usable("Archive::Tar") |
234 | && |
235 | $CPAN::META->has_inst("Compress::Zlib") ) { |
236 | $prefer = 2; |
c1413a7f |
237 | } elsif ($exttar && $extgzip) { |
238 | # no modules and not bz2 |
239 | $prefer = 1; |
547d3dfd |
240 | } else { |
5254b38e |
241 | my $foundtar = $exttar ? "'$exttar'" : "nothing"; |
242 | my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing"; |
243 | my $foundAT; |
244 | if ($CPAN::META->has_usable("Archive::Tar")) { |
245 | $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION; |
246 | } else { |
247 | $foundAT = "nothing"; |
248 | } |
249 | my $foundCZ; |
250 | if ($CPAN::META->has_inst("Compress::Zlib")) { |
251 | $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION; |
252 | } elsif ($foundAT) { |
253 | $foundCZ = "nothing"; |
254 | } else { |
255 | $foundCZ = "also nothing"; |
256 | } |
547d3dfd |
257 | $CPAN::Frontend->mydie(qq{ |
5254b38e |
258 | |
259 | CPAN.pm needs either the external programs tar and gzip -or- both |
260 | modules Archive::Tar and Compress::Zlib installed. |
261 | |
262 | For tar I found $foundtar, for gzip $foundzip. |
263 | |
264 | For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ; |
265 | |
266 | Can't continue cutting file '$file'. |
e82b9348 |
267 | }); |
e82b9348 |
268 | } |
547d3dfd |
269 | my $tar_verb = "v"; |
270 | if (defined $CPAN::Config->{tar_verbosity}) { |
271 | $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" : |
272 | $CPAN::Config->{tar_verbosity}; |
273 | } |
274 | if ($prefer==1) { # 1 => external gzip+tar |
275 | my($system); |
276 | my $is_compressed = $self->gtest(); |
5254b38e |
277 | my $tarcommand = CPAN::HandleConfig->safe_quote($exttar); |
547d3dfd |
278 | if ($is_compressed) { |
5254b38e |
279 | my $command = CPAN::HandleConfig->safe_quote($extgzip); |
547d3dfd |
280 | $system = qq{$command -dc }. |
281 | qq{< "$file" | $tarcommand x${tar_verb}f -}; |
e82b9348 |
282 | } else { |
547d3dfd |
283 | $system = qq{$tarcommand x${tar_verb}f "$file"}; |
e82b9348 |
284 | } |
547d3dfd |
285 | if (system($system) != 0) { |
286 | # people find the most curious tar binaries that cannot handle |
287 | # pipes |
288 | if ($is_compressed) { |
289 | (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//; |
5254b38e |
290 | $ungzf = basename $ungzf; |
547d3dfd |
291 | my $ct = CPAN::Tarzip->new($file); |
292 | if ($ct->gunzip($ungzf)) { |
293 | $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); |
294 | } else { |
295 | $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n}); |
296 | } |
297 | $file = $ungzf; |
298 | } |
299 | $system = qq{$tarcommand x${tar_verb}f "$file"}; |
300 | $CPAN::Frontend->myprint(qq{Using Tar:$system:\n}); |
301 | if (system($system)==0) { |
302 | $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); |
303 | } else { |
304 | $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); |
305 | } |
306 | return 1; |
307 | } else { |
308 | return 1; |
e82b9348 |
309 | } |
547d3dfd |
310 | } elsif ($prefer==2) { # 2 => modules |
311 | unless ($CPAN::META->has_usable("Archive::Tar")) { |
312 | $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue"); |
313 | } |
5254b38e |
314 | # Make sure AT does not use permissions in the archive |
315 | # This leaves it to the user's umask instead |
316 | local $Archive::Tar::CHMOD = 0; |
547d3dfd |
317 | my $tar = Archive::Tar->new($file,1); |
318 | my $af; # archive file |
319 | my @af; |
320 | if ($BUGHUNTING) { |
321 | # RCS 1.337 had this code, it turned out unacceptable slow but |
322 | # it revealed a bug in Archive::Tar. Code is only here to hunt |
323 | # the bug again. It should never be enabled in published code. |
324 | # GDGraph3d-0.53 was an interesting case according to Larry |
325 | # Virden. |
326 | warn(">>>Bughunting code enabled<<< " x 20); |
327 | for $af ($tar->list_files) { |
328 | if ($af =~ m!^(/|\.\./)!) { |
329 | $CPAN::Frontend->mydie("ALERT: Archive contains ". |
330 | "illegal member [$af]"); |
331 | } |
332 | $CPAN::Frontend->myprint("$af\n"); |
333 | $tar->extract($af); # slow but effective for finding the bug |
334 | return if $CPAN::Signal; |
335 | } |
336 | } else { |
337 | for $af ($tar->list_files) { |
338 | if ($af =~ m!^(/|\.\./)!) { |
339 | $CPAN::Frontend->mydie("ALERT: Archive contains ". |
340 | "illegal member [$af]"); |
341 | } |
342 | if ($tar_verb eq "v" || $tar_verb eq "vv") { |
343 | $CPAN::Frontend->myprint("$af\n"); |
344 | } |
345 | push @af, $af; |
346 | return if $CPAN::Signal; |
347 | } |
348 | $tar->extract(@af) or |
349 | $CPAN::Frontend->mydie("Could not untar with Archive::Tar."); |
e82b9348 |
350 | } |
e82b9348 |
351 | |
547d3dfd |
352 | Mac::BuildTools::convert_files([$tar->list_files], 1) |
353 | if ($^O eq 'MacOS'); |
e82b9348 |
354 | |
547d3dfd |
355 | return 1; |
356 | } |
e82b9348 |
357 | } |
358 | |
359 | sub unzip { |
547d3dfd |
360 | my($self) = @_; |
361 | my $file = $self->{FILE}; |
362 | if ($CPAN::META->has_inst("Archive::Zip")) { |
363 | # blueprint of the code from Archive::Zip::Tree::extractTree(); |
364 | my $zip = Archive::Zip->new(); |
365 | my $status; |
366 | $status = $zip->read($file); |
367 | $CPAN::Frontend->mydie("Read of file[$file] failed\n") |
368 | if $status != Archive::Zip::AZ_OK(); |
369 | $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG; |
370 | my @members = $zip->members(); |
371 | for my $member ( @members ) { |
372 | my $af = $member->fileName(); |
373 | if ($af =~ m!^(/|\.\./)!) { |
374 | $CPAN::Frontend->mydie("ALERT: Archive contains ". |
375 | "illegal member [$af]"); |
376 | } |
377 | $status = $member->extractToFileNamed( $af ); |
378 | $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG; |
379 | $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if |
380 | $status != Archive::Zip::AZ_OK(); |
381 | return if $CPAN::Signal; |
382 | } |
383 | return 1; |
384 | } else { |
385 | my $unzip = $CPAN::Config->{unzip} or |
386 | $CPAN::Frontend->mydie("Cannot unzip, no unzip program available"); |
387 | my @system = ($unzip, $file); |
388 | return system(@system) == 0; |
e82b9348 |
389 | } |
e82b9348 |
390 | } |
391 | |
392 | 1; |
393 | |
26844e27 |
394 | __END__ |
395 | |
396 | =head1 LICENSE |
397 | |
398 | This program is free software; you can redistribute it and/or |
399 | modify it under the same terms as Perl itself. |
400 | |
401 | =cut |