From 661c41a09e39a182865e0b51e34cc995a0dc96e8 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Wed, 12 May 2010 16:54:37 +0000 Subject: move tlperl.straw to tlperl git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm | 442 +++++++++++++++++++++++++++++++++ 1 file changed, 442 insertions(+) create mode 100755 Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm (limited to 'Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm') diff --git a/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm b/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm new file mode 100755 index 00000000000..b97bd200164 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm @@ -0,0 +1,442 @@ +# -*- 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 -- cgit v1.2.3