Initial Commit
This commit is contained in:
Riley Schneider
479
database/perl/lib/CPAN/Tarzip.pm
Normal file
479
database/perl/lib/CPAN/Tarzip.pm
Normal file
@@ -0,0 +1,479 @@
|
||||
# -*- 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.5013";
|
||||
# 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;
|
||||
my $me = { FILE => $file };
|
||||
if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
|
||||
$me->{ISCOMPRESSED} = 1;
|
||||
} else {
|
||||
$me->{ISCOMPRESSED} = 0;
|
||||
}
|
||||
if (0) {
|
||||
} elsif ($file =~ /\.(?:bz2|tbz)$/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 bzip2' from the
|
||||
CPAN shell prompt to register it as external program.
|
||||
});
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$me->{UNGZIPPRG} = _my_which("gzip");
|
||||
}
|
||||
$me->{TARPRG} = _my_which("tar") || _my_which("gtar");
|
||||
bless $me, $class;
|
||||
}
|
||||
|
||||
sub _zlib_ok () {
|
||||
$CPAN::META->has_inst("Compress::Zlib") or return;
|
||||
Compress::Zlib->can('gzopen');
|
||||
}
|
||||
|
||||
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 (_zlib_ok) {
|
||||
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");
|
||||
binmode($fhw);
|
||||
$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 (_zlib_ok) {
|
||||
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");
|
||||
binmode($fhw);
|
||||
$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 -d -c "$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;
|
||||
if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
|
||||
my($buffer,$len);
|
||||
$len = 0;
|
||||
my $gz = Compress::Bzip2::bzopen($read, "rb")
|
||||
or $CPAN::Frontend->mydie(sprintf("Cannot bzopen %s: %s\n",
|
||||
$read,
|
||||
$Compress::Bzip2::bzerrno));
|
||||
while ($gz->bzread($buffer) > 0 ) {
|
||||
$len += length($buffer);
|
||||
$buffer = "";
|
||||
}
|
||||
my $err = $gz->bzerror;
|
||||
$success = ! $err || $err == Compress::Bzip2::BZ_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;
|
||||
} elsif ( $read=~/\.(?:gz|tgz)$/ && _zlib_ok ) {
|
||||
# After I had reread the documentation in zlib.h, I discovered that
|
||||
# uncompressed files do not lead to an gzerror (anymore?).
|
||||
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;
|
||||
} elsif (!$self->{ISCOMPRESSED}) {
|
||||
$success = 0;
|
||||
} 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 ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
|
||||
my $gz = Compress::Bzip2::bzopen($file,"rb") or
|
||||
$CPAN::Frontend->mydie("Could not bzopen $file");
|
||||
$self->{GZ} = $gz;
|
||||
$class->debug("via Compress::Bzip2");
|
||||
} elsif ($file =~/\.(?:gz|tgz)$/ && _zlib_ok) {
|
||||
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 -d -c $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 ($CPAN::Config->{prefer_external_tar}) {
|
||||
$prefer = 1;
|
||||
} elsif (
|
||||
$CPAN::META->has_usable("Archive::Tar")
|
||||
&&
|
||||
_zlib_ok ) {
|
||||
my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
|
||||
unless (defined $prefer_external_tar) {
|
||||
if ($^O =~ /(MSWin32|solaris)/) {
|
||||
$prefer_external_tar = 0;
|
||||
} else {
|
||||
$prefer_external_tar = 1;
|
||||
}
|
||||
}
|
||||
$prefer = $prefer_external_tar ? 1 : 2;
|
||||
} elsif ($exttar && $extgzip) {
|
||||
# no modules and not bz2
|
||||
$prefer = 1;
|
||||
# but solaris binary tar is a problem
|
||||
if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
|
||||
$CPAN::Frontend->mywarn(<< 'END_WARN');
|
||||
|
||||
WARNING: Many CPAN distributions were archived with GNU tar and some of
|
||||
them may be incompatible with Solaris tar. We respectfully suggest you
|
||||
configure CPAN to use a GNU tar instead ("o conf init tar") or install
|
||||
a recent Archive::Tar instead;
|
||||
|
||||
END_WARN
|
||||
}
|
||||
} 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 (_zlib_ok) {
|
||||
$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 -d -c }.
|
||||
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});
|
||||
my $ret = system($system);
|
||||
if ($ret==0) {
|
||||
$CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
|
||||
} else {
|
||||
if ($? == -1) {
|
||||
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: '%s'\n},
|
||||
$file, $!);
|
||||
} elsif ($? & 127) {
|
||||
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child died with signal %d, %s coredump\n},
|
||||
$file, ($? & 127), ($? & 128) ? 'with' : 'without');
|
||||
} else {
|
||||
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child exited with value %d\n},
|
||||
$file, $? >> 8);
|
||||
}
|
||||
}
|
||||
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;
|
||||
} elsif ( my $unzip = $CPAN::Config->{unzip} ) {
|
||||
my @system = ($unzip, $file);
|
||||
return system(@system) == 0;
|
||||
}
|
||||
else {
|
||||
$CPAN::Frontend->mydie(<<"END");
|
||||
|
||||
Can't unzip '$file':
|
||||
|
||||
You have not configured an 'unzip' program and do not have Archive::Zip
|
||||
installed. Please either install Archive::Zip or else configure 'unzip'
|
||||
by running the command 'o conf init unzip' from the CPAN shell prompt.
|
||||
|
||||
END
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPAN::Tarzip - internal handling of tar archives for CPAN.pm
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user