$Frontend $Defaultsite
}; #};
-$VERSION = '1.56';
+$VERSION = '1.57';
-# $Id: CPAN.pm,v 1.303 2000/08/01 15:57:15 k Exp $
+# $Id: CPAN.pm,v 1.305 2000/08/16 12:42:32 k Exp $
# only used during development:
$Revision = "";
-# $Revision = "[".substr(q$Revision: 1.303 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.305 $, 10)."]";
use Carp ();
use Config ();
my $command = shift @line;
eval { CPAN::Shell->$command(@line) };
warn $@ if $@;
- chdir $cwd;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
$CPAN::Frontend->myprint("\n");
$continuation = "";
$prompt = "cpan> ";
$pkg =~ s|::|/|g;
if (defined($name=$INC{"$pkg.pm"}))
{
- $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|s;
+ $name =~ s|^(.*)$pkg\.pm(?!\n)\Z|$1auto/$pkg/$func.al|s;
$name = undef unless (-r $name);
}
unless (defined $name)
*$autoload = sub {};
$ok = 1;
} else {
- if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
+ if ($name =~ s{(\w{12,})\.al(?!\n)\Z}{substr($1,0,11).".al"}e){
eval {local $SIG{__DIE__};require $name};
}
if ($@){
$class->$o(@args);
return 1;
} else {
- CPAN->debug("o[$o]");
+ CPAN->debug("o[$o]") if $CPAN::DEBUG;
if ($o =~ /list$/) {
$func = shift @args;
$func ||= "";
- CPAN->debug("func[$func]");
+ CPAN->debug("func[$func]") if $CPAN::DEBUG;
my $changed;
# Let's avoid eval, it's easier to comprehend without.
if ($func eq "push") {
my($entry);
for $entry ($dh->read) {
next if -d MM->catdir($bdir,$entry);
- next unless $entry =~ s/\.pm$//;
+ next unless $entry =~ s/\.pm(?!\n)\Z//;
$CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
}
}
my($k,$v);
for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
$v = $CPAN::DEBUG{$k};
- $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
+ $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
+ if $v & $CPAN::DEBUG;
}
} else {
$CPAN::Frontend->myprint("Debugging turned off completely.\n");
sub _binary_extensions {
my($self) = shift @_;
my(@result,$module,%seen,%need,$headerdone);
- my $isaperl = q{ perl
- -?
- 5[._-]
- (
- \\d{3}(_[0-4][0-9])?
- |
- \\d*[24680]\\.\\d+
- )
- \\.tar[._-]gz$
- };
for $module ($self->expand('Module','/./')) {
my $file = $module->cpan_file;
next if $file eq "N/A";
next if $file =~ /^Contact Author/;
- next if $file =~ / $isaperl /x;
+ my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
+ next if $dist->isa_perl;
next unless $module->xs_file;
local($|) = 1;
$CPAN::Frontend->myprint(".");
for $module ($self->expand('Module',@args)) {
my $file = $module->cpan_file;
next unless defined $file; # ??
- my($latest) = $module->cpan_version;
+ my($latest) = $module->cpan_version; # %vd
my($inst_file) = $module->inst_file;
my($have);
return if $CPAN::Signal;
if ($inst_file){
if ($what eq "a") {
- $have = $module->inst_version;
+ $have = $module->inst_version; # %vd
} elsif ($what eq "r") {
- $have = $module->inst_version;
+ $have = $module->inst_version; # %vd
local($^W) = 0;
if ($have eq "undef"){
$version_undefs++;
"in CPAN file"
));
}
- $latest = substr($latest,0,8) if length($latest) > 8;
- $have = substr($have,0,8) if length($have) > 8;
- $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
+ for ($have,$latest) {
+ if ($] >= 5.006) { # people start using v-strings
+ local($^W) = 0;
+ unless (/^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
+ && "$2$4" ne ""
+ ||
+ /^undef$/
+ ||
+ /^-$/ # not installed
+ ) {
+ $_ = sprintf "%vd", $_;
+ }
+ }
+ $_ = substr($_,0,8) if length($_) > 8;
+ }
+ $CPAN::Frontend->myprint(sprintf $sprintf,
+ $module->id,
+ $have,
+ $latest,
+ $file);
$need{$module->id}++;
}
unless (%need) {
utime $now, $now, $aslocal; # download time is more
# important than upload time
return $aslocal;
- } elsif ($url !~ /\.gz$/) {
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
my $gzurl = "$url.gz";
$CPAN::Frontend->myprint("Fetching with LWP:
$gzurl
$Thesite = $i;
return $aslocal;
}
- if ($aslocal !~ /\.gz$/) {
+ if ($aslocal !~ /\.gz(?!\n)\Z/) {
my $gz = "$aslocal.gz";
$CPAN::Frontend->myprint("Fetching with Net::FTP
$url.gz
}
$Thesite = $i;
return $aslocal;
- } elsif ($url !~ /\.gz$/) {
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
unlink $asl_ungz if
-f $asl_ungz && -s _ == 0;
my $gz = "$aslocal.gz";
#-> sub CPAN::Index::rd_modpacks ;
sub rd_modpacks {
- my($cl, $index_target) = @_;
+ my($self, $index_target) = @_;
my @lines;
return unless defined $index_target;
$CPAN::Frontend->myprint("Going to read $index_target\n");
last if $shift =~ /^\s*$/;
}
if (not defined $line_count) {
+
warn qq{Warning: Your $index_target does not contain a Line-Count header.
-Please check the validity of the index file by comparing it to more than one CPAN
-mirror. I'll continue but problems seem likely to happen.\a
+Please check the validity of the index file by comparing it to more
+than one CPAN mirror. I'll continue but problems seem likely to
+happen.\a
};
+
sleep 5;
} elsif ($line_count != scalar @lines) {
}
foreach (@lines) {
chomp;
- my($mod,$version,$dist) = split;
+ # before 1.56 we split into 3 and discarded the rest. From
+ # 1.57 we assign remaining text to $comment thus allowing to
+ # influence isa_perl
+ my($mod,$version,$dist,$comment) = split " ", $_, 4;
### $version =~ s/^\+//;
# if it is a bundle, instantiate a bundle object
}
if ($id->cpan_file ne $dist){
- $userid = $cl->userid($dist);
+ $userid = $self->userid($dist);
$id->set(
'CPAN_USERID' => $userid,
- 'CPAN_VERSION' => $version,
- 'CPAN_FILE' => $dist
+ 'CPAN_VERSION' => $version, # %vd
+ 'CPAN_FILE' => $dist,
+ 'CPAN_COMMENT' => $comment,
);
}
$self->debug("Removing tmp") if $CPAN::DEBUG;
File::Path::rmtree("tmp");
mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
- chdir "tmp";
+ chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
$self->debug("Changed directory to tmp") if $CPAN::DEBUG;
if (! $local_file) {
Carp::croak "bad download, can't do anything :-(\n";
- } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
+ } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
$self->untar_me($local_file);
- } elsif ( $local_file =~ /\.zip$/i ) {
+ } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
$self->unzip_me($local_file);
- } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
+ } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
$self->pm2dir_me($local_file);
} else {
$self->{archived} = "NO";
}
- chdir File::Spec->updir;
+ my $cwd = File::Spec->updir;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
if ($self->{archived} ne 'NO') {
- chdir File::Spec->catdir(File::Spec->curdir, "tmp");
- # Let's check if the package has its own directory.
- my $dh = DirHandle->new(File::Spec->curdir)
- or Carp::croak("Couldn't opendir .: $!");
- my @readdir = grep $_ !~ /^\.\.?$/s, $dh->read; ### MAC??
- $dh->close;
- my ($distdir,$packagedir);
- if (@readdir == 1 && -d $readdir[0]) {
- $distdir = $readdir[0];
- $packagedir = MM->catdir($builddir,$distdir);
- -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
- File::Path::rmtree($packagedir);
- rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
- } else {
- my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
- $pragmatic_dir =~ s/\W_//g;
- $pragmatic_dir++ while -d "../$pragmatic_dir";
- $packagedir = MM->catdir($builddir,$pragmatic_dir);
- File::Path::mkpath($packagedir);
- my($f);
- for $f (@readdir) { # is already without "." and ".."
- my $to = MM->catdir($packagedir,$f);
- rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
- }
- }
- $self->{'build_dir'} = $packagedir;
- chdir File::Spec->updir;
-
- $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
- if $CPAN::DEBUG;
- File::Path::rmtree("tmp");
- if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
- $CPAN::Frontend->myprint("Going to unlink $local_file\n");
- unlink $local_file or Carp::carp "Couldn't unlink $local_file";
- }
- my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
- unless (-f $makefilepl) {
- my($configure) = MM->catfile($packagedir,"Configure");
- if (-f $configure) {
- # do we have anything to do?
- $self->{'configure'} = $configure;
- } elsif (-f MM->catfile($packagedir,"Makefile")) {
- $CPAN::Frontend->myprint(qq{
+ $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+ # Let's check if the package has its own directory.
+ my $dh = DirHandle->new(File::Spec->curdir)
+ or Carp::croak("Couldn't opendir .: $!");
+ my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
+ $dh->close;
+ my ($distdir,$packagedir);
+ if (@readdir == 1 && -d $readdir[0]) {
+ $distdir = $readdir[0];
+ $packagedir = MM->catdir($builddir,$distdir);
+ -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
+ File::Path::rmtree($packagedir);
+ rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
+ } else {
+ my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
+ $pragmatic_dir =~ s/\W_//g;
+ $pragmatic_dir++ while -d "../$pragmatic_dir";
+ $packagedir = MM->catdir($builddir,$pragmatic_dir);
+ File::Path::mkpath($packagedir);
+ my($f);
+ for $f (@readdir) { # is already without "." and ".."
+ my $to = MM->catdir($packagedir,$f);
+ rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
+ }
+ }
+ $self->{'build_dir'} = $packagedir;
+ $cwd = File::Spec->updir;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+
+ $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
+ if $CPAN::DEBUG;
+ File::Path::rmtree("tmp");
+ if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
+ $CPAN::Frontend->myprint("Going to unlink $local_file\n");
+ unlink $local_file or Carp::carp "Couldn't unlink $local_file";
+ }
+ my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
+ unless (-f $makefilepl) {
+ my($configure) = MM->catfile($packagedir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{'configure'} = $configure;
+ } elsif (-f MM->catfile($packagedir,"Makefile")) {
+ $CPAN::Frontend->myprint(qq{
Package comes with a Makefile and without a Makefile.PL.
We\'ll try to build it with that Makefile then.
});
- $self->{writemakefile} = "YES";
- sleep 2;
- } else {
- my $fh = FileHandle->new(">$makefilepl")
- or Carp::croak("Could not open >$makefilepl");
- my $cf = $self->called_for || "unknown";
- $fh->print(
+ $self->{writemakefile} = "YES";
+ sleep 2;
+ } else {
+ my $fh = FileHandle->new(">$makefilepl")
+ or Carp::croak("Could not open >$makefilepl");
+ my $cf = $self->called_for || "unknown";
+ $fh->print(
qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
# because there was no Makefile.PL supplied.
# Autogenerated on: }.scalar localtime().qq{
WriteMakefile(NAME => q[$cf]);
});
- $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
+ $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
Writing one on our own (calling it $cf)\n});
- }
- }
+ }
+ }
}
return $self;
}
sub unzip_me {
my($self,$local_file) = @_;
+ $self->{archived} = "zip";
if ($CPAN::META->has_inst("Archive::Zip")) {
- $CPAN::Frontend->mywarn("Archive::Zip not yet supported. ".
- "Will use external unzip");
+ if (CPAN::Tarzip->unzip($local_file)) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+ return;
}
my $unzip = $CPAN::Config->{unzip} or
$CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
- $self->{archived} = "zip";
my @system = ($unzip, $local_file);
if (system(@system) == 0) {
$self->{unwrapped} = "YES";
my($self,$local_file) = @_;
$self->{archived} = "pm";
my $to = File::Basename::basename($local_file);
- $to =~ s/\.(gz|Z)$//;
+ $to =~ s/\.(gz|Z)(?!\n)\Z//;
if (CPAN::Tarzip->gunzip($local_file,$to)) {
$self->{unwrapped} = "YES";
} else {
my $getcwd;
$getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
my $pwd = CPAN->$getcwd();
- chdir($dir);
+ chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
system($CPAN::Config->{'shell'}) == 0
or $CPAN::Frontend->mydie("Subprocess shell error");
- chdir($pwd);
+ chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
}
sub cvs_import {
my $package = $self->called_for;
my $module = $CPAN::META->instance('CPAN::Module', $package);
- my $version = $module->cpan_version;
+ my $version = $module->cpan_version; # %vd
my $userid = $self->{CPAN_USERID};
my $cvs_dir = (split '/', $dir)[-1];
- $cvs_dir =~ s/-\d+[^-]+$//;
+ $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
my $cvs_root =
$CPAN::Config->{cvsroot} || $ENV{CVSROOT};
my $cvs_site_perl =
my $getcwd;
$getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
my $pwd = CPAN->$getcwd();
- chdir($dir);
+ chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
$CPAN::Frontend->myprint(qq{@cmd\n});
system(@cmd) == 0 or
$CPAN::Frontend->mydie("cvs import failed");
- chdir($pwd);
+ chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
}
#-> sub CPAN::Distribution::readme ;
$lc_file = CPAN::FTP->localize("authors/id/@local",
"$lc_want.gz",1);
if ($lc_file) {
- $lc_file =~ s/\.gz$//;
+ $lc_file =~ s/\.gz(?!\n)\Z//;
CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
} else {
return;
sub isa_perl {
my($self) = @_;
my $file = File::Basename::basename($self->id);
- return unless $file =~ m{ ^ perl
- -?
- (5)
- ([._-])
- (
- \d{3}(_[0-4][0-9])?
- |
- \d*[24680]\.\d+
- )
- \.tar[._-]gz
- $
- }xs;
- "$1.$3";
+ if ($file =~ m{ ^ perl
+ -?
+ (5)
+ ([._-])
+ (
+ \d{3}(_[0-4][0-9])?
+ |
+ \d*[24680]\.\d+
+ )
+ \.tar[._-]gz
+ (?!\n)\Z
+ }xs){
+ return "$1.$3";
+ } elsif ($self->{'CPAN_COMMENT'} && $self->{'CPAN_COMMENT'} =~ /isa_perl\(.+?\)/){
+ return $1;
+ }
}
#-> sub CPAN::Distribution::perl ;
$CPAN::META->instance(
'CPAN::Module',
$self->called_for
- )->cpan_version,
+ )->cpan_version, # %vd
$self->called_for,
$self->isa_perl,
$self->called_for,
{
local($^W) = 0;
if (defined $mo->inst_file &&
- $mo->inst_version >= $need_version){
+ $mo->inst_version >= $need_version){ # %vd
CPAN->debug(sprintf "inst_file[%s]inst_version[%s]need_version[%s]",
$mo->inst_file, $mo->inst_version, $need_version
);
sub as_string {
my($self) = @_;
$self->contains;
- $self->{INST_VERSION} = $self->inst_version;
+ $self->{INST_VERSION} ||= $self->inst_version; # %vd
return $self->SUPER::as_string;
}
require ExtUtils::Manifest;
my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
my $cwd = CPAN->$getcwd();
- chdir $where;
+ chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
ExtUtils::Manifest::mkmanifest();
- chdir $cwd;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
}
my $fh = FileHandle->new($manifest)
or Carp::croak("Couldn't open $manifest: $!");
);
}
}
- push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
- if $self->{CPAN_VERSION};
+ push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) # %vd
+ if $self->{CPAN_VERSION}; # %vd
push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
if $self->{CPAN_FILE};
my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
push @m, sprintf($sprintf, 'INST_FILE',
$local_file || "(not installed)");
push @m, sprintf($sprintf, 'INST_VERSION',
- $self->inst_version) if $local_file;
+ $self->inst_version) if $local_file; #%vd
join "", @m, "\n";
}
sub manpage_headline {
my($self,$local_file) = @_;
my(@local_file) = $local_file;
- $local_file =~ s/\.pm$/.pod/;
+ $local_file =~ s/\.pm(?!\n)\Z/.pod/;
push @local_file, $local_file;
my(@result,$locf);
for $locf (@local_file) {
# and do not want to
# provoke too many
# bugreports
- $self->{'CPAN_VERSION'};
+ $self->{'CPAN_VERSION'}; # %vd
}
#-> sub CPAN::Module::force ;
#-> sub CPAN::Module::uptodate ;
sub uptodate {
my($self) = @_;
- my($latest) = $self->cpan_version;
+ my($latest) = $self->cpan_version; # %vd
$latest ||= 0;
my($inst_file) = $self->inst_file;
my($have) = 0;
if (defined $inst_file) {
- $have = $self->inst_version;
+ $have = $self->inst_version; # %vd?
}
local($^W)=0;
if ($inst_file
&&
- $have >= $latest
+ $have >= $latest # %vd
) {
return 1;
}
warn $w;
};
$have = MM->parse_version($parsefile) || "undef";
+ $have =~ s/^ //; # since the %vd hack these two lines here are needed
+ $have =~ s/ $//; # trailing whitespace happens all the time
+
# local($SIG{__WARN__}) = sub { warn "2. have[$have]"; };
+
+ if ($] >= 5.006) { # people start using v-strings
+ unless ($have =~ /^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
+ && "$2$4" ne ""
+ ||
+ /^undef$/
+ ||
+ /^-$/
+ ) {
+ $have = sprintf "%vd", $have;
+ }
+ }
$have =~ s/\s*//g; # stringify to float around floating point issues
# local($SIG{__WARN__}) = sub { warn "3. have[$have]"; };
$have; # no stringify needed, \s* above matches always
qq{Couldn\'t uncompress $file\n}
);
}
- $file =~ s/\.gz$//;
+ $file =~ s/\.gz(?!\n)\Z//;
$system = "$CPAN::Config->{tar} xvf $file";
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
if (system($system)==0) {
}
}
+sub unzip {
+ my($class,$file) = @_;
+ return unless $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);
+ die "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 $f = $member->fileName();
+ my $status = $member->extractToFileNamed( $f );
+ $CPAN::META->debug("f[$f]status[$status]") if $CPAN::DEBUG;
+ die "Extracting of file[$f] from zipfile[$file] failed\n" if
+ $status != Archive::Zip::AZ_OK();
+ }
+ return 1;
+}
+
package CPAN;
1;
=head2 Note on urllist parameter's format
urllist parameters are URLs according to RFC 1738. We do a little
-guessing if your URL is not compliant, but if you have problems with file URLs, please try the correct format. Either:
+guessing if your URL is not compliant, but if you have problems with
+file URLs, please try the correct format. Either:
file://localhost/whatever/ftp/pub/CPAN/
projects / p5sagit/p5-mst-13.2.git / commitdiff