cpan/CPAN/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     my $me = { FILE => $file };
  18     if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
  19         $me->{ISCOMPRESSED} = 1;
  20     } else {
  21         $me->{ISCOMPRESSED} = 0;
  22     }
  23     if (0) {
  24     } elsif ($file =~ /\.(?:bz2|tbz)$/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     if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
 118         my($buffer,$len);
 119         $len = 0;
 120         my $gz = Compress::Bzip2::bzopen($read, "rb")
 121             or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
 122                                               $read,
 123                                               $Compress::Bzip2::bzerrno));
 124         while ($gz->bzread($buffer) > 0 ) {
 125             $len += length($buffer);
 126             $buffer = "";
 127         }
 128         my $err = $gz->bzerror;
 129         $success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END();
 130         if ($len == -s $read) {
 131             $success = 0;
 132             CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
 133         }
 134         $gz->gzclose();
 135         CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
 136     } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) {
 137         # After I had reread the documentation in zlib.h, I discovered that
 138         # uncompressed files do not lead to an gzerror (anymore?).
 139         my($buffer,$len);
 140         $len = 0;
 141         my $gz = Compress::Zlib::gzopen($read, "rb")
 142             or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
 143                                               $read,
 144                                               $Compress::Zlib::gzerrno));
 145         while ($gz->gzread($buffer) > 0 ) {
 146             $len += length($buffer);
 147             $buffer = "";
 148         }
 149         my $err = $gz->gzerror;
 150         $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
 151         if ($len == -s $read) {
 152             $success = 0;
 153             CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
 154         }
 155         $gz->gzclose();
 156         CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
 157     } elsif (!$self->{ISCOMPRESSED}) {
 158         $success = 0;
 159     } else {
 160         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 161         $success = 0==system(qq{$command -qdt "$read"});
 162     }
 163     return $self->{GTEST} = $success;
 164 }
 165
 166
 167 sub TIEHANDLE {
 168     my($class,$file) = @_;
 169     my $ret;
 170     $class->debug("file[$file]");
 171     my $self = $class->new($file);
 172     if (0) {
 173     } elsif (!$self->gtest) {
 174         my $fh = FileHandle->new($file)
 175             or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
 176         binmode $fh;
 177         $self->{FH} = $fh;
 178         $class->debug("via uncompressed FH");
 179     } elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
 180         my $gz = Compress::Bzip2::bzopen($file,"rb") or
 181             $CPAN::Frontend->mydie("Could not bzopen $file");
 182         $self->{GZ} = $gz;
 183         $class->debug("via Compress::Bzip2");
 184     } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) {
 185         my $gz = Compress::Zlib::gzopen($file,"rb") or
 186             $CPAN::Frontend->mydie("Could not gzopen $file");
 187         $self->{GZ} = $gz;
 188         $class->debug("via Compress::Zlib");
 189     } else {
 190         my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
 191         my $pipe = "$gzip -dc $file |";
 192         my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
 193         binmode $fh;
 194         $self->{FH} = $fh;
 195         $class->debug("via external $gzip");
 196     }
 197     $self;
 198 }
 199
 200
 201 sub READLINE {
 202     my($self) = @_;
 203     if (exists $self->{GZ}) {
 204         my $gz = $self->{GZ};
 205         my($line,$bytesread);
 206         $bytesread = $gz->gzreadline($line);
 207         return undef if $bytesread <= 0;
 208         return $line;
 209     } else {
 210         my $fh = $self->{FH};
 211         return scalar <$fh>;
 212     }
 213 }
 214
 215
 216 sub READ {
 217     my($self,$ref,$length,$offset) = @_;
 218     $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
 219     if (exists $self->{GZ}) {
 220         my $gz = $self->{GZ};
 221         my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
 222         return $byteread;
 223     } else {
 224         my $fh = $self->{FH};
 225         return read($fh,$$ref,$length);
 226     }
 227 }
 228
 229
 230 sub DESTROY {
 231     my($self) = @_;
 232     if (exists $self->{GZ}) {
 233         my $gz = $self->{GZ};
 234         $gz->gzclose() if defined $gz; # hard to say if it is allowed
 235                                        # to be undef ever. AK, 2000-09
 236     } else {
 237         my $fh = $self->{FH};
 238         $fh->close if defined $fh;
 239     }
 240     undef $self;
 241 }
 242
 243 sub untar {
 244     my($self) = @_;
 245     my $file = $self->{FILE};
 246     my($prefer) = 0;
 247
 248     my $exttar = $self->{TARPRG} || "";
 249     $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
 250     my $extgzip = $self->{UNGZIPPRG} || "";
 251     $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
 252
 253     if (0) { # makes changing order easier
 254     } elsif ($BUGHUNTING) {
 255         $prefer=2;
 256     } elsif ($exttar && $extgzip && $file =~ /\.(?:bz2|tbz)$/i) {
 257         # until Archive::Tar handles bzip2
 258         $prefer = 1;
 259     } elsif (
 260              $CPAN::META->has_usable("Archive::Tar")
 261              &&
 262              $CPAN::META->has_inst("Compress::Zlib") ) {
 263         $prefer = 2;
 264     } elsif ($exttar && $extgzip) {
 265         # no modules and not bz2
 266         $prefer = 1;
 267         # but solaris binary tar is a problem
 268         if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
 269             $CPAN::Frontend->mywarn(<< 'END_WARN');
 270
 271 WARNING: Many CPAN distributions were archived with GNU tar and some of
 272 them may be incompatible with Solaris tar.  We respectfully suggest you
 273 configure CPAN to use a GNU tar instead ("o conf init tar") or install
 274 a recent Archive::Tar instead;
 275
 276 END_WARN
 277         }
 278     } else {
 279         my $foundtar = $exttar ? "'$exttar'" : "nothing";
 280         my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
 281         my $foundAT;
 282         if ($CPAN::META->has_usable("Archive::Tar")) {
 283             $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
 284         } else {
 285             $foundAT = "nothing";
 286         }
 287         my $foundCZ;
 288         if ($CPAN::META->has_inst("Compress::Zlib")) {
 289             $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
 290         } elsif ($foundAT) {
 291             $foundCZ = "nothing";
 292         } else {
 293             $foundCZ = "also nothing";
 294         }
 295         $CPAN::Frontend->mydie(qq{
 296
 297 CPAN.pm needs either the external programs tar and gzip -or- both
 298 modules Archive::Tar and Compress::Zlib installed.
 299
 300 For tar I found $foundtar, for gzip $foundzip.
 301
 302 For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
 303
 304 Can't continue cutting file '$file'.
 305 });
 306     }
 307     my $tar_verb = "v";
 308     if (defined $CPAN::Config->{tar_verbosity}) {
 309         $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
 310             $CPAN::Config->{tar_verbosity};
 311     }
 312     if ($prefer==1) { # 1 => external gzip+tar
 313         my($system);
 314         my $is_compressed = $self->gtest();
 315         my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
 316         if ($is_compressed) {
 317             my $command = CPAN::HandleConfig->safe_quote($extgzip);
 318             $system = qq{$command -dc }.
 319                 qq{< "$file" | $tarcommand x${tar_verb}f -};
 320         } else {
 321             $system = qq{$tarcommand x${tar_verb}f "$file"};
 322         }
 323         if (system($system) != 0) {
 324             # people find the most curious tar binaries that cannot handle
 325             # pipes
 326             if ($is_compressed) {
 327                 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
 328                 $ungzf = basename $ungzf;
 329                 my $ct = CPAN::Tarzip->new($file);
 330                 if ($ct->gunzip($ungzf)) {
 331                     $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
 332                 } else {
 333                     $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
 334                 }
 335                 $file = $ungzf;
 336             }
 337             $system = qq{$tarcommand x${tar_verb}f "$file"};
 338             $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
 339             if (system($system)==0) {
 340                 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
 341             } else {
 342                 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
 343             }
 344             return 1;
 345         } else {
 346             return 1;
 347         }
 348     } elsif ($prefer==2) { # 2 => modules
 349         unless ($CPAN::META->has_usable("Archive::Tar")) {
 350             $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
 351         }
 352         # Make sure AT does not use uid/gid/permissions in the archive
 353         # This leaves it to the user's umask instead
 354         local $Archive::Tar::CHMOD = 1;
 355         local $Archive::Tar::SAME_PERMISSIONS = 0;
 356         # Make sure AT leaves current user as owner
 357         local $Archive::Tar::CHOWN = 0;
 358         my $tar = Archive::Tar->new($file,1);
 359         my $af; # archive file
 360         my @af;
 361         if ($BUGHUNTING) {
 362             # RCS 1.337 had this code, it turned out unacceptable slow but
 363             # it revealed a bug in Archive::Tar. Code is only here to hunt
 364             # the bug again. It should never be enabled in published code.
 365             # GDGraph3d-0.53 was an interesting case according to Larry
 366             # Virden.
 367             warn(">>>Bughunting code enabled<<< " x 20);
 368             for $af ($tar->list_files) {
 369                 if ($af =~ m!^(/|\.\./)!) {
 370                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
 371                                            "illegal member [$af]");
 372                 }
 373                 $CPAN::Frontend->myprint("$af\n");
 374                 $tar->extract($af); # slow but effective for finding the bug
 375                 return if $CPAN::Signal;
 376             }
 377         } else {
 378             for $af ($tar->list_files) {
 379                 if ($af =~ m!^(/|\.\./)!) {
 380                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
 381                                            "illegal member [$af]");
 382                 }
 383                 if ($tar_verb eq "v" || $tar_verb eq "vv") {
 384                     $CPAN::Frontend->myprint("$af\n");
 385                 }
 386                 push @af, $af;
 387                 return if $CPAN::Signal;
 388             }
 389             $tar->extract(@af) or
 390                 $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
 391         }
 392
 393         Mac::BuildTools::convert_files([$tar->list_files], 1)
 394             if ($^O eq 'MacOS');
 395
 396         return 1;
 397     }
 398 }
 399
 400 sub unzip {
 401     my($self) = @_;
 402     my $file = $self->{FILE};
 403     if ($CPAN::META->has_inst("Archive::Zip")) {
 404         # blueprint of the code from Archive::Zip::Tree::extractTree();
 405         my $zip = Archive::Zip->new();
 406         my $status;
 407         $status = $zip->read($file);
 408         $CPAN::Frontend->mydie("Read of file[$file] failed\n")
 409             if $status != Archive::Zip::AZ_OK();
 410         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
 411         my @members = $zip->members();
 412         for my $member ( @members ) {
 413             my $af = $member->fileName();
 414             if ($af =~ m!^(/|\.\./)!) {
 415                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
 416                                        "illegal member [$af]");
 417             }
 418             $status = $member->extractToFileNamed( $af );
 419             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
 420             $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
 421                 $status != Archive::Zip::AZ_OK();
 422             return if $CPAN::Signal;
 423         }
 424         return 1;
 425     } else {
 426         my $unzip = $CPAN::Config->{unzip} or
 427             $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
 428         my @system = ($unzip, $file);
 429         return system(@system) == 0;
 430     }
 431 }
 432
 433 1;
 434
 435 __END__
 436
 437 =head1 LICENSE
 438
 439 This program is free software; you can redistribute it and/or
 440 modify it under the same terms as Perl itself.
 441
 442 =cut