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.501";
   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 && $file =~ /\.bz2$/i) {
 230         # 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     } elsif ($exttar && $extgzip) {
 238         # no modules and not bz2
 239         $prefer = 1;
 240     } else {
 241         my $foundtar = $exttar ? "'$exttar'" : "nothing";
 242         my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
 243         my $foundAT;
 244         if ($CPAN::META->has_usable("Archive::Tar")) {
 245             $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
 246         } else {
 247             $foundAT = "nothing";
 248         }
 249         my $foundCZ;
 250         if ($CPAN::META->has_inst("Compress::Zlib")) {
 251             $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
 252         } elsif ($foundAT) {
 253             $foundCZ = "nothing";
 254         } else {
 255             $foundCZ = "also nothing";
 256         }
 257         $CPAN::Frontend->mydie(qq{
 258
 259 CPAN.pm needs either the external programs tar and gzip -or- both
 260 modules Archive::Tar and Compress::Zlib installed.
 261
 262 For tar I found $foundtar, for gzip $foundzip.
 263
 264 For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
 265
 266 Can't continue cutting file '$file'.
 267 });
 268     }
 269     my $tar_verb = "v";
 270     if (defined $CPAN::Config->{tar_verbosity}) {
 271         $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
 272             $CPAN::Config->{tar_verbosity};
 273     }
 274     if ($prefer==1) { # 1 => external gzip+tar
 275         my($system);
 276         my $is_compressed = $self->gtest();
 277         my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
 278         if ($is_compressed) {
 279             my $command = CPAN::HandleConfig->safe_quote($extgzip);
 280             $system = qq{$command -dc }.
 281                 qq{< "$file" | $tarcommand x${tar_verb}f -};
 282         } else {
 283             $system = qq{$tarcommand x${tar_verb}f "$file"};
 284         }
 285         if (system($system) != 0) {
 286             # people find the most curious tar binaries that cannot handle
 287             # pipes
 288             if ($is_compressed) {
 289                 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
 290                 $ungzf = basename $ungzf;
 291                 my $ct = CPAN::Tarzip->new($file);
 292                 if ($ct->gunzip($ungzf)) {
 293                     $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
 294                 } else {
 295                     $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
 296                 }
 297                 $file = $ungzf;
 298             }
 299             $system = qq{$tarcommand x${tar_verb}f "$file"};
 300             $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
 301             if (system($system)==0) {
 302                 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
 303             } else {
 304                 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
 305             }
 306             return 1;
 307         } else {
 308             return 1;
 309         }
 310     } elsif ($prefer==2) { # 2 => modules
 311         unless ($CPAN::META->has_usable("Archive::Tar")) {
 312             $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
 313         }
 314         # Make sure AT does not use uid/gid/permissions in the archive
 315         # This leaves it to the user's umask instead
 316         local $Archive::Tar::CHMOD = 1;
 317         local $Archive::Tar::SAME_PERMISSIONS = 0;
 318         # Make sure AT leaves current user as owner
 319         local $Archive::Tar::CHOWN = 0;
 320         my $tar = Archive::Tar->new($file,1);
 321         my $af; # archive file
 322         my @af;
 323         if ($BUGHUNTING) {
 324             # RCS 1.337 had this code, it turned out unacceptable slow but
 325             # it revealed a bug in Archive::Tar. Code is only here to hunt
 326             # the bug again. It should never be enabled in published code.
 327             # GDGraph3d-0.53 was an interesting case according to Larry
 328             # Virden.
 329             warn(">>>Bughunting code enabled<<< " x 20);
 330             for $af ($tar->list_files) {
 331                 if ($af =~ m!^(/|\.\./)!) {
 332                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
 333                                            "illegal member [$af]");
 334                 }
 335                 $CPAN::Frontend->myprint("$af\n");
 336                 $tar->extract($af); # slow but effective for finding the bug
 337                 return if $CPAN::Signal;
 338             }
 339         } else {
 340             for $af ($tar->list_files) {
 341                 if ($af =~ m!^(/|\.\./)!) {
 342                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
 343                                            "illegal member [$af]");
 344                 }
 345                 if ($tar_verb eq "v" || $tar_verb eq "vv") {
 346                     $CPAN::Frontend->myprint("$af\n");
 347                 }
 348                 push @af, $af;
 349                 return if $CPAN::Signal;
 350             }
 351             $tar->extract(@af) or
 352                 $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
 353         }
 354
 355         Mac::BuildTools::convert_files([$tar->list_files], 1)
 356             if ($^O eq 'MacOS');
 357
 358         return 1;
 359     }
 360 }
 361
 362 sub unzip {
 363     my($self) = @_;
 364     my $file = $self->{FILE};
 365     if ($CPAN::META->has_inst("Archive::Zip")) {
 366         # blueprint of the code from Archive::Zip::Tree::extractTree();
 367         my $zip = Archive::Zip->new();
 368         my $status;
 369         $status = $zip->read($file);
 370         $CPAN::Frontend->mydie("Read of file[$file] failed\n")
 371             if $status != Archive::Zip::AZ_OK();
 372         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
 373         my @members = $zip->members();
 374         for my $member ( @members ) {
 375             my $af = $member->fileName();
 376             if ($af =~ m!^(/|\.\./)!) {
 377                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
 378                                        "illegal member [$af]");
 379             }
 380             $status = $member->extractToFileNamed( $af );
 381             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
 382             $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
 383                 $status != Archive::Zip::AZ_OK();
 384             return if $CPAN::Signal;
 385         }
 386         return 1;
 387     } else {
 388         my $unzip = $CPAN::Config->{unzip} or
 389             $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
 390         my @system = ($unzip, $file);
 391         return system(@system) == 0;
 392     }
 393 }
 394
 395 1;
 396
 397 __END__
 398
 399 =head1 LICENSE
 400
 401 This program is free software; you can redistribute it and/or
 402 modify it under the same terms as Perl itself.
 403
 404 =cut