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 qw(basename);
   7 $VERSION = "5.5";
   8 # module is internal to CPAN.pm
   9
  10 @ISA = qw(CPAN::Debug); ## no critic
  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 = _my_which("bzip2");
  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         $me->{UNGZIPPRG} = _my_which("gzip");
  39     }
  40     $me->{TARPRG} = _my_which("tar") || _my_which("gtar");
  41     bless $me, $class;
  42 }
  43
  44 sub _my_which {
  45     my($what) = @_;
  46     if ($CPAN::Config->{$what}) {
  47         return $CPAN::Config->{$what};
  48     }
  49     if ($CPAN::META->has_inst("File::Which")) {
  50         return File::Which::which($what);
  51     }
  52     my @cand = MM->maybe_command($what);
  53     return $cand[0] if @cand;
  54     require File::Spec;
  55     my $component;
  56   PATH_COMPONENT: foreach $component (File::Spec->path()) {
  57         next unless defined($component) && $component;
  58         my($abs) = File::Spec->catfile($component,$what);
  59         if (MM->maybe_command($abs)) {
  60             return $abs;
  61         }
  62     }
  63     return;
  64 }
  65
  66 sub gzip {
  67     my($self,$read) = @_;
  68     my $write = $self->{FILE};
  69     if ($CPAN::META->has_inst("Compress::Zlib")) {
  70         my($buffer,$fhw);
  71         $fhw = FileHandle->new($read)
  72             or $CPAN::Frontend->mydie("Could not open $read: $!");
  73         my $cwd = `pwd`;
  74         my $gz = Compress::Zlib::gzopen($write, "wb")
  75             or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
  76         $gz->gzwrite($buffer)
  77             while read($fhw,$buffer,4096) > 0 ;
  78         $gz->gzclose() ;
  79         $fhw->close;
  80         return 1;
  81     } else {
  82         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  83         system(qq{$command -c "$read" > "$write"})==0;
  84     }
  85 }
  86
  87
  88 sub gunzip {
  89     my($self,$write) = @_;
  90     my $read = $self->{FILE};
  91     if ($CPAN::META->has_inst("Compress::Zlib")) {
  92         my($buffer,$fhw);
  93         $fhw = FileHandle->new(">$write")
  94             or $CPAN::Frontend->mydie("Could not open >$write: $!");
  95         my $gz = Compress::Zlib::gzopen($read, "rb")
  96             or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
  97         $fhw->print($buffer)
  98         while $gz->gzread($buffer) > 0 ;
  99         $CPAN::Frontend->mydie("Error reading from $read: $!\n")
 100             if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
 101         $gz->gzclose() ;
 102         $fhw->close;
 103         return 1;
 104     } else {
 105         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 106         system(qq{$command -dc "$read" > "$write"})==0;
 107     }
 108 }
 109
 110
 111 sub gtest {
 112     my($self) = @_;
 113     return $self->{GTEST} if exists $self->{GTEST};
 114     defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
 115     my $read = $self->{FILE};
 116     my $success;
 117     # After I had reread the documentation in zlib.h, I discovered that
 118     # uncompressed files do not lead to an gzerror (anymore?).
 119     if ( $CPAN::META->has_inst("Compress::Zlib") ) {
 120         my($buffer,$len);
 121         $len = 0;
 122         my $gz = Compress::Zlib::gzopen($read, "rb")
 123             or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
 124                                               $read,
 125                                               $Compress::Zlib::gzerrno));
 126         while ($gz->gzread($buffer) > 0 ) {
 127             $len += length($buffer);
 128             $buffer = "";
 129         }
 130         my $err = $gz->gzerror;
 131         $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
 132         if ($len == -s $read) {
 133             $success = 0;
 134             CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
 135         }
 136         $gz->gzclose();
 137         CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
 138     } else {
 139         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 140         $success = 0==system(qq{$command -qdt "$read"});
 141     }
 142     return $self->{GTEST} = $success;
 143 }
 144
 145
 146 sub TIEHANDLE {
 147     my($class,$file) = @_;
 148     my $ret;
 149     $class->debug("file[$file]");
 150     my $self = $class->new($file);
 151     if (0) {
 152     } elsif (!$self->gtest) {
 153         my $fh = FileHandle->new($file)
 154             or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
 155         binmode $fh;
 156         $self->{FH} = $fh;
 157         $class->debug("via uncompressed FH");
 158     } elsif ($CPAN::META->has_inst("Compress::Zlib")) {
 159         my $gz = Compress::Zlib::gzopen($file,"rb") or
 160             $CPAN::Frontend->mydie("Could not gzopen $file");
 161         $self->{GZ} = $gz;
 162         $class->debug("via Compress::Zlib");
 163     } else {
 164         my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 165         my $pipe = "$gzip -dc $file |";
 166         my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
 167         binmode $fh;
 168         $self->{FH} = $fh;
 169         $class->debug("via external gzip");
 170     }
 171     $self;
 172 }
 173
 174
 175 sub READLINE {
 176     my($self) = @_;
 177     if (exists $self->{GZ}) {
 178         my $gz = $self->{GZ};
 179         my($line,$bytesread);
 180         $bytesread = $gz->gzreadline($line);
 181         return undef if $bytesread <= 0;
 182         return $line;
 183     } else {
 184         my $fh = $self->{FH};
 185         return scalar <$fh>;
 186     }
 187 }
 188
 189
 190 sub READ {
 191     my($self,$ref,$length,$offset) = @_;
 192     $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
 193     if (exists $self->{GZ}) {
 194         my $gz = $self->{GZ};
 195         my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
 196         return $byteread;
 197     } else {
 198         my $fh = $self->{FH};
 199         return read($fh,$$ref,$length);
 200     }
 201 }
 202
 203
 204 sub DESTROY {
 205     my($self) = @_;
 206     if (exists $self->{GZ}) {
 207         my $gz = $self->{GZ};
 208         $gz->gzclose() if defined $gz; # hard to say if it is allowed
 209                                        # to be undef ever. AK, 2000-09
 210     } else {
 211         my $fh = $self->{FH};
 212         $fh->close if defined $fh;
 213     }
 214     undef $self;
 215 }
 216
 217 sub untar {
 218     my($self) = @_;
 219     my $file = $self->{FILE};
 220     my($prefer) = 0;
 221
 222     my $exttar = $self->{TARPRG} || "";
 223     $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
 224     my $extgzip = $self->{UNGZIPPRG} || "";
 225     $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
 226     if (0) { # makes changing order easier
 227     } elsif ($BUGHUNTING) {
 228         $prefer=2;
 229     } elsif ($exttar && $extgzip) {
 230         # should be default until Archive::Tar handles bzip2
 231         $prefer = 1;
 232     } elsif (
 233              $CPAN::META->has_usable("Archive::Tar")
 234              &&
 235              $CPAN::META->has_inst("Compress::Zlib") ) {
 236         $prefer = 2;
 237     } else {
 238         my $foundtar = $exttar ? "'$exttar'" : "nothing";
 239         my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
 240         my $foundAT;
 241         if ($CPAN::META->has_usable("Archive::Tar")) {
 242             $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
 243         } else {
 244             $foundAT = "nothing";
 245         }
 246         my $foundCZ;
 247         if ($CPAN::META->has_inst("Compress::Zlib")) {
 248             $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
 249         } elsif ($foundAT) {
 250             $foundCZ = "nothing";
 251         } else {
 252             $foundCZ = "also nothing";
 253         }
 254         $CPAN::Frontend->mydie(qq{
 255
 256 CPAN.pm needs either the external programs tar and gzip -or- both
 257 modules Archive::Tar and Compress::Zlib installed.
 258
 259 For tar I found $foundtar, for gzip $foundzip.
 260
 261 For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
 262
 263 Can't continue cutting file '$file'.
 264 });
 265     }
 266     my $tar_verb = "v";
 267     if (defined $CPAN::Config->{tar_verbosity}) {
 268         $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
 269             $CPAN::Config->{tar_verbosity};
 270     }
 271     if ($prefer==1) { # 1 => external gzip+tar
 272         my($system);
 273         my $is_compressed = $self->gtest();
 274         my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
 275         if ($is_compressed) {
 276             my $command = CPAN::HandleConfig->safe_quote($extgzip);
 277             $system = qq{$command -dc }.
 278                 qq{< "$file" | $tarcommand x${tar_verb}f -};
 279         } else {
 280             $system = qq{$tarcommand x${tar_verb}f "$file"};
 281         }
 282         if (system($system) != 0) {
 283             # people find the most curious tar binaries that cannot handle
 284             # pipes
 285             if ($is_compressed) {
 286                 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
 287                 $ungzf = basename $ungzf;
 288                 my $ct = CPAN::Tarzip->new($file);
 289                 if ($ct->gunzip($ungzf)) {
 290                     $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
 291                 } else {
 292                     $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
 293                 }
 294                 $file = $ungzf;
 295             }
 296             $system = qq{$tarcommand x${tar_verb}f "$file"};
 297             $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
 298             if (system($system)==0) {
 299                 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
 300             } else {
 301                 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
 302             }
 303             return 1;
 304         } else {
 305             return 1;
 306         }
 307     } elsif ($prefer==2) { # 2 => modules
 308         unless ($CPAN::META->has_usable("Archive::Tar")) {
 309             $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
 310         }
 311         # Make sure AT does not use permissions in the archive
 312         # This leaves it to the user's umask instead
 313         local $Archive::Tar::CHMOD = 0;
 314         my $tar = Archive::Tar->new($file,1);
 315         my $af; # archive file
 316         my @af;
 317         if ($BUGHUNTING) {
 318             # RCS 1.337 had this code, it turned out unacceptable slow but
 319             # it revealed a bug in Archive::Tar. Code is only here to hunt
 320             # the bug again. It should never be enabled in published code.
 321             # GDGraph3d-0.53 was an interesting case according to Larry
 322             # Virden.
 323             warn(">>>Bughunting code enabled<<< " x 20);
 324             for $af ($tar->list_files) {
 325                 if ($af =~ m!^(/|\.\./)!) {
 326                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
 327                                            "illegal member [$af]");
 328                 }
 329                 $CPAN::Frontend->myprint("$af\n");
 330                 $tar->extract($af); # slow but effective for finding the bug
 331                 return if $CPAN::Signal;
 332             }
 333         } else {
 334             for $af ($tar->list_files) {
 335                 if ($af =~ m!^(/|\.\./)!) {
 336                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
 337                                            "illegal member [$af]");
 338                 }
 339                 if ($tar_verb eq "v" || $tar_verb eq "vv") {
 340                     $CPAN::Frontend->myprint("$af\n");
 341                 }
 342                 push @af, $af;
 343                 return if $CPAN::Signal;
 344             }
 345             $tar->extract(@af) or
 346                 $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
 347         }
 348
 349         Mac::BuildTools::convert_files([$tar->list_files], 1)
 350             if ($^O eq 'MacOS');
 351
 352         return 1;
 353     }
 354 }
 355
 356 sub unzip {
 357     my($self) = @_;
 358     my $file = $self->{FILE};
 359     if ($CPAN::META->has_inst("Archive::Zip")) {
 360         # blueprint of the code from Archive::Zip::Tree::extractTree();
 361         my $zip = Archive::Zip->new();
 362         my $status;
 363         $status = $zip->read($file);
 364         $CPAN::Frontend->mydie("Read of file[$file] failed\n")
 365             if $status != Archive::Zip::AZ_OK();
 366         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
 367         my @members = $zip->members();
 368         for my $member ( @members ) {
 369             my $af = $member->fileName();
 370             if ($af =~ m!^(/|\.\./)!) {
 371                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
 372                                        "illegal member [$af]");
 373             }
 374             $status = $member->extractToFileNamed( $af );
 375             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
 376             $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
 377                 $status != Archive::Zip::AZ_OK();
 378             return if $CPAN::Signal;
 379         }
 380         return 1;
 381     } else {
 382         my $unzip = $CPAN::Config->{unzip} or
 383             $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
 384         my @system = ($unzip, $file);
 385         return system(@system) == 0;
 386     }
 387 }
 388
 389 1;
 390
 391 __END__
 392
 393 =head1 LICENSE
 394
 395 This program is free software; you can redistribute it and/or
 396 modify it under the same terms as Perl itself.
 397
 398 =cut