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