home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPAN / Tarzip.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  11.9 KB  |  353 lines
  1. # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
  2. package CPAN::Tarzip;
  3. use strict;
  4. use vars qw($VERSION @ISA $BUGHUNTING);
  5. use CPAN::Debug;
  6. use File::Basename ();
  7. $VERSION = sprintf "%.6f", substr(q$Rev: 2213 $,4)/1000000 + 5.4;
  8. # module is internal to CPAN.pm
  9.  
  10. @ISA = qw(CPAN::Debug);
  11. $BUGHUNTING ||= 0; # released code must have turned off
  12.  
  13. # it's ok if file doesn't exist, it just matters if it is .gz or .bz2
  14. sub new {
  15.     my($class,$file) = @_;
  16.     $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
  17.     if (0) {
  18.         # nonono, we get e.g. 01mailrc.txt uncompressed if only wget is available
  19.         $CPAN::Frontend->mydie("file[$file] doesn't match /\\.(bz2|gz|zip|tgz)\$/")
  20.             unless $file =~ /\.(bz2|gz|zip|tgz)$/i;
  21.     }
  22.     my $me = { FILE => $file };
  23.     if (0) {
  24.     } elsif ($file =~ /\.bz2$/i) {
  25.         unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
  26.             my $bzip2;
  27.             if ($CPAN::META->has_inst("File::Which")) {
  28.                 $bzip2 = File::Which::which("bzip2");
  29.             }
  30.             if ($bzip2) {
  31.                 $me->{UNGZIPPRG} = $bzip2 || "bzip2";
  32.             } else {
  33.                 $CPAN::Frontend->mydie(qq{
  34. CPAN.pm needs the external program bzip2 in order to handle '$file'.
  35. Please install it now and run 'o conf init' to register it as external
  36. program.
  37. });
  38.             }
  39.         }
  40.     } else {
  41.         # yes, we let gzip figure it out in *any* other case
  42.         $me->{UNGZIPPRG} = $CPAN::Config->{gzip} || "gzip";
  43.     }
  44.     bless $me, $class;
  45. }
  46.  
  47. sub gzip {
  48.     my($self,$read) = @_;
  49.     my $write = $self->{FILE};
  50.     if ($CPAN::META->has_inst("Compress::Zlib")) {
  51.         my($buffer,$fhw);
  52.         $fhw = FileHandle->new($read)
  53.             or $CPAN::Frontend->mydie("Could not open $read: $!");
  54.         my $cwd = `pwd`;
  55.         my $gz = Compress::Zlib::gzopen($write, "wb")
  56.             or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
  57.         $gz->gzwrite($buffer)
  58.             while read($fhw,$buffer,4096) > 0 ;
  59.         $gz->gzclose() ;
  60.         $fhw->close;
  61.         return 1;
  62.     } else {
  63.         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  64.         system(qq{$command -c "$read" > "$write"})==0;
  65.     }
  66. }
  67.  
  68.  
  69. sub gunzip {
  70.     my($self,$write) = @_;
  71.     my $read = $self->{FILE};
  72.     if ($CPAN::META->has_inst("Compress::Zlib")) {
  73.         my($buffer,$fhw);
  74.         $fhw = FileHandle->new(">$write")
  75.             or $CPAN::Frontend->mydie("Could not open >$write: $!");
  76.         my $gz = Compress::Zlib::gzopen($read, "rb")
  77.             or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
  78.         $fhw->print($buffer)
  79.         while $gz->gzread($buffer) > 0 ;
  80.         $CPAN::Frontend->mydie("Error reading from $read: $!\n")
  81.             if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
  82.         $gz->gzclose() ;
  83.         $fhw->close;
  84.         return 1;
  85.     } else {
  86.         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  87.         system(qq{$command -dc "$read" > "$write"})==0;
  88.     }
  89. }
  90.  
  91.  
  92. sub gtest {
  93.     my($self) = @_;
  94.     return $self->{GTEST} if exists $self->{GTEST};
  95.     defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
  96.     my $read = $self->{FILE};
  97.     my $success;
  98.     # After I had reread the documentation in zlib.h, I discovered that
  99.     # uncompressed files do not lead to an gzerror (anymore?).
  100.     if ( $CPAN::META->has_inst("Compress::Zlib") ) {
  101.         my($buffer,$len);
  102.         $len = 0;
  103.         my $gz = Compress::Zlib::gzopen($read, "rb")
  104.             or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
  105.                                               $read,
  106.                                               $Compress::Zlib::gzerrno));
  107.         while ($gz->gzread($buffer) > 0 ) {
  108.             $len += length($buffer);
  109.             $buffer = "";
  110.         }
  111.         my $err = $gz->gzerror;
  112.         $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
  113.         if ($len == -s $read) {
  114.             $success = 0;
  115.             CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
  116.         }
  117.         $gz->gzclose();
  118.         CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
  119.     } else {
  120.         my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  121.         $success = 0==system(qq{$command -qdt "$read"});
  122.     }
  123.     return $self->{GTEST} = $success;
  124. }
  125.  
  126.  
  127. sub TIEHANDLE {
  128.     my($class,$file) = @_;
  129.     my $ret;
  130.     $class->debug("file[$file]");
  131.     my $self = $class->new($file);
  132.     if (0) {
  133.     } elsif (!$self->gtest) {
  134.         my $fh = FileHandle->new($file)
  135.             or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
  136.         binmode $fh;
  137.         $self->{FH} = $fh;
  138.         $class->debug("via uncompressed FH");
  139.     } elsif ($CPAN::META->has_inst("Compress::Zlib")) {
  140.         my $gz = Compress::Zlib::gzopen($file,"rb") or
  141.             $CPAN::Frontend->mydie("Could not gzopen $file");
  142.         $self->{GZ} = $gz;
  143.         $class->debug("via Compress::Zlib");
  144.     } else {
  145.         my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  146.         my $pipe = "$gzip -dc $file |";
  147.         my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
  148.         binmode $fh;
  149.         $self->{FH} = $fh;
  150.         $class->debug("via external gzip");
  151.     }
  152.     $self;
  153. }
  154.  
  155.  
  156. sub READLINE {
  157.     my($self) = @_;
  158.     if (exists $self->{GZ}) {
  159.         my $gz = $self->{GZ};
  160.         my($line,$bytesread);
  161.         $bytesread = $gz->gzreadline($line);
  162.         return undef if $bytesread <= 0;
  163.         return $line;
  164.     } else {
  165.         my $fh = $self->{FH};
  166.         return scalar <$fh>;
  167.     }
  168. }
  169.  
  170.  
  171. sub READ {
  172.     my($self,$ref,$length,$offset) = @_;
  173.     $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
  174.     if (exists $self->{GZ}) {
  175.         my $gz = $self->{GZ};
  176.         my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
  177.         return $byteread;
  178.     } else {
  179.         my $fh = $self->{FH};
  180.         return read($fh,$$ref,$length);
  181.     }
  182. }
  183.  
  184.  
  185. sub DESTROY {
  186.     my($self) = @_;
  187.     if (exists $self->{GZ}) {
  188.         my $gz = $self->{GZ};
  189.         $gz->gzclose() if defined $gz; # hard to say if it is allowed
  190.                                        # to be undef ever. AK, 2000-09
  191.     } else {
  192.         my $fh = $self->{FH};
  193.         $fh->close if defined $fh;
  194.     }
  195.     undef $self;
  196. }
  197.  
  198.  
  199. sub untar {
  200.     my($self) = @_;
  201.     my $file = $self->{FILE};
  202.     my($prefer) = 0;
  203.  
  204.     if (0) { # makes changing order easier
  205.     } elsif ($BUGHUNTING) {
  206.         $prefer=2;
  207.     } elsif (MM->maybe_command($self->{UNGZIPPRG})
  208.              &&
  209.              MM->maybe_command($CPAN::Config->{tar})) {
  210.         # should be default until Archive::Tar handles bzip2
  211.         $prefer = 1;
  212.     } elsif (
  213.              $CPAN::META->has_usable("Archive::Tar")
  214.              &&
  215.              $CPAN::META->has_inst("Compress::Zlib") ) {
  216.         $prefer = 2;
  217.     } else {
  218.         $CPAN::Frontend->mydie(qq{
  219. CPAN.pm needs either the external programs tar, gzip and bzip2
  220. installed. Can't continue.
  221. });
  222.     }
  223.     my $tar_verb = "v";
  224.     if (defined $CPAN::Config->{tar_verbosity}) {
  225.         $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
  226.             $CPAN::Config->{tar_verbosity};
  227.     }
  228.     if ($prefer==1) { # 1 => external gzip+tar
  229.         my($system);
  230.         my $is_compressed = $self->gtest();
  231.         my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar";
  232.         if ($is_compressed) {
  233.             my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
  234.             $system = qq{$command -dc }.
  235.                 qq{< "$file" | $tarcommand x${tar_verb}f -};
  236.         } else {
  237.             $system = qq{$tarcommand x${tar_verb}f "$file"};
  238.         }
  239.         if (system($system) != 0) {
  240.             # people find the most curious tar binaries that cannot handle
  241.             # pipes
  242.             if ($is_compressed) {
  243.                 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
  244.                 $ungzf = File::Basename::basename($ungzf);
  245.                 my $ct = CPAN::Tarzip->new($file);
  246.                 if ($ct->gunzip($ungzf)) {
  247.                     $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
  248.                 } else {
  249.                     $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
  250.                 }
  251.                 $file = $ungzf;
  252.             }
  253.             $system = qq{$tarcommand x${tar_verb}f "$file"};
  254.             $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
  255.             if (system($system)==0) {
  256.                 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
  257.             } else {
  258.                 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
  259.             }
  260.             return 1;
  261.         } else {
  262.             return 1;
  263.         }
  264.     } elsif ($prefer==2) { # 2 => modules
  265.         unless ($CPAN::META->has_usable("Archive::Tar")) {
  266.             $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
  267.         }
  268.         my $tar = Archive::Tar->new($file,1);
  269.         my $af; # archive file
  270.         my @af;
  271.         if ($BUGHUNTING) {
  272.             # RCS 1.337 had this code, it turned out unacceptable slow but
  273.             # it revealed a bug in Archive::Tar. Code is only here to hunt
  274.             # the bug again. It should never be enabled in published code.
  275.             # GDGraph3d-0.53 was an interesting case according to Larry
  276.             # Virden.
  277.             warn(">>>Bughunting code enabled<<< " x 20);
  278.             for $af ($tar->list_files) {
  279.                 if ($af =~ m!^(/|\.\./)!) {
  280.                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
  281.                                            "illegal member [$af]");
  282.                 }
  283.                 $CPAN::Frontend->myprint("$af\n");
  284.                 $tar->extract($af); # slow but effective for finding the bug
  285.                 return if $CPAN::Signal;
  286.             }
  287.         } else {
  288.             for $af ($tar->list_files) {
  289.                 if ($af =~ m!^(/|\.\./)!) {
  290.                     $CPAN::Frontend->mydie("ALERT: Archive contains ".
  291.                                            "illegal member [$af]");
  292.                 }
  293.                 if ($tar_verb eq "v" || $tar_verb eq "vv") {
  294.                     $CPAN::Frontend->myprint("$af\n");
  295.                 }
  296.                 push @af, $af;
  297.                 return if $CPAN::Signal;
  298.             }
  299.             $tar->extract(@af) or
  300.                 $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
  301.         }
  302.  
  303.         Mac::BuildTools::convert_files([$tar->list_files], 1)
  304.             if ($^O eq 'MacOS');
  305.  
  306.         return 1;
  307.     }
  308. }
  309.  
  310. sub unzip {
  311.     my($self) = @_;
  312.     my $file = $self->{FILE};
  313.     if ($CPAN::META->has_inst("Archive::Zip")) {
  314.         # blueprint of the code from Archive::Zip::Tree::extractTree();
  315.         my $zip = Archive::Zip->new();
  316.         my $status;
  317.         $status = $zip->read($file);
  318.         $CPAN::Frontend->mydie("Read of file[$file] failed\n")
  319.             if $status != Archive::Zip::AZ_OK();
  320.         $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
  321.         my @members = $zip->members();
  322.         for my $member ( @members ) {
  323.             my $af = $member->fileName();
  324.             if ($af =~ m!^(/|\.\./)!) {
  325.                 $CPAN::Frontend->mydie("ALERT: Archive contains ".
  326.                                        "illegal member [$af]");
  327.             }
  328.             $status = $member->extractToFileNamed( $af );
  329.             $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
  330.             $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
  331.                 $status != Archive::Zip::AZ_OK();
  332.             return if $CPAN::Signal;
  333.         }
  334.         return 1;
  335.     } else {
  336.         my $unzip = $CPAN::Config->{unzip} or
  337.             $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
  338.         my @system = ($unzip, $file);
  339.         return system(@system) == 0;
  340.     }
  341. }
  342.  
  343. 1;
  344.  
  345. __END__
  346.  
  347. =head1 LICENSE
  348.  
  349. This program is free software; you can redistribute it and/or
  350. modify it under the same terms as Perl itself.
  351.  
  352. =cut
  353.