Commit | Line | Data |
---|---|---|
547d3dfd | 1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
e82b9348 SP |
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); |
6b1bef9a | 7 | $VERSION = "5.501"; |
e82b9348 SP |
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 SP |
12 | |
13 | # it's ok if file doesn't exist, it just matters if it is .gz or .bz2 | |
14 | sub new { | |
547d3dfd SP |
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 SP |
29 | } else { |
30 | $CPAN::Frontend->mydie(qq{ | |
e82b9348 SP |
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 SP |
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 SP |
42 | } |
43 | ||
5254b38e SP |
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 SP |
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 SP |
85 | } |
86 | ||
87 | ||
88 | sub gunzip { | |
547d3dfd SP |
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 SP |
108 | } |
109 | ||
110 | ||
111 | sub gtest { | |
547d3dfd SP |
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 SP |
143 | } |
144 | ||
145 | ||
146 | sub TIEHANDLE { | |
547d3dfd SP |
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 SP |
172 | } |
173 | ||
174 | ||
175 | sub READLINE { | |
547d3dfd SP |
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 SP |
187 | } |
188 | ||
189 | ||
190 | sub READ { | |
547d3dfd SP |
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 SP |
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 SP |
218 | my($self) = @_; |
219 | my $file = $self->{FILE}; | |
220 | my($prefer) = 0; | |
e82b9348 | 221 | |
5254b38e SP |
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 SP |
226 | if (0) { # makes changing order easier |
227 | } elsif ($BUGHUNTING) { | |
228 | $prefer=2; | |
c1413a7f A |
229 | } elsif ($exttar && $extgzip && $file =~ /\.bz2$/i) { |
230 | # until Archive::Tar handles bzip2 | |
547d3dfd SP |
231 | $prefer = 1; |
232 | } elsif ( | |
233 | $CPAN::META->has_usable("Archive::Tar") | |
234 | && | |
235 | $CPAN::META->has_inst("Compress::Zlib") ) { | |
236 | $prefer = 2; | |
c1413a7f A |
237 | } elsif ($exttar && $extgzip) { |
238 | # no modules and not bz2 | |
239 | $prefer = 1; | |
547d3dfd | 240 | } else { |
5254b38e SP |
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 SP |
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 SP |
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 SP |
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 SP |
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 SP |
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 SP |
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 | } | |
6b1bef9a | 314 | # Make sure AT does not use uid/gid/permissions in the archive |
5254b38e | 315 | # This leaves it to the user's umask instead |
6b1bef9a A |
316 | local $Archive::Tar::CHMOD = 1; |
317 | local $Archive::Tar::SAME_PERMISSIONS = 0; | |
318 | # Make sure AT leaves current user as owner | |
319 | local $Archive::Tar::CHOWN = 0; | |
547d3dfd SP |
320 | my $tar = Archive::Tar->new($file,1); |
321 | my $af; # archive file | |
322 | my @af; | |
323 | if ($BUGHUNTING) { | |
324 | # RCS 1.337 had this code, it turned out unacceptable slow but | |
325 | # it revealed a bug in Archive::Tar. Code is only here to hunt | |
326 | # the bug again. It should never be enabled in published code. | |
327 | # GDGraph3d-0.53 was an interesting case according to Larry | |
328 | # Virden. | |
329 | warn(">>>Bughunting code enabled<<< " x 20); | |
330 | for $af ($tar->list_files) { | |
331 | if ($af =~ m!^(/|\.\./)!) { | |
332 | $CPAN::Frontend->mydie("ALERT: Archive contains ". | |
333 | "illegal member [$af]"); | |
334 | } | |
335 | $CPAN::Frontend->myprint("$af\n"); | |
336 | $tar->extract($af); # slow but effective for finding the bug | |
337 | return if $CPAN::Signal; | |
338 | } | |
339 | } else { | |
340 | for $af ($tar->list_files) { | |
341 | if ($af =~ m!^(/|\.\./)!) { | |
342 | $CPAN::Frontend->mydie("ALERT: Archive contains ". | |
343 | "illegal member [$af]"); | |
344 | } | |
345 | if ($tar_verb eq "v" || $tar_verb eq "vv") { | |
346 | $CPAN::Frontend->myprint("$af\n"); | |
347 | } | |
348 | push @af, $af; | |
349 | return if $CPAN::Signal; | |
350 | } | |
351 | $tar->extract(@af) or | |
352 | $CPAN::Frontend->mydie("Could not untar with Archive::Tar."); | |
e82b9348 | 353 | } |
e82b9348 | 354 | |
547d3dfd SP |
355 | Mac::BuildTools::convert_files([$tar->list_files], 1) |
356 | if ($^O eq 'MacOS'); | |
e82b9348 | 357 | |
547d3dfd SP |
358 | return 1; |
359 | } | |
e82b9348 SP |
360 | } |
361 | ||
362 | sub unzip { | |
547d3dfd SP |
363 | my($self) = @_; |
364 | my $file = $self->{FILE}; | |
365 | if ($CPAN::META->has_inst("Archive::Zip")) { | |
366 | # blueprint of the code from Archive::Zip::Tree::extractTree(); | |
367 | my $zip = Archive::Zip->new(); | |
368 | my $status; | |
369 | $status = $zip->read($file); | |
370 | $CPAN::Frontend->mydie("Read of file[$file] failed\n") | |
371 | if $status != Archive::Zip::AZ_OK(); | |
372 | $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG; | |
373 | my @members = $zip->members(); | |
374 | for my $member ( @members ) { | |
375 | my $af = $member->fileName(); | |
376 | if ($af =~ m!^(/|\.\./)!) { | |
377 | $CPAN::Frontend->mydie("ALERT: Archive contains ". | |
378 | "illegal member [$af]"); | |
379 | } | |
380 | $status = $member->extractToFileNamed( $af ); | |
381 | $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG; | |
382 | $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if | |
383 | $status != Archive::Zip::AZ_OK(); | |
384 | return if $CPAN::Signal; | |
385 | } | |
386 | return 1; | |
387 | } else { | |
388 | my $unzip = $CPAN::Config->{unzip} or | |
389 | $CPAN::Frontend->mydie("Cannot unzip, no unzip program available"); | |
390 | my @system = ($unzip, $file); | |
391 | return system(@system) == 0; | |
e82b9348 | 392 | } |
e82b9348 SP |
393 | } |
394 | ||
395 | 1; | |
396 | ||
26844e27 SP |
397 | __END__ |
398 | ||
399 | =head1 LICENSE | |
400 | ||
401 | This program is free software; you can redistribute it and/or | |
402 | modify it under the same terms as Perl itself. | |
403 | ||
404 | =cut |