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