# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
-$VERSION = '1.59_56';
-# $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $
+$VERSION = '1.64';
+# $Id: CPAN.pm,v 1.397 2003/02/06 09:44:40 k Exp $
# only used during development:
$Revision = "";
-# $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.397 $, 10)."]";
use Carp ();
use Config ();
use Text::ParseWords ();
use Text::Wrap;
use File::Spec;
+use Sys::Hostname;
no lib "."; # we need to run chdir all over and we would get at wrong
# libraries there
$readline::rl_completion_function =
$readline::rl_completion_function = 'CPAN::Complete::cpl';
}
+ if (my $histfile = $CPAN::Config->{'histfile'}) {{
+ unless ($term->can("AddHistory")) {
+ $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
+ last;
+ }
+ my($fh) = FileHandle->new;
+ open $fh, "<$histfile" or last;
+ local $/ = "\n";
+ while (<$fh>) {
+ chomp;
+ $term->AddHistory($_);
+ }
+ close $fh;
+ }}
# $term->OUT is autoflushed anyway
my $odef = select STDERR;
$| = 1;
if (-f $lockfile && -M _ > 0) {
my $fh = FileHandle->new($lockfile) or
$CPAN::Frontend->mydie("Could not open $lockfile: $!");
- my $other = <$fh>;
+ my $otherpid = <$fh>;
+ my $otherhost = <$fh>;
$fh->close;
- if (defined $other && $other) {
- chomp $other;
- return if $$==$other; # should never happen
+ if (defined $otherpid && $otherpid) {
+ chomp $otherpid;
+ }
+ if (defined $otherhost && $otherhost) {
+ chomp $otherhost;
+ }
+ my $thishost = hostname();
+ if (defined $otherhost && defined $thishost &&
+ $otherhost ne '' && $thishost ne '' &&
+ $otherhost ne $thishost) {
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
+ "reports other host $otherhost and other process $otherpid.\n".
+ "Cannot proceed.\n"));
+ }
+ elsif (defined $otherpid && $otherpid) {
+ return if $$ == $otherpid; # should never happen
$CPAN::Frontend->mywarn(
qq{
-There seems to be running another CPAN process ($other). Contacting...
+There seems to be running another CPAN process (pid $otherpid). Contacting...
});
- if (kill 0, $other) {
+ if (kill 0, $otherpid) {
$CPAN::Frontend->mydie(qq{Other job is running.
You may want to kill it and delete the lockfile, maybe. On UNIX try:
- kill $other
+ kill $otherpid
rm $lockfile
});
} elsif (-w $lockfile) {
);
}
} else {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
"reports other process with ID ".
- "$other. Cannot proceed.\n"));
+ "$otherpid. Cannot proceed.\n"));
}
}
my $dotcpan = $CPAN::Config->{cpan_home};
$CPAN::Frontend->mydie("Could not open >$lockfile: $!");
}
$fh->print($$, "\n");
+ $fh->print(hostname(), "\n");
$self->{LOCK} = $lockfile;
$fh->close;
$SIG{TERM} = sub {
my($message) = @_;
my $i = 0;
my $ineval = 0;
- if (
- 0 && # disabled, try reload cpan with it
- $] > 5.004_60 # thereabouts
- ) {
- $ineval = $^S;
- } else {
- my($subroutine);
- while ((undef,undef,undef,$subroutine) = caller(++$i)) {
+ my($subroutine);
+ while ((undef,undef,undef,$subroutine) = caller(++$i)) {
$ineval = 1, last if
$subroutine eq '(eval)';
- }
}
return if $ineval && !$End;
- return unless defined $META->{LOCK}; # unsafe meta access, ok
- return unless -f $META->{LOCK}; # unsafe meta access, ok
- unlink $META->{LOCK}; # unsafe meta access, ok
+ return unless defined $META->{LOCK};
+ return unless -f $META->{LOCK};
+ $META->savehist;
+ unlink $META->{LOCK};
# require Carp;
# Carp::cluck("DEBUGGING");
$CPAN::Frontend->mywarn("Lockfile removed.\n");
}
+#-> sub CPAN::savehist
+sub savehist {
+ my($self) = @_;
+ my($histfile,$histsize);
+ unless ($histfile = $CPAN::Config->{'histfile'}){
+ $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
+ return;
+ }
+ $histsize = $CPAN::Config->{'histsize'} || 100;
+ unless ($CPAN::term->can("GetHistory")) {
+ $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
+ return;
+ }
+ my @h = $CPAN::term->GetHistory;
+ splice @h, 0, @h-$histsize if @h>$histsize;
+ my($fh) = FileHandle->new;
+ open $fh, ">$histfile" or mydie("Couldn't open >$histfile: $!");
+ local $\ = local $, = "\n";
+ print $fh @h;
+ close $fh;
+}
+
+sub is_tested {
+ my($self,$what) = @_;
+ $self->{is_tested}{$what} = 1;
+}
+
+sub is_installed {
+ my($self,$what) = @_;
+ delete $self->{is_tested}{$what};
+}
+
+sub set_perl5lib {
+ my($self) = @_;
+ $self->{is_tested} ||= {};
+ return unless %{$self->{is_tested}};
+ my $env = $ENV{PERL5LIB};
+ $env = $ENV{PERLLIB} unless defined $env;
+ my @env;
+ push @env, $env if defined $env and length $env;
+ my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
+ $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+}
+
package CPAN::CacheMgr;
#-> sub CPAN::CacheMgr::as_string ;
my @accept;
for (@arg) {
unless (/^[A-Z\-]+$/i) {
- $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
+ $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
next;
}
push @accept, uc $_;
sub paintdots_onreload {
my($ref) = shift;
sub {
- if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
+ if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
my($subr) = $1;
++$$ref;
local($|) = 1;
$command ||= "";
$self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
if ($command =~ /cpan/i) {
- CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
- my $fh = FileHandle->new($INC{'CPAN.pm'});
- local($/);
- my $redef = 0;
- local($SIG{__WARN__}) = paintdots_onreload(\$redef);
- eval <$fh>;
- warn $@ if $@;
- $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
+ next unless $INC{$f};
+ CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
+ my $fh = FileHandle->new($INC{$f});
+ local($/);
+ my $redef = 0;
+ local($SIG{__WARN__}) = paintdots_onreload(\$redef);
+ eval <$fh>;
+ warn $@ if $@;
+ $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ }
} elsif ($command =~ /index/) {
CPAN::Index->force_reload;
} else {
print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
}
} else {
+ # chomp $what;
+ # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
print $what;
}
}
push @qcopy, $obj;
} elsif ($CPAN::META->exists('CPAN::Author',$s)) {
$obj = $CPAN::META->instance('CPAN::Author',$s);
- if ($meth eq "dump") {
- $obj->dump;
+ if ($meth =~ /^(dump|ls)$/) {
+ $obj->$meth();
} else {
$CPAN::Frontend->myprint(
join "",
@ISA = qw(Exporter LWP::UserAgent);
$SETUPDONE++;
} else {
- $CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
+ $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
}
}
CPAN::LWP::UserAgent->config;
eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
if ($@) {
- $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
+ $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
if $CPAN::DEBUG;
} else {
my($var);
CPAN::LWP::UserAgent->config;
eval { $Ua = CPAN::LWP::UserAgent->new; };
if ($@) {
- $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
+ $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
}
}
my $res = $Ua->mirror($url, $aslocal);
$url
]);
my($system) =
- "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
+ "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
$self->debug("system[$system]") if $CPAN::DEBUG;
my($wstatus);
if (($wstatus = system($system)) == 0
Trying with "$funkyftp$src_switch" to get
$url.gz
]);
- my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
+ my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
$self->debug("system[$system]") if $CPAN::DEBUG;
my($wstatus);
if (($wstatus = system($system)) == 0
@dialog,
"lcd $aslocal_dir",
"cd /",
- map("cd $_", split "/", $dir), # RFC 1738
+ map("cd $_", split /\//, $dir), # RFC 1738
"bin",
"get $getfile $targetfile",
"quit"
$cache->{PROTOCOL} = PROTOCOL;
$CPAN::Frontend->myprint("Going to write $metadata_file\n");
eval { Storable::nstore($cache, $metadata_file) };
- $CPAN::Frontend->mywarn($@) if $@;
+ $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}
#-> sub CPAN::Index::read_metadata_cache ;
$CPAN::Frontend->myprint("Going to read $metadata_file\n");
my $cache;
eval { $cache = Storable::retrieve($metadata_file) };
- $CPAN::Frontend->mywarn($@) if $@;
+ $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
if (!$cache || ref $cache ne 'HASH'){
$LAST_TIME = 0;
return;
if (exists $cache->{PROTOCOL}) {
if (PROTOCOL > $cache->{PROTOCOL}) {
$CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
- "with protocol v%s, requiring v%s",
+ "with protocol v%s, requiring v%s\n",
$cache->{PROTOCOL},
PROTOCOL)
);
}
} else {
$CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
- "with protocol v1.0");
+ "with protocol v1.0\n");
return;
}
my $clcnt = 0;
) {
return $s if $s =~ m:^N/A|^Contact Author: ;
$s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
- $CPAN::Frontend->mywarn("Strange distribution name [$s]");
+ $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
CPAN->debug("s[$s]") if $CPAN::DEBUG;
}
$s;
$CPAN::Config->{keep_source_where},
"authors",
"id",
- split("/",$self->id)
+ split(/\//,$self->id)
);
$self->debug("Doing localize") if $CPAN::DEBUG;
my $userid = $self->cpan_userid;
- my $cvs_dir = (split '/', $dir)[-1];
+ my $cvs_dir = (split /\//, $dir)[-1];
$cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
my $cvs_root =
$CPAN::Config->{cvsroot} || $ENV{CVSROOT};
$CPAN::Config->{keep_source_where},
"authors",
"id",
- split("/","$sans.readme"),
+ split(/\//,"$sans.readme"),
);
$self->debug("Doing localize") if $CPAN::DEBUG;
$local_file = CPAN::FTP->localize("authors/id/$sans.readme",
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
my($lc_want,$lc_file,@local,$basename);
- @local = split("/",$self->id);
+ @local = split(/\//,$self->id);
pop @local;
push @local, "CHECKSUMS";
$lc_want =
return;
}
+ local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
+ $CPAN::META->set_perl5lib;
my $system = join " ", $CPAN::Config->{'make'}, "test";
if (system($system) == 0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
+ $CPAN::META->is_tested($self->{'build_dir'});
$self->{make_test} = "YES";
} else {
$self->{make_test} = "NO";
$pipe->close;
if ($?==0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
+ $CPAN::META->is_installed($self->{'build_dir'});
return $self->{'install'} = "YES";
} else {
$self->{'install'} = "NO";
package CPAN::Bundle;
+sub look {
+ my $self = shift;
+ $CPAN::Frontend->myprint(
+ qq{ look() commmand on bundles not}.
+ qq{ implemented (What should it do?)}
+ );
+}
+
sub undelay {
my $self = shift;
delete $self->{later};
my $inpod = 0;
local $/ = "\n";
while (<$fh>) {
- $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
- m/^=head1\s+NAME/ ? 1 : $inpod;
+ $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
+ m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
next unless $inpod;
next if /^=/;
next if /^\s+$/;
# And if they say v1.2, then the old perl takes it as "v12"
- $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
+ $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
return $n;
}
my $better = sprintf "v%vd", $n;
autobundle, clean, install, make, recompile, test
+=head1 STATUS
+
+This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
+of a modern rewrite from ground up with greater extensibility and more
+features but no full compatibility. If you're new to CPAN.pm, you
+probably should investigate if CPANPLUS is the better choice for you.
+If you're already used to CPAN.pm you're welcome to continue using it,
+if you accept that its development is mostly (though not completely)
+stalled.
+
=head1 DESCRIPTION
The CPAN module is designed to automate the make and install of perl
dontload_hash anonymous hash: modules in the keys will not be
loaded by the CPAN::has_inst() routine
gzip location of external program gzip
+ histfile file to maintain history between sessions
+ histsize maximum number of lines to keep in histfile
inactivity_timeout breaks interactive Makefile.PLs after this
many seconds inactivity. Set to 0 to never break.
inhibit_startup_message
hide a complete network behind one IP address. With this firewall no
special compiling is needed as you can access hosts directly.
+For accessing ftp servers behind such firewalls you may need to set
+the environment variable C<FTP_PASSIVE> to a true value, e.g.
+
+ env FTP_PASSIVE=1 perl -MCPAN -eshell
+
+or
+
+ perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
+
+
=back
=back
https://perl5.git.perl.org / perl5.git / blobdiff