lib/CPAN/Tarzip.pm

   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