diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (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-x | Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm | 442 |
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 |