# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN;
-$CPAN::VERSION = '1.88_53';
-$CPAN::VERSION = eval $CPAN::VERSION;
+$CPAN::VERSION = '1.9102';
+$CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/;
use CPAN::HandleConfig;
use CPAN::Version;
use File::Path ();
use File::Spec ();
use FileHandle ();
+use Fcntl qw(:flock);
use Safe ();
use Sys::Hostname qw(hostname);
use Text::ParseWords ();
BEGIN {
if (File::Spec->can("rel2abs")) {
for my $inc (@INC) {
- $inc = File::Spec->rel2abs($inc);
+ $inc = File::Spec->rel2abs($inc) unless ref $inc;
}
}
}
no lib ".";
require Mac::BuildTools if $^O eq 'MacOS';
+$ENV{PERL5_CPAN_IS_RUNNING}=1;
+$ENV{PERL5_CPANPLUS_IS_RUNNING}=1; # https://rt.cpan.org/Ticket/Display.html?id=23735
END { $CPAN::End++; &cleanup; }
$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
$CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
-
-use vars qw($VERSION @EXPORT $AUTOLOAD
- $DEBUG $META $HAS_USABLE $term
- $GOTOSHELL
- $Signal $Suppress_readline $Frontend
- @Defaultsites $Have_warned $Defaultdocs $Defaultrecent
+# our globals are getting a mess
+use vars qw(
+ $AUTOLOAD
$Be_Silent
+ $CONFIG_DIRTY
+ $Defaultdocs
+ $Defaultrecent
+ $Echo_readline
+ $Frontend
+ $GOTOSHELL
+ $HAS_USABLE
+ $Have_warned
+ $MAX_RECURSION
+ $META
+ $RUN_DEGRADED
+ $Signal
+ $SQLite
+ $Suppress_readline
+ $VERSION
$autoload_recursion
+ $term
+ @Defaultsites
+ @EXPORT
);
+$MAX_RECURSION = 32;
+
@CPAN::ISA = qw(CPAN::Debug Exporter);
# note that these functions live in CPAN::Shell and get executed via
cvs_import
expand
force
+ fforce
get
install
+ install_tested
+ is_tested
make
mkmyconfig
notest
readme
recent
recompile
+ report
shell
test
upgrade
$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;
+ $META->readhist($term,$histfile);
}}
for ($CPAN::Config->{term_ornaments}) { # alias
local $Term::ReadLine::termcap_nowarn = 1;
select $odef;
}
- # no strict; # I do not recall why no strict was here (2000-09-03)
$META->checklock();
my @cwd = grep { defined $_ and length $_ }
CPAN::anycwd(),
$try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
my $rl_avail = $Suppress_readline ? "suppressed" :
($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
- "available (try 'install Bundle::CPAN')";
+ "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
unless ($CPAN::Config->{'inhibit_startup_message'}){
$CPAN::Frontend->myprint(
my $last_term_ornaments;
SHELLCOMMAND: while () {
if ($Suppress_readline) {
+ if ($Echo_readline) {
+ $|=1;
+ }
print $prompt;
last SHELLCOMMAND unless defined ($_ = <> );
+ if ($Echo_readline) {
+ # backdoor: I could not find a way to record sessions
+ print $_;
+ }
chomp;
} else {
last SHELLCOMMAND unless
$CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
my $command = shift @line;
eval { CPAN::Shell->$command(@line) };
- warn $@ if $@;
- if ($command =~ /^(make|test|install|force|notest|clean|upgrade)$/) {
+ if ($@ && "$@" =~ /\S/){
+ require Carp;
+ Carp::cluck("Catching error: '$@'");
+ }
+ if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
CPAN::Shell->failed($CPAN::CurrentCommandId,1);
}
soft_chdir_with_alternatives(\@cwd);
}
}
}
- if ($CPAN::DEBUG && $CPAN::DEBUG & $CPAN::DEBUG{CPAN}) {
- # debugging 'incommandcolor': should always be off at the end of a command
- # (incommandcolor is used to detect recursive dependencies)
- for my $class (qw(Module Distribution)) {
- for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
- next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
- CPAN->debug("BUG: $class '$dm' was in command state, resetting");
- delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
- }
+ for my $class (qw(Module Distribution)) {
+ # again unsafe meta access?
+ for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
+ next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
+ CPAN->debug("BUG: $class '$dm' was in command state, resetting");
+ delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
}
}
if ($GOTOSHELL) {
}
}
+sub _yaml_module () {
+ my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
+ if (
+ $yaml_module ne "YAML"
+ &&
+ !$CPAN::META->has_inst($yaml_module)
+ ) {
+ # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
+ $yaml_module = "YAML";
+ }
+ if ($yaml_module eq "YAML"
+ &&
+ $CPAN::META->has_inst($yaml_module)
+ &&
+ $YAML::VERSION < 0.60
+ &&
+ !$Have_warned->{"YAML"}++
+ ) {
+ $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
+ "I'll continue but problems are *very* likely to happen.\n"
+ );
+ $CPAN::Frontend->mysleep(5);
+ }
+ return $yaml_module;
+}
+
+# CPAN::_yaml_loadfile
+sub _yaml_loadfile {
+ my($self,$local_file) = @_;
+ return +[] unless -s $local_file;
+ my $yaml_module = _yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my $code;
+ if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
+ my @yaml;
+ eval { @yaml = $code->($local_file); };
+ if ($@) {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
+ }
+ return \@yaml;
+ } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
+ local *FH;
+ open FH, $local_file or die "Could not open '$local_file': $!";
+ local $/;
+ my $ystream = <FH>;
+ my @yaml;
+ eval { @yaml = $code->($ystream); };
+ if ($@) {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
+ }
+ return \@yaml;
+ }
+ } else {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
+ }
+ return +[];
+}
+
+# CPAN::_yaml_dumpfile
+sub _yaml_dumpfile {
+ my($self,$local_file,@what) = @_;
+ my $yaml_module = _yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my $code;
+ if (UNIVERSAL::isa($local_file, "FileHandle")) {
+ $code = UNIVERSAL::can($yaml_module, "Dump");
+ eval { print $local_file $code->(@what) };
+ } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
+ eval { $code->($local_file,@what); };
+ } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
+ local *FH;
+ open FH, ">$local_file" or die "Could not open '$local_file': $!";
+ print FH $code->(@what);
+ }
+ if ($@) {
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
+ }
+ } else {
+ if (UNIVERSAL::isa($local_file, "FileHandle")) {
+ # I think this case does not justify a warning at all
+ } else {
+ die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
+ }
+ }
+}
+
+sub _init_sqlite () {
+ unless ($CPAN::META->has_inst("CPAN::SQLite")) {
+ $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
+ unless $Have_warned->{"CPAN::SQLite"}++;
+ return;
+ }
+ require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
+ $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
+}
+
+{
+ my $negative_cache = {};
+ sub _sqlite_running {
+ if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
+ # need to cache the result, otherwise too slow
+ return $negative_cache->{fact};
+ } else {
+ $negative_cache = {}; # reset
+ }
+ my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
+ return $ret if $ret; # fast anyway
+ $negative_cache->{time} = time;
+ return $negative_cache->{fact} = $ret;
+ }
+}
+
package CPAN::CacheMgr;
use strict;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
package CPAN::FTP;
use strict;
+use Fcntl qw(:flock);
use vars qw($Ua $Thesite $ThesiteURL $Themethod);
@CPAN::FTP::ISA = qw(CPAN::Debug);
package CPAN::Complete;
use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
+# Q: where is the "How do I add a new command" HOWTO?
+# A: svn diff -r 1048:1049 where andk added the report command
@CPAN::Complete::COMMANDS = sort qw(
! a b d h i m o q r u
autobundle
clean
cvs_import
dump
+ failed
force
+ fforce
+ hosts
install
+ install_tested
+ is_tested
look
ls
make
recent
recompile
reload
+ report
+ reports
scripts
test
upgrade
package CPAN::Index;
use strict;
-use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
+use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
use strict;
use overload '""' => "as_string";
+# a module sees its distribution (no version)
+# a distribution sees its prereqs (which are module names) (usually with versions)
+# a bundle sees its module names and/or its distributions (no version)
+
sub new {
my($class) = shift;
my($deps) = shift;
- my @deps;
- my %seen;
- for my $dep (@$deps) {
- push @deps, $dep;
- last if $seen{$dep}++;
+ my (@deps,%seen,$loop_starts_with);
+ DCHAIN: for my $dep (@$deps) {
+ push @deps, {name => $dep, display_as => $dep};
+ if ($seen{$dep}++){
+ $loop_starts_with = $dep;
+ last DCHAIN;
+ }
+ }
+ my $in_loop = 0;
+ for my $i (0..$#deps) {
+ my $x = $deps[$i]{name};
+ $in_loop ||= $x eq $loop_starts_with;
+ my $xo = CPAN::Shell->expandany($x) or next;
+ if ($xo->isa("CPAN::Module")) {
+ my $have = $xo->inst_version || "N/A";
+ my($want,$d,$want_type);
+ if ($i>0 and $d = $deps[$i-1]{name}) {
+ my $do = CPAN::Shell->expandany($d);
+ $want = $do->{prereq_pm}{requires}{$x};
+ if (defined $want) {
+ $want_type = "requires: ";
+ } else {
+ $want = $do->{prereq_pm}{build_requires}{$x};
+ if (defined $want) {
+ $want_type = "build_requires: ";
+ } else {
+ $want_type = "unknown status";
+ $want = "???";
+ }
+ }
+ } else {
+ $want = $xo->cpan_version;
+ $want_type = "want: ";
+ }
+ $deps[$i]{have} = $have;
+ $deps[$i]{want_type} = $want_type;
+ $deps[$i]{want} = $want;
+ $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
+ } elsif ($xo->isa("CPAN::Distribution")) {
+ $deps[$i]{display_as} = $xo->pretty_id;
+ if ($in_loop) {
+ $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
+ } else {
+ $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
+ }
+ $xo->store_persistent_state; # otherwise I will not reach
+ # all involved parties for
+ # the next session
+ }
}
bless { deps => \@deps }, $class;
}
sub as_string {
my($self) = shift;
- "\nRecursive dependency detected:\n " .
- join("\n => ", @{$self->{deps}}) .
- ".\nCannot continue.\n";
+ my $ret = "\nRecursive dependency detected:\n ";
+ $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
+ $ret .= ".\nCannot resolve.\n";
+ $ret;
+}
+
+package CPAN::Exception::yaml_not_installed;
+use strict;
+use overload '""' => "as_string";
+
+sub new {
+ my($class,$module,$file,$during) = @_;
+ bless { module => $module, file => $file, during => $during }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
+}
+
+package CPAN::Exception::yaml_process_error;
+use strict;
+use overload '""' => "as_string";
+
+sub new {
+ my($class,$module,$file,$during,$error) = @_;
+ bless { module => $module,
+ file => $file,
+ during => $during,
+ error => $error }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($self->{during}) {
+ if ($self->{file}) {
+ if ($self->{module}) {
+ if ($self->{error}) {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' the following error was encountered:\n".
+ " $self->{error}\n";
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' some YAML file\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: unknown error encountered\n";
+ }
}
package CPAN::Prompt; use overload '""' => "as_string";
bless {}, shift;
}
sub as_string {
+ my $word = "cpan";
+ unless ($CPAN::META->{LOCK}) {
+ $word = "nolock_cpan";
+ }
if ($CPAN::Config->{commandnumber_in_prompt}) {
- sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
+ sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
} else {
- "cpan> ";
+ "$word> ";
}
}
TEXT => $arg,
FAILED => substr($arg,0,2) eq "NO",
COMMANDID => $CPAN::CurrentCommandId,
+ TIME => time,
}, $class;
}
sub commandid { shift->{COMMANDID} }
$COLOR_REGISTERED ||= 0;
{
- # $GLOBAL_AUTOLOAD_RECURSION = 12;
$autoload_recursion ||= 0;
#-> sub CPAN::Shell::AUTOLOAD ;
# from here on only subs.
################################################################################
+sub _perl_fingerprint {
+ my($self,$other_fingerprint) = @_;
+ my $dll = eval {OS2::DLLname()};
+ my $mtime_dll = 0;
+ if (defined $dll) {
+ $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
+ }
+ my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
+ my $this_fingerprint = {
+ '$^X' => $^X,
+ sitearchexp => $Config::Config{sitearchexp},
+ 'mtime_$^X' => $mtime_perl,
+ 'mtime_dll' => $mtime_dll,
+ };
+ if ($other_fingerprint) {
+ if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
+ $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
+ }
+ # mandatory keys since 1.88_57
+ for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
+ return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
+ }
+ return 1;
+ } else {
+ return $this_fingerprint;
+ }
+}
+
sub suggest_myconfig () {
SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
$CPAN::Frontend->myprint("You don't seem to have a user ".
"reports other host $otherhost and other ".
"process $otherpid.\n".
"Cannot proceed.\n"));
- }
- elsif (defined $otherpid && $otherpid) {
+ } elsif ($RUN_DEGRADED) {
+ $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
+ } elsif (defined $otherpid && $otherpid) {
return if $$ == $otherpid; # should never happen
$CPAN::Frontend->mywarn(
qq{
There seems to be running another CPAN process (pid $otherpid). Contacting...
});
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:
+ $CPAN::Frontend->mywarn(qq{Other job is running.\n});
+ my($ans) =
+ CPAN::Shell::colorable_makemaker_prompt
+ (qq{Shall I try to run in degraded }.
+ qq{mode? (Y/n)},"y");
+ if ($ans =~ /^y/i) {
+ $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
+Please report if something unexpected happens\n");
+ $RUN_DEGRADED = 1;
+ for ($CPAN::Config) {
+ # XXX
+ # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
+ $_->{commandnumber_in_prompt} = 0; # visibility
+ $_->{histfile} = ""; # who should win otherwise?
+ $_->{cache_metadata} = 0; # better would be a lock?
+ $_->{use_sqlite} = 0; # better would be a write lock!
+ }
+ } else {
+ $CPAN::Frontend->mydie("
+You may want to kill the other job and delete the lockfile. On UNIX try:
kill $otherpid
rm $lockfile
-});
+");
+ }
} elsif (-w $lockfile) {
my($ans) =
CPAN::Shell::colorable_makemaker_prompt
);
}
} else {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
- "reports other process with ID ".
- "$otherpid. Cannot proceed.\n"));
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
+ "'$lockfile', please remove. Cannot proceed.\n"));
}
}
my $dotcpan = $CPAN::Config->{cpan_home};
return suggest_myconfig;
}
} # $@ after eval mkpath $dotcpan
- my $fh;
- unless ($fh = FileHandle->new(">$lockfile")) {
- if ($! =~ /Permission/) {
- $CPAN::Frontend->myprint(qq{
+ if (0) { # to test what happens when a race condition occurs
+ for (reverse 1..10) {
+ print $_, "\n";
+ sleep 1;
+ }
+ }
+ # locking
+ if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
+ my $fh;
+ unless ($fh = FileHandle->new("+>>$lockfile")) {
+ if ($! =~ /Permission/) {
+ $CPAN::Frontend->myprint(qq{
Your configuration suggests that CPAN.pm should use a working
directory of
this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
\@INC path;
});
- return suggest_myconfig;
- }
+ return suggest_myconfig;
+ }
+ }
+ my $sleep = 1;
+ while (!flock $fh, LOCK_EX|LOCK_NB) {
+ if ($sleep>10) {
+ $CPAN::Frontend->mydie("Giving up\n");
+ }
+ $CPAN::Frontend->mysleep($sleep++);
+ $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
+ }
+
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ $fh->print($$, "\n");
+ $fh->print(hostname(), "\n");
+ $self->{LOCK} = $lockfile;
+ $self->{LOCKFH} = $fh;
}
- $fh->print($$, "\n");
- $fh->print(hostname(), "\n");
- $self->{LOCK} = $lockfile;
- $fh->close;
$SIG{TERM} = sub {
my $sig = shift;
&cleanup;
### Carp::croak "exists called without class argument" unless $class;
$id ||= "";
$id =~ s/:+/::/g if $class eq "CPAN::Module";
- exists $META->{readonly}{$class}{$id} or
- exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
+ my $exists;
+ if (CPAN::_sqlite_running) {
+ $exists = (exists $META->{readonly}{$class}{$id} or
+ $CPAN::SQLite->set($class, $id));
+ } else {
+ $exists = exists $META->{readonly}{$class}{$id};
+ }
+ $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
}
#-> sub CPAN::delete ;
],
'File::HomeDir' => [
sub {require File::HomeDir;
- unless (File::HomeDir->VERSION >= 0.52){
+ unless (File::HomeDir::->VERSION >= 0.52){
for ("Will not use File::HomeDir, need 0.52\n") {
$CPAN::Frontend->mywarn($_);
die $_;
}
},
],
+ 'Archive::Tar' => [
+ sub {require Archive::Tar;
+ unless (Archive::Tar::->VERSION >= 1.00) {
+ for ("Will not use Archive::Tar, need 1.00\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ],
};
if ($usable->{$mod}) {
for my $c (0..$#{$usable->{$mod}}) {
$CPAN::Frontend->mysleep(3);
} elsif ($mod eq "Digest::SHA"){
if ($Have_warned->{"Digest::SHA"}++) {
- $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
+ $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled }.
qq{because Digest::SHA not installed.\n});
} else {
$CPAN::Frontend->mywarn(qq{
$CPAN::Frontend->mysleep(2);
}
} elsif ($mod eq "Module::Signature"){
- if (not $CPAN::Config->{check_sigs}) {
+ # NOT prefs_lookup, we are not a distro
+ my $check_sigs = $CPAN::Config->{check_sigs};
+ if (not $check_sigs) {
# they do not want us:-(
} elsif (not $Have_warned->{"Module::Signature"}++) {
# No point in complaining unless the user can
return unless defined $META->{LOCK};
return unless -f $META->{LOCK};
$META->savehist;
+ close $META->{LOCKFH};
unlink $META->{LOCK};
# require Carp;
# Carp::cluck("DEBUGGING");
+ if ( $CPAN::CONFIG_DIRTY ) {
+ $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
+ }
$CPAN::Frontend->myprint("Lockfile removed.\n");
}
+#-> sub CPAN::readhist
+sub readhist {
+ my($self,$term,$histfile) = @_;
+ my($fh) = FileHandle->new;
+ open $fh, "<$histfile" or last;
+ local $/ = "\n";
+ while (<$fh>) {
+ chomp;
+ $term->AddHistory($_);
+ }
+ close $fh;
+}
+
#-> sub CPAN::savehist
sub savehist {
my($self) = @_;
close $fh;
}
+#-> sub CPAN::is_tested
sub is_tested {
- my($self,$what) = @_;
- $self->{is_tested}{$what} = 1;
+ my($self,$what,$when) = @_;
+ unless ($what) {
+ Carp::cluck("DEBUG: empty what");
+ return;
+ }
+ $self->{is_tested}{$what} = $when;
}
+#-> sub CPAN::is_installed
# unsets the is_tested flag: as soon as the thing is installed, it is
# not needed in set_perl5lib anymore
sub is_installed {
delete $self->{is_tested}{$what};
}
-sub set_perl5lib {
+sub _list_sorted_descending_is_tested {
my($self) = @_;
+ sort
+ { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
+ keys %{$self->{is_tested}}
+}
+
+#-> sub CPAN::set_perl5lib
+sub set_perl5lib {
+ my($self,$for) = @_;
+ unless ($for) {
+ (undef,undef,undef,$for) = caller(1);
+ $for =~ s/.*://;
+ }
$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");
+ #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
+ #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
+
+ my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
+ if (@dirs < 12) {
+ $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
+ } elsif (@dirs < 24) {
+ my @d = map {my $cp = $_;
+ $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
+ $cp
+ } @dirs;
+ $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
+ "%BUILDDIR%=$CPAN::Config->{build_dir} ".
+ "for '$for'\n"
+ );
+ } else {
+ my $cnt = keys %{$self->{is_tested}};
+ $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
+ "$cnt build dirs to PERL5LIB; ".
+ "for '$for'\n"
+ );
+ }
+
$ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
}
#-> sub CPAN::CacheMgr::tidyup ;
sub tidyup {
my($self) = @_;
+ return unless $CPAN::META->{LOCK};
return unless -d $self->{ID};
- while ($self->{DU} > $self->{'MAX'} ) {
- my($toremove) = shift @{$self->{FIFO}};
+ my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
+ for my $current (0..$#toremove) {
+ my $toremove = $toremove[$current];
$CPAN::Frontend->myprint(sprintf(
- "Deleting from cache".
- ": $toremove (%.1f>%.1f MB)\n",
- $self->{DU}, $self->{'MAX'})
- );
+ "DEL(%d/%d): %s \n",
+ $current+1,
+ scalar @toremove,
+ $toremove,
+ )
+ );
return if $CPAN::Signal;
- $self->force_clean_cache($toremove);
+ $self->_clean_cache($toremove);
return if $CPAN::Signal;
}
}
}
}
chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
- sort { -M $b <=> -M $a} @entries;
+ sort { -M $a <=> -M $b} @entries;
}
#-> sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
- my($self,$dir) = @_;
+ my($self,$dir,$fast) = @_;
return if exists $self->{SIZE}{$dir};
return if $CPAN::Signal;
my($Du) = 0;
if (-e $dir) {
- unless (-x $dir) {
- unless (chmod 0755, $dir) {
- $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
- "permission to change the permission; cannot ".
- "estimate disk usage of '$dir'\n");
- $CPAN::Frontend->mysleep(5);
- return;
+ if (-d $dir) {
+ unless (-x $dir) {
+ unless (chmod 0755, $dir) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
+ "permission to change the permission; cannot ".
+ "estimate disk usage of '$dir'\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
}
+ } elsif (-f $dir) {
+ # nothing to say, no matter what the permissions
}
} else {
- $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
+ $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
return;
}
- find(
- sub {
+ if ($fast) {
+ $Du = 0; # placeholder
+ } else {
+ find(
+ sub {
$File::Find::prune++ if $CPAN::Signal;
return if -l $_;
if ($^O eq 'MacOS') {
}
},
$dir
- );
+ );
+ }
return if $CPAN::Signal;
$self->{SIZE}{$dir} = $Du/1024/1024;
- push @{$self->{FIFO}}, $dir;
+ unshift @{$self->{FIFO}}, $dir;
$self->debug("measured $dir is $Du") if $CPAN::DEBUG;
$self->{DU} += $Du/1024/1024;
$self->{DU};
}
-#-> sub CPAN::CacheMgr::force_clean_cache ;
-sub force_clean_cache {
+#-> sub CPAN::CacheMgr::_clean_cache ;
+sub _clean_cache {
my($self,$dir) = @_;
return unless -e $dir;
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
+ $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
+ "will not remove\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
$self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
if $CPAN::DEBUG;
File::Path::rmtree($dir);
+ my $id_deleted = 0;
+ if ($dir !~ /\.yml$/ && -f "$dir.yml") {
+ my $yaml_module = CPAN::_yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
+ unlink "$dir.yml" or
+ $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
+ return;
+ } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
+ $CPAN::META->delete("CPAN::Distribution", $id);
+
+ # XXX we should restore the state NOW, otherise this
+ # distro does not exist until we read an index. BUG ALERT(?)
+
+ # $CPAN::Frontend->mywarn (" +++\n");
+ $id_deleted++;
+ }
+ }
+ unlink "$dir.yml"; # may fail
+ unless ($id_deleted) {
+ CPAN->debug("no distro found associated with '$dir'");
+ }
+ }
$self->{DU} -= $self->{SIZE}{$dir};
delete $self->{SIZE}{$dir};
}
my($debug,$t2);
$debug = "";
my $self = {
- ID => $CPAN::Config->{'build_dir'},
+ ID => $CPAN::Config->{build_dir},
MAX => $CPAN::Config->{'build_cache'},
SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
DU => 0
return if $self->{SCAN} eq 'never';
$CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
unless $self->{SCAN} eq 'atstart';
+ return unless $CPAN::META->{LOCK};
$CPAN::Frontend->myprint(
sprintf("Scanning cache %s for sizes\n",
$self->{ID}));
my $e;
- for $e ($self->entries($self->{ID})) {
- next if $e eq ".." || $e eq ".";
- $self->disk_usage($e);
+ my @entries = $self->entries($self->{ID});
+ my $i = 0;
+ my $painted = 0;
+ for $e (@entries) {
+ my $symbol = ".";
+ if ($self->{DU} > $self->{MAX}) {
+ $symbol = "-";
+ $self->disk_usage($e,1);
+ } else {
+ $self->disk_usage($e);
+ }
+ $i++;
+ while (($painted/76) < ($i/@entries)) {
+ $CPAN::Frontend->myprint($symbol);
+ $painted++;
+ }
return if $CPAN::Signal;
}
+ $CPAN::Frontend->myprint("DONE\n");
$self->tidyup;
}
upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
Pragmas
- force COMMAND unconditionally do command
- notest COMMAND skip testing
+ force CMD try hard to do command fforce CMD try harder
+ notest CMD skip testing
Other
h,? display this menu ! perl-code eval a perl command
$pathglob = $2;
$author = CPAN::Shell->expand_by_method('CPAN::Author',
['id'],
- $a2) or die "No author found for $a2";
+ $a2)
+ or $CPAN::Frontend->mydie("No author found for $a2\n");
} else {
$author = CPAN::Shell->expand_by_method('CPAN::Author',
['id'],
- $a) or die "No author found for $a";
+ $a)
+ or $CPAN::Frontend->mydie("No author found for $a\n");
}
if ($silent) {
my $alpha = substr $author->id, 0, 1;
# more than one
# author
for my $pragma (@$pragmas) {
- my $meth = "un$pragma";
- if ($author->can($meth)) {
- $author->$meth();
+ my $unpragma = "un$pragma";
+ if ($author->can($unpragma)) {
+ $author->$unpragma();
}
}
}
# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
sub o {
my($self,$o_type,@o_what) = @_;
- $DB::single = 1;
$o_type ||= "";
CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
if ($o_type eq 'conf') {
CPAN::HandleConfig->prettyprint($k);
}
$CPAN::Frontend->myprint("\n");
- } elsif (!CPAN::HandleConfig->edit(@o_what)) {
- $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
- qq{items\n\n});
+ } else {
+ if (CPAN::HandleConfig->edit(@o_what)) {
+ } else {
+ $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
+ qq{items\n\n});
+ }
}
} elsif ($o_type eq 'debug') {
my(%valid);
};
}
+#-> sub CPAN::Shell::hosts ;
+sub hosts {
+ my($self) = @_;
+ my $fullstats = CPAN::FTP->_ftp_statistics();
+ my $history = $fullstats->{history} || [];
+ my %S; # statistics
+ while (my $last = pop @$history) {
+ my $attempts = $last->{attempts} or next;
+ my $start;
+ if (@$attempts) {
+ $start = $attempts->[-1]{start};
+ if ($#$attempts > 0) {
+ for my $i (0..$#$attempts-1) {
+ my $url = $attempts->[$i]{url} or next;
+ $S{no}{$url}++;
+ }
+ }
+ } else {
+ $start = $last->{start};
+ }
+ next unless $last->{thesiteurl}; # C-C? bad filenames?
+ $S{start} = $start;
+ $S{end} ||= $last->{end};
+ my $dltime = $last->{end} - $start;
+ my $dlsize = $last->{filesize} || 0;
+ my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
+ my $s = $S{ok}{$url} ||= {};
+ $s->{n}++;
+ $s->{dlsize} ||= 0;
+ $s->{dlsize} += $dlsize/1024;
+ $s->{dltime} ||= 0;
+ $s->{dltime} += $dltime;
+ }
+ my $res;
+ for my $url (keys %{$S{ok}}) {
+ next if $S{ok}{$url}{dltime} == 0; # div by zero
+ push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
+ $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
+ $url,
+ ];
+ }
+ for my $url (keys %{$S{no}}) {
+ push @{$res->{no}}, [$S{no}{$url},
+ $url,
+ ];
+ }
+ my $R = ""; # report
+ if ($S{start} && $S{end}) {
+ $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
+ $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
+ }
+ if ($res->{ok} && @{$res->{ok}}) {
+ $R .= sprintf "\nSuccessful downloads:
+ N kB secs kB/s url\n";
+ my $i = 20;
+ for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
+ $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
+ last if --$i<=0;
+ }
+ }
+ if ($res->{no} && @{$res->{no}}) {
+ $R .= sprintf "\nUnsuccessful downloads:\n";
+ my $i = 20;
+ for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
+ $R .= sprintf "%4d %s\n", @$_;
+ last if --$i<=0;
+ }
+ }
+ $CPAN::Frontend->myprint($R);
+}
+
#-> sub CPAN::Shell::reload ;
sub reload {
my($self,$command,@arg) = @_;
my $failed;
my @relo = (
"CPAN.pm",
- "CPAN/HandleConfig.pm",
- "CPAN/FirstTime.pm",
- "CPAN/Tarzip.pm",
"CPAN/Debug.pm",
- "CPAN/Version.pm",
+ "CPAN/FirstTime.pm",
+ "CPAN/HandleConfig.pm",
+ "CPAN/Kwalify.pm",
"CPAN/Queue.pm",
"CPAN/Reporter.pm",
+ "CPAN/SQLite.pm",
+ "CPAN/Tarzip.pm",
+ "CPAN/Version.pm",
);
MFILE: for my $f (@relo) {
next unless exists $INC{$f};
$p =~ s|/|::|g;
$CPAN::Frontend->myprint("($p");
local($SIG{__WARN__}) = paintdots_onreload(\$redef);
- $self->reload_this($f) or $failed++;
+ $self->_reload_this($f) or $failed++;
my $v = eval "$p\::->VERSION";
$CPAN::Frontend->myprint("v$v)");
}
}
# reload means only load again what we have loaded before
-#-> sub CPAN::Shell::reload_this ;
-sub reload_this {
+#-> sub CPAN::Shell::_reload_this ;
+sub _reload_this {
my($self,$f,$args) = @_;
CPAN->debug("f[$f]") if $CPAN::DEBUG;
return 1 unless $INC{$f}; # we never loaded this, so we do not
unless ($file && -f $file) {
# this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
$file = $INC{$f};
- @inc = substr($file,0,-length($f)); # bring in back to me!
+ unless (CPAN->has_inst("File::Basename")) {
+ @inc = File::Basename::dirname($file);
+ } else {
+ # do we ever need this?
+ @inc = substr($file,0,-length($f)-1); # bring in back to me!
+ }
}
CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
unless (-f $file) {
$reload->{$f} ||= $^T;
my $must_reload = $mtime > $reload->{$f};
$args ||= {};
- $must_reload ||= $args->{force};
+ $must_reload ||= $args->{reloforce};
if ($must_reload) {
my $fh = FileHandle->new($file) or
$CPAN::Frontend->mydie("Could not open $file: $!");
# don't do it twice
$cpan_file = $module->cpan_file;
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->force;
+ $pack->force; #
$dist{$cpan_file}++;
}
for $cpan_file (sort keys %dist) {
}
}
+#-> sub CPAN::Shell::report ;
+sub report {
+ my($self,@args) = @_;
+ unless ($CPAN::META->has_inst("CPAN::Reporter")) {
+ $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
+ }
+ local $CPAN::Config->{test_report} = 1;
+ $self->force("test",@args); # force is there so that the test be
+ # re-run (as documented)
+}
+
+# compare with is_tested
+#-> sub CPAN::Shell::install_tested
+sub install_tested {
+ my($self,@some) = @_;
+ $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
+ return if @some;
+ CPAN::Index->reload;
+
+ for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
+ my $yaml = "$b.yml";
+ unless (-f $yaml){
+ $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
+ next;
+ }
+ my $yaml_content = CPAN->_yaml_loadfile($yaml);
+ my $id = $yaml_content->[0]{distribution}{ID};
+ unless ($id){
+ $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
+ next;
+ }
+ my $do = CPAN::Shell->expandany($id);
+ unless ($do){
+ $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
+ next;
+ }
+ unless ($do->{build_dir}) {
+ $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
+ next;
+ }
+ unless ($do->{build_dir} eq $b) {
+ $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
+ next;
+ }
+ push @some, $do;
+ }
+
+ $CPAN::Frontend->mywarn("No tested distributions found.\n"),
+ return unless @some;
+
+ @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
+ $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
+ return unless @some;
+
+ # @some = grep { not $_->uptodate } @some;
+ # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
+ # return unless @some;
+
+ CPAN->debug("some[@some]");
+ for my $d (@some) {
+ my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
+ $CPAN::Frontend->myprint("install_tested: Running for $id\n");
+ $CPAN::Frontend->mysleep(1);
+ $self->install($d);
+ }
+}
+
#-> sub CPAN::Shell::upgrade ;
sub upgrade {
my($self,@args) = @_;
}
my $color_on = "";
my $color_off = "";
- # $GLOBAL_AUTOLOAD_RECURSION = 12;
if (
$COLOR_REGISTERED
&&
my @failed;
DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
my $failed = "";
- NAY: for my $nosayer (
+ NAY: for my $nosayer ( # order matters!
+ "unwrapped",
"writemakefile",
"signature_verify",
"make",
"make_clean",
) {
next unless exists $d->{$nosayer};
+ next unless defined $d->{$nosayer};
next unless (
- $d->{$nosayer}->can("failed") ?
+ UNIVERSAL::can($d->{$nosayer},"failed") ?
$d->{$nosayer}->failed :
$d->{$nosayer} =~ /^NO/
);
next NAY if $only_id && $only_id != (
- $d->{$nosayer}->can("commandid")
+ UNIVERSAL::can($d->{$nosayer},"commandid")
?
$d->{$nosayer}->commandid
:
# " %-45s: %s %s\n",
push @failed,
(
- $d->{$failed}->can("failed") ?
+ UNIVERSAL::can($d->{$failed},"failed") ?
[
$d->{$failed}->commandid,
$id,
$failed,
$d->{$failed}->text,
+ $d->{$failed}{TIME}||0,
] :
[
1,
$id,
$failed,
$d->{$failed},
+ 0,
]
);
}
- my $scope = $only_id ? "command" : "session";
+ my $scope;
+ if ($only_id) {
+ $scope = "this command";
+ } elsif ($CPAN::Index::HAVE_REANIMATED) {
+ $scope = "this or a previous session";
+ # it might be nice to have a section for previous session and
+ # a second for this
+ } else {
+ $scope = "this session";
+ }
if (@failed) {
- my $print = join "",
- map { sprintf " %-45s: %s %s\n", @$_[1,2,3] }
- sort { $a->[0] <=> $b->[0] } @failed;
- $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
+ my $print;
+ my $debug = 0;
+ if ($debug) {
+ $print = join "",
+ map { sprintf "%5d %-45s: %s %s\n", @$_ }
+ sort { $a->[0] <=> $b->[0] } @failed;
+ } else {
+ $print = join "",
+ map { sprintf " %-45s: %s %s\n", @$_[1..3] }
+ sort {
+ $a->[0] <=> $b->[0]
+ ||
+ $a->[4] <=> $b->[4]
+ } @failed;
+ }
+ $CPAN::Frontend->myprint("Failed during $scope:\n$print");
} elsif (!$only_id || !$silent) {
- $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
+ $CPAN::Frontend->myprint("Nothing failed in $scope\n");
}
}
}
}
+# compare with install_tested
+#-> sub CPAN::Shell::is_tested
+sub is_tested {
+ my($self) = @_;
+ CPAN::Index->reload;
+ for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
+ my $time;
+ if ($CPAN::META->{is_tested}{$b}) {
+ $time = scalar(localtime $CPAN::META->{is_tested}{$b});
+ } else {
+ $time = scalar localtime;
+ $time =~ s/\S/?/g;
+ }
+ $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
+ }
+}
+
#-> sub CPAN::Shell::autobundle ;
sub autobundle {
my($self) = shift;
sub expandany {
my($self,$s) = @_;
CPAN->debug("s[$s]") if $CPAN::DEBUG;
- if ($s =~ m|/|) { # looks like a file
+ if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
$s = CPAN::Distribution->normalize($s);
return $CPAN::META->instance('CPAN::Distribution',$s);
# Distributions spring into existence, not expand
my $class = "CPAN::$type";
my $methods = ['id'];
for my $meth (qw(name)) {
- next if $] < 5.00303; # no "can"
next unless $class->can($meth);
push @$methods, $meth;
}
$self->expand_by_method($class,$methods,@args);
}
+#-> sub CPAN::Shell::expand_by_method ;
sub expand_by_method {
my $self = shift;
my($class,$methods,@args) = @_;
defined $command ? $command : "UNDEFINED",
) if $CPAN::DEBUG;
if (defined $regex) {
+ if (CPAN::_sqlite_running) {
+ $CPAN::SQLite->search($class, $regex);
+ }
for $obj (
$CPAN::META->all_objects($class)
) {
- unless ($obj->id){
+ unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
# BUG, we got an empty object somewhere
require Data::Dumper;
CPAN->debug(sprintf(
if ($CPAN::META->has_inst("File::Temp")) {
$installation_report_fh
= File::Temp->new(
+ dir => File::Spec->tmpdir,
template => 'cpan_install_XXXX',
suffix => '.txt',
unlink => 0,
}
+#-> sub CPAN::Shell::print_ornamented ;
sub print_ornamented {
my($self,$what,$ornament) = @_;
return unless defined $what;
if ($self->colorize_output) {
if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
# if you want to have this configurable, please file a bugreport
- $ornament = "black on_cyan";
+ $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
}
my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
if ($@) {
print "Term::ANSIColor rejects color[$ornament]: $@\n
-Please choose a different color (Hint: try 'o conf init color.*')\n";
+Please choose a different color (Hint: try 'o conf init /color/')\n";
}
print $color_on,
$swhat,
}
}
+#-> sub CPAN::Shell::myprint ;
+
# where is myprint/mywarn/Frontend/etc. documented? We need guidelines
# where to use what! I think, we send everything to STDOUT and use
# print for normal/good news and warn for news that need more
$self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
}
+#-> sub CPAN::Shell::myexit ;
sub myexit {
my($self,$what) = @_;
$self->myprint($what);
exit;
}
+#-> sub CPAN::Shell::mywarn ;
sub mywarn {
my($self,$what) = @_;
$self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
}
# only to be used for shell commands
+#-> sub CPAN::Shell::mydie ;
sub mydie {
my($self,$what) = @_;
- $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
+ $self->mywarn($what);
- # If it is the shell, we want that the following die to be silent,
+ # If it is the shell, we want the following die to be silent,
# but if it is not the shell, we would need a 'die $what'. We need
# to take care that only shell commands use mydie. Is this
# possible?
die "\n";
}
-# sub CPAN::Shell::colorable_makemaker_prompt
+# sub CPAN::Shell::colorable_makemaker_prompt ;
sub colorable_makemaker_prompt {
my($foo,$bar) = @_;
if (CPAN::Shell->colorize_output) {
}
# use this only for unrecoverable errors!
+#-> sub CPAN::Shell::unrecoverable_error ;
sub unrecoverable_error {
my($self,$what) = @_;
my @lines = split /\n/, $what;
$self->mydie(join "", @lines);
}
+#-> sub CPAN::Shell::mysleep ;
sub mysleep {
my($self, $sleep) = @_;
- sleep $sleep;
+ if (CPAN->has_inst("Time::HiRes")) {
+ Time::HiRes::sleep($sleep);
+ } else {
+ sleep($sleep < 1 ? 1 : int($sleep + 0.5));
+ }
}
+#-> sub CPAN::Shell::setup_output ;
sub setup_output {
return if -t STDOUT;
my $odef = select STDERR;
}
#-> sub CPAN::Shell::rematein ;
-# RE-adme||MA-ke||TE-st||IN-stall
+# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
sub rematein {
my $self = shift;
my($meth,@some) = @_;
my @pragma;
- while($meth =~ /^(force|notest)$/) {
+ while($meth =~ /^(ff?orce|notest)$/) {
push @pragma, $meth;
$meth = shift @some or
$CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
# enter the queue but not its copy. How do they get a sensible
# test_count?
+ my $needs_recursion_protection = "make|test|install";
+
# construct the queue
my($s,@s,@qcopy);
STHING: foreach $s (@some) {
$obj = $s;
} elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
} elsif ($s =~ m|^/|) { # looks like a regexp
- $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
- "not supported.\nRejecting argument '$s'\n");
- $CPAN::Frontend->mysleep(2);
- next;
+ if (substr($s,-1,1) eq ".") {
+ $obj = CPAN::Shell->expandany($s);
+ } else {
+ $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
+ "not supported.\nRejecting argument '$s'\n");
+ $CPAN::Frontend->mysleep(2);
+ next;
+ }
} elsif ($meth eq "ls") {
$self->globls($s,\@pragma);
next STHING;
}
if (0) {
} elsif (ref $obj) {
- $obj->color_cmd_tmps(0,1);
- CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
- push @qcopy, $obj;
- } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
+ if ($meth =~ /^($needs_recursion_protection)$/) {
+ # it would be silly to check for recursion for look or dump
+ # (we are in CPAN::Shell::rematein)
+ CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
+ eval { $obj->color_cmd_tmps(0,1); };
+ if ($@){
+ if (ref $@
+ and $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ } else {
+ if (0) {
+ require Carp;
+ Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
+ }
+ die;
+ }
+ }
+ }
+ CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
+ push @qcopy, $obj;
+ } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
$obj = $CPAN::META->instance('CPAN::Author',uc($s));
- if ($meth =~ /^(dump|ls)$/) {
+ if ($meth =~ /^(dump|ls|reports)$/) {
$obj->$meth();
} else {
$CPAN::Frontend->mywarn(
my $s = $q->as_string;
my $reqtype = $q->reqtype || "";
$obj = CPAN::Shell->expandany($s);
+ unless ($obj) {
+ # don't know how this can happen, maybe we should panic,
+ # but maybe we get a solution from the first user who hits
+ # this unfortunate exception?
+ $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
+ "to an object. Skipping.\n");
+ $CPAN::Frontend->mysleep(5);
+ CPAN::Queue->delete_first($s);
+ next;
+ }
$obj->{reqtype} ||= "";
- CPAN->debug("obj-reqtype[$obj->{reqtype}]".
- "q-reqtype[$reqtype]") if $CPAN::DEBUG;
+ {
+ # force debugging because CPAN::SQLite somehow delivers us
+ # an empty object;
+
+ # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
+
+ CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
+ "q-reqtype[$reqtype]") if $CPAN::DEBUG;
+ }
if ($obj->{reqtype}) {
if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
$obj->{reqtype} = $reqtype;
exists $obj->{install}
&&
(
- $obj->{install}->can("failed") ?
+ UNIVERSAL::can($obj->{install},"failed") ?
$obj->{install}->failed :
$obj->{install} =~ /^NO/
)
for my $pragma (@pragma) {
if ($pragma
&&
- ($] < 5.00303 || $obj->can($pragma))){
- ### compatibility with 5.003
- $obj->$pragma($meth); # the pragma "force" in
- # "CPAN::Distribution" must know
- # what we are intending
+ $obj->can($pragma)){
+ $obj->$pragma($meth);
}
}
- if ($]>=5.00303 && $obj->can('called_for')) {
+ if (UNIVERSAL::can($obj, 'called_for')) {
$obj->called_for($s);
}
CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
push @qcopy, $obj;
- if ($obj->$meth()){
+ if (! UNIVERSAL::can($obj,$meth)) {
+ # Must never happen
+ my $serialized = "";
+ if (0) {
+ } elsif ($CPAN::META->has_inst("YAML::Syck")) {
+ $serialized = YAML::Syck::Dump($obj);
+ } elsif ($CPAN::META->has_inst("YAML")) {
+ $serialized = YAML::Dump($obj);
+ } elsif ($CPAN::META->has_inst("Data::Dumper")) {
+ $serialized = Data::Dumper::Dumper($obj);
+ } else {
+ require overload;
+ $serialized = overload::StrVal($obj);
+ }
+ CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
+ $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
+ } elsif ($obj->$meth()){
CPAN::Queue->delete($s);
+ CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
} else {
- CPAN->debug("failed");
+ CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
}
$obj->undelay;
+ for my $pragma (@pragma) {
+ my $unpragma = "un$pragma";
+ if ($obj->can($unpragma)) {
+ $obj->$unpragma();
+ }
+ }
CPAN::Queue->delete_first($s);
}
- for my $obj (@qcopy) {
- $obj->color_cmd_tmps(0,0);
- delete $obj->{incommandcolor};
+ if ($meth =~ /^($needs_recursion_protection)$/) {
+ for my $obj (@qcopy) {
+ $obj->color_cmd_tmps(0,0);
+ }
}
}
cvs_import
dump
force
+ fforce
get
install
look
notest
perldoc
readme
+ reports
test
)) {
*$command = sub { shift->rematein($command, @_); };
}
sub _get_username_and_password_from_user {
- my $self = shift;
my $username_message = shift;
my ($username,$password);
package CPAN::FTP;
use strict;
+#-> sub CPAN::FTP::ftp_statistics
+# if they want to rewrite, they need to pass in a filehandle
+sub _ftp_statistics {
+ my($self,$fh) = @_;
+ my $locktype = $fh ? LOCK_EX : LOCK_SH;
+ $fh ||= FileHandle->new;
+ my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
+ open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
+ my $sleep = 1;
+ my $waitstart;
+ while (!flock $fh, $locktype|LOCK_NB) {
+ $waitstart ||= localtime();
+ if ($sleep>3) {
+ $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
+ }
+ $CPAN::Frontend->mysleep($sleep);
+ if ($sleep <= 3) {
+ $sleep+=0.33;
+ } elsif ($sleep <=6) {
+ $sleep+=0.11;
+ }
+ }
+ my $stats = eval { CPAN->_yaml_loadfile($file); };
+ if ($@) {
+ if (ref $@) {
+ if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
+ $CPAN::Frontend->myprint("Warning (usually harmless): $@");
+ return;
+ } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
+ $CPAN::Frontend->mydie($@);
+ }
+ } else {
+ $CPAN::Frontend->mydie($@);
+ }
+ }
+ return $stats->[0];
+}
+
+#-> sub CPAN::FTP::_mytime
+sub _mytime () {
+ if (CPAN->has_inst("Time::HiRes")) {
+ return Time::HiRes::time();
+ } else {
+ return time;
+ }
+}
+
+#-> sub CPAN::FTP::_new_stats
+sub _new_stats {
+ my($self,$file) = @_;
+ my $ret = {
+ file => $file,
+ attempts => [],
+ start => _mytime,
+ };
+ $ret;
+}
+
+#-> sub CPAN::FTP::_add_to_statistics
+sub _add_to_statistics {
+ my($self,$stats) = @_;
+ my $yaml_module = CPAN::_yaml_module;
+ $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ $stats->{thesiteurl} = $ThesiteURL;
+ if (CPAN->has_inst("Time::HiRes")) {
+ $stats->{end} = Time::HiRes::time();
+ } else {
+ $stats->{end} = time;
+ }
+ my $fh = FileHandle->new;
+ my $time = time;
+ my $sdebug = 0;
+ my @debug;
+ @debug = $time if $sdebug;
+ my $fullstats = $self->_ftp_statistics($fh);
+ close $fh;
+ $fullstats->{history} ||= [];
+ push @debug, scalar @{$fullstats->{history}} if $sdebug;
+ push @debug, time if $sdebug;
+ push @{$fullstats->{history}}, $stats;
+ # arbitrary hardcoded constants until somebody demands to have
+ # them settable; YAML.pm 0.62 is unacceptably slow with 999;
+ # YAML::Syck 0.82 has no noticable performance problem with 999;
+ while (
+ @{$fullstats->{history}} > 99
+ || $time - $fullstats->{history}[0]{start} > 14*86400
+ ) {
+ shift @{$fullstats->{history}}
+ }
+ push @debug, scalar @{$fullstats->{history}} if $sdebug;
+ push @debug, time if $sdebug;
+ push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
+ # need no eval because if this fails, it is serious
+ my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
+ CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
+ if ( $sdebug ) {
+ local $CPAN::DEBUG = 512; # FTP
+ push @debug, time;
+ CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
+ "after[%d]at[%d]oldest[%s]dumped backat[%d]",
+ @debug,
+ ));
+ }
+ # Win32 cannot rename a file to an existing filename
+ unlink($sfile) if ($^O eq 'MSWin32');
+ rename "$sfile.$$", $sfile
+ or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
+ }
+}
+
+# if file is CHECKSUMS, suggest the place where we got the file to be
+# checked from, maybe only for young files?
+#-> sub CPAN::FTP::_recommend_url_for
+sub _recommend_url_for {
+ my($self, $file) = @_;
+ my $urllist = $self->_get_urllist;
+ if ($file =~ s|/CHECKSUMS(.gz)?$||) {
+ my $fullstats = $self->_ftp_statistics();
+ my $history = $fullstats->{history} || [];
+ while (my $last = pop @$history) {
+ last if $last->{end} - time > 3600; # only young results are interesting
+ next unless $last->{file}; # dirname of nothing dies!
+ next unless $file eq File::Basename::dirname($last->{file});
+ return $last->{thesiteurl};
+ }
+ }
+ if ($CPAN::Config->{randomize_urllist}
+ &&
+ rand(1) < $CPAN::Config->{randomize_urllist}
+ ) {
+ $urllist->[int rand scalar @$urllist];
+ } else {
+ return ();
+ }
+}
+
+#-> sub CPAN::FTP::_get_urllist
+sub _get_urllist {
+ my($self) = @_;
+ $CPAN::Config->{urllist} ||= [];
+ unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
+ $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
+ $CPAN::Config->{urllist} = [];
+ }
+ my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
+ for my $u (@urllist) {
+ CPAN->debug("u[$u]") if $CPAN::DEBUG;
+ if (UNIVERSAL::can($u,"text")) {
+ $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
+ } else {
+ $u .= "/" unless substr($u,-1) eq "/";
+ $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
+ }
+ }
+ \@urllist;
+}
+
#-> sub CPAN::FTP::ftp_get ;
sub ftp_get {
my($class,$host,$dir,$file,$target) = @_;
"could not remove.");
}
}
- my($restore) = 0;
+ my($maybe_restore) = 0;
if (-f $aslocal){
- rename $aslocal, "$aslocal.bak";
- $restore++;
+ rename $aslocal, "$aslocal.bak$$";
+ $maybe_restore++;
}
my($aslocal_dir) = File::Basename::dirname($aslocal);
if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
$Ua->proxy('http', $var)
if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
-
-
-# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
-#
-# > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
-# > use ones that require basic autorization.
-#
-# > Example of when I use it manually in my own stuff:
-#
-# > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
-# > $req->proxy_authorization_basic("username","password");
-# > $res = $ua->request($req);
-#
-
$Ua->no_proxy($var)
if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
}
# Try the list of urls for each single object. We keep a record
# where we did get a file from
my(@reordered,$last);
- $CPAN::Config->{urllist} ||= [];
- unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
- $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
- $CPAN::Config->{urllist} = [];
- }
- $last = $#{$CPAN::Config->{urllist}};
+ my $ccurllist = $self->_get_urllist;
+ $last = $#$ccurllist;
if ($force & 2) { # local cpans probably out of date, don't reorder
@reordered = (0..$last);
} else {
@reordered =
sort {
- (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
+ (substr($ccurllist->[$b],0,4) eq "file")
<=>
- (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
+ (substr($ccurllist->[$a],0,4) eq "file")
or
defined($ThesiteURL)
and
- ($CPAN::Config->{urllist}[$b] eq $ThesiteURL)
+ ($ccurllist->[$b] eq $ThesiteURL)
<=>
- ($CPAN::Config->{urllist}[$a] eq $ThesiteURL)
+ ($ccurllist->[$a] eq $ThesiteURL)
} 0..$last;
}
my(@levels);
$Themethod ||= "";
- $self->debug("Themethod[$Themethod]") if $CPAN::DEBUG;
+ $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
if ($Themethod) {
@levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
} else {
local $ENV{FTP_PASSIVE} =
exists $CPAN::Config->{ftp_passive} ?
$CPAN::Config->{ftp_passive} : 1;
- for $levelno (0..$#levels) {
+ my $ret;
+ my $stats = $self->_new_stats($file);
+ LEVEL: for $levelno (0..$#levels) {
my $level = $levels[$levelno];
my $method = "host$level";
my @host_seq = $level eq "easy" ?
@reordered : 0..$last; # reordered has CDROM up front
- my @urllist = map { $CPAN::Config->{urllist}[$_] } @host_seq;
- for my $u (@urllist) {
- if ($u->can("text")) {
- $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
- } else {
- $u .= "/" unless substr($u,-1) eq "/";
- $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
- }
- }
+ my @urllist = map { $ccurllist->[$_] } @host_seq;
for my $u (@CPAN::Defaultsites) {
push @urllist, $u unless grep { $_ eq $u } @urllist;
}
$self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
- my $ret = $self->$method(\@urllist,$file,$aslocal);
+ my $aslocal_tempfile = $aslocal . ".tmp" . $$;
+ if (my $recommend = $self->_recommend_url_for($file)) {
+ @urllist = grep { $_ ne $recommend } @urllist;
+ unshift @urllist, $recommend;
+ }
+ $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
+ $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
if ($ret) {
- $Themethod = $level;
- my $now = time;
- # utime $now, $now, $aslocal; # too bad, if we do that, we
- # might alter a local mirror
- $self->debug("level[$level]") if $CPAN::DEBUG;
- return $ret;
+ CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
+ if ($ret eq $aslocal_tempfile) {
+ # if we got it exactly as we asked for, only then we
+ # want to rename
+ rename $aslocal_tempfile, $aslocal
+ or $CPAN::Frontend->mydie("Error while trying to rename ".
+ "'$ret' to '$aslocal': $!");
+ $ret = $aslocal;
+ }
+ $Themethod = $level;
+ my $now = time;
+ # utime $now, $now, $aslocal; # too bad, if we do that, we
+ # might alter a local mirror
+ $self->debug("level[$level]") if $CPAN::DEBUG;
+ last LEVEL;
} else {
- unlink $aslocal;
- last if $CPAN::Signal; # need to cleanup
+ unlink $aslocal_tempfile;
+ last if $CPAN::Signal; # need to cleanup
}
}
+ if ($ret) {
+ $stats->{filesize} = -s $ret;
+ }
+ $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
+ $self->_add_to_statistics($stats);
+ $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
+ if ($ret) {
+ unlink "$aslocal.bak$$";
+ return $ret;
+ }
unless ($CPAN::Signal) {
my(@mess);
local $" = " ";
$CPAN::Frontend->mywarn("Could not fetch $file\n");
$CPAN::Frontend->mysleep(2);
}
- if ($restore) {
- rename "$aslocal.bak", $aslocal;
+ if ($maybe_restore) {
+ rename "$aslocal.bak$$", $aslocal;
$CPAN::Frontend->myprint("Trying to get away with old file:\n" .
$self->ls($aslocal));
return $aslocal;
return;
}
+sub _set_attempt {
+ my($self,$stats,$method,$url) = @_;
+ push @{$stats->{attempts}}, {
+ method => $method,
+ start => _mytime,
+ url => $url,
+ };
+}
+
# package CPAN::FTP;
sub hosteasy {
- my($self,$host_seq,$file,$aslocal) = @_;
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
my($ro_url);
HOSTEASY: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"easy",$ro_url);
my $url .= "$ro_url$file";
$self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
if ($url =~ /^file:/) {
# Maybe mirror has compressed it?
if (-f "$l.gz") {
$self->debug("found compressed $l.gz") if $CPAN::DEBUG;
- CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
+ eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
if ( -f $aslocal) {
$ThesiteURL = $ro_url;
return $aslocal;
}
}
}
+ $self->debug("it was not a file URL") if $CPAN::DEBUG;
if ($CPAN::META->has_usable('LWP')) {
$CPAN::Frontend->myprint("Fetching with LWP:
$url
$gzurl
");
$res = $Ua->mirror($gzurl, "$aslocal.gz");
- if ($res->is_success &&
- CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
- ) {
- $ThesiteURL = $ro_url;
- return $aslocal;
+ if ($res->is_success) {
+ if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
}
} else {
$CPAN::Frontend->myprint(sprintf(
# Net::FTP can still succeed where LWP fails. So we do not
# skip Net::FTP anymore when LWP is available.
}
- } elsif (
- $ro_url->can("text")
- and
- $ro_url->{FROM} eq "USER"
- ){
- my $ret = $self->hosthard([$ro_url],$file,$aslocal);
- return $ret if $ret;
} else {
$CPAN::Frontend->mywarn(" LWP not available\n");
}
return if $CPAN::Signal;
if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
# that's the nice and easy way thanks to Graham
+ $self->debug("recognized ftp") if $CPAN::DEBUG;
my($host,$dir,$getfile) = ($1,$2,$3);
if ($CPAN::META->has_usable('Net::FTP')) {
$dir =~ s|/+|/|g;
$dir,
"$getfile.gz",
$gz) &&
- CPAN::Tarzip->new($gz)->gunzip($aslocal)
+ eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
){
$ThesiteURL = $ro_url;
return $aslocal;
}
}
# next HOSTEASY;
- }
+ } else {
+ CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
+ }
}
+ if (
+ UNIVERSAL::can($ro_url,"text")
+ and
+ $ro_url->{FROM} eq "USER"
+ ){
+ ##address #17973: default URLs should not try to override
+ ##user-defined URLs just because LWP is not available
+ my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
+ return $ret if $ret;
+ }
return if $CPAN::Signal;
}
}
# package CPAN::FTP;
sub hosthard {
- my($self,$host_seq,$file,$aslocal) = @_;
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
# Came back if Net::FTP couldn't establish connection (or
# failed otherwise) Maybe they are behind a firewall, but they
my($aslocal_dir) = File::Basename::dirname($aslocal);
File::Path::mkpath($aslocal_dir);
HOSTHARD: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"hard",$ro_url);
my $url = "$ro_url$file";
my($proto,$host,$dir,$getfile);
if ($f eq "lynx") {
# lynx returns 0 when it fails somewhere
if (-s $asl_ungz) {
- my $content = do { local *FH; open FH, $asl_ungz or die; local $/; <FH> };
- if ($content =~ /^<.*<title>[45]/si) {
+ my $content = do { local *FH;
+ open FH, $asl_ungz or die;
+ local $/;
+ <FH> };
+ if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
$CPAN::Frontend->mywarn(qq{
No success, the file that lynx has has downloaded looks like an error message:
$content
# Looks good
} elsif ($asl_ungz ne $aslocal) {
# test gzip integrity
- if (CPAN::Tarzip->new($asl_ungz)->gtest) {
+ if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
# e.g. foo.tar is gzipped --> foo.tar.gz
rename $asl_ungz, $aslocal;
} else {
- CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
+ eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
}
}
$ThesiteURL = $ro_url;
-s $asl_gz
) {
# test gzip integrity
- my $ct = CPAN::Tarzip->new($asl_gz);
- if ($ct->gtest) {
- $ct->gunzip($aslocal);
- } else {
- # somebody uncompressed file for us?
- rename $asl_ungz, $aslocal;
- }
- $ThesiteURL = $ro_url;
- return $aslocal;
+ my $ct = eval{CPAN::Tarzip->new($asl_gz)};
+ if ($ct && $ct->gtest) {
+ $ct->gunzip($aslocal);
+ } else {
+ # somebody uncompressed file for us?
+ rename $asl_ungz, $aslocal;
+ }
+ $ThesiteURL = $ro_url;
+ return $aslocal;
} else {
unlink $asl_gz if -f $asl_gz;
}
# package CPAN::FTP;
sub hosthardest {
- my($self,$host_seq,$file,$aslocal) = @_;
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
my($ro_url);
my($aslocal_dir) = File::Basename::dirname($aslocal);
File::Path::mkpath($aslocal_dir);
my $ftpbin = $CPAN::Config->{ftp};
- unless (length $ftpbin && MM->maybe_command($ftpbin)) {
+ unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
$CPAN::Frontend->myprint("No external ftp command available\n\n");
return;
}
});
$CPAN::Frontend->mysleep(2);
HOSTHARDEST: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"hardest",$ro_url);
my $url = "$ro_url$file";
$self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
$pos ||= 0;
CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
$line =~ s/^\s*//;
- if ($line =~ s/^(force\s*)//) {
+ if ($line =~ s/^((?:notest|f?force)\s*)//) {
$pos -= length($1);
}
my @return;
#-> sub CPAN::Complete::cplx ;
sub cplx {
my($class, $word) = @_;
- # I believed for many years that this was sorted, today I
- # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
- # make it sorted again. Maybe sort was dropped when GNU-readline
- # support came in? The RCS file is difficult to read on that:-(
+ if (CPAN::_sqlite_running) {
+ $CPAN::SQLite->search($class, "^\Q$word\E");
+ }
sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
}
#-> sub CPAN::Index::reload ;
sub reload {
- my($cl,$force) = @_;
+ my($self,$force) = @_;
my $time = time;
# XXX check if a newer one is available. (We currently read it
Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
}
unless ($CPAN::META->{PROTOCOL}) {
- $cl->read_metadata_cache;
+ $self->read_metadata_cache;
$CPAN::META->{PROTOCOL} ||= "1.0";
}
if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
# warn "Setting last_time to 0";
$LAST_TIME = 0; # No warning necessary
}
- return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
- and ! $force;
- if (0) {
+ if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
+ and ! $force){
+ # called too often
+ # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
+ } elsif (0) {
# IFF we are developing, it helps to wipe out the memory
# between reloads, otherwise it is not what a user expects.
undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
$CPAN::META = CPAN->new;
- }
- {
+ } else {
my($debug,$t2);
local $LAST_TIME = $time;
local $CPAN::META->{PROTOCOL} = PROTOCOL;
my $needshort = $^O eq "dos";
- $cl->rd_authindex($cl
+ $self->rd_authindex($self
->reload_x(
"authors/01mailrc.txt.gz",
$needshort ?
$debug = "timing reading 01[".($t2 - $time)."]";
$time = $t2;
return if $CPAN::Signal; # this is sometimes lengthy
- $cl->rd_modpacks($cl
+ $self->rd_modpacks($self
->reload_x(
"modules/02packages.details.txt.gz",
$needshort ?
$debug .= "02[".($t2 - $time)."]";
$time = $t2;
return if $CPAN::Signal; # this is sometimes lengthy
- $cl->rd_modlist($cl
+ $self->rd_modlist($self
->reload_x(
"modules/03modlist.data.gz",
$needshort ?
File::Spec->catfile('modules', '03mlist.gz') :
File::Spec->catfile('modules', '03modlist.data.gz'),
$force));
- $cl->write_metadata_cache;
+ $self->write_metadata_cache;
$t2 = time;
$debug .= "03[".($t2 - $time)."]";
$time = $t2;
CPAN->debug($debug) if $CPAN::DEBUG;
}
+ if ($CPAN::Config->{build_dir_reuse}) {
+ $self->reanimate_build_dir;
+ }
+ if (CPAN::_sqlite_running) {
+ $CPAN::SQLite->reload(time => $time, force => $force)
+ if not $LAST_TIME;
+ }
$LAST_TIME = $time;
$CPAN::META->{PROTOCOL} = PROTOCOL;
}
+#-> sub CPAN::Index::reanimate_build_dir ;
+sub reanimate_build_dir {
+ my($self) = @_;
+ unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
+ return;
+ }
+ return if $HAVE_REANIMATED++;
+ my $d = $CPAN::Config->{build_dir};
+ my $dh = DirHandle->new;
+ opendir $dh, $d or return; # does not exist
+ my $dirent;
+ my $i = 0;
+ my $painted = 0;
+ my $restored = 0;
+ $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
+ my @candidates = map { $_->[0] }
+ sort { $b->[1] <=> $a->[1] }
+ map { [ $_, -M File::Spec->catfile($d,$_) ] }
+ grep {/\.yml$/} readdir $dh;
+ DISTRO: for $i (0..$#candidates) {
+ my $dirent = $candidates[$i];
+ my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
+ if ($@) {
+ warn "Error while parsing file '$dirent'; error: '$@'";
+ next DISTRO;
+ }
+ my $c = $y->[0];
+ if ($c && CPAN->_perl_fingerprint($c->{perl})) {
+ my $key = $c->{distribution}{ID};
+ for my $k (keys %{$c->{distribution}}) {
+ if ($c->{distribution}{$k}
+ && ref $c->{distribution}{$k}
+ && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
+ $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
+ }
+ }
+
+ #we tried to restore only if element already
+ #exists; but then we do not work with metadata
+ #turned off.
+ my $do
+ = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
+ = $c->{distribution};
+ for my $skipper (qw(badtestcnt notest force_update)) {
+ delete $do->{$skipper};
+ }
+ # $DB::single = 1;
+ if ($do->{make_test}
+ && $do->{build_dir}
+ && !(UNIVERSAL::can($do->{make_test},"failed") ?
+ $do->{make_test}->failed :
+ $do->{make_test} =~ /^YES/
+ )
+ && (
+ !$do->{install}
+ ||
+ $do->{install}->failed
+ )
+ ) {
+ $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
+ }
+ $restored++;
+ }
+ $i++;
+ while (($painted/76) < ($i/@candidates)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ }
+ $CPAN::Frontend->myprint(sprintf(
+ "DONE\nFound %s old build%s, restored the state of %s\n",
+ @candidates ? sprintf("%d",scalar @candidates) : "no",
+ @candidates==1 ? "" : "s",
+ $restored || "none",
+ ));
+}
+
+
#-> sub CPAN::Index::reload_x ;
sub reload_x {
my($cl,$wanted,$localname,$force) = @_;
#-> sub CPAN::Index::rd_authindex ;
sub rd_authindex {
my($cl, $index_target) = @_;
- my @lines;
return unless defined $index_target;
+ return if CPAN::_sqlite_running;
+ my @lines;
$CPAN::Frontend->myprint("Going to read $index_target\n");
local(*FH);
tie *FH, 'CPAN::Tarzip', $index_target;
local($_);
push @lines, split /\012/ while <FH>;
my $i = 0;
- my $modulus = int(@lines/75) || 1;
+ my $painted = 0;
foreach (@lines) {
my($userid,$fullname,$email) =
- m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
- next unless $userid && $fullname && $email;
-
- # instantiate an author object
- my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
- $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
- $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
+ m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
+ $fullname ||= $email;
+ if ($userid && $fullname && $email){
+ my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
+ $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
+ } else {
+ CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
+ }
+ $i++;
+ while (($painted/76) < ($i/@lines)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
sub rd_modpacks {
my($self, $index_target) = @_;
return unless defined $index_target;
+ return if CPAN::_sqlite_running;
$CPAN::Frontend->myprint("Going to read $index_target\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
my(%exists);
my $i = 0;
- my $modulus = int(@lines/75) || 1;
+ my $painted = 0;
foreach (@lines) {
# before 1.56 we split into 3 and discarded the rest. From
# 1.57 we assign remaining text to $comment thus allowing to
$exists{$name} = undef;
}
}
- $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
+ $i++;
+ while (($painted/76) < ($i/@lines)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
sub rd_modlist {
my($cl,$index_target) = @_;
return unless defined $index_target;
+ return if CPAN::_sqlite_running;
$CPAN::Frontend->myprint("Going to read $index_target\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
Carp::confess($@) if $@;
return if $CPAN::Signal;
my $i = 0;
- my $until = keys %$ret;
- my $modulus = int($until/75) || 1;
+ my $until = keys(%$ret);
+ my $painted = 0;
CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
for (keys %$ret) {
my $obj = $CPAN::META->instance("CPAN::Module",$_);
delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
$obj->set(%{$ret->{$_}});
- $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
+ $i++;
+ while (($painted/76) < ($i/$until)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
sub write_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running;
return unless $CPAN::META->has_usable("Storable");
my $cache;
foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
sub read_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running;
return unless $CPAN::META->has_usable("Storable");
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
return unless -r $metadata_file and -f $metadata_file;
exists $self->{RO} and return $self->{RO};
}
+#-> sub CPAN::InfoObj::cpan_userid
sub cpan_userid {
my $self = shift;
- my $ro = $self->ro or return "N/A"; # N/A for bundles found locally
- return $ro->{CPAN_USERID} || "N/A";
+ my $ro = $self->ro;
+ if ($ro) {
+ return $ro->{CPAN_USERID} || "N/A";
+ } else {
+ $self->debug("ID[$self->{ID}]");
+ # N/A for bundles found locally
+ return "N/A";
+ }
}
sub id { shift->{ID}; }
push @m, $class, " id = $self->{ID}\n";
my $ro;
unless ($ro = $self->ro) {
- $CPAN::Frontend->mydie("Unknown object $self->{ID}");
+ if (substr($self->{ID},-1,1) eq ".") { # directory
+ $ro = +{};
+ } else {
+ $CPAN::Frontend->mydie("Unknown object $self->{ID}");
+ }
}
for (sort keys %$ro) {
# next if m/^(ID|RO)$/;
next unless defined $ro->{$_};
push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
}
- for (sort keys %$self) {
+ KEY: for (sort keys %$self) {
next if m/^(ID|RO)$/;
+ unless (defined $self->{$_}) {
+ delete $self->{$_};
+ next KEY;
+ }
if (ref($self->{$_}) eq "ARRAY") {
push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
} elsif (ref($self->{$_}) eq "HASH") {
+ my $value;
+ if (/^CONTAINSMODS$/) {
+ $value = join(" ",sort keys %{$self->{$_}});
+ } elsif (/^prereq_pm$/) {
+ my @value;
+ my $v = $self->{$_};
+ for my $x (sort keys %$v) {
+ my @svalue;
+ for my $y (sort keys %{$v->{$x}}) {
+ push @svalue, "$y=>$v->{$x}{$y}";
+ }
+ push @value, "$x\:" . join ",", @svalue if @svalue;
+ }
+ $value = join ";", @value;
+ } else {
+ $value = $self->{$_};
+ }
push @m, sprintf(
" %-12s %s\n",
$_,
- join(" ",sort keys %{$self->{$_}}),
+ $value,
);
} else {
push @m, sprintf " %-12s %s\n", $_, $self->{$_};
"$lc_want.gz",1);
if ($lc_file) {
$lc_file =~ s{\.gz(?!\n)\Z}{}; #};
- CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
+ eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
} else {
return;
}
@result;
}
+#-> sub CPAN::Author::reports
+sub reports {
+ $CPAN::Frontend->mywarn("reports on authors not implemented.
+Please file a bugreport if you need this.\n");
+}
+
package CPAN::Distribution;
use strict;
$ro->{CPAN_COMMENT}
}
-# CPAN::Distribution::undelay
+#-> CPAN::Distribution::undelay
sub undelay {
my $self = shift;
delete $self->{later};
}
+#-> CPAN::Distribution::is_dot_dist
+sub is_dot_dist {
+ my($self) = @_;
+ return substr($self->id,-1,1) eq ".";
+}
+
# add the A/AN/ stuff
-# CPAN::Distribution::normalize
+#-> CPAN::Distribution::normalize
sub normalize {
my($self,$s) = @_;
$s = $self->id unless defined $s;
- if (
+ if (substr($s,-1,1) eq ".") {
+ # using a global because we are sometimes called as static method
+ if (!$CPAN::META->{LOCK}
+ && !$CPAN::Have_warned->{"$s is unlocked"}++
+ ) {
+ $CPAN::Frontend->mywarn("You are visiting the local directory
+ '$s'
+ without lock, take care that concurrent processes do not do likewise.\n");
+ $CPAN::Frontend->mysleep(1);
+ }
+ if ($s eq ".") {
+ $s = "$CPAN::iCwd/.";
+ } elsif (File::Spec->file_name_is_absolute($s)) {
+ } elsif (File::Spec->can("rel2abs")) {
+ $s = File::Spec->rel2abs($s);
+ } else {
+ $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
+ }
+ CPAN->debug("s[$s]") if $CPAN::DEBUG;
+ unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
+ for ($CPAN::META->instance("CPAN::Distribution", $s)) {
+ $_->{build_dir} = $s;
+ $_->{archived} = "local_directory";
+ $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
+ }
+ }
+ } elsif (
$s =~ tr|/|| == 1
or
$s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
#-> sub CPAN::Distribution::author ;
sub author {
my($self) = @_;
- my($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
+ my($authorid);
+ if (substr($self->id,-1,1) eq ".") {
+ $authorid = "LOCAL";
+ } else {
+ ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
+ }
CPAN::Shell->expand("Author",$authorid);
}
$local_wanted)) {
$CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
}
- if ($CPAN::META->has_inst("YAML")) {
- my $yaml = YAML::LoadFile($local_file);
- return $yaml;
- } else {
- $CPAN::Frontend->mydie("Yaml not installed, cannot parse '$local_file'\n");
+ my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
+}
+
+#-> sub CPAN::Distribution::cpan_userid
+sub cpan_userid {
+ my $self = shift;
+ if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
+ return $1;
}
+ return $self->SUPER::cpan_userid;
}
#-> sub CPAN::Distribution::pretty_id
substr($id,5);
}
-# mark as dirty/clean
+# mark as dirty/clean for the sake of recursion detection. $color=1
+# means "in use", $color=0 means "not in use anymore". $color=2 means
+# we have determined prereqs now and thus insist on passing this
+# through (at least) once again.
+
#-> sub CPAN::Distribution::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
# a distribution needs to recurse into its prereq_pms
return if exists $self->{incommandcolor}
+ && $color==1
&& $self->{incommandcolor}==$color;
- if ($depth>=100){
- $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
+ if ($depth>=$CPAN::MAX_RECURSION){
+ die(CPAN::Exception::RecursiveDependency->new($ancestors));
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
my $prereq_pm = $self->prereq_pm;
}
if ($color==0) {
delete $self->{sponsored_mods};
+
+ # as we are at the end of a command, we'll give up this
+ # reminder of a broken test. Other commands may test this guy
+ # again. Maybe 'badtestcnt' should be renamed to
+ # 'make_test_failed_within_command'?
delete $self->{badtestcnt};
}
$self->{incommandcolor} = $color;
my $mod_id = $mod->{ID} or next;
# warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
# sleep 1;
+ if ($CPAN::Signal) {
+ delete $self->{CONTAINSMODS};
+ return;
+ }
$self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
}
- keys %{$self->{CONTAINSMODS}};
+ keys %{$self->{CONTAINSMODS}||{}};
}
#-> sub CPAN::Distribution::upload_date ;
#-> sub CPAN::Distribution::get ;
sub get {
my($self) = @_;
+ $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
+ if (my $goto = $self->prefs->{goto}) {
+ $CPAN::Frontend->mywarn
+ (sprintf(
+ "delegating to '%s' as specified in prefs file '%s' doc %d\n",
+ $goto,
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ ));
+ return $self->goto($goto);
+ }
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
EXCUSE: {
my @e;
- exists $self->{'build_dir'} and push @e,
- "Is already unwrapped into directory $self->{'build_dir'}";
- $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ my $goodbye_message;
+ $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
+ if ($self->prefs->{disabled}) {
+ my $why = sprintf(
+ "Disabled via prefs file '%s' doc %d",
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ );
+ push @e, $why;
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
+ $goodbye_message = "[disabled] -- NA $why";
+ # note: not intended to be persistent but at least visible
+ # during this session
+ } else {
+ if (exists $self->{build_dir} && -d $self->{build_dir}
+ && ($self->{modulebuild}||$self->{writemakefile})
+ ) {
+ # this deserves print, not warn:
+ $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
+ "$self->{build_dir}\n"
+ );
+ return 1;
+ }
+
+ # although we talk about 'force' we shall not test on
+ # force directly. New model of force tries to refrain from
+ # direct checking of force.
+ exists $self->{unwrapped} and (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )
+ and push @e, "Unwrapping had some problem, won't try again without force";
+ }
+ if (@e) {
+ $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
+ if ($goodbye_message) {
+ $self->goodbye($goodbye_message);
+ }
+ return;
+ }
}
my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
- #
- # Get the file on local disk
- #
+ $self->get_file_onto_local_disk;
+ return if $CPAN::Signal;
+ $self->check_integrity;
+ return if $CPAN::Signal;
+ my($packagedir,$local_file) = $self->run_preps_on_packagedir;
+ $packagedir ||= $self->{build_dir};
+
+ if ($CPAN::Signal){
+ $self->safe_chdir($sub_wd);
+ return;
+ }
+ return $self->run_MM_or_MB($local_file,$packagedir);
+}
+
+#-> CPAN::Distribution::get_file_onto_local_disk
+sub get_file_onto_local_disk {
+ my($self) = @_;
+ return if $self->is_dot_dist;
my($local_file);
my($local_wanted) =
File::Spec->catfile(
}
$CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
}
- $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
+
+ $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
$self->{localfile} = $local_file;
- return if $CPAN::Signal;
+}
- #
- # Check integrity
- #
+
+#-> CPAN::Distribution::check_integrity
+sub check_integrity {
+ my($self) = @_;
+
+ return if $self->is_dot_dist;
if ($CPAN::META->has_inst("Digest::SHA")) {
$self->debug("Digest::SHA is installed, verifying");
$self->verifyCHECKSUM;
} else {
$self->debug("Digest::SHA is NOT installed");
}
- return if $CPAN::Signal;
+}
+
+#-> CPAN::Distribution::run_preps_on_packagedir
+sub run_preps_on_packagedir {
+ my($self) = @_;
+ return if $self->is_dot_dist;
- #
- # Create a clean room and go there
- #
$CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
$self->safe_chdir($builddir);
- $self->debug("Removing tmp") if $CPAN::DEBUG;
- File::Path::rmtree("tmp");
- unless (mkdir "tmp", 0755) {
+ $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
+ File::Path::rmtree("tmp-$$");
+ unless (mkdir "tmp-$$", 0755) {
$CPAN::Frontend->unrecoverable_error(<<EOF);
-Couldn't mkdir '$builddir/tmp': $!
+Couldn't mkdir '$builddir/tmp-$$': $!
Cannot continue: Please find the reason why I cannot make the
directory
-$builddir/tmp
+$builddir/tmp-$$
and fix the problem, then retry.
EOF
}
if ($CPAN::Signal){
- $self->safe_chdir($sub_wd);
return;
}
- $self->safe_chdir("tmp");
+ $self->safe_chdir("tmp-$$");
#
# Unpack the goods
#
- $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
- my $ct = CPAN::Tarzip->new($local_file);
+ my $local_file = $self->{localfile};
+ my $ct = eval{CPAN::Tarzip->new($local_file)};
+ unless ($ct) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO");
+ delete $self->{build_dir};
+ return;
+ }
if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
- $self->{was_uncompressed}++ unless $ct->gtest();
+ $self->{was_uncompressed}++ unless eval{$ct->gtest()};
$self->untar_me($ct);
} elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
$self->unzip_me($ct);
} else {
$self->{was_uncompressed}++ unless $ct->gtest();
- $self->debug("calling pm2dir for local_file[$local_file]")
- if $CPAN::DEBUG;
$local_file = $self->handle_singlefile($local_file);
-# } else {
-# $self->{archived} = "NO";
-# $self->safe_chdir($sub_wd);
-# return;
}
# we are still in the tmp directory!
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 = File::Spec->catdir($builddir,$distdir);
- $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
- if $CPAN::DEBUG;
- -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
- "$packagedir\n");
- File::Path::rmtree($packagedir);
- unless (File::Copy::move($distdir,$packagedir)) {
- $CPAN::Frontend->unrecoverable_error(<<EOF);
+ my ($packagedir);
+ # XXX here we want in each branch File::Temp to protect all build_dir directories
+ if (CPAN->has_inst("File::Temp")) {
+ my $tdir_base;
+ my $from_dir;
+ my @dirents;
+ if (@readdir == 1 && -d $readdir[0]) {
+ $tdir_base = $readdir[0];
+ $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
+ my $dh2 = DirHandle->new($from_dir)
+ or Carp::croak("Couldn't opendir $from_dir: $!");
+ @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
+ } else {
+ my $userid = $self->cpan_userid;
+ CPAN->debug("userid[$userid]");
+ if (!$userid or $userid eq "N/A") {
+ $userid = "anon";
+ }
+ $tdir_base = $userid;
+ $from_dir = File::Spec->curdir;
+ @dirents = @readdir;
+ }
+ $packagedir = File::Temp::tempdir(
+ "$tdir_base-XXXXXX",
+ DIR => $builddir,
+ CLEANUP => 0,
+ );
+ my $f;
+ for $f (@dirents) { # is already without "." and ".."
+ my $from = File::Spec->catdir($from_dir,$f);
+ my $to = File::Spec->catdir($packagedir,$f);
+ unless (File::Copy::move($from,$to)) {
+ my $err = $!;
+ $from = File::Spec->rel2abs($from);
+ Carp::confess("Couldn't move $from to $to: $err");
+ }
+ }
+ } else { # older code below, still better than nothing when there is no File::Temp
+ my($distdir);
+ if (@readdir == 1 && -d $readdir[0]) {
+ $distdir = $readdir[0];
+ $packagedir = File::Spec->catdir($builddir,$distdir);
+ $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
+ if $CPAN::DEBUG;
+ -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
+ "$packagedir\n");
+ File::Path::rmtree($packagedir);
+ unless (File::Copy::move($distdir,$packagedir)) {
+ $CPAN::Frontend->unrecoverable_error(<<EOF);
Couldn't move '$distdir' to '$packagedir': $!
Cannot continue: Please find the reason why I cannot move
-$builddir/tmp/$distdir
+$builddir/tmp-$$/$distdir
to
$packagedir
and fix the problem, then retry
EOF
+ }
+ $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
+ $distdir,
+ $packagedir,
+ -e $packagedir,
+ -d $packagedir,
+ )) if $CPAN::DEBUG;
+ } else {
+ my $userid = $self->cpan_userid;
+ CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
+ if (!$userid or $userid eq "N/A") {
+ $userid = "anon";
+ }
+ my $pragmatic_dir = $userid . '000';
+ $pragmatic_dir =~ s/\W_//g;
+ $pragmatic_dir++ while -d "../$pragmatic_dir";
+ $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
+ $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
+ File::Path::mkpath($packagedir);
+ my($f);
+ for $f (@readdir) { # is already without "." and ".."
+ my $to = File::Spec->catdir($packagedir,$f);
+ File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
+ }
}
- $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
- $distdir,
- $packagedir,
- -e $packagedir,
- -d $packagedir,
- )) if $CPAN::DEBUG;
- } else {
- my $userid = $self->cpan_userid;
- unless ($userid) {
- CPAN->debug("no userid? self[$self]");
- $userid = "anon";
- }
- my $pragmatic_dir = $userid . '000';
- $pragmatic_dir =~ s/\W_//g;
- $pragmatic_dir++ while -d "../$pragmatic_dir";
- $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
- $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
- File::Path::mkpath($packagedir);
- my($f);
- for $f (@readdir) { # is already without "." and ".."
- my $to = File::Spec->catdir($packagedir,$f);
- File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
- }
- }
- if ($CPAN::Signal){
- $self->safe_chdir($sub_wd);
- return;
}
-
- $self->{'build_dir'} = $packagedir;
+ $self->{build_dir} = $packagedir;
$self->safe_chdir($builddir);
- File::Path::rmtree("tmp");
+ File::Path::rmtree("tmp-$$");
$self->safe_chdir($packagedir);
- if ($CPAN::Config->{check_sigs}) {
- if ($CPAN::META->has_inst("Module::Signature")) {
- if (-f "SIGNATURE") {
- $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
- my $rv = Module::Signature::verify();
- if ($rv != Module::Signature::SIGNATURE_OK() and
- $rv != Module::Signature::SIGNATURE_MISSING()) {
- $CPAN::Frontend->myprint(
- qq{\nSignature invalid for }.
- qq{distribution file. }.
- qq{Please investigate.\n\n}.
- $self->as_string,
- $CPAN::META->instance(
- 'CPAN::Author',
- $self->cpan_userid,
- )->as_string
- );
-
- my $wrap =
- sprintf(qq{I'd recommend removing %s. Its signature
-is invalid. Maybe you have configured your 'urllist' with
-a bad URL. Please check this array with 'o conf urllist', and
-retry. For more information, try opening a subshell with
- look %s
-and there run
- cpansign -v
-},
- $self->{localfile},
- $self->pretty_id,
- );
- $self->{signature_verify} = CPAN::Distrostatus->new("NO");
- $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
- $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
- } else {
- $self->{signature_verify} = CPAN::Distrostatus->new("YES");
- $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
- }
- } else {
- $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
- }
- } else {
- $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
- }
- }
- $self->safe_chdir($builddir);
- return if $CPAN::Signal;
+ $self->_signature_business();
+ $self->safe_chdir($builddir);
+ return($packagedir,$local_file);
+}
+#-> sub CPAN::Distribution::run_MM_or_MB
+sub run_MM_or_MB {
+ my($self,$local_file,$packagedir) = @_;
my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
my($mpl_exists) = -f $mpl;
unless ($mpl_exists) {
if (-f File::Spec->catfile($packagedir,"Build.PL")) {
if ($mpl_exists) { # they *can* choose
if ($CPAN::META->has_inst("Module::Build")) {
- $prefer_installer = $CPAN::Config->{prefer_installer};
+ $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
+ q{prefer_installer});
}
} else {
$prefer_installer = "mb";
}
}
+ return unless $self->patch;
if (lc($prefer_installer) eq "mb") {
$self->{modulebuild} = 1;
+ } elsif ($self->{archived} eq "patch") {
+ # not an edge case, nothing to install for sure
+ my $why = "A patch file cannot be installed";
+ $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
} elsif (! $mpl_exists) {
- $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
- $mpl,
- CPAN::anycwd(),
- )) if $CPAN::DEBUG;
- my($configure) = File::Spec->catfile($packagedir,"Configure");
- if (-f $configure) {
- # do we have anything to do?
- $self->{'configure'} = $configure;
- } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
- $CPAN::Frontend->mywarn(qq{
+ $self->_edge_cases($mpl,$packagedir,$local_file);
+ }
+ if ($self->{build_dir}
+ &&
+ $CPAN::Config->{build_dir_reuse}
+ ) {
+ $self->store_persistent_state;
+ }
+ return $self;
+}
+
+#-> CPAN::Distribution::store_persistent_state
+sub store_persistent_state {
+ my($self) = @_;
+ my $dir = $self->{build_dir};
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
+ $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
+ "will not store persistent state\n");
+ return;
+ }
+ my $file = sprintf "%s.yml", $dir;
+ my $yaml_module = CPAN::_yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ CPAN->_yaml_dumpfile(
+ $file,
+ {
+ time => time,
+ perl => CPAN::_perl_fingerprint,
+ distribution => $self,
+ }
+ );
+ } else {
+ $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
+ "will not store persistent state\n");
+ }
+}
+
+#-> CPAN::Distribution::patch
+sub try_download {
+ my($self,$patch) = @_;
+ my $norm = $self->normalize($patch);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$norm),
+ );
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ return CPAN::FTP->localize("authors/id/$norm",
+ $local_wanted);
+}
+
+{
+ my $stdpatchargs = "";
+ #-> CPAN::Distribution::patch
+ sub patch {
+ my($self) = @_;
+ $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
+ my $patches = $self->prefs->{patches};
+ $patches ||= "";
+ $self->debug("patches[$patches]") if $CPAN::DEBUG;
+ if ($patches) {
+ return unless @$patches;
+ $self->safe_chdir($self->{build_dir});
+ CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
+ my $patchbin = $CPAN::Config->{patch};
+ unless ($patchbin && length $patchbin) {
+ $CPAN::Frontend->mydie("No external patch command configured\n\n".
+ "Please run 'o conf init /patch/'\n\n");
+ }
+ unless (MM->maybe_command($patchbin)) {
+ $CPAN::Frontend->mydie("No external patch command available\n\n".
+ "Please run 'o conf init /patch/'\n\n");
+ }
+ $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
+ local $ENV{PATCH_GET} = 0; # formerly known as -g0
+ unless ($stdpatchargs) {
+ my $system = "$patchbin --version |";
+ local *FH;
+ open FH, $system or die "Could not fork '$system': $!";
+ local $/ = "\n";
+ my $pversion;
+ PARSEVERSION: while (<FH>) {
+ if (/^patch\s+([\d\.]+)/) {
+ $pversion = $1;
+ last PARSEVERSION;
+ }
+ }
+ if ($pversion) {
+ $stdpatchargs = "-N --fuzz=3";
+ } else {
+ $stdpatchargs = "-N";
+ }
+ }
+ my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
+ $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
+ for my $patch (@$patches) {
+ unless (-f $patch) {
+ if (my $trydl = $self->try_download($patch)) {
+ $patch = $trydl;
+ } else {
+ my $fail = "Could not find patch '$patch'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ }
+ $CPAN::Frontend->myprint(" $patch\n");
+ my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
+
+ my $pcommand;
+ my $ppp = $self->_patch_p_parameter($readfh);
+ if ($ppp eq "applypatch") {
+ $pcommand = "$CPAN::Config->{applypatch} -verbose";
+ } else {
+ my $thispatchargs = join " ", $stdpatchargs, $ppp;
+ $pcommand = "$patchbin $thispatchargs";
+ }
+
+ $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
+ my $writefh = FileHandle->new;
+ $CPAN::Frontend->myprint(" $pcommand\n");
+ unless (open $writefh, "|$pcommand") {
+ my $fail = "Could not fork '$pcommand'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ while (my $x = $readfh->READLINE) {
+ print $writefh $x;
+ }
+ unless (close $writefh) {
+ my $fail = "Could not apply patch '$patch'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ }
+ $self->{patched}++;
+ }
+ return 1;
+ }
+}
+
+sub _patch_p_parameter {
+ my($self,$fh) = @_;
+ my $cnt_files = 0;
+ my $cnt_p0files = 0;
+ local($_);
+ while ($_ = $fh->READLINE) {
+ if (
+ $CPAN::Config->{applypatch}
+ &&
+ /\#\#\#\# ApplyPatch data follows \#\#\#\#/
+ ) {
+ return "applypatch"
+ }
+ next unless /^[\*\+]{3}\s(\S+)/;
+ my $file = $1;
+ $cnt_files++;
+ $cnt_p0files++ if -f $file;
+ CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
+ if $CPAN::DEBUG;
+ }
+ return "-p1" unless $cnt_files;
+ return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
+}
+
+#-> sub CPAN::Distribution::_edge_cases
+# with "configure" or "Makefile" or single file scripts
+sub _edge_cases {
+ my($self,$mpl,$packagedir,$local_file) = @_;
+ $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
+ $mpl,
+ CPAN::anycwd(),
+ )) if $CPAN::DEBUG;
+ my($configure) = File::Spec->catfile($packagedir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{configure} = $configure;
+ } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
+ $CPAN::Frontend->mywarn(qq{
Package comes with a Makefile and without a Makefile.PL.
We\'ll try to build it with that Makefile then.
});
- $self->{writemakefile} = CPAN::Distrostatus->new("YES");
- $CPAN::Frontend->mysleep(2);
- } else {
- my $cf = $self->called_for || "unknown";
- if ($cf =~ m|/|) {
- $cf =~ s|.*/||;
- $cf =~ s|\W.*||;
- }
- $cf =~ s|[/\\:]||g; # risk of filesystem damage
- $cf = "unknown" unless length($cf);
- $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
+ $self->{writemakefile} = CPAN::Distrostatus->new("YES");
+ $CPAN::Frontend->mysleep(2);
+ } else {
+ my $cf = $self->called_for || "unknown";
+ if ($cf =~ m|/|) {
+ $cf =~ s|.*/||;
+ $cf =~ s|\W.*||;
+ }
+ $cf =~ s|[/\\:]||g; # risk of filesystem damage
+ $cf = "unknown" unless length($cf);
+ $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
(The test -f "$mpl" returned false.)
Writing one on our own (setting NAME to $cf)\a\n});
- $self->{had_no_makefile_pl}++;
- $CPAN::Frontend->mysleep(3);
-
- # Writing our own Makefile.PL
-
- my $script = "";
- if ($self->{archived} eq "maybe_pl"){
- my $fh = FileHandle->new;
- my $script_file = File::Spec->catfile($packagedir,$local_file);
- $fh->open($script_file)
- or Carp::croak("Could not open $script_file: $!");
- local $/ = "\n";
- # name parsen und prereq
- my($state) = "poddir";
- my($name, $prereq) = ("", "");
- while (<$fh>){
- if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
- if ($1 eq 'NAME') {
- $state = "name";
- } elsif ($1 eq 'PREREQUISITES') {
- $state = "prereq";
- }
- } elsif ($state =~ m{^(name|prereq)$}) {
- if (/^=/) {
- $state = "poddir";
- } elsif (/^\s*$/) {
- # nop
- } elsif ($state eq "name") {
- if ($name eq "") {
- ($name) = /^(\S+)/;
- $state = "poddir";
- }
- } elsif ($state eq "prereq") {
- $prereq .= $_;
- }
- } elsif (/^=cut\b/) {
- last;
- }
- }
- $fh->close;
+ $self->{had_no_makefile_pl}++;
+ $CPAN::Frontend->mysleep(3);
- for ($name) {
- s{.*<}{}; # strip X<...>
- s{>.*}{};
- }
- chomp $prereq;
- $prereq = join " ", split /\s+/, $prereq;
- my($PREREQ_PM) = join("\n", map {
- s{.*<}{}; # strip X<...>
- s{>.*}{};
- if (/[\s\'\"]/) { # prose?
- } else {
- s/[^\w:]$//; # period?
- " "x28 . "'$_' => 0,";
+ # Writing our own Makefile.PL
+
+ my $script = "";
+ if ($self->{archived} eq "maybe_pl") {
+ my $fh = FileHandle->new;
+ my $script_file = File::Spec->catfile($packagedir,$local_file);
+ $fh->open($script_file)
+ or Carp::croak("Could not open script '$script_file': $!");
+ local $/ = "\n";
+ # name parsen und prereq
+ my($state) = "poddir";
+ my($name, $prereq) = ("", "");
+ while (<$fh>) {
+ if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
+ if ($1 eq 'NAME') {
+ $state = "name";
+ } elsif ($1 eq 'PREREQUISITES') {
+ $state = "prereq";
}
- } split /\s*,\s*/, $prereq);
+ } elsif ($state =~ m{^(name|prereq)$}) {
+ if (/^=/) {
+ $state = "poddir";
+ } elsif (/^\s*$/) {
+ # nop
+ } elsif ($state eq "name") {
+ if ($name eq "") {
+ ($name) = /^(\S+)/;
+ $state = "poddir";
+ }
+ } elsif ($state eq "prereq") {
+ $prereq .= $_;
+ }
+ } elsif (/^=cut\b/) {
+ last;
+ }
+ }
+ $fh->close;
+
+ for ($name) {
+ s{.*<}{}; # strip X<...>
+ s{>.*}{};
+ }
+ chomp $prereq;
+ $prereq = join " ", split /\s+/, $prereq;
+ my($PREREQ_PM) = join("\n", map {
+ s{.*<}{}; # strip X<...>
+ s{>.*}{};
+ if (/[\s\'\"]/) { # prose?
+ } else {
+ s/[^\w:]$//; # period?
+ " "x28 . "'$_' => 0,";
+ }
+ } split /\s*,\s*/, $prereq);
- $script = "
+ $script = "
EXE_FILES => ['$name'],
PREREQ_PM => {
$PREREQ_PM
},
";
+ if ($name) {
+ my $to_file = File::Spec->catfile($packagedir, $name);
+ rename $script_file, $to_file
+ or die "Can't rename $script_file to $to_file: $!";
+ }
+ }
- my $to_file = File::Spec->catfile($packagedir, $name);
- rename $script_file, $to_file
- or die "Can't rename $script_file to $to_file: $!";
- }
-
- my $fh = FileHandle->new;
- $fh->open(">$mpl")
- or Carp::croak("Could not open >$mpl: $!");
- $fh->print(
-qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
+ my $fh = FileHandle->new;
+ $fh->open(">$mpl")
+ or Carp::croak("Could not open >$mpl: $!");
+ $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{
NAME => q[$cf],$script
);
});
- $fh->close;
- }
+ $fh->close;
}
+}
- return $self;
+#-> CPAN::Distribution::_signature_business
+sub _signature_business {
+ my($self) = @_;
+ my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
+ q{check_sigs});
+ if ($check_sigs) {
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ if (-f "SIGNATURE") {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
+ my $rv = Module::Signature::verify();
+ if ($rv != Module::Signature::SIGNATURE_OK() and
+ $rv != Module::Signature::SIGNATURE_MISSING()) {
+ $CPAN::Frontend->mywarn(
+ qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}
+ );
+
+ my $wrap =
+ sprintf(qq{I'd recommend removing %s. Some error occured }.
+ qq{while checking its signature, so it could }.
+ qq{be invalid. Maybe you have configured }.
+ qq{your 'urllist' with a bad URL. Please check this }.
+ qq{array with 'o conf urllist' and retry. Or }.
+ qq{examine the distribution in a subshell. Try
+ look %s
+and run
+ cpansign -v
+},
+ $self->{localfile},
+ $self->pretty_id,
+ );
+ $self->{signature_verify} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
+ $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
+ } else {
+ $self->{signature_verify} = CPAN::Distrostatus->new("YES");
+ $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
+ }
+ } else {
+ $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
+ }
+ } else {
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
+ }
+ }
}
-# CPAN::Distribution::untar_me ;
+#-> CPAN::Distribution::untar_me ;
sub untar_me {
my($self,$ct) = @_;
$self->{archived} = "tar";
if ($ct->untar()) {
- $self->{unwrapped} = "YES";
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
- $self->{unwrapped} = "NO";
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
}
}
my($self,$ct) = @_;
$self->{archived} = "zip";
if ($ct->unzip()) {
- $self->{unwrapped} = "YES";
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
- $self->{unwrapped} = "NO";
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
}
return;
}
if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
$self->{archived} = "pm";
+ } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
+ $self->{archived} = "patch";
} else {
$self->{archived} = "maybe_pl";
}
my $to = File::Basename::basename($local_file);
if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
- if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
- $self->{unwrapped} = "YES";
+ if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
- $self->{unwrapped} = "NO";
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
}
} else {
- File::Copy::cp($local_file,".");
- $self->{unwrapped} = "YES";
+ if (File::Copy::cp($local_file,".")) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
+ }
}
return $to;
}
"$lc_want.gz",1);
if ($lc_file) {
$lc_file =~ s/\.gz(?!\n)\Z//;
- CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
+ eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
} else {
return;
}
$sloppy ||= 0;
$self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
- if ($CPAN::Config->{check_sigs}) {
- if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
- $self->debug("Module::Signature is installed, verifying");
+ my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
+ q{check_sigs});
+ if ($check_sigs) {
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
$self->SIG_check_file($chk_file);
} else {
- $self->debug("Module::Signature is NOT installed");
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
}
}
# "Force get forgets previous error conditions"
+#-> sub CPAN::Distribution::fforce ;
+sub fforce {
+ my($self, $method) = @_;
+ $self->force($method,1);
+}
+
#-> sub CPAN::Distribution::force ;
sub force {
- my($self, $method) = @_;
- for my $att (qw(
- CHECKSUM_STATUS archived build_dir localfile make install unwrapped
- writemakefile modulebuild make_test signature_verify
- )) {
- delete $self->{$att};
+ my($self, $method,$fforce) = @_;
+ my %phase_map = (
+ get => [
+ "unwrapped",
+ "build_dir",
+ "archived",
+ "localfile",
+ "CHECKSUM_STATUS",
+ "signature_verify",
+ "prefs",
+ "prefs_file",
+ "prefs_file_doc",
+ ],
+ make => [
+ "writemakefile",
+ "make",
+ "modulebuild",
+ "prereq_pm",
+ "prereq_pm_detected",
+ ],
+ test => [
+ "badtestcnt",
+ "make_test",
+ ],
+ install => [
+ "install",
+ ],
+ unknown => [
+ "reqtype",
+ "yaml_content",
+ ],
+ );
+ my $methodmatch = 0;
+ my $ldebug = 0;
+ PHASE: for my $phase (qw(unknown get make test install)) { # order matters
+ $methodmatch = 1 if $fforce || $phase eq $method;
+ next unless $methodmatch;
+ ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
+ if ($phase eq "get") {
+ if (substr($self->id,-1,1) eq "."
+ && $att =~ /(unwrapped|build_dir|archived)/ ) {
+ # cannot be undone for local distros
+ next ATTRIBUTE;
+ }
+ if ($att eq "build_dir"
+ && $self->{build_dir}
+ && $CPAN::META->{is_tested}
+ ) {
+ delete $CPAN::META->{is_tested}{$self->{build_dir}};
+ }
+ } elsif ($phase eq "test") {
+ if ($att eq "make_test"
+ && $self->{make_test}
+ && $self->{make_test}{COMMANDID}
+ && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
+ ) {
+ # endless loop too likely
+ next ATTRIBUTE;
+ }
+ }
+ delete $self->{$att};
+ if ($ldebug || $CPAN::DEBUG) {
+ # local $CPAN::DEBUG = 16; # Distribution
+ CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
+ }
+ }
}
if ($method && $method =~ /make|test|install/) {
- $self->{"force_update"}++; # name should probably have been force_install
+ $self->{force_update} = 1; # name should probably have been force_install
}
}
+#-> sub CPAN::Distribution::notest ;
sub notest {
my($self, $method) = @_;
- # warn "XDEBUG: set notest for $self $method";
+ # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
$self->{"notest"}++; # name should probably have been force_install
}
+#-> sub CPAN::Distribution::unnotest ;
sub unnotest {
my($self) = @_;
# warn "XDEBUG: deleting notest";
- delete $self->{'notest'};
+ delete $self->{notest};
}
#-> sub CPAN::Distribution::unforce ;
sub unforce {
my($self) = @_;
- delete $self->{'force_update'};
+ delete $self->{force_update};
}
#-> sub CPAN::Distribution::isa_perl ;
|
\d+\.\d+
)
- \.tar[._-]gz
+ \.tar[._-](?:gz|bz2)
(?!\n)\Z
}xs){
return "$1.$3";
#-> sub CPAN::Distribution::make ;
sub make {
my($self) = @_;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
my $make = $self->{modulebuild} ? "Build" : "make";
# Emergency brake if they said install Pippi and get newest perl
if ($self->isa_perl) {
}
$CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
$self->get;
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
if ($CPAN::Signal){
delete $self->{force_update};
return;
}
+
+ my $builddir;
EXCUSE: {
my @e;
- !$self->{archived} || $self->{archived} eq "NO" and push @e,
- "Is neither a tar nor a zip archive.";
+ if (!$self->{archived} || $self->{archived} eq "NO") {
+ push @e, "Is neither a tar nor a zip archive.";
+ }
- !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
- "Had problems unarchiving. Please build manually";
+ if (!$self->{unwrapped}
+ || (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )) {
+ push @e, "Had problems unarchiving. Please build manually";
+ }
unless ($self->{force_update}) {
- exists $self->{signature_verify} and (
- $self->{signature_verify}->can("failed") ?
- $self->{signature_verify}->failed :
- $self->{signature_verify} =~ /^NO/
- )
+ exists $self->{signature_verify} and
+ (
+ UNIVERSAL::can($self->{signature_verify},"failed") ?
+ $self->{signature_verify}->failed :
+ $self->{signature_verify} =~ /^NO/
+ )
and push @e, "Did not pass the signature test.";
}
if (exists $self->{writemakefile} &&
(
- $self->{writemakefile}->can("failed") ?
+ UNIVERSAL::can($self->{writemakefile},"failed") ?
$self->{writemakefile}->failed :
$self->{writemakefile} =~ /^NO/
)) {
# XXX maybe a retry would be in order?
- my $err = $self->{writemakefile}->can("text") ?
+ my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
$self->{writemakefile}->text :
$self->{writemakefile};
$err =~ s/^NO\s*//;
push @e, $err;
}
- defined $self->{make} and push @e,
- "Has already been processed within this session";
+ if (defined $self->{make}) {
+ if (UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/) {
+ if ($self->{force_update}) {
+ # Trying an already failed 'make' (unless somebody else blocks)
+ } else {
+ # introduced for turning recursion detection into a distrostatus
+ my $error = length $self->{make}>3
+ ? substr($self->{make},3) : "Unknown error";
+ $CPAN::Frontend->mywarn("Could not make: $error\n");
+ $self->store_persistent_state;
+ return;
+ }
+ } else {
+ push @e, "Has already been made";
+ }
+ }
- if (exists $self->{later} and length($self->{later})) {
+ if ($self->{later}) { # see also undelay
if ($self->unsat_prereq) {
push @e, $self->{later};
-# RT ticket 18438 raises doubts if the deletion of {later} is valid.
-# YAML-0.53 triggered the later hodge-podge here, but my margin notes
-# are not sufficient to be sure if we really must/may do the delete
-# here. SO I accept the suggested patch for now. If we trigger a bug
-# again, I must go into deep contemplation about the {later} flag.
-
-# } else {
-# delete $self->{later};
}
}
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+ unless (chdir $builddir) {
+ push @e, "Couldn't chdir to '$builddir': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
if ($CPAN::Signal){
delete $self->{force_update};
return;
}
$CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
- my $builddir = $self->dir or
- $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
- chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
return;
}
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next unless defined $v;
+ $env{$k} = $v;
+ }
+ local %ENV = %env;
my $system;
- if ($self->{'configure'}) {
+ if (my $commandline = $self->prefs->{pl}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{'configure'}) {
$system = $self->{'configure'};
} elsif ($self->{modulebuild}) {
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
# $switch = "-MExtUtils::MakeMaker ".
# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
# if $] > 5.00310;
+ my $makepl_arg = $self->make_x_arg("pl");
$system = sprintf("%s%s Makefile.PL%s",
$perl,
$switch ? " $switch" : "",
- $CPAN::Config->{makepl_arg} ? " $CPAN::Config->{makepl_arg}" : "",
+ $makepl_arg ? " $makepl_arg" : "",
);
}
- unless (exists $self->{writemakefile}) {
+ if (my $env = $self->prefs->{pl}{env}) {
+ for my $e (keys %$env) {
+ $ENV{$e} = $env->{$e};
+ }
+ }
+ if (exists $self->{writemakefile}) {
+ } else {
local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
my($ret,$pid);
$@ = "";
return;
}
} else {
- $ret = system($system);
- if ($ret != 0) {
- $self->{writemakefile} = CPAN::Distrostatus
- ->new("NO '$system' returned status $ret");
- $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
- return;
- }
+ if (my $expect_model = $self->_prefs_with_expect("pl")) {
+ $ret = $self->_run_via_expect($system,$expect_model);
+ if (! defined $ret
+ && $self->{writemakefile}
+ && $self->{writemakefile}->failed) {
+ # timeout
+ return;
+ }
+ } else {
+ $ret = system($system);
+ }
+ if ($ret != 0) {
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new("NO '$system' returned status $ret");
+ $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- NOT OK\n");
+ }
}
if (-f "Makefile" || -f "Build") {
$self->{writemakefile} = CPAN::Distrostatus->new("YES");
delete $self->{make_clean}; # if cleaned before, enable next
} else {
$self->{writemakefile} = CPAN::Distrostatus
- ->new(qq{NO -- Unknown reason.});
+ ->new(qq{NO -- Unknown reason});
}
}
if ($CPAN::Signal){
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
$self->{make} = CPAN::Distrostatus->new("NO $need");
- return;
+ $self->store_persistent_state;
+ return $self->goodbye("[prereq] -- NOT OK\n");
} else {
- return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
+ my $follow = eval { $self->follow_prereqs(@prereq); };
+ if (0) {
+ } elsif ($follow){
+ # signal success to the queuerunner
+ return 1;
+ } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ return $self->goodbye("[depend] -- NOT OK\n");
+ }
}
}
- if ($self->{modulebuild}) {
- unless (-f "Build") {
- my $cwd = Cwd::cwd;
- $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
- " in cwd[$cwd]. Danger, Will Robinson!");
- $CPAN::Frontend->mysleep(5);
+ if ($CPAN::Signal){
+ delete $self->{force_update};
+ return;
+ }
+ if (my $commandline = $self->prefs->{make}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
+ } else {
+ if ($self->{modulebuild}) {
+ unless (-f "Build") {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
+ " in cwd[$cwd]. Danger, Will Robinson!\n");
+ $CPAN::Frontend->mysleep(5);
+ }
+ $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
+ } else {
+ $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
+ }
+ $system =~ s/\s+$//;
+ my $make_arg = $self->make_x_arg("make");
+ $system = sprintf("%s%s",
+ $system,
+ $make_arg ? " $make_arg" : "",
+ );
+ }
+ if (my $env = $self->prefs->{make}{env}) { # overriding the local
+ # ENV of PL, not the
+ # outer ENV, but
+ # unlikely to be a risk
+ for my $e (keys %$env) {
+ $ENV{$e} = $env->{$e};
}
- $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
+ }
+ my $expect_model = $self->_prefs_with_expect("make");
+ my $want_expect = 0;
+ if ( $expect_model && @{$expect_model->{talk}} ) {
+ my $can_expect = $CPAN::META->has_inst("Expect");
+ if ($can_expect) {
+ $want_expect = 1;
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
+ "system()\n");
+ }
+ }
+ my $system_ok;
+ if ($want_expect) {
+ $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
} else {
- $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
+ $system_ok = system($system) == 0;
}
- if (system($system) == 0) {
+ $self->introduce_myself;
+ if ( $system_ok ) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$self->{make} = CPAN::Distrostatus->new("YES");
} else {
$self->{make} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
}
+ $self->store_persistent_state;
}
-sub _make_command {
- my ($self) = @_;
- if ($self) {
- return
- CPAN::HandleConfig
- ->safe_quote(
- $CPAN::Config->{make} || $Config::Config{make} || 'make'
- );
+# CPAN::Distribution::goodbye ;
+sub goodbye {
+ my($self,$goodbye) = @_;
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn(" $id\n $goodbye");
+ return;
+}
+
+# CPAN::Distribution::_run_via_expect ;
+sub _run_via_expect {
+ my($self,$system,$expect_model) = @_;
+ CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
+ if ($CPAN::META->has_inst("Expect")) {
+ my $expo = Expect->new; # expo Expect object;
+ $expo->spawn($system);
+ $expect_model->{mode} ||= "deterministic";
+ if ($expect_model->{mode} eq "deterministic") {
+ return $self->_run_via_expect_deterministic($expo,$expect_model);
+ } elsif ($expect_model->{mode} eq "anyorder") {
+ return $self->_run_via_expect_anyorder($expo,$expect_model);
+ } else {
+ die "Panic: Illegal expect mode: $expect_model->{mode}";
+ }
} else {
- # Old style call, without object. Deprecated
- Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
- return
- safe_quote(undef, $CPAN::Config->{make} || $Config::Config{make} || 'make');
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
+ return system($system);
+ }
+}
+
+sub _run_via_expect_anyorder {
+ my($self,$expo,$expect_model) = @_;
+ my $timeout = $expect_model->{timeout} || 5;
+ my @expectacopy = @{$expect_model->{talk}}; # we trash it!
+ my $but = "";
+ EXPECT: while () {
+ my($eof,$ran_into_timeout);
+ my @match = $expo->expect($timeout,
+ [ eof => sub {
+ $eof++;
+ } ],
+ [ timeout => sub {
+ $ran_into_timeout++;
+ } ],
+ -re => eval"qr{.}",
+ );
+ if ($match[2]) {
+ $but .= $match[2];
+ }
+ $but .= $expo->clear_accum;
+ if ($eof) {
+ $expo->soft_close;
+ return $expo->exitstatus();
+ } elsif ($ran_into_timeout) {
+ # warn "DEBUG: they are asking a question, but[$but]";
+ for (my $i = 0; $i <= $#expectacopy; $i+=2) {
+ my($next,$send) = @expectacopy[$i,$i+1];
+ my $regex = eval "qr{$next}";
+ # warn "DEBUG: will compare with regex[$regex].";
+ if ($but =~ /$regex/) {
+ # warn "DEBUG: will send send[$send]";
+ $expo->send($send);
+ splice @expectacopy, $i, 2; # never allow reusing an QA pair
+ next EXPECT;
+ }
+ }
+ my $why = "could not answer a question during the dialog";
+ $CPAN::Frontend->mywarn("Failing: $why\n");
+ $self->{writemakefile} =
+ CPAN::Distrostatus->new("NO $why");
+ return;
+ }
}
}
-#-> sub CPAN::Distribution::follow_prereqs ;
-sub follow_prereqs {
- my($self) = shift;
- my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
- return unless @prereq_tuples;
- my @prereq = map { $_->[0] } @prereq_tuples;
- my $id = $self->id;
- my %map = (
- b => "build_requires",
- r => "requires",
- c => "commandline",
- );
- $CPAN::Frontend->
- myprint("---- Unsatisfied dependencies detected during\n".
- "---- $id\n".
- join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
- );
- my $follow = 0;
- if ($CPAN::Config->{prerequisites_policy} eq "follow") {
- $follow = 1;
- } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
- my $answer = CPAN::Shell::colorable_makemaker_prompt(
-"Shall I follow them and prepend them to the queue
-of modules we are processing right now?", "yes");
- $follow = $answer =~ /^\s*y/i;
- } else {
- local($") = ", ";
- $CPAN::Frontend->
- myprint(" Ignoring dependencies on modules @prereq\n");
+sub _run_via_expect_deterministic {
+ my($self,$expo,$expect_model) = @_;
+ my $ran_into_timeout;
+ my $timeout = $expect_model->{timeout} || 15; # currently unsettable
+ my $expecta = $expect_model->{talk};
+ EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
+ my($re,$send) = @$expecta[$i,$i+1];
+ CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
+ my $regex = eval "qr{$re}";
+ $expo->expect($timeout,
+ [ eof => sub {
+ my $but = $expo->clear_accum;
+ $CPAN::Frontend->mywarn("EOF (maybe harmless)
+expected[$regex]\nbut[$but]\n\n");
+ last EXPECT;
+ } ],
+ [ timeout => sub {
+ my $but = $expo->clear_accum;
+ $CPAN::Frontend->mywarn("TIMEOUT
+expected[$regex]\nbut[$but]\n\n");
+ $ran_into_timeout++;
+ } ],
+ -re => $regex);
+ if ($ran_into_timeout){
+ # note that the caller expects 0 for success
+ $self->{writemakefile} =
+ CPAN::Distrostatus->new("NO timeout during expect dialog");
+ return;
+ }
+ $expo->send($send);
}
- if ($follow) {
- # color them as dirty
- for my $p (@prereq) {
+ $expo->soft_close;
+ return $expo->exitstatus();
+}
+
+#-> CPAN::Distribution::_validate_distropref
+sub _validate_distropref {
+ my($self,@args) = @_;
+ if (
+ $CPAN::META->has_inst("CPAN::Kwalify")
+ &&
+ $CPAN::META->has_inst("Kwalify")
+ ) {
+ eval {CPAN::Kwalify::_validate("distroprefs",@args);};
+ if ($@) {
+ $CPAN::Frontend->mywarn($@);
+ }
+ } else {
+ CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
+ }
+}
+
+#-> CPAN::Distribution::_find_prefs
+sub _find_prefs {
+ my($self) = @_;
+ my $distroid = $self->pretty_id;
+ #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
+ my $prefs_dir = $CPAN::Config->{prefs_dir};
+ eval { File::Path::mkpath($prefs_dir); };
+ if ($@) {
+ $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
+ }
+ my $yaml_module = CPAN::_yaml_module;
+ my @extensions;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ push @extensions, "yml";
+ } else {
+ my @fallbacks;
+ if ($CPAN::META->has_inst("Data::Dumper")) {
+ push @extensions, "dd";
+ push @fallbacks, "Data::Dumper";
+ }
+ if ($CPAN::META->has_inst("Storable")) {
+ push @extensions, "st";
+ push @fallbacks, "Storable";
+ }
+ if (@fallbacks) {
+ local $" = " and ";
+ unless ($self->{have_complained_about_missing_yaml}++) {
+ $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
+ "to @fallbacks to read prefs '$prefs_dir'\n");
+ }
+ } else {
+ unless ($self->{have_complained_about_missing_yaml}++) {
+ $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
+ "read prefs '$prefs_dir'\n");
+ }
+ }
+ }
+ if (@extensions) {
+ my $dh = DirHandle->new($prefs_dir)
+ or die Carp::croak("Couldn't open '$prefs_dir': $!");
+ DIRENT: for (sort $dh->read) {
+ next if $_ eq "." || $_ eq "..";
+ my $exte = join "|", @extensions;
+ next unless /\.($exte)$/;
+ my $thisexte = $1;
+ my $abs = File::Spec->catfile($prefs_dir, $_);
+ if (-f $abs) {
+ #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
+ my @distropref;
+ if ($thisexte eq "yml") {
+ # need no eval because if we have no YAML we do not try to read *.yml
+ #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
+ @distropref = @{CPAN->_yaml_loadfile($abs)};
+ #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
+ } elsif ($thisexte eq "dd") {
+ package CPAN::Eval;
+ no strict;
+ open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
+ local $/;
+ my $eval = <FH>;
+ close FH;
+ eval $eval;
+ if ($@) {
+ $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
+ }
+ my $i = 1;
+ while (${"VAR".$i}) {
+ push @distropref, ${"VAR".$i};
+ $i++;
+ }
+ } elsif ($thisexte eq "st") {
+ # eval because Storable is never forward compatible
+ eval { @distropref = @{scalar Storable::retrieve($abs)}; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Error reading distroprefs file ".
+ "$_, skipping\: $@");
+ $CPAN::Frontend->mysleep(4);
+ next DIRENT;
+ }
+ }
+ # $DB::single=1;
+ #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
+ ELEMENT: for my $y (0..$#distropref) {
+ my $distropref = $distropref[$y];
+ $self->_validate_distropref($distropref,$abs,$y);
+ my $match = $distropref->{match};
+ unless ($match) {
+ #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
+ next ELEMENT;
+ }
+ my $ok = 1;
+ # do not take the order of C<keys %$match> because
+ # "module" is by far the slowest
+ my $saw_valid_subkeys = 0;
+ for my $sub_attribute (qw(distribution perl perlconfig module)) {
+ next unless exists $match->{$sub_attribute};
+ $saw_valid_subkeys++;
+ my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
+ if ($sub_attribute eq "module") {
+ my $okm = 0;
+ #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
+ my @modules = $self->containsmods;
+ #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
+ MODULE: for my $module (@modules) {
+ $okm ||= $module =~ /$qr/;
+ last MODULE if $okm;
+ }
+ $ok &&= $okm;
+ } elsif ($sub_attribute eq "distribution") {
+ my $okd = $distroid =~ /$qr/;
+ $ok &&= $okd;
+ } elsif ($sub_attribute eq "perl") {
+ my $okp = $^X =~ /$qr/;
+ $ok &&= $okp;
+ } elsif ($sub_attribute eq "perlconfig") {
+ for my $perlconfigkey (keys %{$match->{perlconfig}}) {
+ my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
+ # XXX should probably warn if Config does not exist
+ my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
+ $ok &&= $okpc;
+ last if $ok == 0;
+ }
+ } else {
+ $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
+ "unknown sub_attribut '$sub_attribute'. ".
+ "Please ".
+ "remove, cannot continue.");
+ }
+ last if $ok == 0; # short circuit
+ }
+ unless ($saw_valid_subkeys) {
+ $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
+ "missing match/* subattribute. ".
+ "Please ".
+ "remove, cannot continue.");
+ }
+ #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
+ if ($ok) {
+ return {
+ prefs => $distropref,
+ prefs_file => $abs,
+ prefs_file_doc => $y,
+ };
+ }
+
+ }
+ }
+ }
+ $dh->close;
+ }
+ return;
+}
+
+# CPAN::Distribution::prefs
+sub prefs {
+ my($self) = @_;
+ if (exists $self->{negative_prefs_cache}
+ &&
+ $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
+ ) {
+ delete $self->{negative_prefs_cache};
+ delete $self->{prefs};
+ }
+ if (exists $self->{prefs}) {
+ return $self->{prefs}; # XXX comment out during debugging
+ }
+ if ($CPAN::Config->{prefs_dir}) {
+ CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
+ my $prefs = $self->_find_prefs();
+ $prefs ||= ""; # avoid warning next line
+ CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
+ if ($prefs) {
+ for my $x (qw(prefs prefs_file prefs_file_doc)) {
+ $self->{$x} = $prefs->{$x};
+ }
+ my $bs = sprintf(
+ "%s[%s]",
+ File::Basename::basename($self->{prefs_file}),
+ $self->{prefs_file_doc},
+ );
+ my $filler1 = "_" x 22;
+ my $filler2 = int(66 - length($bs))/2;
+ $filler2 = 0 if $filler2 < 0;
+ $filler2 = " " x $filler2;
+ $CPAN::Frontend->myprint("
+$filler1 D i s t r o P r e f s $filler1
+$filler2 $bs $filler2
+");
+ $CPAN::Frontend->mysleep(1);
+ return $self->{prefs};
+ }
+ }
+ $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
+ return $self->{prefs} = +{};
+}
+
+# CPAN::Distribution::make_x_arg
+sub make_x_arg {
+ my($self, $whixh) = @_;
+ my $make_x_arg;
+ my $prefs = $self->prefs;
+ if (
+ $prefs
+ && exists $prefs->{$whixh}
+ && exists $prefs->{$whixh}{args}
+ && $prefs->{$whixh}{args}
+ ) {
+ $make_x_arg = join(" ",
+ map {CPAN::HandleConfig
+ ->safe_quote($_)} @{$prefs->{$whixh}{args}},
+ );
+ }
+ my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
+ $make_x_arg ||= $CPAN::Config->{$what};
+ return $make_x_arg;
+}
+
+# CPAN::Distribution::_make_command
+sub _make_command {
+ my ($self) = @_;
+ if ($self) {
+ return
+ CPAN::HandleConfig
+ ->safe_quote(
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make})
+ || $Config::Config{make}
+ || 'make'
+ );
+ } else {
+ # Old style call, without object. Deprecated
+ Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
+ return
+ safe_quote(undef,
+ CPAN::HandleConfig->prefs_lookup($self,q{make})
+ || $CPAN::Config->{make}
+ || $Config::Config{make}
+ || 'make');
+ }
+}
+
+#-> sub CPAN::Distribution::follow_prereqs ;
+sub follow_prereqs {
+ my($self) = shift;
+ my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
+ return unless @prereq_tuples;
+ my @prereq = map { $_->[0] } @prereq_tuples;
+ my $pretty_id = $self->pretty_id;
+ my %map = (
+ b => "build_requires",
+ r => "requires",
+ c => "commandline",
+ );
+ my($filler1,$filler2,$filler3,$filler4);
+ # $DB::single=1;
+ my $unsat = "Unsatisfied dependencies detected during";
+ my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
+ {
+ my $r = int(($w - length($unsat))/2);
+ my $l = $w - length($unsat) - $r;
+ $filler1 = "-"x4 . " "x$l;
+ $filler2 = " "x$r . "-"x4 . "\n";
+ }
+ {
+ my $r = int(($w - length($pretty_id))/2);
+ my $l = $w - length($pretty_id) - $r;
+ $filler3 = "-"x4 . " "x$l;
+ $filler4 = " "x$r . "-"x4 . "\n";
+ }
+ $CPAN::Frontend->
+ myprint("$filler1 $unsat $filler2".
+ "$filler3 $pretty_id $filler4".
+ join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
+ );
+ my $follow = 0;
+ if ($CPAN::Config->{prerequisites_policy} eq "follow") {
+ $follow = 1;
+ } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
+ my $answer = CPAN::Shell::colorable_makemaker_prompt(
+"Shall I follow them and prepend them to the queue
+of modules we are processing right now?", "yes");
+ $follow = $answer =~ /^\s*y/i;
+ } else {
+ local($") = ", ";
+ $CPAN::Frontend->
+ myprint(" Ignoring dependencies on modules @prereq\n");
+ }
+ if ($follow) {
+ my $id = $self->id;
+ # color them as dirty
+ for my $p (@prereq) {
# warn "calling color_cmd_tmps(0,1)";
- CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
+ my $any = CPAN::Shell->expandany($p);
+ if ($any) {
+ $any->color_cmd_tmps(0,2);
+ } else {
+ $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
+ $CPAN::Frontend->mysleep(2);
+ }
}
# queue them and re-queue yourself
CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
my $prereq_pm = $self->prereq_pm or return;
my(@need);
my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
+ my @merged = %merged;
+ CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
NEED: while (my($need_module, $need_version) = each %merged) {
- my($have_version,$inst_file);
+ my($available_version,$available_file,$nmo);
if ($need_module eq "perl") {
- $have_version = $];
- $inst_file = $^X;
+ $available_version = $];
+ $available_file = $^X;
} else {
- my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
+ $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
next if $nmo->uptodate;
- $inst_file = $nmo->inst_file;
+ $available_file = $nmo->available_file;
# if they have not specified a version, we accept any installed one
- if (not defined $need_version or
- $need_version eq "0" or
- $need_version eq "undef") {
- next if defined $inst_file;
+ if (defined $available_file
+ and ( # a few quick shortcurcuits
+ not defined $need_version
+ or $need_version eq '0' # "==" would trigger warning when not numeric
+ or $need_version eq "undef"
+ )) {
+ next NEED;
}
- $have_version = $nmo->inst_version;
+ $available_version = $nmo->available_version;
}
# We only want to install prereqs if either they're not installed
# or if the installed version is too old. We cannot omit this
# check, because if 'force' is in effect, nobody else will check.
- if (defined $inst_file) {
+ if (defined $available_file) {
my(@all_requirements) = split /\s*,\s*/, $need_version;
local($^W) = 0;
my $ok = 0;
if ($rq =~ s|>=\s*||) {
} elsif ($rq =~ s|>\s*||) {
# 2005-12: one user
- if (CPAN::Version->vgt($have_version,$rq)){
+ if (CPAN::Version->vgt($available_version,$rq)){
$ok++;
}
next RQ;
} elsif ($rq =~ s|!=\s*||) {
# 2005-12: no user
- if (CPAN::Version->vcmp($have_version,$rq)){
+ if (CPAN::Version->vcmp($available_version,$rq)){
$ok++;
next RQ;
} else {
}
} elsif ($rq =~ m|<=?\s*|) {
# 2005-12: no user
- $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
+ $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
$ok++;
next RQ;
}
- if (! CPAN::Version->vgt($rq, $have_version)){
+ if (! CPAN::Version->vgt($rq, $available_version)){
$ok++;
}
- CPAN->debug(sprintf("need_module[%s]inst_file[%s]".
- "inst_version[%s]rq[%s]ok[%d]",
+ CPAN->debug(sprintf("need_module[%s]available_file[%s]".
+ "available_version[%s]rq[%s]ok[%d]",
$need_module,
- $inst_file,
- $have_version,
+ $available_file,
+ $available_version,
CPAN::Version->readable($rq),
$ok,
)) if $CPAN::DEBUG;
}
if ($self->{sponsored_mods}{$need_module}++){
# We have already sponsored it and for some reason it's still
- # not available. So we do nothing. Or what should we do?
+ # not available. So we do ... what??
+
# if we push it again, we have a potential infinite loop
- next;
+
+ # The following "next" was a very problematic construct.
+ # It helped a lot but broke some day and had to be
+ # replaced.
+
+ # We must be able to deal with modules that come again and
+ # again as a prereq and have themselves prereqs and the
+ # queue becomes long but finally we would find the correct
+ # order. The RecursiveDependency check should trigger a
+ # die when it's becoming too weird. Unfortunately removing
+ # this next breaks many other things.
+
+ # The bug that brought this up is described in Todo under
+ # "5.8.9 cannot install Compress::Zlib"
+
+ # next; # this is the next that had to go away
+
+ # The following "next NEED" are fine and the error message
+ # explains well what is going on. For example when the DBI
+ # fails and consequently DBD::SQLite fails and now we are
+ # processing CPAN::SQLite. Then we must have a "next" for
+ # DBD::SQLite. How can we get it and how can we identify
+ # all other cases we must identify?
+
+ my $do = $nmo->distribution;
+ next NEED unless $do; # not on CPAN
+ NOSAYER: for my $nosayer (
+ "unwrapped",
+ "writemakefile",
+ "signature_verify",
+ "make",
+ "make_test",
+ "install",
+ "make_clean",
+ ) {
+ if ($do->{$nosayer}) {
+ if (UNIVERSAL::can($do->{$nosayer},"failed") ?
+ $do->{$nosayer}->failed :
+ $do->{$nosayer} =~ /^NO/) {
+ if ($nosayer eq "make_test"
+ &&
+ $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
+ ) {
+ next NOSAYER;
+ }
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$self->{ID}' failed when ".
+ "processing '$do->{ID}' with ".
+ "'$nosayer => $do->{$nosayer}'. Continuing, ".
+ "but chances to succeed are limited.\n"
+ );
+ next NEED;
+ } else { # the other guy succeeded
+ if ($nosayer eq "install") {
+ # we had this with
+ # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
+ # 2007-03
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$self->{ID}' already installed ".
+ "but installation looks suspicious. ".
+ "Skipping another installation attempt, ".
+ "to prevent looping endlessly.\n"
+ );
+ next NEED;
+ }
+ }
+ }
+ }
}
my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
push @need, [$need_module,$needed_as];
}
+ my @unfolded = map { "[".join(",",@$_)."]" } @need;
+ CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
@need;
}
my $yaml = File::Spec->catfile($build_dir,"META.yml");
$self->debug("yaml[$yaml]") if $CPAN::DEBUG;
return unless -f $yaml;
- if ($CPAN::META->has_inst("YAML")) {
- eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
- if ($@) {
- $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
- return;
- }
- if (not exists $self->{yaml_content}{dynamic_config}
- or $self->{yaml_content}{dynamic_config}
- ) {
- $self->{yaml_content} = undef;
- }
+ eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Could not read ".
+ "'$yaml'. Falling back to other ".
+ "methods to determine prerequisites\n");
+ return $self->{yaml_content} = undef; # if we die, then we
+ # cannot read YAML's own
+ # META.yml
+ }
+ # not "authoritative"
+ if (not exists $self->{yaml_content}{dynamic_config}
+ or $self->{yaml_content}{dynamic_config}
+ ) {
+ $self->{yaml_content} = undef;
}
$self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
if $CPAN::DEBUG;
#-> sub CPAN::Distribution::prereq_pm ;
sub prereq_pm {
my($self) = @_;
- return $self->{prereq_pm} if
- exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
+ $self->{prereq_pm_detected} ||= 0;
+ CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
+ return $self->{prereq_pm} if $self->{prereq_pm_detected};
return unless $self->{writemakefile} # no need to have succeeded
# but we must have run it
|| $self->{modulebuild};
+ CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
+ $self->{writemakefile}||"",
+ $self->{modulebuild}||"",
+ ) if $CPAN::DEBUG;
my($req,$breq);
if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
$req = $yaml->{requires} || {};
$breq = $yaml->{build_requires} || {};
undef $req unless ref $req eq "HASH" && %$req;
if ($req) {
- if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
+ if ($yaml->{generated_by} &&
+ $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
my $eummv = do { local $^W = 0; $1+0; };
if ($eummv < 6.2501) {
# thanks to Slaven for digging that out: MM before
if (-f $makefile
and
$fh = FileHandle->new("<$makefile\0")) {
+ CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
local($/) = "\n";
while (<$fh>) {
last if /MakeMaker post_initialize section/;
# Regexp modified by A.Speer to remember actual version of file
# PREREQ_PM hash key wants, then add to
- while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
+ while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
# In case a prereq is mentioned twice, complain.
if ( defined $req->{$1} ) {
warn "Warning: PREREQ_PM mentions $1 more than once, ".
"last mention wins";
}
- $req->{$1} = $2;
+ my($m,$n) = ($1,$2);
+ if ($n =~ /^q\[(.*?)\]$/) {
+ $n = $1;
+ }
+ $req->{$m} = $n;
}
last;
}
- } elsif (-f "Build") {
- if ($CPAN::META->has_inst("Module::Build")) {
- eval {
- $req = Module::Build->current->requires();
- $breq = Module::Build->current->build_requires();
- };
+ }
+ }
+ unless ($req || $breq) {
+ my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
+ my $buildfile = File::Spec->catfile($build_dir,"Build");
+ if (-f $buildfile) {
+ CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
+ my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
+ if (-f $build_prereqs) {
+ CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
+ my $content = do { local *FH;
+ open FH, $build_prereqs
+ or $CPAN::Frontend->mydie("Could not open ".
+ "'$build_prereqs': $!");
+ local $/;
+ <FH>;
+ };
+ my $bphash = eval $content;
if ($@) {
- # HTML::Mason prompted for this with bleadperl@28900 or so
- $CPAN::Frontend
- ->mywarn(
- sprintf("Warning: while trying to determine ".
- "prerequisites for %s with the help of ".
- "Module::Build the following error ".
- "occurred: '%s'\n\nCannot care for prerequisites\n",
- $self->id,
- $@
- ));
- $self->{prereq_pm_detected}++;
- return $self->{prereq_pm} = {requires=>{},build_requires=>{}};
+ } else {
+ $req = $bphash->{requires} || +{};
+ $breq = $bphash->{build_requires} || +{};
}
}
}
$req->{"Module::Build"} = 0;
delete $self->{writemakefile};
}
- $self->{prereq_pm_detected}++;
- return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
+ if ($req || $breq) {
+ $self->{prereq_pm_detected}++;
+ return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
+ }
}
#-> sub CPAN::Distribution::test ;
sub test {
my($self) = @_;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
$self->make;
if ($CPAN::Signal){
delete $self->{force_update};
}
my $make = $self->{modulebuild} ? "Build" : "make";
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
$CPAN::Frontend->myprint("Running $make test\n");
- if (my @prereq = $self->unsat_prereq){
- unless ($prereq[0][0] eq "perl") {
- return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
- }
- }
+
+# if (my @prereq = $self->unsat_prereq){
+# if ( $CPAN::DEBUG ) {
+# require Data::Dumper;
+# CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
+# }
+# unless ($prereq[0][0] eq "perl") {
+# return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
+# }
+# }
+
EXCUSE: {
my @e;
- unless (exists $self->{make} or exists $self->{later}) {
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
push @e,
"Make had some problems, won't test";
}
exists $self->{make} and
(
- $self->{make}->can("failed") ?
+ UNIVERSAL::can($self->{make},"failed") ?
$self->{make}->failed :
$self->{make} =~ /^NO/
) and push @e, "Can't test without successful make";
-
$self->{badtestcnt} ||= 0;
- $self->{badtestcnt} > 0 and
+ if ($self->{badtestcnt} > 0) {
+ require Data::Dumper;
+ CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
push @e, "Won't repeat unsuccessful test during this command";
+ }
- exists $self->{later} and length($self->{later}) and
- push @e, $self->{later};
+ push @e, $self->{later} if $self->{later};
if (exists $self->{build_dir}) {
- if ($CPAN::META->{is_tested}{$self->{build_dir}}
- &&
- exists $self->{make_test}
- &&
- !(
- $self->{make_test}->can("failed") ?
- $self->{make_test}->failed :
- $self->{make_test} =~ /^NO/
- )
- ) {
- push @e, "Already tested successfully";
+ if (exists $self->{make_test}) {
+ if (
+ UNIVERSAL::can($self->{make_test},"failed") ?
+ $self->{make_test}->failed :
+ $self->{make_test} =~ /^NO/
+ ) {
+ if (
+ UNIVERSAL::can($self->{make_test},"commandid")
+ &&
+ $self->{make_test}->commandid == $CPAN::CurrentCommandId
+ ) {
+ push @e, "Has already been tested within this command";
+ }
+ } else {
+ push @e, "Has already been tested successfully";
+ }
}
} elsif (!@e) {
push @e, "Has no own directory";
}
-
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ unless (chdir $self->{build_dir}) {
+ push @e, "Couldn't chdir to '$self->{build_dir}': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
- chdir $self->{'build_dir'} or
- Carp::croak("Couldn't chdir to $self->{'build_dir'}");
- $self->debug("Changed directory to $self->{'build_dir'}")
+ $self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
}
}
- local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
- ? $ENV{PERL5LIB}
- : ($ENV{PERLLIB} || "");
-
- $CPAN::META->set_perl5lib;
- local $ENV{MAKEFLAGS}; # protect us from outer make calls
-
my $system;
- if ($self->{modulebuild}) {
+ if (my $commandline = $self->prefs->{test}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{modulebuild}) {
$system = sprintf "%s test", $self->_build_command();
} else {
$system = join " ", $self->_make_command(), "test";
}
- my $tests_ok;
- if ( $CPAN::Config->{test_report} &&
- $CPAN::META->has_inst("CPAN::Reporter") ) {
+ my $make_test_arg = $self->make_x_arg("test");
+ $system = sprintf("%s%s",
+ $system,
+ $make_test_arg ? " $make_test_arg" : "",
+ );
+ my($tests_ok);
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next unless defined $v;
+ $env{$k} = $v;
+ }
+ local %ENV = %env;
+ if (my $env = $self->prefs->{test}{env}) {
+ for my $e (keys %$env) {
+ $ENV{$e} = $env->{$e};
+ }
+ }
+ my $expect_model = $self->_prefs_with_expect("test");
+ my $want_expect = 0;
+ if ( $expect_model && @{$expect_model->{talk}} ) {
+ my $can_expect = $CPAN::META->has_inst("Expect");
+ if ($can_expect) {
+ $want_expect = 1;
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
+ "testing without\n");
+ }
+ }
+ my $test_report = CPAN::HandleConfig->prefs_lookup($self,
+ q{test_report});
+ my $want_report;
+ if ($test_report) {
+ my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
+ if ($can_report) {
+ $want_report = 1;
+ } else {
+ $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
+ "testing without\n");
+ }
+ }
+ my $ready_to_report = $want_report;
+ if ($ready_to_report
+ && $self->is_dot_dist
+ ) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "for local directories\n");
+ $ready_to_report = 0;
+ }
+ if ($ready_to_report
+ &&
+ $self->prefs->{patches}
+ &&
+ @{$self->prefs->{patches}}
+ &&
+ $self->{patched}
+ ) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "when the source has been patched\n");
+ $ready_to_report = 0;
+ }
+ if ($want_expect) {
+ if ($ready_to_report) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
+ "not supported when distroprefs specify ".
+ "an interactive test\n");
+ }
+ $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
+ } elsif ( $ready_to_report ) {
$tests_ok = CPAN::Reporter::test($self, $system);
} else {
$tests_ok = system($system) == 0;
}
+ $self->introduce_myself;
if ( $tests_ok ) {
{
my @prereq;
+
+ # local $CPAN::DEBUG = 16; # Distribution
for my $m (keys %{$self->{sponsored_mods}}) {
- my $m_obj = CPAN::Shell->expand("Module",$m);
- if (!$m_obj->distribution->{make_test}
- ||
- $m_obj->distribution->{make_test}->failed){
- #$m_obj->dump;
+ my $m_obj = CPAN::Shell->expand("Module",$m) or next;
+ # XXX we need available_version which reflects
+ # $ENV{PERL5LIB} so that already tested but not yet
+ # installed modules are counted.
+ my $available_version = $m_obj->available_version;
+ my $available_file = $m_obj->available_file;
+ if ($available_version &&
+ !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
+ ) {
+ CPAN->debug("m[$m] good enough available_version[$available_version]")
+ if $CPAN::DEBUG;
+ } elsif ($available_file
+ && (
+ !$self->{prereq_pm}{$m}
+ ||
+ $self->{prereq_pm}{$m} == 0
+ )
+ ) {
+ # lex Class::Accessor::Chained::Fast which has no $VERSION
+ CPAN->debug("m[$m] have available_file[$available_file]")
+ if $CPAN::DEBUG;
+ } else {
push @prereq, $m;
}
}
if (@prereq){
my $cnt = @prereq;
my $which = join ",", @prereq;
- my $verb = $cnt == 1 ? "one dependency not OK ($which)" :
+ my $but = $cnt == 1 ? "one dependency not OK ($which)" :
"$cnt dependencies missing ($which)";
- $CPAN::Frontend->mywarn("Tests succeeded but $verb\n");
- $self->{make_test} = CPAN::Distrostatus->new("NO -- $verb");
- return;
+ $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO $but");
+ $self->store_persistent_state;
+ return $self->goodbye("[dependencies] -- NA");
}
}
$CPAN::Frontend->myprint(" $system -- OK\n");
- $CPAN::META->is_tested($self->{'build_dir'});
$self->{make_test} = CPAN::Distrostatus->new("YES");
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ # probably impossible to need the next line because badtestcnt
+ # has a lifespan of one command
+ delete $self->{badtestcnt};
} else {
$self->{make_test} = CPAN::Distrostatus->new("NO");
$self->{badtestcnt}++;
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
}
+ $self->store_persistent_state;
+}
+
+sub _prefs_with_expect {
+ my($self,$where) = @_;
+ return unless my $prefs = $self->prefs;
+ return unless my $where_prefs = $prefs->{$where};
+ if ($where_prefs->{expect}) {
+ return {
+ mode => "deterministic",
+ timeout => 15,
+ talk => $where_prefs->{expect},
+ };
+ } elsif ($where_prefs->{"eexpect"}) {
+ return $where_prefs->{"eexpect"};
+ }
+ return;
}
#-> sub CPAN::Distribution::clean ;
$CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
return 1;
}
+ if (exists $self->{writemakefile}
+ and $self->{writemakefile}->failed
+ ) {
+ $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
+ return 1;
+ }
EXCUSE: {
my @e;
exists $self->{make_clean} and $self->{make_clean} eq "YES" and
push @e, "make clean already called once";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
- chdir $self->{'build_dir'} or
- Carp::croak("Couldn't chdir to $self->{'build_dir'}");
- $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
+ chdir $self->{build_dir} or
+ Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
+ $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_clean($self);
my $system;
if ($self->{modulebuild}) {
unless (-f "Build") {
- my $cwd = Cwd::cwd;
+ my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
" in cwd[$cwd]. Danger, Will Robinson!");
$CPAN::Frontend->mysleep(5);
} else {
$system = join " ", $self->_make_command(), "clean";
}
- if (system($system) == 0) {
+ my $system_ok = system($system) == 0;
+ $self->introduce_myself;
+ if ( $system_ok ) {
$CPAN::Frontend->myprint(" $system -- OK\n");
# $self->force;
# $self->force("make"); # so that this directory won't be used again
}
+ $self->store_persistent_state;
+}
+
+#-> sub CPAN::Distribution::goto ;
+sub goto {
+ my($self,$goto) = @_;
+ $goto = $self->normalize($goto);
+
+ # inject into the queue
+
+ CPAN::Queue->delete($self->id);
+ CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
+
+ # and run where we left off
+
+ my($method) = (caller(1))[3];
+ CPAN->instance("CPAN::Distribution",$goto)->$method();
+ CPAN::Queue->delete_first($goto);
}
#-> sub CPAN::Distribution::install ;
sub install {
my($self) = @_;
- $self->test;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+ # $DB::single=1;
+ unless ($self->{badtestcnt}) {
+ $self->test;
+ }
if ($CPAN::Signal){
delete $self->{force_update};
return;
$CPAN::Frontend->myprint("Running $make install\n");
EXCUSE: {
my @e;
- unless (exists $self->{make} or exists $self->{later}) {
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
push @e,
"Make had some problems, won't install";
}
exists $self->{make} and
(
- $self->{make}->can("failed") ?
+ UNIVERSAL::can($self->{make},"failed") ?
$self->{make}->failed :
$self->{make} =~ /^NO/
) and
if (exists $self->{make_test} and
(
- $self->{make_test}->can("failed") ?
+ UNIVERSAL::can($self->{make_test},"failed") ?
$self->{make_test}->failed :
$self->{make_test} =~ /^NO/
)){
"won't install without force"
}
}
- if (exists $self->{'install'}) {
- if ($self->{'install'}->can("text") ?
- $self->{'install'}->text eq "YES" :
- $self->{'install'} =~ /^YES/
+ if (exists $self->{install}) {
+ if (UNIVERSAL::can($self->{install},"text") ?
+ $self->{install}->text eq "YES" :
+ $self->{install} =~ /^YES/
) {
- push @e, "Already done";
+ $CPAN::Frontend->myprint(" Already done\n");
+ $CPAN::META->is_installed($self->{build_dir});
+ return 1;
} else {
# comment in Todo on 2006-02-11; maybe retry?
push @e, "Already tried without success";
}
}
- exists $self->{later} and length($self->{later}) and
- push @e, $self->{later};
+ push @e, $self->{later} if $self->{later};
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ unless (chdir $self->{build_dir}) {
+ push @e, "Couldn't chdir to '$self->{build_dir}': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
- chdir $self->{'build_dir'} or
- Carp::croak("Couldn't chdir to $self->{'build_dir'}");
- $self->debug("Changed directory to $self->{'build_dir'}")
+ $self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
}
my $system;
- if ($self->{modulebuild}) {
+ if (my $commandline = $self->prefs->{install}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{modulebuild}) {
my($mbuild_install_build_command) =
exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
$CPAN::Config->{mbuild_install_build_command} ?
$CPAN::Config->{mbuild_install_arg},
);
} else {
- my($make_install_make_command) = $CPAN::Config->{make_install_make_command} ||
- $self->_make_command();
+ my($make_install_make_command) =
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make_install_make_command})
+ || $self->_make_command();
$system = sprintf("%s install %s",
$make_install_make_command,
$CPAN::Config->{make_install_arg},
}
my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
- $CPAN::Config->{build_requires_install_policy}||="ask/yes";
+ my $brip = CPAN::HandleConfig->prefs_lookup($self,
+ q{build_requires_install_policy});
+ $brip ||="ask/yes";
my $id = $self->id;
my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
my $want_install = "yes";
if ($reqtype eq "b") {
- if ($CPAN::Config->{build_requires_install_policy} eq "no") {
+ if ($brip eq "no") {
$want_install = "no";
- } elsif ($CPAN::Config->{build_requires_install_policy} =~ m|^ask/(.+)|) {
+ } elsif ($brip =~ m|^ask/(.+)|) {
my $default = $1;
$default = "yes" unless $default =~ /^(y|n)/i;
$want_install =
$makeout .= $_;
}
$pipe->close;
- if ($?==0) {
+ my $close_ok = $? == 0;
+ $self->introduce_myself;
+ if ( $close_ok ) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$CPAN::META->is_installed($self->{build_dir});
- return $self->{install} = CPAN::Distrostatus->new("YES");
+ $self->{install} = CPAN::Distrostatus->new("YES");
} else {
$self->{install} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ my $mimc =
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make_install_make_command});
if (
$makeout =~ /permission/s
&& $> > 0
&& (
- ! $CPAN::Config->{make_install_make_command}
- || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
+ ! $mimc
+ || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
+ q{make}))
)
) {
$CPAN::Frontend->myprint(
}
}
delete $self->{force_update};
+ # $DB::single = 1;
+ $self->store_persistent_state;
+}
+
+sub introduce_myself {
+ my($self) = @_;
+ $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
}
#-> sub CPAN::Distribution::dir ;
sub dir {
- shift->{'build_dir'};
+ shift->{build_dir};
}
#-> sub CPAN::Distribution::perldoc ;
$CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
if $CPAN::DEBUG;
- local *README;
- $pid = open README, "which $binary|"
- or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
- while (<README>) {
- $out .= $_;
+ if ($CPAN::META->has_inst("File::Which")) {
+ return File::Which::which($binary);
+ } else {
+ local *README;
+ $pid = open README, "which $binary|"
+ or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
+ return unless $pid;
+ while (<README>) {
+ $out .= $_;
+ }
+ close README
+ or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
+ and return;
}
- close README or die "Could not run 'which $binary': $!";
$CPAN::Frontend->myprint(qq{ + $out \n})
if $CPAN::DEBUG && $out;
my($fh,$filename);
if ($CPAN::META->has_inst("File::Temp")) {
$fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
template => 'cpan_htmlconvert_XXXX',
suffix => '.txt',
unlink => 0,
my($fh,$filename);
if ($CPAN::META->has_inst("File::Temp")) {
$fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
template => "cpan_getsave_url_XXXX",
suffix => ".html",
unlink => 0,
return "./Build";
}
+#-> sub CPAN::Distribution::reports
+sub reports {
+ my($self) = @_;
+ my $pathname = $self->id;
+ $CPAN::Frontend->myprint("Distribution: $pathname\n");
+
+ unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
+ $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
+ }
+ unless ($CPAN::META->has_usable("LWP")) {
+ $CPAN::Frontend->mydie("LWP not installed; cannot continue");
+ }
+ unless ($CPAN::META->has_inst("File::Temp")) {
+ $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
+ }
+
+ my $d = CPAN::DistnameInfo->new($pathname);
+
+ my $dist = $d->dist; # "CPAN-DistnameInfo"
+ my $version = $d->version; # "0.02"
+ my $maturity = $d->maturity; # "released"
+ my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
+ my $cpanid = $d->cpanid; # "GBARR"
+ my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
+
+ my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
+
+ CPAN::LWP::UserAgent->config;
+ my $Ua;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ $CPAN::Frontend->myprint("Fetching '$url'...");
+ my $resp = $Ua->get($url);
+ unless ($resp->is_success) {
+ $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
+ }
+ $CPAN::Frontend->myprint("DONE\n\n");
+ my $yaml = $resp->content;
+ # was fuer ein Umweg!
+ my $fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => 'cpan_reports_XXXX',
+ suffix => '.yaml',
+ unlink => 0,
+ );
+ my $tfilename = $fh->filename;
+ print $fh $yaml;
+ close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
+ my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
+ unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
+ my %other_versions;
+ my $this_version_seen;
+ for my $rep (@$unserialized) {
+ my $rversion = $rep->{version};
+ if ($rversion eq $version){
+ unless ($this_version_seen++) {
+ $CPAN::Frontend->myprint ("$rep->{version}:\n");
+ }
+ $CPAN::Frontend->myprint
+ (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
+ $rep->{archname} eq $Config::Config{archname}?"*":"",
+ $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
+ $rep->{action},
+ $rep->{perl},
+ ucfirst $rep->{osname},
+ $rep->{osvers},
+ $rep->{archname},
+ ));
+ } else {
+ $other_versions{$rep->{version}}++;
+ }
+ }
+ unless ($this_version_seen) {
+ $CPAN::Frontend->myprint("No reports found for version '$version'
+Reports for other versions:\n");
+ for my $v (sort keys %other_versions) {
+ $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
+ }
+ }
+ $url =~ s/\.yaml/.html/;
+ $CPAN::Frontend->myprint("See $url for details\n");
+}
+
package CPAN::Bundle;
use strict;
$CPAN::Frontend->myprint($self->as_string);
}
+#-> CPAN::Bundle::undelay
sub undelay {
my $self = shift;
delete $self->{later};
# to recurse into its prereq_pms, a bundle needs to recurse into its modules
return if exists $self->{incommandcolor}
+ && $color==1
&& $self->{incommandcolor}==$color;
- if ($depth>=100){
- $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
+ if ($depth>=$CPAN::MAX_RECURSION){
+ die(CPAN::Exception::RecursiveDependency->new($ancestors));
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
$obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
- if ($color==0) {
- delete $self->{badtestcnt};
- }
+ # never reached code?
+ #if ($color==0) {
+ #delete $self->{badtestcnt};
+ #}
$self->{incommandcolor} = $color;
}
}
my $dist = $CPAN::META->instance('CPAN::Distribution',
$self->cpan_file);
+ $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
$dist->get;
- $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
+ $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
my($todir) = $CPAN::Config->{'cpan_home'};
my(@me,$from,$to,$me);
@me = split /::/, $self->id;
$me[-1] .= ".pm";
$me = File::Spec->catfile(@me);
- $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
+ $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
$to = File::Spec->catfile($todir,$me);
File::Path::mkpath(File::Basename::dirname($to));
File::Copy::copy($from, $to)
if ($type eq 'CPAN::Distribution') {
$CPAN::Frontend->mywarn(qq{
The Bundle }.$self->id.qq{ contains
-explicitly a file $s.
+explicitly a file '$s'.
+Going to $meth that.
});
- $CPAN::Frontend->mysleep(3);
+ $CPAN::Frontend->mysleep(5);
}
# possibly noisy action:
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
my $obj = $CPAN::META->instance($type,$s);
$obj->{reqtype} = $self->{reqtype};
$obj->$meth();
- if ($obj->isa('CPAN::Bundle')
- &&
- exists $obj->{install_failed}
- &&
- ref($obj->{install_failed}) eq "HASH"
- ) {
- for (keys %{$obj->{install_failed}}) {
- $self->{install_failed}{$_} = undef; # propagate faiure up
- # to me in a
- # recursive call
- $fail{$s} = 1; # the bundle itself may have succeeded but
- # not all children
- }
- } else {
- my $success;
- $success = $obj->can("uptodate") ? $obj->uptodate : 0;
- $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
- if ($success) {
- delete $self->{install_failed}{$s};
- } else {
- $fail{$s} = 1;
- }
- }
- }
-
- # recap with less noise
- if ( $meth eq "install" ) {
- if (%fail) {
- require Text::Wrap;
- my $raw = sprintf(qq{Bundle summary:
-The following items in bundle %s had installation problems:},
- $self->id
- );
- $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
- $CPAN::Frontend->myprint("\n");
- my $paragraph = "";
- my %reported;
- for $s ($self->contains) {
- if ($fail{$s}){
- $paragraph .= "$s ";
- $self->{install_failed}{$s} = undef;
- $reported{$s} = undef;
- }
- }
- my $report_propagated;
- for $s (sort keys %{$self->{install_failed}}) {
- next if exists $reported{$s};
- $paragraph .= "and the following items had problems
-during recursive bundle calls: " unless $report_propagated++;
- $paragraph .= "$s ";
- }
- $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
- $CPAN::Frontend->myprint("\n");
- } else {
- $self->{'install'} = 'YES';
- }
}
}
}
#-> sub CPAN::Bundle::force ;
+sub fforce { shift->rematein('fforce',@_); }
+#-> sub CPAN::Bundle::force ;
sub force { shift->rematein('force',@_); }
#-> sub CPAN::Bundle::notest ;
sub notest { shift->rematein('notest',@_); }
#-> sub CPAN::Bundle::test ;
sub test {
my $self = shift;
- $self->{badtestcnt} ||= 0;
+ # $self->{badtestcnt} ||= 0;
$self->rematein('test',@_);
}
#-> sub CPAN::Bundle::install ;
use strict;
# Accessors
-# sub CPAN::Module::userid
+#-> sub CPAN::Module::userid
sub userid {
my $self = shift;
my $ro = $self->ro;
return unless $ro;
return $ro->{userid} || $ro->{CPAN_USERID};
}
-# sub CPAN::Module::description
+#-> sub CPAN::Module::description
sub description {
my $self = shift;
my $ro = $self->ro or return "";
$ro->{description}
}
+#-> sub CPAN::Module::distribution
sub distribution {
my($self) = @_;
CPAN::Shell->expand("Distribution",$self->cpan_file);
}
-# sub CPAN::Module::undelay
+#-> sub CPAN::Module::undelay
sub undelay {
my $self = shift;
delete $self->{later};
# a module needs to recurse to its cpan_file
return if exists $self->{incommandcolor}
+ && $color==1
&& $self->{incommandcolor}==$color;
- return if $depth>=1 && $self->uptodate;
- if ($depth>=100){
- $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
- }
+ return if $color==0 && !$self->{incommandcolor};
+ if ($color>=1) {
+ if ( $self->uptodate ) {
+ $self->{incommandcolor} = $color;
+ return;
+ } elsif (my $have_version = $self->available_version) {
+ # maybe what we have is good enough
+ if (@$ancestors) {
+ my $who_asked_for_me = $ancestors->[-1];
+ my $obj = CPAN::Shell->expandany($who_asked_for_me);
+ if (0) {
+ } elsif ($obj->isa("CPAN::Bundle")) {
+ # bundles cannot specify a minimum version
+ return;
+ } elsif ($obj->isa("CPAN::Distribution")) {
+ if (my $prereq_pm = $obj->prereq_pm) {
+ for my $k (keys %$prereq_pm) {
+ if (my $want_version = $prereq_pm->{$k}{$self->id}) {
+ if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
+ $self->{incommandcolor} = $color;
+ return;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ $self->{incommandcolor} = $color; # set me before recursion,
+ # so we can break it
+ }
+ if ($depth>=$CPAN::MAX_RECURSION){
+ die(CPAN::Exception::RecursiveDependency->new($ancestors));
+ }
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
$dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
- if ($color==0) {
- delete $self->{badtestcnt};
- }
+ # unreached code?
+ # if ($color==0) {
+ # delete $self->{badtestcnt};
+ # }
$self->{incommandcolor} = $color;
}
sub dslip_status {
my($self) = @_;
my($stat);
+ # development status
@{$stat->{D}}{qw,i c a b R M S,} = qw,idea
pre-alpha alpha beta released
mature standard,;
+ # support level
@{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
developer comp.lang.perl.*
none abandoned,;
+ # language
@{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
+ # interface
@{$stat->{I}}{qw,f r O p h n,} = qw,functions
references+ties
object-oriented pragma
hybrid none,;
+ # public licence
@{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
GPL LGPL
BSD Artistic
join "", @m, "\n";
}
+#-> sub CPAN::Module::manpage_headline
sub manpage_headline {
my($self,$local_file) = @_;
my(@local_file) = $local_file;
# Note: also inherited by CPAN::Bundle
sub cpan_file {
my $self = shift;
- CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
+ # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
unless ($self->ro) {
CPAN::Index->reload;
}
#-> sub CPAN::Module::force ;
sub force {
my($self) = @_;
- $self->{'force_update'}++;
+ $self->{force_update} = 1;
}
+#-> sub CPAN::Module::fforce ;
+sub fforce {
+ my($self) = @_;
+ $self->{force_update} = 2;
+}
+
+#-> sub CPAN::Module::notest ;
sub notest {
my($self) = @_;
- # warn "XDEBUG: set notest for Module";
- $self->{'notest'}++;
+ # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
+ $self->{notest}++;
}
#-> sub CPAN::Module::rematein ;
}
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
$pack->called_for($self->id);
- $pack->force($meth) if exists $self->{'force_update'};
- $pack->notest($meth) if exists $self->{'notest'};
+ if (exists $self->{force_update}){
+ if ($self->{force_update} == 2) {
+ $pack->fforce($meth);
+ } else {
+ $pack->force($meth);
+ }
+ }
+ $pack->notest($meth) if exists $self->{notest} && $self->{notest};
$pack->{reqtype} ||= "";
CPAN->debug("dist-reqtype[$pack->{reqtype}]".
exists $pack->{install}
&&
(
- $pack->{install}->can("failed") ?
+ UNIVERSAL::can($pack->{install},"failed") ?
$pack->{install}->failed :
$pack->{install} =~ /^NO/
)
$pack->{reqtype} = $self->{reqtype};
}
- eval {
+ my $success = eval {
$pack->$meth();
};
my $err = $@;
- $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
- $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
- delete $self->{'force_update'};
- delete $self->{'notest'};
+ $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
+ $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
+ delete $self->{force_update};
+ delete $self->{notest};
if ($err) {
die $err;
}
+ return $success;
}
#-> sub CPAN::Module::perldoc ;
#-> sub CPAN::Module::test ;
sub test {
my $self = shift;
- $self->{badtestcnt} ||= 0;
+ # $self->{badtestcnt} ||= 0;
$self->rematein('test',@_);
}
#-> sub CPAN::Module::uptodate ;
my($doit) = 0;
if ($self->uptodate
&&
- not exists $self->{'force_update'}
+ not exists $self->{force_update}
) {
$CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
$self->id,
#-> sub CPAN::Module::inst_file ;
sub inst_file {
my($self) = @_;
+ $self->_file_in_path([@INC]);
+}
+
+#-> sub CPAN::Module::available_file ;
+sub available_file {
+ my($self) = @_;
+ my $sep = $Config::Config{path_sep};
+ my $perllib = $ENV{PERL5LIB};
+ $perllib = $ENV{PERLLIB} unless defined $perllib;
+ my @perllib = split(/$sep/,$perllib) if defined $perllib;
+ $self->_file_in_path([@perllib,@INC]);
+}
+
+#-> sub CPAN::Module::file_in_path ;
+sub _file_in_path {
+ my($self,$path) = @_;
my($dir,@packpath);
@packpath = split /::/, $self->{ID};
$packpath[-1] .= ".pm";
if (@packpath == 1 && $packpath[0] eq "readline.pm") {
unshift @packpath, "Term", "ReadLine"; # historical reasons
}
- foreach $dir (@INC) {
+ foreach $dir (@$path) {
my $pmfile = File::Spec->catfile($dir,@packpath);
if (-f $pmfile){
return $pmfile;
sub inst_version {
my($self) = @_;
my $parsefile = $self->inst_file or return;
- local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
- my $have;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
- $have = MM->parse_version($parsefile) || "undef";
+#-> sub CPAN::Module::inst_version ;
+sub available_version {
+ my($self) = @_;
+ my $parsefile = $self->available_file or return;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
+
+#-> sub CPAN::Module::parse_version ;
+sub parse_version {
+ my($self,$parsefile) = @_;
+ my $have = MM->parse_version($parsefile);
+ $have = "undef" unless defined $have && length $have;
$have =~ s/^ //; # since the %vd hack these two lines here are needed
$have =~ s/ $//; # trailing whitespace happens all the time
- # My thoughts about why %vd processing should happen here
-
- # Alt1 maintain it as string with leading v:
- # read index files do nothing
- # compare it use utility for compare
- # print it do nothing
-
- # Alt2 maintain it as what it is
- # read index files convert
- # compare it use utility because there's still a ">" vs "gt" issue
- # print it use CPAN::Version for print
-
- # Seems cleaner to hold it in memory as a string starting with a "v"
-
- # If the author of this module made a mistake and wrote a quoted
- # "v1.13" instead of v1.13, we simply leave it at that with the
- # effect that *we* will treat it like a v-tring while the rest of
- # perl won't. Seems sensible when we consider that any action we
- # could take now would just add complexity.
-
$have = CPAN::Version->readable($have);
$have =~ s/\s*//g; # stringify to float around floating point issues
$have; # no stringify needed, \s* above matches always
}
+#-> sub CPAN::Module::reports
+sub reports {
+ my($self) = @_;
+ $self->distribution->reports;
+}
+
package CPAN;
use strict;
Interactive mode:
- perl -MCPAN -e shell;
+ perl -MCPAN -e shell
-Batch mode:
+--or--
- use CPAN;
+ cpan
- # modules:
+Basic commands:
- $mod = "Acme::Meta";
- install $mod;
- CPAN::Shell->install($mod); # same thing
- CPAN::Shell->expandany($mod)->install; # same thing
- CPAN::Shell->expand("Module",$mod)->install; # same thing
- CPAN::Shell->expand("Module",$mod)
- ->distribution->install; # same thing
+ # Modules:
- # distributions:
+ cpan> install Acme::Meta # in the shell
- $distro = "NWCLARK/Acme-Meta-0.01.tar.gz";
- install $distro; # same thing
- CPAN::Shell->install($distro); # same thing
- CPAN::Shell->expandany($distro)->install; # same thing
- CPAN::Shell->expand("Distribution",$distro)->install; # same thing
+ CPAN::Shell->install("Acme::Meta"); # in perl
-=head1 STATUS
+ # Distributions:
-This module and its competitor, the CPANPLUS module, are both much
-cooler than the other.
+ cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
-=head1 COMPATIBILITY
+ CPAN::Shell->
+ install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
-CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
-newer versions. It is getting more and more difficult to get the
-minimal prerequisites working on older perls. It is close to
-impossible to get the whole Bundle::CPAN working there. If you're in
-the position to have only these old versions, be advised that CPAN is
-designed to work fine without the Bundle::CPAN installed.
+ # module objects:
-To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
-compatible with ancient perls and that File::Temp is listed as a
-prerequisite but CPAN has reasonable workarounds if it is missing.
+ $mo = CPAN::Shell->expandany($mod);
+ $mo = CPAN::Shell->expand("Module",$mod); # same thing
+
+ # distribution objects:
+
+ $do = CPAN::Shell->expand("Module",$mod)->distribution;
+ $do = CPAN::Shell->expandany($distro); # same thing
+ $do = CPAN::Shell->expand("Distribution",
+ $distro); # same thing
=head1 DESCRIPTION
-The CPAN module is designed to automate the make and install of perl
-modules and extensions. It includes some primitive searching
-capabilities and knows how to use Net::FTP or LWP (or some external
-download clients) to fetch the raw data from the net.
+The CPAN module automates or at least simplifies the make and install
+of perl modules and extensions. It includes some primitive searching
+capabilities and knows how to use Net::FTP or LWP or some external
+download clients to fetch the distributions from the net.
-Modules are fetched from one or more of the mirrored CPAN
-(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
-directory.
+These are fetched from one or more of the mirrored CPAN (Comprehensive
+Perl Archive Network) sites and unpacked in a dedicated directory.
The CPAN module also supports the concept of named and versioned
I<bundles> of modules. Bundles simplify the handling of sets of
related modules. See Bundles below.
-The package contains a session manager and a cache manager. There is
-no status retained between sessions. The session manager keeps track
-of what has been fetched, built and installed in the current
-session. The cache manager keeps track of the disk space occupied by
-the make processes and deletes excess space according to a simple FIFO
-mechanism.
+The package contains a session manager and a cache manager. The
+session manager keeps track of what has been fetched, built and
+installed in the current session. The cache manager keeps track of the
+disk space occupied by the make processes and deletes excess space
+according to a simple FIFO mechanism.
All methods provided are accessible in a programmer style and in an
interactive shell style.
perl -MCPAN -e shell
-which puts you into a readline interface. You will have the most fun if
-you install Term::ReadKey and Term::ReadLine to enjoy both history and
-command completion.
+or
+
+ cpan
-Once you are on the command line, type 'h' and the rest should be
-self-explanatory.
+which puts you into a readline interface. If C<Term::ReadKey> and
+either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
+it supports both history and command completion.
+
+Once you are on the command line, type C<h> to get a one page help
+screen and the rest should be self-explanatory.
The function call C<shell> takes two optional arguments, one is the
prompt, the second is the default initial command line (the latter
more than one, we display each object with the terse method
C<as_glimpse>.
-=item make, test, install, clean modules or distributions
+=item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
These commands take any number of arguments and investigate what is
necessary to perform the action. If the argument is a distribution
the module's META.yml or Makefile.PL (this behavior is controlled by
the configuration parameter C<prerequisites_policy>.)
+C<get> downloads a distribution file and untars or unzips it, C<make>
+builds it, C<test> runs the test suite, and C<install> installs it.
+
Any C<make> or C<test> are run unconditionally. An
install <distribution_file>
CPAN also keeps track of what it has done within the current session
and doesn't try to build a package a second time regardless if it
-succeeded or not. The C<force> pragma may precede another command
-(currently: C<make>, C<test>, or C<install>) and executes the
-command from scratch and tries to continue in case of some errors.
-
-Example:
+succeeded or not. It does not repeat a test run if the test
+has been run successfully before. Same for install runs.
- cpan> install OpenGL
- OpenGL is up to date.
- cpan> force install OpenGL
- Running make
- OpenGL-0.4/
- OpenGL-0.4/COPYRIGHT
- [...]
+The C<force> pragma may precede another command (currently: C<get>,
+C<make>, C<test>, or C<install>) and executes the command from scratch
+and tries to continue in case of some errors. See the section below on
+the C<force> and the C<fforce> pragma.
-The C<notest> pragma may be set to skip the test part in the build
+The C<notest> pragma may be used to skip the test part in the build
process.
Example:
being executed within the distribution file's working directory.
-=item get, readme, perldoc, look module or distribution
+=item C<readme>, C<perldoc>, C<look> module or distribution
-C<get> downloads a distribution file without further action. C<readme>
-displays the README file of the associated distribution. C<Look> gets
-and untars (if not yet done) the distribution file, changes to the
-appropriate directory and opens a subshell process in that directory.
-C<perldoc> displays the pod documentation of the module in html or
-plain text format.
+C<readme> displays the README file of the associated distribution.
+C<Look> gets and untars (if not yet done) the distribution file,
+changes to the appropriate directory and opens a subshell process in
+that directory. C<perldoc> displays the pod documentation of the
+module in html or plain text format.
-=item ls author
+=item C<ls> author
-=item ls globbing_expression
+=item C<ls> globbing_expression
The first form lists all distribution files in and below an author's
CPAN directory as they are stored in the CHECKUMS files distributed on
example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
regarded as a bug and may be changed in future versions.
-=item failed
+=item C<failed>
The C<failed> command reports all distributions that failed on one of
C<make>, C<test> or C<install> for some reason in the currently
running shell session.
+=item Persistence between sessions
+
+If the C<YAML> or the c<YAML::Syck> module is installed a record of
+the internal state of all modules is written to disk after each step.
+The files contain a signature of the currently running perl version
+for later perusal.
+
+If the configurations variable C<build_dir_reuse> is set to a true
+value, then CPAN.pm reads the collected YAML files. If the stored
+signature matches the currently running perl the stored state is
+loaded into memory such that effectively persistence between sessions
+is established.
+
+=item The C<force> and the C<fforce> pragma
+
+To speed things up in complex installation scenarios, CPAN.pm keeps
+track of what it has already done and refuses to do some things a
+second time. A C<get>, a C<make>, and an C<install> are not repeated.
+A C<test> is only repeated if the previous test was unsuccessful. The
+diagnostic message when CPAN.pm refuses to do something a second time
+is one of I<Has already been >C<unwrapped|made|tested successfully> or
+something similar. Another situation where CPAN refuses to act is an
+C<install> if the according C<test> was not successful.
+
+In all these cases, the user can override the goatish behaviour by
+prepending the command with the word force, for example:
+
+ cpan> force get Foo
+ cpan> force make AUTHOR/Bar-3.14.tar.gz
+ cpan> force test Baz
+ cpan> force install Acme::Meta
+
+Each I<forced> command is executed with the according part of its
+memory erased.
+
+The C<fforce> pragma is a variant that emulates a C<force get> which
+erases the entire memory followed by the action specified, effectively
+restarting the whole get/make/test/install procedure from scratch.
+
=item Lockfile
-Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>
-(but the directory can be configured via the C<cpan_home> config
-variable). The shell is a bit picky if you try to start another CPAN
-session. It dies immediately if there is a lockfile and the lock seems
-to belong to a running process. In case you want to run a second shell
-session, it is probably safest to maintain another directory, say
-C<~/.cpan-for-X/> and a C<~/.cpan-for-X/CPAN/MyConfig.pm> that
-contains the configuration options. Then you can start the second
-shell with
+Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
+Batch jobs can run without a lockfile and do not disturb each other.
- perl -I ~/.cpan-for-X -MCPAN::MyConfig -MCPAN -e shell
+The shell offers to run in I<degraded mode> when another process is
+holding the lockfile. This is an experimental feature that is not yet
+tested very well. This second shell then does not write the history
+file, does not use the metadata file and has a different prompt.
=item Signals
installed within @INC. The name of the bundle file is based on the
current date and a counter.
+=head2 hosts
+
+Note: this feature is still in alpha state and may change in future
+versions of CPAN.pm
+
+This commands provides a statistical overview over recent download
+activities. The data for this is collected in the YAML file
+C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
+configured or YAML not installed, then no stats are provided.
+
+=head2 mkmyconfig
+
+mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
+directory so that you can save your own preferences instead of the
+system wide ones.
+
=head2 recompile
recompile() is a very special command in that it takes no argument and
is in turn depending on binary compatibility (so you cannot run CPAN
commands), then you should try the CPAN::Nox module for recovery.
+=head2 report Bundle|Distribution|Module
+
+The C<report> command temporarily turns on the C<test_report> config
+variable, then runs the C<force test> command with the given
+arguments. The C<force> pragma is used to re-run the tests and repeat
+every step that might have failed before.
+
=head2 upgrade [Module|/Regex/]...
The C<upgrade> command first runs an C<r> command with the given
arguments and then installs the newest versions of all modules that
were listed by that.
-=head2 mkmyconfig
-
-mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
-directory so that you can save your own preferences instead of the
-system wide ones.
-
=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
Although it may be considered internal, the class hierarchy does matter
to the most recent official release. Developers may mark their releases
as unstable development versions (by inserting an underbar into the
module version number which will also be reflected in the distribution
-name when you run 'make dist'), so the really hottest and newest
-distribution is not always the default. If a module Foo circulates
-on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
+name when you run 'make dist'), so the really hottest and newest
+distribution is not always the default. If a module Foo circulates
+on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
way to install version 1.23 by saying
install Foo
directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
so you would have to say
- install BAR/Foo-1.23_90.tar.gz
+ install BAR/Foo-1.23_90.tar.gz
+
+The first example will be driven by an object of the class
+CPAN::Module, the second by an object of class CPAN::Distribution.
+
+=head2 Integrating local directories
+
+Note: this feature is still in alpha state and may change in future
+versions of CPAN.pm
+
+Distribution objects are normally distributions from the CPAN, but
+there is a slightly degenerate case for Distribution objects, too, of
+projects held on the local disk. These distribution objects have the
+same name as the local directory and end with a dot. A dot by itself
+is also allowed for the current directory at the time CPAN.pm was
+used. All actions such as C<make>, C<test>, and C<install> are applied
+directly to that directory. This gives the command C<cpan .> an
+interesting touch: while the normal mantra of installing a CPAN module
+without CPAN.pm is one of
+
+ perl Makefile.PL perl Build.PL
+ ( go and get prerequisites )
+ make ./Build
+ make test ./Build test
+ make install ./Build install
+
+the command C<cpan .> does all of this at once. It figures out which
+of the two mantras is appropriate, fetches and installs all
+prerequisites, cares for them recursively and finally finishes the
+installation of the module in the current directory, be it a CPAN
+module or not.
+
+The typical usage case is for private modules or working copies of
+projects from remote repositories on the local disk.
+
+=head1 CONFIGURATION
+
+When the CPAN module is used for the first time, a configuration
+dialog tries to determine a couple of site specific options. The
+result of the dialog is stored in a hash reference C< $CPAN::Config >
+in a file CPAN/Config.pm.
+
+The default values defined in the CPAN/Config.pm file can be
+overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
+best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
+added to the search path of the CPAN module before the use() or
+require() statements. The mkmyconfig command writes this file for you.
+
+The C<o conf> command has various bells and whistles:
+
+=over
+
+=item completion support
+
+If you have a ReadLine module installed, you can hit TAB at any point
+of the commandline and C<o conf> will offer you completion for the
+built-in subcommands and/or config variable names.
+
+=item displaying some help: o conf help
+
+Displays a short help
+
+=item displaying current values: o conf [KEY]
+
+Displays the current value(s) for this config variable. Without KEY
+displays all subcommands and config variables.
+
+Example:
+
+ o conf shell
+
+=item changing of scalar values: o conf KEY VALUE
+
+Sets the config variable KEY to VALUE. The empty string can be
+specified as usual in shells, with C<''> or C<"">
+
+Example:
+
+ o conf wget /usr/bin/wget
+
+=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
+
+If a config variable name ends with C<list>, it is a list. C<o conf
+KEY shift> removes the first element of the list, C<o conf KEY pop>
+removes the last element of the list. C<o conf KEYS unshift LIST>
+prepends a list of values to the list, C<o conf KEYS push LIST>
+appends a list of valued to the list.
+
+Likewise, C<o conf KEY splice LIST> passes the LIST to the according
+splice command.
+
+Finally, any other list of arguments is taken as a new list value for
+the KEY variable discarding the previous value.
+
+Examples:
+
+ o conf urllist unshift http://cpan.dev.local/CPAN
+ o conf urllist splice 3 1
+ o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
+
+=item reverting to saved: o conf defaults
+
+Reverts all config variables to the state in the saved config file.
+
+=item saving the config: o conf commit
+
+Saves all config variables to the current config file (CPAN/Config.pm
+or CPAN/MyConfig.pm that was loaded at start).
+
+=back
+
+The configuration dialog can be started any time later again by
+issuing the command C< o conf init > in the CPAN shell. A subset of
+the configuration dialog can be run by issuing C<o conf init WORD>
+where WORD is any valid config variable or a regular expression.
+
+=head2 Config Variables
+
+Currently the following keys in the hash reference $CPAN::Config are
+defined:
+
+ applypatch path to external prg
+ auto_commit commit all changes to config variables to disk
+ build_cache size of cache for directories to build modules
+ build_dir locally accessible directory to build modules
+ build_dir_reuse boolean if distros in build_dir are persistent
+ build_requires_install_policy
+ to install or not to install when a module is
+ only needed for building. yes|no|ask/yes|ask/no
+ bzip2 path to external prg
+ cache_metadata use serializer to cache metadata
+ commands_quote prefered character to use for quoting external
+ commands when running them. Defaults to double
+ quote on Windows, single tick everywhere else;
+ can be set to space to disable quoting
+ check_sigs if signatures should be verified
+ colorize_debug Term::ANSIColor attributes for debugging output
+ colorize_output boolean if Term::ANSIColor should colorize output
+ colorize_print Term::ANSIColor attributes for normal output
+ colorize_warn Term::ANSIColor attributes for warnings
+ commandnumber_in_prompt
+ boolean if you want to see current command number
+ cpan_home local directory reserved for this package
+ curl path to external prg
+ dontload_hash DEPRECATED
+ dontload_list arrayref: modules in the list will not be
+ loaded by the CPAN::has_inst() routine
+ ftp path to external prg
+ ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
+ ftp_proxy proxy host for ftp requests
+ getcwd see below
+ gpg path to external prg
+ gzip location of external program gzip
+ histfile file to maintain history between sessions
+ histsize maximum number of lines to keep in histfile
+ http_proxy proxy host for http requests
+ inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
+ after this many seconds inactivity. Set to 0 to
+ never break.
+ index_expire after this many days refetch index files
+ inhibit_startup_message
+ if true, does not print the startup message
+ keep_source_where directory in which to keep the source (if we do)
+ lynx path to external prg
+ make location of external make program
+ make_arg arguments that should always be passed to 'make'
+ make_install_make_command
+ the make command for running 'make install', for
+ example 'sudo make'
+ make_install_arg same as make_arg for 'make install'
+ makepl_arg arguments passed to 'perl Makefile.PL'
+ mbuild_arg arguments passed to './Build'
+ mbuild_install_arg arguments passed to './Build install'
+ mbuild_install_build_command
+ command to use instead of './Build' when we are
+ in the install stage, for example 'sudo ./Build'
+ mbuildpl_arg arguments passed to 'perl Build.PL'
+ ncftp path to external prg
+ ncftpget path to external prg
+ no_proxy don't proxy to these hosts/domains (comma separated list)
+ pager location of external program more (or any pager)
+ password your password if you CPAN server wants one
+ patch path to external prg
+ prefer_installer legal values are MB and EUMM: if a module comes
+ with both a Makefile.PL and a Build.PL, use the
+ former (EUMM) or the latter (MB); if the module
+ comes with only one of the two, that one will be
+ used in any case
+ prerequisites_policy
+ what to do if you are missing module prerequisites
+ ('follow' automatically, 'ask' me, or 'ignore')
+ prefs_dir local directory to store per-distro build options
+ proxy_user username for accessing an authenticating proxy
+ proxy_pass password for accessing an authenticating proxy
+ randomize_urllist add some randomness to the sequence of the urllist
+ scan_cache controls scanning of cache ('atstart' or 'never')
+ shell your favorite shell
+ show_upload_date boolean if commands should try to determine upload date
+ tar location of external program tar
+ term_is_latin if true internal UTF-8 is translated to ISO-8859-1
+ (and nonsense for characters outside latin range)
+ term_ornaments boolean to turn ReadLine ornamenting on/off
+ test_report email test reports (if CPAN::Reporter is installed)
+ unzip location of external program unzip
+ urllist arrayref to nearby CPAN sites (or equivalent locations)
+ use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
+ username your username if you CPAN server wants one
+ wait_list arrayref to a wait server to try (See CPAN::WAIT)
+ wget path to external prg
+ yaml_module which module to use to read/write YAML files
+
+You can set and query each of these options interactively in the cpan
+shell with the C<o conf> or the C<o conf init> command as specified below.
+
+=over 2
+
+=item C<o conf E<lt>scalar optionE<gt>>
+
+prints the current value of the I<scalar option>
+
+=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
+
+Sets the value of the I<scalar option> to I<value>
+
+=item C<o conf E<lt>list optionE<gt>>
+
+prints the current value of the I<list option> in MakeMaker's
+neatvalue format.
+
+=item C<o conf E<lt>list optionE<gt> [shift|pop]>
+
+shifts or pops the array in the I<list option> variable
+
+=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
+
+works like the corresponding perl commands.
+
+=item interactive editing: o conf init [MATCH|LIST]
+
+Runs an interactive configuration dialog for matching variables.
+Without argument runs the dialog over all supported config variables.
+To specify a MATCH the argument must be enclosed by slashes.
+
+Examples:
+
+ o conf init ftp_passive ftp_proxy
+ o conf init /color/
+
+Note: this method of setting config variables often provides more
+explanation about the functioning of a variable than the manpage.
+
+=back
+
+=head2 CPAN::anycwd($path): Note on config variable getcwd
+
+CPAN.pm changes the current working directory often and needs to
+determine its own current working directory. Per default it uses
+Cwd::cwd but if this doesn't work on your system for some reason,
+alternatives can be configured according to the following table:
+
+=over 4
+
+=item cwd
+
+Calls Cwd::cwd
+
+=item getcwd
+
+Calls Cwd::getcwd
+
+=item fastcwd
+
+Calls Cwd::fastcwd
+
+=item backtickcwd
+
+Calls the external command cwd.
+
+=back
+
+=head2 Note on the format of the urllist parameter
+
+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
+C<file> URLs, please try the correct format. Either:
+
+ file://localhost/whatever/ftp/pub/CPAN/
+
+or
+
+ file:///home/ftp/pub/CPAN/
+
+=head2 The urllist parameter has CD-ROM support
+
+The C<urllist> parameter of the configuration table contains a list of
+URLs that are to be used for downloading. If the list contains any
+C<file> URLs, CPAN always tries to get files from there first. This
+feature is disabled for index files. So the recommendation for the
+owner of a CD-ROM with CPAN contents is: include your local, possibly
+outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
+
+ o conf urllist push file://localhost/CDROM/CPAN
+
+CPAN.pm will then fetch the index files from one of the CPAN sites
+that come at the beginning of urllist. It will later check for each
+module if there is a local copy of the most recent version.
+
+Another peculiarity of urllist is that the site that we could
+successfully fetch the last file from automatically gets a preference
+token and is tried as the first site for the next request. So if you
+add a new site at runtime it may happen that the previously preferred
+site will be tried another time. This means that if you want to disallow
+a site for the next transfer, it must be explicitly removed from
+urllist.
+
+=head2 Maintaining the urllist parameter
+
+If you have YAML.pm (or some other YAML module configured in
+C<yaml_module>) installed, CPAN.pm collects a few statistical data
+about recent downloads. You can view the statistics with the C<hosts>
+command or inspect them directly by looking into the C<FTPstats.yml>
+file in your C<cpan_home> directory.
+
+To get some interesting statistics it is recommended to set the
+C<randomize_urllist> parameter that introduces some amount of
+randomness into the URL selection.
+
+=head2 The C<requires> and C<build_requires> dependency declarations
+
+Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
+a distribution are treated differently depending on the config
+variable C<build_requires_install_policy>. By setting
+C<build_requires_install_policy> to C<no> such a module is not being
+installed. It is only built and tested and then kept in the list of
+tested but uninstalled modules. As such it is available during the
+build of the dependent module by integrating the path to the
+C<blib/arch> and C<blib/lib> directories in the environment variable
+PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
+both modules declared as C<requires> and those declared as
+C<build_requires> are treated alike. By setting to C<ask/yes> or
+C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
+
+=head2 Configuration for individual distributions (I<Distroprefs>)
+
+(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
+still considered beta quality)
+
+Distributions on the CPAN usually behave according to what we call the
+CPAN mantra. Or since the event of Module::Build we should talk about
+two mantras:
+
+ perl Makefile.PL perl Build.PL
+ make ./Build
+ make test ./Build test
+ make install ./Build install
+
+But some modules cannot be built with this mantra. They try to get
+some extra data from the user via the environment, extra arguments or
+interactively thus disturbing the installation of large bundles like
+Phalanx100 or modules with many dependencies like Plagger.
+
+The distroprefs system of C<CPAN.pm> addresses this problem by
+allowing the user to specify extra informations and recipes in YAML
+files to either
+
+=over
+
+=item
+
+pass additional arguments to one of the four commands,
+
+=item
+
+set environment variables
+
+=item
+
+instantiate an Expect object that reads from the console, waits for
+some regular expressions and enters some answers
+
+=item
+
+temporarily override assorted C<CPAN.pm> configuration variables
+
+=item
+
+disable the installation of an object altogether
+
+=back
+
+See the YAML and Data::Dumper files that come with the C<CPAN.pm>
+distribution in the C<distroprefs/> directory for examples.
+
+=head2 Filenames
+
+The YAML files themselves must have the C<.yml> extension, all other
+files are ignored (for two exceptions see I<Fallback Data::Dumper and
+Storable> below). The containing directory can be specified in
+C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
+prefs_dir> in the CPAN shell to set and activate the distroprefs
+system.
+
+Every YAML file may contain arbitrary documents according to the YAML
+specification and every single document is treated as an entity that
+can specify the treatment of a single distribution.
+
+The names of the files can be picked freely, C<CPAN.pm> always reads
+all files (in alphabetical order) and takes the key C<match> (see
+below in I<Language Specs>) as a hashref containing match criteria
+that determine if the current distribution matches the YAML document
+or not.
+
+=head2 Fallback Data::Dumper and Storable
+
+If neither your configured C<yaml_module> nor YAML.pm is installed
+CPAN.pm falls back to using Data::Dumper and Storable and looks for
+files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
+directory. These files are expected to contain one or more hashrefs.
+For Data::Dumper generated files, this is expected to be done with by
+defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
+with the command
+
+ ysh < somefile.yml > somefile.dd
+
+For Storable files the rule is that they must be constructed such that
+C<Storable::retrieve(file)> returns an array reference and the array
+elements represent one distropref object each. The conversion from
+YAML would look like so:
+
+ perl -MYAML=LoadFile -MStorable=nstore -e '
+ @y=LoadFile(shift);
+ nstore(\@y, shift)' somefile.yml somefile.st
+
+In bootstrapping situations it is usually sufficient to translate only
+a few YAML files to Data::Dumper for the crucial modules like
+C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
+over Data::Dumper, remember to pull out a Storable version that writes
+an older format than all the other Storable versions that will need to
+read them.
+
+=head2 Blueprint
+
+The following example contains all supported keywords and structures
+with the exception of C<eexpect> which can be used instead of
+C<expect>.
+
+ ---
+ comment: "Demo"
+ match:
+ module: "Dancing::Queen"
+ distribution: "^CHACHACHA/Dancing-"
+ perl: "/usr/local/cariba-perl/bin/perl"
+ perlconfig:
+ archname: "freebsd"
+ disabled: 1
+ cpanconfig:
+ make: gmake
+ pl:
+ args:
+ - "--somearg=specialcase"
+
+ env: {}
+
+ expect:
+ - "Which is your favorite fruit"
+ - "apple\n"
+
+ make:
+ args:
+ - all
+ - extra-all
+
+ env: {}
+
+ expect: []
+
+ commendline: "echo SKIPPING make"
+
+ test:
+ args: []
+
+ env: {}
+
+ expect: []
+
+ install:
+ args: []
+
+ env:
+ WANT_TO_INSTALL: YES
+
+ expect:
+ - "Do you really want to install"
+ - "y\n"
+
+ patches:
+ - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
+
+
+=head2 Language Specs
+
+Every YAML document represents a single hash reference. The valid keys
+in this hash are as follows:
+
+=over
+
+=item comment [scalar]
+
+A comment
+
+=item cpanconfig [hash]
+
+Temporarily override assorted C<CPAN.pm> configuration variables.
+
+Supported are: C<build_requires_install_policy>, C<check_sigs>,
+C<make>, C<make_install_make_command>, C<prefer_installer>,
+C<test_report>. Please report as a bug when you need another one
+supported.
+
+=item disabled [boolean]
+
+Specifies that this distribution shall not be processed at all.
+
+=item goto [string]
+
+The canonical name of a delegate distribution that shall be installed
+instead. Useful when a new version, although it tests OK itself,
+breaks something else or a developer release or a fork is already
+uploaded that is better than the last released version.
+
+=item install [hash]
+
+Processing instructions for the C<make install> or C<./Build install>
+phase of the CPAN mantra. See below under I<Processiong Instructions>.
+
+=item make [hash]
+
+Processing instructions for the C<make> or C<./Build> phase of the
+CPAN mantra. See below under I<Processiong Instructions>.
+
+=item match [hash]
+
+A hashref with one or more of the keys C<distribution>, C<modules>,
+C<perl>, and C<perlconfig> that specify if a document is targeted at a
+specific CPAN distribution or installation.
+
+The corresponding values are interpreted as regular expressions. The
+C<distribution> related one will be matched against the canonical
+distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
+
+The C<module> related one will be matched against I<all> modules
+contained in the distribution until one module matches.
+
+The C<perl> related one will be matched against C<$^X>.
+
+The value associated with C<perlconfig> is itself a hashref that is
+matched against corresponding values in the C<%Config::Config> hash
+living in the C< Config.pm > module.
+
+If more than one restriction of C<module>, C<distribution>, and
+C<perl> is specified, the results of the separately computed match
+values must all match. If this is the case then the hashref
+represented by the YAML document is returned as the preference
+structure for the current distribution.
+
+=item patches [array]
+
+An array of patches on CPAN or on the local disk to be applied in
+order via the external patch program. If the value for the C<-p>
+parameter is C<0> or C<1> is determined by reading the patch
+beforehand.
+
+Note: if the C<applypatch> program is installed and C<CPAN::Config>
+knows about it B<and> a patch is written by the C<makepatch> program,
+then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
+and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
+distribution.
+
+=item pl [hash]
+
+Processing instructions for the C<perl Makefile.PL> or C<perl
+Build.PL> phase of the CPAN mantra. See below under I<Processiong
+Instructions>.
+
+=item test [hash]
+
+Processing instructions for the C<make test> or C<./Build test> phase
+of the CPAN mantra. See below under I<Processiong Instructions>.
+
+=back
+
+=head2 Processing Instructions
+
+=over
+
+=item args [array]
+
+Arguments to be added to the command line
+
+=item commandline
+
+A full commandline that will be executed as it stands by a system
+call. During the execution the environment variable PERL will is set
+to $^X. If C<commandline> is specified, the content of C<args> is not
+used.
+
+=item eexpect [hash]
+
+Extended C<expect>. This is a hash reference with three allowed keys,
+C<mode>, C<timeout>, and C<talk>.
+
+C<mode> may have the values C<deterministic> for the case where all
+questions come in the order written down and C<anyorder> for the case
+where the questions may come in any order. The default mode is
+C<deterministic>.
+
+C<timeout> denotes a timeout in seconds. Floating point timeouts are
+OK. In the case of a C<mode=deterministic> the timeout denotes the
+timeout per question, in the case of C<mode=anyorder> it denotes the
+timeout per byte received from the stream or questions.
+
+C<talk> is a reference to an array that contains alternating questions
+and answers. Questions are regular expressions and answers are literal
+strings. The Expect module will then watch the stream coming from the
+execution of the external program (C<perl Makefile.PL>, C<perl
+Build.PL>, C<make>, etc.).
+
+In the case of C<mode=deterministic> the CPAN.pm will inject the
+according answer as soon as the stream matches the regular expression.
+In the case of C<mode=anyorder> the CPAN.pm will answer a question as
+soon as the timeout is reached for the next byte in the input stream.
+In the latter case it removes the according question/answer pair from
+the array, so if you want to answer the question C<Do you really want
+to do that> several times, then it must be included in the array at
+least as often as you want this answer to be given.
+
+=item env [hash]
+
+Environment variables to be set during the command
+
+=item expect [array]
+
+C<< expect: <array> >> is a short notation for
+
+ eexpect:
+ mode: deterministic
+ timeout: 15
+ talk: <array>
+
+=back
+
+=head2 Schema verification with C<Kwalify>
+
+If you have the C<Kwalify> module installed (which is part of the
+Bundle::CPANxxl), then all your distroprefs files are checked for
+syntactical correctness.
+
+=head2 Example Distroprefs Files
-The first example will be driven by an object of the class
-CPAN::Module, the second by an object of class CPAN::Distribution.
+C<CPAN.pm> comes with a collection of example YAML files. Note that these
+are really just examples and should not be used without care because
+they cannot fit everybody's purpose. After all the authors of the
+packages that ask questions had a need to ask, so you should watch
+their questions and adjust the examples to your environment and your
+needs. You have beend warned:-)
=head1 PROGRAMMER'S INTERFACE
If you do not enter the shell, the available shell commands are both
available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
-functions in the calling package (C<install(...)>).
+functions in the calling package (C<install(...)>). Before calling low-level
+commands it makes sense to initialize components of CPAN you need, e.g.:
+
+ CPAN::HandleConfig->load;
+ CPAN::Shell::setup_output;
+ CPAN::Index->reload;
+
+High-level commands do such initializations automatically.
There's currently only one class that has a stable interface -
CPAN::Shell. All commands that are available in the CPAN shell are
# install my favorite programs if necessary:
for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
- my $obj = CPAN::Shell->expand('Module',$mod);
- $obj->install;
+ CPAN::Shell->install($mod);
}
# list all modules on my disk that have no VERSION number
=head2 Methods in the other Classes
-The programming interface for the classes CPAN::Module,
-CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
-beta and partially even alpha. In the following paragraphs only those
-methods are documented that have proven useful over a longer time and
-thus are unlikely to change.
-
=over 4
=item CPAN::Author::as_glimpse()
=item CPAN::Bundle::force($method,@args)
-Forces CPAN to perform a task that normally would have failed. Force
-takes as arguments a method name to be called and any number of
-additional arguments that should be passed to the called method. The
-internals of the object get the needed changes so that CPAN.pm does
-not refuse to take the action. The C<force> is passed recursively to
-all contained objects.
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. The C<force> is passed recursively
+to all contained objects. See also the section above on the C<force>
+and the C<fforce> pragma.
=item CPAN::Bundle::get()
=item CPAN::Distribution::force($method,@args)
-Forces CPAN to perform a task that normally would have failed. Force
-takes as arguments a method name to be called and any number of
-additional arguments that should be passed to the called method. The
-internals of the object get the needed changes so that CPAN.pm does
-not refuse to take the action.
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. See also the section above on the
+C<force> and the C<fforce> pragma.
=item CPAN::Distribution::get()
cancellation can be avoided by letting C<force> run the C<install> for
you.
+This install method has only the power to install the distribution if
+there are no dependencies in the way. To install an object and all of
+its dependencies, use CPAN::Shell->install.
+
Note that install() gives no meaningful return value. See uptodate().
+=item CPAN::Distribution::install_tested()
+
+Install all the distributions that have been tested sucessfully but
+not yet installed. See also C<is_tested>.
+
=item CPAN::Distribution::isa_perl()
Returns 1 if this distribution file seems to be a perl distribution.
CPAN can contain a hint to achieve a return value of true for other
filenames too.
+=item CPAN::Distribution::is_tested()
+
+List all the distributions that have been tested sucessfully but not
+yet installed. See also C<install_tested>.
+
=item CPAN::Distribution::look()
Changes to the directory where the distribution has been unpacked and
command html2text and runs it through the pager specified
in C<$CPAN::Config->{pager}>
+=item CPAN::Distribution::prefs()
+
+Returns the hash reference from the first matching YAML file that the
+user has deposited in the C<prefs_dir/> directory. The first
+succeeding match wins. The files in the C<prefs_dir/> are processed
+alphabetically and the canonical distroname (e.g.
+AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
+stored in the $root->{match}{distribution} attribute value.
+Additionally all module names contained in a distribution are matched
+agains the regular expressions in the $root->{match}{module} attribute
+value. The two match values are ANDed together. Each of the two
+attributes are optional.
+
=item CPAN::Distribution::prereq_pm()
Returns the hash reference that has been announced by a distribution
-as the merge of the C<requires> element and the C<build_requires>
-element of the META.yml or the C<PREREQ_PM> hash in the
-C<Makefile.PL>. Note: works only after an attempt has been made to
-C<make> the distribution. Returns undef otherwise.
+as the the C<requires> and C<build_requires> elements. These can be
+declared either by the C<META.yml> (if authoritative) or can be
+deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
+or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
+a comment in the produced C<Makefile>. I<Note>: this method only works
+after an attempt has been made to C<make> the distribution. Returns
+undef otherwise.
=item CPAN::Distribution::readme()
Downloads the README file associated with a distribution and runs it
through the pager specified in C<$CPAN::Config->{pager}>.
+=item CPAN::Distribution::reports()
+
+Downloads report data for this distribution from cpantesters.perl.org
+and displays a subset of them.
+
=item CPAN::Distribution::read_yaml()
Returns the content of the META.yml of this distro as a hashref. Note:
works only after an attempt has been made to C<make> the distribution.
-Returns undef otherwise.
+Returns undef otherwise. Also returns undef if the content of META.yml
+is not authoritative. (The rules about what exactly makes the content
+authoritative are still in flux.)
=item CPAN::Distribution::test()
=item CPAN::Module::force($method,@args)
-Forces CPAN to perform a task that normally would have failed. Force
-takes as arguments a method name to be called and any number of
-additional arguments that should be passed to the called method. The
-internals of the object get the needed changes so that CPAN.pm does
-not refuse to take the action.
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. See also the section above on the
+C<force> and the C<fforce> pragma.
=item CPAN::Module::get()
is reported just like perl itself stops searching @INC when it finds a
module.
+=item CPAN::Module::available_file()
+
+Returns the filename of the module found in PERL5LIB or @INC. The
+first file found is reported. The advantage of this method over
+C<inst_file> is that modules that have been tested but not yet
+installed are included because PERL5LIB keeps track of tested modules.
+
=item CPAN::Module::inst_version()
-Returns the version number of the module in readable format.
+Returns the version number of the installed module in readable format.
+
+=item CPAN::Module::available_version()
+
+Returns the version number of the available module in readable format.
=item CPAN::Module::install()
Runs a C<readme> on the distribution associated with this module.
+=item CPAN::Module::reports()
+
+Calls the reports() method on the associated distribution object.
+
=item CPAN::Module::test()
Runs a C<test> on the distribution associated with this module.
=item has_inst($module)
-Returns true if the module is installed. See the source for details.
+Returns true if the module is installed. Used to load all modules into
+the running CPAN.pm which are considered optional. The config variable
+C<dontload_list> can be used to intercept the C<has_inst()> call such
+that an optional module is not loaded despite being available. For
+example the following command will prevent that C<YAML.pm> is being
+loaded:
-=item has_usable($module)
+ cpan> o conf dontload_list push YAML
-Returns true if the module is installed and several and is in a usable
-state. Only useful for a handful of modules that are used internally.
See the source for details.
+=item has_usable($module)
+
+Returns true if the module is installed and is in a usable state. Only
+useful for a handful of modules that are used internally. See the
+source for details.
+
=item instance($module)
The constructor for all the singletons used to represent modules,
=back
-=head1 CONFIGURATION
-
-When the CPAN module is used for the first time, a configuration
-dialog tries to determine a couple of site specific options. The
-result of the dialog is stored in a hash reference C< $CPAN::Config >
-in a file CPAN/Config.pm.
-
-The default values defined in the CPAN/Config.pm file can be
-overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
-best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
-added to the search path of the CPAN module before the use() or
-require() statements.
-
-The configuration dialog can be started any time later again by
-issuing the command C< o conf init > in the CPAN shell. A subset of
-the configuration dialog can be run by issuing C<o conf init WORD>
-where WORD is any valid config variable or a regular expression.
-
-Currently the following keys in the hash reference $CPAN::Config are
-defined:
-
- build_cache size of cache for directories to build modules
- build_dir locally accessible directory to build modules
- build_requires_install_policy
- to install or not to install: when a module is
- only needed for building. yes|no|ask/yes|ask/no
- bzip2 path to external prg
- cache_metadata use serializer to cache metadata
- commands_quote prefered character to use for quoting external
- commands when running them. Defaults to double
- quote on Windows, single tick everywhere else;
- can be set to space to disable quoting
- check_sigs if signatures should be verified
- colorize_output boolean if Term::ANSIColor should colorize output
- colorize_print Term::ANSIColor attributes for normal output
- colorize_warn Term::ANSIColor attributes for warnings
- commandnumber_in_prompt
- boolean if you want to see current command number
- cpan_home local directory reserved for this package
- curl path to external prg
- dontload_hash DEPRECATED
- dontload_list arrayref: modules in the list will not be
- loaded by the CPAN::has_inst() routine
- ftp path to external prg
- ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
- ftp_proxy proxy host for ftp requests
- getcwd see below
- gpg path to external prg
- gzip location of external program gzip
- histfile file to maintain history between sessions
- histsize maximum number of lines to keep in histfile
- http_proxy proxy host for http requests
- inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
- after this many seconds inactivity. Set to 0 to
- never break.
- index_expire after this many days refetch index files
- inhibit_startup_message
- if true, does not print the startup message
- keep_source_where directory in which to keep the source (if we do)
- lynx path to external prg
- make location of external make program
- make_arg arguments that should always be passed to 'make'
- make_install_make_command
- the make command for running 'make install', for
- example 'sudo make'
- make_install_arg same as make_arg for 'make install'
- makepl_arg arguments passed to 'perl Makefile.PL'
- mbuild_arg arguments passed to './Build'
- mbuild_install_arg arguments passed to './Build install'
- mbuild_install_build_command
- command to use instead of './Build' when we are
- in the install stage, for example 'sudo ./Build'
- mbuildpl_arg arguments passed to 'perl Build.PL'
- ncftp path to external prg
- ncftpget path to external prg
- no_proxy don't proxy to these hosts/domains (comma separated list)
- pager location of external program more (or any pager)
- password your password if you CPAN server wants one
- prefer_installer legal values are MB and EUMM: if a module comes
- with both a Makefile.PL and a Build.PL, use the
- former (EUMM) or the latter (MB); if the module
- comes with only one of the two, that one will be
- used in any case
- prerequisites_policy
- what to do if you are missing module prerequisites
- ('follow' automatically, 'ask' me, or 'ignore')
- proxy_user username for accessing an authenticating proxy
- proxy_pass password for accessing an authenticating proxy
- scan_cache controls scanning of cache ('atstart' or 'never')
- shell your favorite shell
- show_upload_date boolean if commands should try to determine upload date
- tar location of external program tar
- term_is_latin if true internal UTF-8 is translated to ISO-8859-1
- (and nonsense for characters outside latin range)
- term_ornaments boolean to turn ReadLine ornamenting on/off
- test_report email test reports (if CPAN::Reporter is installed)
- unzip location of external program unzip
- urllist arrayref to nearby CPAN sites (or equivalent locations)
- username your username if you CPAN server wants one
- wait_list arrayref to a wait server to try (See CPAN::WAIT)
- wget path to external prg
-
-You can set and query each of these options interactively in the cpan
-shell with the command set defined within the C<o conf> command:
-
-=over 2
-
-=item C<o conf E<lt>scalar optionE<gt>>
-
-prints the current value of the I<scalar option>
-
-=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
-
-Sets the value of the I<scalar option> to I<value>
-
-=item C<o conf E<lt>list optionE<gt>>
-
-prints the current value of the I<list option> in MakeMaker's
-neatvalue format.
-
-=item C<o conf E<lt>list optionE<gt> [shift|pop]>
-
-shifts or pops the array in the I<list option> variable
-
-=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
-
-works like the corresponding perl commands.
-
-=back
-
-=head2 CPAN::anycwd($path): Note on config variable getcwd
-
-CPAN.pm changes the current working directory often and needs to
-determine its own current working directory. Per default it uses
-Cwd::cwd but if this doesn't work on your system for some reason,
-alternatives can be configured according to the following table:
-
-=over 2
-
-=item cwd
-
-Calls Cwd::cwd
-
-=item getcwd
-
-Calls Cwd::getcwd
-
-=item fastcwd
-
-Calls Cwd::fastcwd
-
-=item backtickcwd
-
-Calls the external command cwd.
-
-=back
-
-=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:
-
- file://localhost/whatever/ftp/pub/CPAN/
-
-or
-
- file:///home/ftp/pub/CPAN/
-
-=head2 urllist parameter has CD-ROM support
-
-The C<urllist> parameter of the configuration table contains a list of
-URLs that are to be used for downloading. If the list contains any
-C<file> URLs, CPAN always tries to get files from there first. This
-feature is disabled for index files. So the recommendation for the
-owner of a CD-ROM with CPAN contents is: include your local, possibly
-outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
-
- o conf urllist push file://localhost/CDROM/CPAN
-
-CPAN.pm will then fetch the index files from one of the CPAN sites
-that come at the beginning of urllist. It will later check for each
-module if there is a local copy of the most recent version.
-
-Another peculiarity of urllist is that the site that we could
-successfully fetch the last file from automatically gets a preference
-token and is tried as the first site for the next request. So if you
-add a new site at runtime it may happen that the previously preferred
-site will be tried another time. This means that if you want to disallow
-a site for the next transfer, it must be explicitly removed from
-urllist.
-
=head1 SECURITY
There's no strong security layer in CPAN.pm. CPAN.pm helps you to
the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
already set.
+When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
+
When the config variable ftp_passive is set, all downloads will be run
with the environment variable FTP_PASSIVE set to this value. This is
in general a good idea as it influences both Net::FTP and LWP based
o conf makepl_arg "LIB=~/myperl/lib \
INSTALLMAN1DIR=~/myperl/man/man1 \
- INSTALLMAN3DIR=~/myperl/man/man3"
+ INSTALLMAN3DIR=~/myperl/man/man3 \
+ INSTALLSCRIPT=~/myperl/bin \
+ INSTALLBIN=~/myperl/bin"
+
+and then (oh joy) the equivalent command for Module::Build.
You can make this setting permanent like all C<o conf> settings with
-C<o conf commit>.
+C<o conf commit> or by setting C<auto_commit> beforehand.
You will have to add ~/myperl/man to the MANPATH environment variable
and also tell your perl programs to look into ~/myperl/lib, e.g. by
force install Foo::Bar
-This does a bit more than really needed because it untars the
-distribution again and runs make and test and only then install.
-
-Or, if you find this is too fast and you would prefer to do smaller
-steps, say
-
- force get Foo::Bar
-
-first and then continue as always. C<Force get> I<forgets> previous
-error conditions.
-
Or you can use
look Foo::Bar
and then 'make install' directly in the subshell.
-Or you leave the CPAN shell and start it again.
-
-For the really curious, by accessing internals directly, you I<could>
-
- !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
-
-but this is neither guaranteed to work in the future nor is it a
-decent command.
-
=item 12)
How do I install a "DEVELOPER RELEASE" of a module?
=item 14)
-How do I create a Module::Build based Build.PL derived from an
+How do I create a Module::Build based Build.PL derived from an
ExtUtils::MakeMaker focused Makefile.PL?
http://search.cpan.org/search?query=Module::Build::Convert
-http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
+http://www.refcnt.org/papers/module-build-convert
+
+=item 15)
+
+What's the best CPAN site for me?
+
+The urllist config parameter is yours. You can add and remove sites at
+will. You should find out which sites have the best uptodateness,
+bandwidth, reliability, etc. and are topologically close to you. Some
+people prefer fast downloads, others uptodateness, others reliability.
+You decide which to try in which order.
+Henk P. Penning maintains a site that collects data about CPAN sites:
+
+ http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
=back
-=head1 BUGS
+=head1 COMPATIBILITY
-Please report bugs via http://rt.cpan.org/
+=head2 OLD PERL VERSIONS
-Before submitting a bug, please make sure that the traditional method
-of building a Perl module package from a shell by following the
-installation instructions of that package still works in your
-environment.
+CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
+newer versions. It is getting more and more difficult to get the
+minimal prerequisites working on older perls. It is close to
+impossible to get the whole Bundle::CPAN working there. If you're in
+the position to have only these old versions, be advised that CPAN is
+designed to work fine without the Bundle::CPAN installed.
+
+To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
+compatible with ancient perls and that File::Temp is listed as a
+prerequisite but CPAN has reasonable workarounds if it is missing.
+
+=head2 CPANPLUS
+
+This module and its competitor, the CPANPLUS module, are both much
+cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
+more modular but it was never tried to make it compatible with CPAN.pm.
=head1 SECURITY ADVICE
contain bugs and may alter the way your computer works or even make it
unusable. Please consider backing up your data before every upgrade.
+=head1 BUGS
+
+Please report bugs via http://rt.cpan.org/
+
+Before submitting a bug, please make sure that the traditional method
+of building a Perl module package from a shell by following the
+installation instructions of that package still works in your
+environment.
+
=head1 AUTHOR
Andreas Koenig C<< <andk@cpan.org> >>
=head1 TRANSLATIONS
Kawai,Takanori provides a Japanese translation of this manpage at
-http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
+http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
=head1 SEE ALSO
cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
=cut
+
+
projects / p5sagit/p5-mst-13.2.git / blobdiff