[Summary view] [Print] [Text view]

   1  # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   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: 2213 $,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("CPAN::Tarzip->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_usable("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      my $tar_verb = "v";
 224      if (defined $CPAN::Config->{tar_verbosity}) {
 225          $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
 226              $CPAN::Config->{tar_verbosity};
 227      }
 228      if ($prefer==1) { # 1 => external gzip+tar
 229          my($system);
 230          my $is_compressed = $self->gtest();
 231          my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar";
 232          if ($is_compressed) {
 233              my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 234              $system = qq{$command -dc }.
 235                  qq{< "$file" | $tarcommand x$tar_verb}f -};
 236          } else {
 237              $system = qq{$tarcommand x$tar_verb}f "$file"};
 238          }
 239          if (system($system) != 0) {
 240              # people find the most curious tar binaries that cannot handle
 241              # pipes
 242              if ($is_compressed) {
 243                  (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
 244                  $ungzf = File::Basename::basename($ungzf);
 245                  my $ct = CPAN::Tarzip->new($file);
 246                  if ($ct->gunzip($ungzf)) {
 247                      $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
 248                  } else {
 249                      $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
 250                  }
 251                  $file = $ungzf;
 252              }
 253              $system = qq{$tarcommand x$tar_verb}f "$file"};
 254              $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
 255              if (system($system)==0) {
 256                  $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
 257              } else {
 258                  $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
 259              }
 260              return 1;
 261          } else {
 262              return 1;
 263          }
 264      } elsif ($prefer==2) { # 2 => modules
 265          unless ($CPAN::META->has_usable("Archive::Tar")) {
 266              $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
 267          }
 268          my $tar = Archive::Tar->new($file,1);
 269          my $af; # archive file
 270          my @af;
 271          if ($BUGHUNTING) {
 272              # RCS 1.337 had this code, it turned out unacceptable slow but
 273              # it revealed a bug in Archive::Tar. Code is only here to hunt
 274              # the bug again. It should never be enabled in published code.
 275              # GDGraph3d-0.53 was an interesting case according to Larry
 276              # Virden.
 277              warn(">>>Bughunting code enabled<<< " x 20);
 278              for $af ($tar->list_files) {
 279                  if ($af =~ m!^(/|\.\./)!) {
 280                      $CPAN::Frontend->mydie("ALERT: Archive contains ".
 281                                             "illegal member [$af]");
 282                  }
 283                  $CPAN::Frontend->myprint("$af\n");
 284                  $tar->extract($af); # slow but effective for finding the bug
 285                  return if $CPAN::Signal;
 286              }
 287          } else {
 288              for $af ($tar->list_files) {
 289                  if ($af =~ m!^(/|\.\./)!) {
 290                      $CPAN::Frontend->mydie("ALERT: Archive contains ".
 291                                             "illegal member [$af]");
 292                  }
 293                  if ($tar_verb eq "v" || $tar_verb eq "vv") {
 294                      $CPAN::Frontend->myprint("$af\n");
 295                  }
 296                  push @af, $af;
 297                  return if $CPAN::Signal;
 298              }
 299              $tar->extract(@af) or
 300                  $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
 301          }
 302  
 303          Mac::BuildTools::convert_files([$tar->list_files], 1)
 304              if ($^O eq 'MacOS');
 305  
 306          return 1;
 307      }
 308  }
 309  
 310  sub unzip {
 311      my($self) = @_;
 312      my $file = $self->{FILE};
 313      if ($CPAN::META->has_inst("Archive::Zip")) {
 314          # blueprint of the code from Archive::Zip::Tree::extractTree();
 315          my $zip = Archive::Zip->new();
 316          my $status;
 317          $status = $zip->read($file);
 318          $CPAN::Frontend->mydie("Read of file[$file] failed\n")
 319              if $status != Archive::Zip::AZ_OK();
 320          $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
 321          my @members = $zip->members();
 322          for my $member ( @members ) {
 323              my $af = $member->fileName();
 324              if ($af =~ m!^(/|\.\./)!) {
 325                  $CPAN::Frontend->mydie("ALERT: Archive contains ".
 326                                         "illegal member [$af]");
 327              }
 328              $status = $member->extractToFileNamed( $af );
 329              $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
 330              $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
 331                  $status != Archive::Zip::AZ_OK();
 332              return if $CPAN::Signal;
 333          }
 334          return 1;
 335      } else {
 336          my $unzip = $CPAN::Config->{unzip} or
 337              $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
 338          my @system = ($unzip, $file);
 339          return system(@system) == 0;
 340      }
 341  }
 342  
 343  1;
 344  
 345  __END__
 346  
 347  =head1 LICENSE
 348  
 349  This program is free software; you can redistribute it and/or
 350  modify it under the same terms as Perl itself.
 351  
 352  =cut