ANSI-C headers in test snippets to please g++ (and the rest)
[p5sagit/p5-mst-13.2.git] / lib / CPAN / Tarzip.pm
CommitLineData
e82b9348 1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
2package CPAN::Tarzip;
3use strict;
4use vars qw($VERSION @ISA $BUGHUNTING);
5use CPAN::Debug;
0cf35e6a 6use File::Basename ();
ed84aac9 7$VERSION = sprintf "%.6f", substr(q$Rev: 714 $,4)/1000000 + 5.4;
e82b9348 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
14sub 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{
34CPAN.pm needs the external program bzip2 in order to handle '$file'.
35Please install it now and run 'o conf init' to register it as external
36program.
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
47sub 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
69sub 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
92sub gtest {
93 my($self) = @_;
87892b73 94 return $self->{GTEST} if exists $self->{GTEST};
95 my $read = $self->{FILE} or die;
96 my $success;
e82b9348 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;
87892b73 111 $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
e82b9348 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;
e82b9348 118 } else {
ed84aac9 119 my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
120 $success = 0==system(qq{$command -qdt "$read"});
e82b9348 121 }
87892b73 122 return $self->{GTEST} = $success;
e82b9348 123}
124
125
126sub TIEHANDLE {
127 my($class,$file) = @_;
128 my $ret;
129 $class->debug("file[$file]");
87892b73 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")) {
e82b9348 137 my $gz = Compress::Zlib::gzopen($file,"rb") or
138 die "Could not gzopen $file";
87892b73 139 $self->{GZ} = $gz;
e82b9348 140 } else {
ed84aac9 141 my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
142 my $pipe = "$gzip -dc $file |";
e82b9348 143 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
144 binmode $fh;
87892b73 145 $self->{FH} = $fh;
e82b9348 146 }
87892b73 147 $self;
e82b9348 148}
149
150
151sub 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
166sub 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
180sub 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
194sub 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 &&
ed84aac9 204 MM->maybe_command($CPAN::Config->{tar})) {
e82b9348 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{
213Archive::Tar lacks support for bz2. Can't continue.
214});
215 }
216 $prefer = 2;
217 } else {
218 $CPAN::Frontend->mydie(qq{
219CPAN.pm needs either the external programs tar, gzip and bzip2
220installed. 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
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 }
0cf35e6a 289 $tar->extract(@af) or
290 $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
e82b9348 291 }
292
293 Mac::BuildTools::convert_files([$tar->list_files], 1)
294 if ($^O eq 'MacOS');
295
296 return 1;
297 }
298}
299
300sub 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
3321;
333