lib/CPAN/Tarzip.pm

   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 use File::Basename ();
   7 $VERSION = sprintf "%.6f", substr(q$Rev: 1301 $,4)/1000000 + 5.4;
   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
  14 sub new {
  15   my($class,$file) = @_;
  16   $CPAN::Frontend->mydie("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}) {
  26       my $bzip2;
  27       if ($CPAN::META->has_inst("File::Which")) {
  28         $bzip2 = File::Which::which("bzip2");
  29       }
  30       if ($bzip2) {
  31         $me->{UNGZIPPRG} = $bzip2 || "bzip2";
  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
  42     $me->{UNGZIPPRG} = $CPAN::Config->{gzip} || "gzip";
  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 {
  63     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  64     system(qq{$command -c "$read" > "$write"})==0;
  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 {
  86     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  87     system(qq{$command -dc "$read" > "$write"})==0;
  88   }
  89 }
  90
  91
  92 sub gtest {
  93   my($self) = @_;
  94   return $self->{GTEST} if exists $self->{GTEST};
  95   defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
  96   my $read = $self->{FILE};
  97   my $success;
  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;
 112     $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
 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;
 119   } else {
 120     my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 121     $success = 0==system(qq{$command -qdt "$read"});
 122   }
 123   return $self->{GTEST} = $success;
 124 }
 125
 126
 127 sub TIEHANDLE {
 128   my($class,$file) = @_;
 129   my $ret;
 130   $class->debug("file[$file]");
 131   my $self = $class->new($file);
 132   if (0) {
 133   } elsif (!$self->gtest) {
 134     my $fh = FileHandle->new($file)
 135         or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
 136     binmode $fh;
 137     $self->{FH} = $fh;
 138     $class->debug("via uncompressed FH");
 139   } elsif ($CPAN::META->has_inst("Compress::Zlib")) {
 140     my $gz = Compress::Zlib::gzopen($file,"rb") or
 141         $CPAN::Frontend->mydie("Could not gzopen $file");
 142     $self->{GZ} = $gz;
 143     $class->debug("via Compress::Zlib");
 144   } else {
 145     my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 146     my $pipe = "$gzip -dc $file |";
 147     my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
 148     binmode $fh;
 149     $self->{FH} = $fh;
 150     $class->debug("via external gzip");
 151   }
 152   $self;
 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) = @_;
 173   $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
 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            &&
 209            MM->maybe_command($CPAN::Config->{tar})) {
 210     # should be default until Archive::Tar handles bzip2
 211     $prefer = 1;
 212   } elsif (
 213            $CPAN::META->has_inst("Archive::Tar")
 214            &&
 215            $CPAN::META->has_inst("Compress::Zlib") ) {
 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();
 226     my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar";
 227     if ($is_compressed) {
 228       my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 229       $system = qq{$command -dc }.
 230           qq{< "$file" | $tarcommand xvf -};
 231     } else {
 232       $system = qq{$tarcommand xvf "$file"};
 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//;
 239         $ungzf = File::Basename::basename($ungzf);
 240         my $ct = CPAN::Tarzip->new($file);
 241         if ($ct->gunzip($ungzf)) {
 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       }
 248       $system = qq{$tarcommand xvf "$file"};
 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     unless ($CPAN::META->has_inst("Archive::Tar")) {
 261       $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
 262     }
 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       }
 292       $tar->extract(@af) or
 293           $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
 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);
 311     $CPAN::Frontend->mydie("Read of file[$file] failed\n")
 312         if $status != Archive::Zip::AZ_OK();
 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;
 323       $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
 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
 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