summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Tarzip.pm442
1 files changed, 0 insertions, 442 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm b/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
deleted file mode 100755
index b97bd200164..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
+++ /dev/null
@@ -1,442 +0,0 @@
-# -*- 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;
- 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' 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;
- 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 gzopen %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)$/ && $CPAN::META->has_inst("Compress::Zlib") ) {
- # 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)$/ && $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|tbz)$/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;
- # 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 ($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