[p5sagit/p5-mst-13.2.git] / lib / CPAN / Tarzip.pm

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