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 $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