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