Commit | Line | Data |
e82b9348 |
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; |
0cf35e6a |
6 | use File::Basename (); |
f20de9f0 |
7 | $VERSION = sprintf "%.6f", substr(q$Rev: 1525 $,4)/1000000 + 5.4; |
e82b9348 |
8 | # module is internal to CPAN.pm |
9 | |
10 | @ISA = qw(CPAN::Debug); |
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 { |
15 | my($class,$file) = @_; |
0cf35e6a |
16 | $CPAN::Frontend->mydie("new called without arg") unless defined $file; |
1a43333d |
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 | } |
e82b9348 |
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) { |
ed84aac9 |
31 | $me->{UNGZIPPRG} = $bzip2 || "bzip2"; |
e82b9348 |
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 |
ed84aac9 |
42 | $me->{UNGZIPPRG} = $CPAN::Config->{gzip} || "gzip"; |
e82b9348 |
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 { |
ed84aac9 |
63 | my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); |
64 | system(qq{$command -c "$read" > "$write"})==0; |
e82b9348 |
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 { |
ed84aac9 |
86 | my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); |
87 | system(qq{$command -dc "$read" > "$write"})==0; |
e82b9348 |
88 | } |
89 | } |
90 | |
91 | |
92 | sub gtest { |
93 | my($self) = @_; |
87892b73 |
94 | return $self->{GTEST} if exists $self->{GTEST}; |
be34b10d |
95 | defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified"); |
96 | my $read = $self->{FILE}; |
87892b73 |
97 | my $success; |
e82b9348 |
98 | # After I had reread the documentation in zlib.h, I discovered that |
99 | # uncompressed files do not lead to an gzerror (anymore?). |
100 | if ( $CPAN::META->has_inst("Compress::Zlib") ) { |
101 | my($buffer,$len); |
102 | $len = 0; |
103 | my $gz = Compress::Zlib::gzopen($read, "rb") |
104 | or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n", |
105 | $read, |
106 | $Compress::Zlib::gzerrno)); |
107 | while ($gz->gzread($buffer) > 0 ){ |
108 | $len += length($buffer); |
109 | $buffer = ""; |
110 | } |
111 | my $err = $gz->gzerror; |
87892b73 |
112 | $success = ! $err || $err == Compress::Zlib::Z_STREAM_END(); |
e82b9348 |
113 | if ($len == -s $read){ |
114 | $success = 0; |
115 | CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG; |
116 | } |
117 | $gz->gzclose(); |
118 | CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG; |
e82b9348 |
119 | } else { |
ed84aac9 |
120 | my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); |
121 | $success = 0==system(qq{$command -qdt "$read"}); |
e82b9348 |
122 | } |
87892b73 |
123 | return $self->{GTEST} = $success; |
e82b9348 |
124 | } |
125 | |
126 | |
127 | sub TIEHANDLE { |
128 | my($class,$file) = @_; |
129 | my $ret; |
130 | $class->debug("file[$file]"); |
87892b73 |
131 | my $self = $class->new($file); |
132 | if (0) { |
133 | } elsif (!$self->gtest) { |
be34b10d |
134 | my $fh = FileHandle->new($file) |
135 | or $CPAN::Frontend->mydie("Could not open file[$file]: $!"); |
87892b73 |
136 | binmode $fh; |
137 | $self->{FH} = $fh; |
7d97ad34 |
138 | $class->debug("via uncompressed FH"); |
87892b73 |
139 | } elsif ($CPAN::META->has_inst("Compress::Zlib")) { |
e82b9348 |
140 | my $gz = Compress::Zlib::gzopen($file,"rb") or |
be34b10d |
141 | $CPAN::Frontend->mydie("Could not gzopen $file"); |
87892b73 |
142 | $self->{GZ} = $gz; |
7d97ad34 |
143 | $class->debug("via Compress::Zlib"); |
e82b9348 |
144 | } else { |
ed84aac9 |
145 | my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); |
146 | my $pipe = "$gzip -dc $file |"; |
be34b10d |
147 | my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!"); |
e82b9348 |
148 | binmode $fh; |
87892b73 |
149 | $self->{FH} = $fh; |
7d97ad34 |
150 | $class->debug("via external gzip"); |
e82b9348 |
151 | } |
87892b73 |
152 | $self; |
e82b9348 |
153 | } |
154 | |
155 | |
156 | sub READLINE { |
157 | my($self) = @_; |
158 | if (exists $self->{GZ}) { |
159 | my $gz = $self->{GZ}; |
160 | my($line,$bytesread); |
161 | $bytesread = $gz->gzreadline($line); |
162 | return undef if $bytesread <= 0; |
163 | return $line; |
164 | } else { |
165 | my $fh = $self->{FH}; |
166 | return scalar <$fh>; |
167 | } |
168 | } |
169 | |
170 | |
171 | sub READ { |
172 | my($self,$ref,$length,$offset) = @_; |
be34b10d |
173 | $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset; |
e82b9348 |
174 | if (exists $self->{GZ}) { |
175 | my $gz = $self->{GZ}; |
176 | my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8 |
177 | return $byteread; |
178 | } else { |
179 | my $fh = $self->{FH}; |
180 | return read($fh,$$ref,$length); |
181 | } |
182 | } |
183 | |
184 | |
185 | sub DESTROY { |
186 | my($self) = @_; |
187 | if (exists $self->{GZ}) { |
188 | my $gz = $self->{GZ}; |
189 | $gz->gzclose() if defined $gz; # hard to say if it is allowed |
190 | # to be undef ever. AK, 2000-09 |
191 | } else { |
192 | my $fh = $self->{FH}; |
193 | $fh->close if defined $fh; |
194 | } |
195 | undef $self; |
196 | } |
197 | |
198 | |
199 | sub untar { |
200 | my($self) = @_; |
201 | my $file = $self->{FILE}; |
202 | my($prefer) = 0; |
203 | |
204 | if (0) { # makes changing order easier |
205 | } elsif ($BUGHUNTING){ |
206 | $prefer=2; |
207 | } elsif (MM->maybe_command($self->{UNGZIPPRG}) |
208 | && |
ed84aac9 |
209 | MM->maybe_command($CPAN::Config->{tar})) { |
e82b9348 |
210 | # should be default until Archive::Tar handles bzip2 |
211 | $prefer = 1; |
212 | } elsif ( |
f20de9f0 |
213 | $CPAN::META->has_usable("Archive::Tar") |
e82b9348 |
214 | && |
215 | $CPAN::META->has_inst("Compress::Zlib") ) { |
e82b9348 |
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(); |
ed84aac9 |
226 | my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar"; |
e82b9348 |
227 | if ($is_compressed) { |
ed84aac9 |
228 | my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); |
229 | $system = qq{$command -dc }. |
230 | qq{< "$file" | $tarcommand xvf -}; |
e82b9348 |
231 | } else { |
ed84aac9 |
232 | $system = qq{$tarcommand xvf "$file"}; |
e82b9348 |
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//; |
0cf35e6a |
239 | $ungzf = File::Basename::basename($ungzf); |
240 | my $ct = CPAN::Tarzip->new($file); |
241 | if ($ct->gunzip($ungzf)) { |
e82b9348 |
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 | } |
ed84aac9 |
248 | $system = qq{$tarcommand xvf "$file"}; |
e82b9348 |
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 |
f20de9f0 |
260 | unless ($CPAN::META->has_usable("Archive::Tar")) { |
2ccf00a7 |
261 | $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue"); |
262 | } |
e82b9348 |
263 | my $tar = Archive::Tar->new($file,1); |
264 | my $af; # archive file |
265 | my @af; |
266 | if ($BUGHUNTING) { |
267 | # RCS 1.337 had this code, it turned out unacceptable slow but |
268 | # it revealed a bug in Archive::Tar. Code is only here to hunt |
269 | # the bug again. It should never be enabled in published code. |
270 | # GDGraph3d-0.53 was an interesting case according to Larry |
271 | # Virden. |
272 | warn(">>>Bughunting code enabled<<< " x 20); |
273 | for $af ($tar->list_files) { |
274 | if ($af =~ m!^(/|\.\./)!) { |
275 | $CPAN::Frontend->mydie("ALERT: Archive contains ". |
276 | "illegal member [$af]"); |
277 | } |
278 | $CPAN::Frontend->myprint("$af\n"); |
279 | $tar->extract($af); # slow but effective for finding the bug |
280 | return if $CPAN::Signal; |
281 | } |
282 | } else { |
283 | for $af ($tar->list_files) { |
284 | if ($af =~ m!^(/|\.\./)!) { |
285 | $CPAN::Frontend->mydie("ALERT: Archive contains ". |
286 | "illegal member [$af]"); |
287 | } |
288 | $CPAN::Frontend->myprint("$af\n"); |
289 | push @af, $af; |
290 | return if $CPAN::Signal; |
291 | } |
0cf35e6a |
292 | $tar->extract(@af) or |
293 | $CPAN::Frontend->mydie("Could not untar with Archive::Tar."); |
e82b9348 |
294 | } |
295 | |
296 | Mac::BuildTools::convert_files([$tar->list_files], 1) |
297 | if ($^O eq 'MacOS'); |
298 | |
299 | return 1; |
300 | } |
301 | } |
302 | |
303 | sub unzip { |
304 | my($self) = @_; |
305 | my $file = $self->{FILE}; |
306 | if ($CPAN::META->has_inst("Archive::Zip")) { |
307 | # blueprint of the code from Archive::Zip::Tree::extractTree(); |
308 | my $zip = Archive::Zip->new(); |
309 | my $status; |
310 | $status = $zip->read($file); |
be34b10d |
311 | $CPAN::Frontend->mydie("Read of file[$file] failed\n") |
312 | if $status != Archive::Zip::AZ_OK(); |
e82b9348 |
313 | $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG; |
314 | my @members = $zip->members(); |
315 | for my $member ( @members ) { |
316 | my $af = $member->fileName(); |
317 | if ($af =~ m!^(/|\.\./)!) { |
318 | $CPAN::Frontend->mydie("ALERT: Archive contains ". |
319 | "illegal member [$af]"); |
320 | } |
321 | $status = $member->extractToFileNamed( $af ); |
322 | $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG; |
be34b10d |
323 | $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if |
e82b9348 |
324 | $status != Archive::Zip::AZ_OK(); |
325 | return if $CPAN::Signal; |
326 | } |
327 | return 1; |
328 | } else { |
329 | my $unzip = $CPAN::Config->{unzip} or |
330 | $CPAN::Frontend->mydie("Cannot unzip, no unzip program available"); |
331 | my @system = ($unzip, $file); |
332 | return system(@system) == 0; |
333 | } |
334 | } |
335 | |
336 | 1; |
337 | |
26844e27 |
338 | __END__ |
339 | |
340 | =head1 LICENSE |
341 | |
342 | This program is free software; you can redistribute it and/or |
343 | modify it under the same terms as Perl itself. |
344 | |
345 | =cut |