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: 659 $,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;
  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};
  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     system(qq{$self->{UNGZIPPRG} -c "$read" > "$write"})==0;
  64   }
  65 }
  66
  67
  68 sub gunzip {
  69   my($self,$write) = @_;
  70   my $read = $self->{FILE};
  71   if ($CPAN::META->has_inst("Compress::Zlib")) {
  72     my($buffer,$fhw);
  73     $fhw = FileHandle->new(">$write")
  74         or $CPAN::Frontend->mydie("Could not open >$write: $!");
  75     my $gz = Compress::Zlib::gzopen($read, "rb")
  76         or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
  77     $fhw->print($buffer)
  78         while $gz->gzread($buffer) > 0 ;
  79     $CPAN::Frontend->mydie("Error reading from $read: $!\n")
  80         if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
  81     $gz->gzclose() ;
  82     $fhw->close;
  83     return 1;
  84   } else {
  85     system(qq{$self->{UNGZIPPRG} -dc "$read" > "$write"})==0;
  86   }
  87 }
  88
  89
  90 sub gtest {
  91   my($self) = @_;
  92   return $self->{GTEST} if exists $self->{GTEST};
  93   my $read = $self->{FILE} or die;
  94   my $success;
  95   # After I had reread the documentation in zlib.h, I discovered that
  96   # uncompressed files do not lead to an gzerror (anymore?).
  97   if ( $CPAN::META->has_inst("Compress::Zlib") ) {
  98     my($buffer,$len);
  99     $len = 0;
 100     my $gz = Compress::Zlib::gzopen($read, "rb")
 101         or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
 102                                           $read,
 103                                           $Compress::Zlib::gzerrno));
 104     while ($gz->gzread($buffer) > 0 ){
 105         $len += length($buffer);
 106         $buffer = "";
 107     }
 108     my $err = $gz->gzerror;
 109     $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
 110     if ($len == -s $read){
 111         $success = 0;
 112         CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
 113     }
 114     $gz->gzclose();
 115     CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
 116   } else {
 117     $success = 0==system(qq{$self->{UNGZIPPRG} -qdt "$read"});
 118   }
 119   return $self->{GTEST} = $success;
 120 }
 121
 122
 123 sub TIEHANDLE {
 124   my($class,$file) = @_;
 125   my $ret;
 126   $class->debug("file[$file]");
 127   my $self = $class->new($file);
 128   if (0) {
 129   } elsif (!$self->gtest) {
 130     my $fh = FileHandle->new($file) or die "Could not open file[$file]: $!";
 131     binmode $fh;
 132     $self->{FH} = $fh;
 133   } elsif ($CPAN::META->has_inst("Compress::Zlib")) {
 134     my $gz = Compress::Zlib::gzopen($file,"rb") or
 135         die "Could not gzopen $file";
 136     $self->{GZ} = $gz;
 137   } else {
 138     my $pipe = "$CPAN::Config->{gzip} -dc $file |";
 139     my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
 140     binmode $fh;
 141     $self->{FH} = $fh;
 142   }
 143   $self;
 144 }
 145
 146
 147 sub READLINE {
 148   my($self) = @_;
 149   if (exists $self->{GZ}) {
 150     my $gz = $self->{GZ};
 151     my($line,$bytesread);
 152     $bytesread = $gz->gzreadline($line);
 153     return undef if $bytesread <= 0;
 154     return $line;
 155   } else {
 156     my $fh = $self->{FH};
 157     return scalar <$fh>;
 158   }
 159 }
 160
 161
 162 sub READ {
 163   my($self,$ref,$length,$offset) = @_;
 164   die "read with offset not implemented" if defined $offset;
 165   if (exists $self->{GZ}) {
 166     my $gz = $self->{GZ};
 167     my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
 168     return $byteread;
 169   } else {
 170     my $fh = $self->{FH};
 171     return read($fh,$$ref,$length);
 172   }
 173 }
 174
 175
 176 sub DESTROY {
 177     my($self) = @_;
 178     if (exists $self->{GZ}) {
 179         my $gz = $self->{GZ};
 180         $gz->gzclose() if defined $gz; # hard to say if it is allowed
 181                                        # to be undef ever. AK, 2000-09
 182     } else {
 183         my $fh = $self->{FH};
 184         $fh->close if defined $fh;
 185     }
 186     undef $self;
 187 }
 188
 189
 190 sub untar {
 191   my($self) = @_;
 192   my $file = $self->{FILE};
 193   my($prefer) = 0;
 194
 195   if (0) { # makes changing order easier
 196   } elsif ($BUGHUNTING){
 197     $prefer=2;
 198   } elsif (MM->maybe_command($self->{UNGZIPPRG})
 199            &&
 200            MM->maybe_command($CPAN::Config->{'tar'})) {
 201     # should be default until Archive::Tar handles bzip2
 202     $prefer = 1;
 203   } elsif (
 204            $CPAN::META->has_inst("Archive::Tar")
 205            &&
 206            $CPAN::META->has_inst("Compress::Zlib") ) {
 207     if ($file =~ /\.bz2$/) {
 208       $CPAN::Frontend->mydie(qq{
 209 Archive::Tar lacks support for bz2. Can't continue.
 210 });
 211     }
 212     $prefer = 2;
 213   } else {
 214     $CPAN::Frontend->mydie(qq{
 215 CPAN.pm needs either the external programs tar, gzip and bzip2
 216 installed. Can't continue.
 217 });
 218   }
 219   if ($prefer==1) { # 1 => external gzip+tar
 220     my($system);
 221     my $is_compressed = $self->gtest();
 222     if ($is_compressed) {
 223       $system = qq{$self->{UNGZIPPRG} -dc }.
 224           qq{< "$file" | $CPAN::Config->{tar} xvf -};
 225     } else {
 226       $system = qq{$CPAN::Config->{tar} xvf "$file"};
 227     }
 228     if (system($system) != 0) {
 229       # people find the most curious tar binaries that cannot handle
 230       # pipes
 231       if ($is_compressed) {
 232         (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
 233         $ungzf = File::Basename::basename($ungzf);
 234         my $ct = CPAN::Tarzip->new($file);
 235         if ($ct->gunzip($ungzf)) {
 236           $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
 237         } else {
 238           $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
 239         }
 240         $file = $ungzf;
 241       }
 242       $system = qq{$CPAN::Config->{tar} xvf "$file"};
 243       $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
 244       if (system($system)==0) {
 245         $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
 246       } else {
 247         $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
 248       }
 249       return 1;
 250     } else {
 251       return 1;
 252     }
 253   } elsif ($prefer==2) { # 2 => modules
 254     my $tar = Archive::Tar->new($file,1);
 255     my $af; # archive file
 256     my @af;
 257     if ($BUGHUNTING) {
 258       # RCS 1.337 had this code, it turned out unacceptable slow but
 259       # it revealed a bug in Archive::Tar. Code is only here to hunt
 260       # the bug again. It should never be enabled in published code.
 261       # GDGraph3d-0.53 was an interesting case according to Larry
 262       # Virden.
 263       warn(">>>Bughunting code enabled<<< " x 20);
 264       for $af ($tar->list_files) {
 265         if ($af =~ m!^(/|\.\./)!) {
 266           $CPAN::Frontend->mydie("ALERT: Archive contains ".
 267                                  "illegal member [$af]");
 268         }
 269         $CPAN::Frontend->myprint("$af\n");
 270         $tar->extract($af); # slow but effective for finding the bug
 271         return if $CPAN::Signal;
 272       }
 273     } else {
 274       for $af ($tar->list_files) {
 275         if ($af =~ m!^(/|\.\./)!) {
 276           $CPAN::Frontend->mydie("ALERT: Archive contains ".
 277                                  "illegal member [$af]");
 278         }
 279         $CPAN::Frontend->myprint("$af\n");
 280         push @af, $af;
 281         return if $CPAN::Signal;
 282       }
 283       $tar->extract(@af) or
 284           $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
 285     }
 286
 287     Mac::BuildTools::convert_files([$tar->list_files], 1)
 288           if ($^O eq 'MacOS');
 289
 290     return 1;
 291   }
 292 }
 293
 294 sub unzip {
 295   my($self) = @_;
 296   my $file = $self->{FILE};
 297   if ($CPAN::META->has_inst("Archive::Zip")) {
 298     # blueprint of the code from Archive::Zip::Tree::extractTree();
 299     my $zip = Archive::Zip->new();
 300     my $status;
 301     $status = $zip->read($file);
 302     die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
 303     $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
 304     my @members = $zip->members();
 305     for my $member ( @members ) {
 306       my $af = $member->fileName();
 307       if ($af =~ m!^(/|\.\./)!) {
 308         $CPAN::Frontend->mydie("ALERT: Archive contains ".
 309                                "illegal member [$af]");
 310       }
 311       $status = $member->extractToFileNamed( $af );
 312       $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
 313       die "Extracting of file[$af] from zipfile[$file] failed\n" if
 314           $status != Archive::Zip::AZ_OK();
 315       return if $CPAN::Signal;
 316     }
 317     return 1;
 318   } else {
 319     my $unzip = $CPAN::Config->{unzip} or
 320         $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
 321     my @system = ($unzip, $file);
 322     return system(@system) == 0;
 323   }
 324 }
 325
 326 1;
 327