# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Tarzip;
use strict;
use vars qw($VERSION @ISA $BUGHUNTING);
use CPAN::Debug;
use File::Basename qw(basename);
$VERSION = "5.501";
# module is internal to CPAN.pm
@ISA = qw(CPAN::Debug); ## no critic
$BUGHUNTING ||= 0; # released code must have turned off
# it's ok if file doesn't exist, it just matters if it is .gz or .bz2
sub new {
my($class,$file) = @_;
$CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
if (0) {
# nonono, we get e.g. 01mailrc.txt uncompressed if only wget is available
$CPAN::Frontend->mydie("file[$file] doesn't match /\\.(bz2|gz|zip|tgz)\$/")
unless $file =~ /\.(bz2|gz|zip|tgz)$/i;
}
my $me = { FILE => $file };
if (0) {
} elsif ($file =~ /\.bz2$/i) {
unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
my $bzip2 = _my_which("bzip2");
if ($bzip2) {
$me->{UNGZIPPRG} = $bzip2;
} else {
$CPAN::Frontend->mydie(qq{
CPAN.pm needs the external program bzip2 in order to handle '$file'.
Please install it now and run 'o conf init' to register it as external
program.
});
}
}
} else {
$me->{UNGZIPPRG} = _my_which("gzip");
}
$me->{TARPRG} = _my_which("tar") || _my_which("gtar");
bless $me, $class;
}
sub _my_which {
my($what) = @_;
if ($CPAN::Config->{$what}) {
return $CPAN::Config->{$what};
}
if ($CPAN::META->has_inst("File::Which")) {
return File::Which::which($what);
}
my @cand = MM->maybe_command($what);
return $cand[0] if @cand;
require File::Spec;
my $component;
PATH_COMPONENT: foreach $component (File::Spec->path()) {
next unless defined($component) && $component;
my($abs) = File::Spec->catfile($component,$what);
if (MM->maybe_command($abs)) {
return $abs;
}
}
return;
}
sub gzip {
my($self,$read) = @_;
my $write = $self->{FILE};
if ($CPAN::META->has_inst("Compress::Zlib")) {
my($buffer,$fhw);
$fhw = FileHandle->new($read)
or $CPAN::Frontend->mydie("Could not open $read: $!");
my $cwd = `pwd`;
my $gz = Compress::Zlib::gzopen($write, "wb")
or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
$gz->gzwrite($buffer)
while read($fhw,$buffer,4096) > 0 ;
$gz->gzclose() ;
$fhw->close;
return 1;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
system(qq{$command -c "$read" > "$write"})==0;
}
}
sub gunzip {
my($self,$write) = @_;
my $read = $self->{FILE};
if ($CPAN::META->has_inst("Compress::Zlib")) {
my($buffer,$fhw);
$fhw = FileHandle->new(">$write")
or $CPAN::Frontend->mydie("Could not open >$write: $!");
my $gz = Compress::Zlib::gzopen($read, "rb")
or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
$fhw->print($buffer)
while $gz->gzread($buffer) > 0 ;
$CPAN::Frontend->mydie("Error reading from $read: $!\n")
if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
$gz->gzclose() ;
$fhw->close;
return 1;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
system(qq{$command -dc "$read" > "$write"})==0;
}
}
sub gtest {
my($self) = @_;
return $self->{GTEST} if exists $self->{GTEST};
defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
my $read = $self->{FILE};
my $success;
# After I had reread the documentation in zlib.h, I discovered that
# uncompressed files do not lead to an gzerror (anymore?).
if ( $CPAN::META->has_inst("Compress::Zlib") ) {
my($buffer,$len);
$len = 0;
my $gz = Compress::Zlib::gzopen($read, "rb")
or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
$read,
$Compress::Zlib::gzerrno));
while ($gz->gzread($buffer) > 0 ) {
$len += length($buffer);
$buffer = "";
}
my $err = $gz->gzerror;
$success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
if ($len == -s $read) {
$success = 0;
CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
}
$gz->gzclose();
CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
$success = 0==system(qq{$command -qdt "$read"});
}
return $self->{GTEST} = $success;
}
sub TIEHANDLE {
my($class,$file) = @_;
my $ret;
$class->debug("file[$file]");
my $self = $class->new($file);
if (0) {
} elsif (!$self->gtest) {
my $fh = FileHandle->new($file)
or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
binmode $fh;
$self->{FH} = $fh;
$class->debug("via uncompressed FH");
} elsif ($CPAN::META->has_inst("Compress::Zlib")) {
my $gz = Compress::Zlib::gzopen($file,"rb") or
$CPAN::Frontend->mydie("Could not gzopen $file");
$self->{GZ} = $gz;
$class->debug("via Compress::Zlib");
} else {
my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
my $pipe = "$gzip -dc $file |";
my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
binmode $fh;
$self->{FH} = $fh;
$class->debug("via external gzip");
}
$self;
}
sub READLINE {
my($self) = @_;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
my($line,$bytesread);
$bytesread = $gz->gzreadline($line);
return undef if $bytesread <= 0;
return $line;
} else {
my $fh = $self->{FH};
return scalar <$fh>;
}
}
sub READ {
my($self,$ref,$length,$offset) = @_;
$CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
return $byteread;
} else {
my $fh = $self->{FH};
return read($fh,$$ref,$length);
}
}
sub DESTROY {
my($self) = @_;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
$gz->gzclose() if defined $gz; # hard to say if it is allowed
# to be undef ever. AK, 2000-09
} else {
my $fh = $self->{FH};
$fh->close if defined $fh;
}
undef $self;
}
sub untar {
my($self) = @_;
my $file = $self->{FILE};
my($prefer) = 0;
my $exttar = $self->{TARPRG} || "";
$exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
my $extgzip = $self->{UNGZIPPRG} || "";
$extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
if (0) { # makes changing order easier
} elsif ($BUGHUNTING) {
$prefer=2;
} elsif ($exttar && $extgzip && $file =~ /\.bz2$/i) {
# until Archive::Tar handles bzip2
$prefer = 1;
} elsif (
$CPAN::META->has_usable("Archive::Tar")
&&
$CPAN::META->has_inst("Compress::Zlib") ) {
$prefer = 2;
} elsif ($exttar && $extgzip) {
# no modules and not bz2
$prefer = 1;
} else {
my $foundtar = $exttar ? "'$exttar'" : "nothing";
my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
my $foundAT;
if ($CPAN::META->has_usable("Archive::Tar")) {
$foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
} else {
$foundAT = "nothing";
}
my $foundCZ;
if ($CPAN::META->has_inst("Compress::Zlib")) {
$foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
} elsif ($foundAT) {
$foundCZ = "nothing";
} else {
$foundCZ = "also nothing";
}
$CPAN::Frontend->mydie(qq{
CPAN.pm needs either the external programs tar and gzip -or- both
modules Archive::Tar and Compress::Zlib installed.
For tar I found $foundtar, for gzip $foundzip.
For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
Can't continue cutting file '$file'.
});
}
my $tar_verb = "v";
if (defined $CPAN::Config->{tar_verbosity}) {
$tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
$CPAN::Config->{tar_verbosity};
}
if ($prefer==1) { # 1 => external gzip+tar
my($system);
my $is_compressed = $self->gtest();
my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
if ($is_compressed) {
my $command = CPAN::HandleConfig->safe_quote($extgzip);
$system = qq{$command -dc }.
qq{< "$file" | $tarcommand x${tar_verb}f -};
} else {
$system = qq{$tarcommand x${tar_verb}f "$file"};
}
if (system($system) != 0) {
# people find the most curious tar binaries that cannot handle
# pipes
if ($is_compressed) {
(my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
$ungzf = basename $ungzf;
my $ct = CPAN::Tarzip->new($file);
if ($ct->gunzip($ungzf)) {
$CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
} else {
$CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
}
$file = $ungzf;
}
$system = qq{$tarcommand x${tar_verb}f "$file"};
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
if (system($system)==0) {
$CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
} else {
$CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
}
return 1;
} else {
return 1;
}
} elsif ($prefer==2) { # 2 => modules
unless ($CPAN::META->has_usable("Archive::Tar")) {
$CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
}
# Make sure AT does not use uid/gid/permissions in the archive
# This leaves it to the user's umask instead
local $Archive::Tar::CHMOD = 1;
local $Archive::Tar::SAME_PERMISSIONS = 0;
# Make sure AT leaves current user as owner
local $Archive::Tar::CHOWN = 0;
my $tar = Archive::Tar->new($file,1);
my $af; # archive file
my @af;
if ($BUGHUNTING) {
# RCS 1.337 had this code, it turned out unacceptable slow but
# it revealed a bug in Archive::Tar. Code is only here to hunt
# the bug again. It should never be enabled in published code.
# GDGraph3d-0.53 was an interesting case according to Larry
# Virden.
warn(">>>Bughunting code enabled<<< " x 20);
for $af ($tar->list_files) {
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
$CPAN::Frontend->myprint("$af\n");
$tar->extract($af); # slow but effective for finding the bug
return if $CPAN::Signal;
}
} else {
for $af ($tar->list_files) {
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
if ($tar_verb eq "v" || $tar_verb eq "vv") {
$CPAN::Frontend->myprint("$af\n");
}
push @af, $af;
return if $CPAN::Signal;
}
$tar->extract(@af) or
$CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
}
Mac::BuildTools::convert_files([$tar->list_files], 1)
if ($^O eq 'MacOS');
return 1;
}
}
sub unzip {
my($self) = @_;
my $file = $self->{FILE};
if ($CPAN::META->has_inst("Archive::Zip")) {
# blueprint of the code from Archive::Zip::Tree::extractTree();
my $zip = Archive::Zip->new();
my $status;
$status = $zip->read($file);
$CPAN::Frontend->mydie("Read of file[$file] failed\n")
if $status != Archive::Zip::AZ_OK();
$CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
my @members = $zip->members();
for my $member ( @members ) {
my $af = $member->fileName();
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
$status = $member->extractToFileNamed( $af );
$CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
$CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
$status != Archive::Zip::AZ_OK();
return if $CPAN::Signal;
}
return 1;
} else {
my $unzip = $CPAN::Config->{unzip} or
$CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
my @system = ($unzip, $file);
return system(@system) == 0;
}
}
1;
__END__
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut