# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN;
-$CPAN::VERSION = '1.88_63';
-$CPAN::VERSION = eval $CPAN::VERSION;
+$CPAN::VERSION = '1.9205';
+$CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/;
use CPAN::HandleConfig;
use CPAN::Version;
use CPAN::Debug;
use CPAN::Queue;
use CPAN::Tarzip;
+use CPAN::DeferedCode;
use Carp ();
use Config ();
use Cwd ();
use Text::ParseWords ();
use Text::Wrap ();
+sub find_perl ();
+
# we need to run chdir all over and we would get at wrong libraries
# there
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_CPAN_IS_RUNNING}=$$;
+$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
END { $CPAN::End++; &cleanup; }
$CPAN::Signal ||= 0;
$CPAN::Frontend ||= "CPAN::Shell";
-unless (@CPAN::Defaultsites){
+unless (@CPAN::Defaultsites) {
@CPAN::Defaultsites = map {
CPAN::URL->new(TEXT => $_, FROM => "DEF")
}
# $CPAN::iCwd (i for initial) is going to be initialized during find_perl
$CPAN::Perl ||= CPAN::find_perl();
$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
-$CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
+$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
+$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
# our globals are getting a mess
use vars qw(
$AUTOLOAD
$Be_Silent
$CONFIG_DIRTY
- $DEBUG
$Defaultdocs
- $Defaultrecent
+ $Echo_readline
$Frontend
$GOTOSHELL
$HAS_USABLE
$Have_warned
+ $MAX_RECURSION
$META
$RUN_DEGRADED
$Signal
@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
recompile
report
shell
+ smoke
test
upgrade
- );
+ );
sub soft_chdir_with_alternatives ($);
my(%export);
@export{@EXPORT} = '';
CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
- if (exists $export{$l}){
+ if (exists $export{$l}) {
CPAN::Shell->$l(@_);
} else {
die(qq{Unknown CPAN command "$AUTOLOAD". }.
local($^W) = 1;
unless ($Suppress_readline) {
- require Term::ReadLine;
+ require Term::ReadLine;
if (! $term
or
$term->ReadLine eq "Term::ReadLine::Stub"
) {
$term = Term::ReadLine->new('CPAN Monitor');
}
- if ($term->ReadLine eq "Term::ReadLine::Gnu") {
- my $attribs = $term->Attribs;
- $attribs->{attempted_completion_function} = sub {
- &CPAN::Complete::gnu_cpl;
- }
- } else {
- $readline::rl_completion_function =
- $readline::rl_completion_function = 'CPAN::Complete::cpl';
- }
+ if ($term->ReadLine eq "Term::ReadLine::Gnu") {
+ my $attribs = $term->Attribs;
+ $attribs->{attempted_completion_function} = sub {
+ &CPAN::Complete::gnu_cpl;
+ }
+ } else {
+ $readline::rl_completion_function =
+ $readline::rl_completion_function = 'CPAN::Complete::cpl';
+ }
if (my $histfile = $CPAN::Config->{'histfile'}) {{
unless ($term->can("AddHistory")) {
$CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
last;
}
- my($fh) = FileHandle->new;
- open $fh, "<$histfile" or last;
- local $/ = "\n";
- while (<$fh>) {
- chomp;
- $term->AddHistory($_);
- }
- close $fh;
+ $META->readhist($term,$histfile);
}}
for ($CPAN::Config->{term_ornaments}) { # alias
local $Term::ReadLine::termcap_nowarn = 1;
$term->ornaments($_) if defined;
}
- # $term->OUT is autoflushed anyway
- my $odef = select STDERR;
- $| = 1;
- select STDOUT;
- $| = 1;
- select $odef;
+ # $term->OUT is autoflushed anyway
+ my $odef = select STDERR;
+ $| = 1;
+ select STDOUT;
+ $| = 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(),
File::Spec->rootdir();
my $try_detect_readline;
$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')";
-
- unless ($CPAN::Config->{'inhibit_startup_message'}){
+ unless ($CPAN::Config->{inhibit_startup_message}) {
+ my $rl_avail = $Suppress_readline ? "suppressed" :
+ ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
+ "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
$CPAN::Frontend->myprint(
sprintf qq{
cpan shell -- CPAN exploration and modules installation (v%s)
my($continuation) = "";
my $last_term_ornaments;
SHELLCOMMAND: while () {
- if ($Suppress_readline) {
- print $prompt;
- last SHELLCOMMAND unless defined ($_ = <> );
- chomp;
- } else {
- last SHELLCOMMAND unless
+ 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
defined ($_ = $term->readline($prompt, $commandline));
- }
- $_ = "$continuation$_" if $continuation;
- s/^\s+//;
- next SHELLCOMMAND if /^$/;
- $_ = 'h' if /^\s*\?/;
- if (/^(?:q(?:uit)?|bye|exit)$/i) {
- last SHELLCOMMAND;
- } elsif (s/\\$//s) {
- chomp;
- $continuation = $_;
- $prompt = " > ";
- } elsif (/^\!/) {
- s/^\!//;
- my($eval) = $_;
- package CPAN::Eval;
+ }
+ $_ = "$continuation$_" if $continuation;
+ s/^\s+//;
+ next SHELLCOMMAND if /^$/;
+ s/^\s*\?\s*/help /;
+ if (/^(?:q(?:uit)?|bye|exit)$/i) {
+ last SHELLCOMMAND;
+ } elsif (s/\\$//s) {
+ chomp;
+ $continuation = $_;
+ $prompt = " > ";
+ } elsif (/^\!/) {
+ s/^\!//;
+ my($eval) = $_;
+ package CPAN::Eval;
use strict;
- use vars qw($import_done);
- CPAN->import(':DEFAULT') unless $import_done++;
- CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
- eval($eval);
- warn $@ if $@;
- $continuation = "";
- $prompt = $oprompt;
- } elsif (/./) {
- my(@line);
+ use vars qw($import_done);
+ CPAN->import(':DEFAULT') unless $import_done++;
+ CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
+ eval($eval);
+ warn $@ if $@;
+ $continuation = "";
+ $prompt = $oprompt;
+ } elsif (/./) {
+ my(@line);
eval { @line = Text::ParseWords::shellwords($_) };
warn($@), next SHELLCOMMAND if $@;
warn("Text::Parsewords could not parse the line [$_]"),
next SHELLCOMMAND unless @line;
- $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
- my $command = shift @line;
- eval { CPAN::Shell->$command(@line) };
- if ($@){
- require Carp;
- Carp::cluck($@);
- }
- if ($command =~ /^(make|test|install|force|notest|clean|report|upgrade)$/) {
+ $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
+ my $command = shift @line;
+ eval { CPAN::Shell->$command(@line) };
+ if ($@) {
+ my $err = "$@";
+ if ($err =~ /\S/) {
+ require Carp;
+ require Dumpvalue;
+ my $dv = Dumpvalue->new();
+ Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
+ }
+ }
+ if ($command =~ /^(
+ # classic commands
+ make
+ |test
+ |install
+ |clean
+
+ # pragmas for classic commands
+ |ff?orce
+ |notest
+
+ # compounds
+ |report
+ |smoke
+ |upgrade
+ )$/x) {
+ # only commands that tell us something about failed distros
CPAN::Shell->failed($CPAN::CurrentCommandId,1);
}
soft_chdir_with_alternatives(\@cwd);
- $CPAN::Frontend->myprint("\n");
- $continuation = "";
+ $CPAN::Frontend->myprint("\n");
+ $continuation = "";
$CPAN::CurrentCommandId++;
- $prompt = $oprompt;
- }
+ $prompt = $oprompt;
+ }
} continue {
- $commandline = ""; # I do want to be able to pass a default to
- # shell, but on the second command I see no
- # use in that
- $Signal=0;
- CPAN::Queue->nullify_queue;
- if ($try_detect_readline) {
- if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
- ||
- $CPAN::META->has_inst("Term::ReadLine::Perl")
- ) {
- delete $INC{"Term/ReadLine.pm"};
- my $redef = 0;
- local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
- require Term::ReadLine;
- $CPAN::Frontend->myprint("\n$redef subroutines in ".
- "Term::ReadLine redefined\n");
- $GOTOSHELL = 1;
- }
- }
- if ($term and $term->can("ornaments")) {
- for ($CPAN::Config->{term_ornaments}) { # alias
- if (defined $_) {
- if (not defined $last_term_ornaments
- or $_ != $last_term_ornaments
- ) {
- local $Term::ReadLine::termcap_nowarn = 1;
- $term->ornaments($_);
- $last_term_ornaments = $_;
- }
- } else {
- undef $last_term_ornaments;
- }
- }
- }
- 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) {
- $GOTOSHELL = 0; # not too often
- $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
- @_ = ($oprompt,"");
- goto &shell;
- }
+ $commandline = ""; # I do want to be able to pass a default to
+ # shell, but on the second command I see no
+ # use in that
+ $Signal=0;
+ CPAN::Queue->nullify_queue;
+ if ($try_detect_readline) {
+ if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
+ ||
+ $CPAN::META->has_inst("Term::ReadLine::Perl")
+ ) {
+ delete $INC{"Term/ReadLine.pm"};
+ my $redef = 0;
+ local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
+ require Term::ReadLine;
+ $CPAN::Frontend->myprint("\n$redef subroutines in ".
+ "Term::ReadLine redefined\n");
+ $GOTOSHELL = 1;
+ }
+ }
+ if ($term and $term->can("ornaments")) {
+ for ($CPAN::Config->{term_ornaments}) { # alias
+ if (defined $_) {
+ if (not defined $last_term_ornaments
+ or $_ != $last_term_ornaments
+ ) {
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $term->ornaments($_);
+ $last_term_ornaments = $_;
+ }
+ } else {
+ undef $last_term_ornaments;
+ }
+ }
+ }
+ 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) {
+ $GOTOSHELL = 0; # not too often
+ $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
+ @_ = ($oprompt,"");
+ goto &shell;
+ }
}
soft_chdir_with_alternatives(\@cwd);
}
+#-> CPAN::soft_chdir_with_alternatives ;
sub soft_chdir_with_alternatives ($) {
my($cwd) = @_;
unless (@$cwd) {
}
}
-sub _yaml_module {
+sub _flock {
+ my($fh,$mode) = @_;
+ if ($Config::Config{d_flock}) {
+ return flock $fh, $mode;
+ } elsif (!$Have_warned->{"d_flock"}++) {
+ $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
+ $CPAN::Frontend->mysleep(5);
+ return 1;
+ } else {
+ return 1;
+ }
+}
+
+sub _yaml_module () {
my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
if (
$yaml_module ne "YAML"
# $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;
}
sub _yaml_loadfile {
my($self,$local_file) = @_;
return +[] unless -s $local_file;
- my $yaml_module = $self->_yaml_module;
+ my $yaml_module = _yaml_module;
if ($CPAN::META->has_inst($yaml_module)) {
- my $code = UNIVERSAL::can($yaml_module, "LoadFile");
- my @yaml;
- eval { @yaml = $code->($local_file); };
- if ($@) {
- $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
- " $local_file\n".
- "with $yaml_module the following error was encountered:\n".
- " $@\n"
- );
+ # temporarly enable yaml code deserialisation
+ no strict 'refs';
+ # 5.6.2 could not do the local() with the reference
+ local $YAML::LoadCode;
+ local $YAML::Syck::LoadCode;
+ ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
+
+ 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;
}
- return \@yaml;
} else {
- $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
+ # 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,$to_local_file,@what) = @_;
- my $yaml_module = $self->_yaml_module;
+ my($self,$local_file,@what) = @_;
+ my $yaml_module = _yaml_module;
if ($CPAN::META->has_inst($yaml_module)) {
- if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
- my $code = UNIVERSAL::can($yaml_module, "Dump");
- eval { print $to_local_file $code->(@what) };
- } else {
- my $code = UNIVERSAL::can($yaml_module, "DumpFile");
- eval { $code->($to_local_file,@what); };
+ 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 ($@) {
- $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n".
- " $to_local_file\n".
- "with $yaml_module the following error was encountered:\n".
- " $@\n"
- );
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
}
} else {
- if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
+ if (UNIVERSAL::isa($local_file, "FileHandle")) {
# I think this case does not justify a warning at all
} else {
- $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' ".
- "not installed, not dumping to '$to_local_file'\n");
+ die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
}
}
}
sub _init_sqlite () {
- unless ($CPAN::META->has_inst("CPAN::SQLite")
- &&
- $CPAN::META->has_inst("CPAN::SQLite::META")
- ) {
- $CPAN::Frontend->mywarn(qq{SQLite not installed, cannot work with CPAN::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);
+use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
@CPAN::FTP::ISA = qw(CPAN::Debug);
package CPAN::LWP::UserAgent;
# 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
+ ? ! a b d h i m o q r u
autobundle
+ bye
clean
cvs_import
dump
+ exit
+ failed
force
+ fforce
hosts
install
install_tested
+ is_tested
look
ls
make
mkmyconfig
notest
perldoc
+ quit
readme
recent
recompile
reload
report
+ reports
scripts
+ smoke
test
upgrade
);
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";
$ADVANCED_QUERY
$AUTOLOAD
$COLOR_REGISTERED
+ $Help
$autoload_recursion
$reload
@ISA
);
@CPAN::Shell::ISA = qw(CPAN::Debug);
$COLOR_REGISTERED ||= 0;
-
+$Help = {
+ '?' => \"help",
+ '!' => "eval the rest of the line as perl",
+ a => "whois author",
+ autobundle => "wtite inventory into a bundle file",
+ b => "info about bundle",
+ bye => \"quit",
+ clean => "clean up a distribution's build directory",
+ # cvs_import
+ d => "info about a distribution",
+ # dump
+ exit => \"quit",
+ failed => "list all failed actions within current session",
+ fforce => "redo a command from scratch",
+ force => "redo a command",
+ h => \"help",
+ help => "overview over commands; 'help ...' explains specific commands",
+ hosts => "statistics about recently used hosts",
+ i => "info about authors/bundles/distributions/modules",
+ install => "install a distribution",
+ install_tested => "install all distributions tested OK",
+ is_tested => "list all distributions tested OK",
+ look => "open a subshell in a distribution's directory",
+ ls => "list distributions according to a glob",
+ m => "info about a module",
+ make => "make/build a distribution",
+ mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
+ notest => "run a (usually install) command but leave out the test phase",
+ o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
+ perldoc => "try to get a manpage for a module",
+ q => \"quit",
+ quit => "leave the cpan shell",
+ r => "review over upgradeable modules",
+ readme => "display the README of a distro woth a pager",
+ recent => "show recent uploads to the CPAN",
+ # recompile
+ reload => "'reload cpan' or 'reload index'",
+ report => "test a distribution and send a test report to cpantesters",
+ reports => "info about reported tests from cpantesters",
+ # scripts
+ # smoke
+ test => "test a distribution",
+ u => "display uninstalled modules",
+ upgrade => "combine 'r' command with immediate installation",
+ };
{
$autoload_recursion ||= 0;
if (defined $dll) {
$mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
}
+ my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
my $this_fingerprint = {
- '$^X' => $^X,
+ '$^X' => CPAN::find_perl,
sitearchexp => $Config::Config{sitearchexp},
- 'mtime_$^X' => (stat $^X)[9],
+ 'mtime_$^X' => $mtime_perl,
'mtime_dll' => $mtime_dll,
};
if ($other_fingerprint) {
my($self) = @_;
my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
if (-f $lockfile && -M _ > 0) {
- my $fh = FileHandle->new($lockfile) or
+ my $fh = FileHandle->new($lockfile) or
$CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
- my $otherpid = <$fh>;
- my $otherhost = <$fh>;
- $fh->close;
- if (defined $otherpid && $otherpid) {
- chomp $otherpid;
- }
- if (defined $otherhost && $otherhost) {
- chomp $otherhost;
- }
- my $thishost = hostname();
- if (defined $otherhost && defined $thishost &&
- $otherhost ne '' && $thishost ne '' &&
- $otherhost ne $thishost) {
+ my $otherpid = <$fh>;
+ my $otherhost = <$fh>;
+ $fh->close;
+ if (defined $otherpid && $otherpid) {
+ chomp $otherpid;
+ }
+ if (defined $otherhost && $otherhost) {
+ chomp $otherhost;
+ }
+ my $thishost = hostname();
+ if (defined $otherhost && defined $thishost &&
+ $otherhost ne '' && $thishost ne '' &&
+ $otherhost ne $thishost) {
$CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
"reports other host $otherhost and other ".
"process $otherpid.\n".
"Cannot proceed.\n"));
- } elsif ($RUN_DEGRADED) {
+ } 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{
+ 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->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 (kill 0, $otherpid) {
+ $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");
$_->{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("
rm $lockfile
");
}
- } elsif (-w $lockfile) {
- my($ans) =
- CPAN::Shell::colorable_makemaker_prompt
- (qq{Other job not responding. Shall I overwrite }.
- qq{the lockfile '$lockfile'? (Y/n)},"y");
- $CPAN::Frontend->myexit("Ok, bye\n")
- unless $ans =~ /^y/i;
- } else {
- Carp::croak(
- qq{Lockfile '$lockfile' not writeable by you. }.
- qq{Cannot proceed.\n}.
- qq{ On UNIX try:\n}.
- qq{ rm '$lockfile'\n}.
- qq{ and then rerun us.\n}
- );
- }
- } else {
+ } elsif (-w $lockfile) {
+ my($ans) =
+ CPAN::Shell::colorable_makemaker_prompt
+ (qq{Other job not responding. Shall I overwrite }.
+ qq{the lockfile '$lockfile'? (Y/n)},"y");
+ $CPAN::Frontend->myexit("Ok, bye\n")
+ unless $ans =~ /^y/i;
+ } else {
+ Carp::croak(
+ qq{Lockfile '$lockfile' not writeable by you. }.
+ qq{Cannot proceed.\n}.
+ qq{ On UNIX try:\n}.
+ qq{ rm '$lockfile'\n}.
+ qq{ and then rerun us.\n}
+ );
+ }
+ } else {
$CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
"'$lockfile', please remove. Cannot proceed.\n"));
}
$mess .= qq{
Please make sure the directory exists and is writable.
};
- $CPAN::Frontend->myprint($mess);
+ $CPAN::Frontend->mywarn($mess);
return suggest_myconfig;
}
} # $@ after eval mkpath $dotcpan
my $fh;
unless ($fh = FileHandle->new("+>>$lockfile")) {
if ($! =~ /Permission/) {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->mywarn(qq{
Your configuration suggests that CPAN.pm should use a working
directory of
}
}
my $sleep = 1;
- while (!flock $fh, LOCK_EX|LOCK_NB) {
+ while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
if ($sleep>10) {
$CPAN::Frontend->mydie("Giving up\n");
}
seek $fh, 0, 0;
truncate $fh, 0;
+ $fh->autoflush(1);
$fh->print($$, "\n");
$fh->print(hostname(), "\n");
$self->{LOCK} = $lockfile;
sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
#-> sub CPAN::find_perl ;
-sub find_perl {
+sub find_perl () {
my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
my $pwd = $CPAN::iCwd = CPAN::anycwd();
my $candidate = File::Spec->catfile($pwd,$^X);
$perl ||= $candidate if MM->maybe_command($candidate);
unless ($perl) {
- my ($component,$perl_name);
+ my ($component,$perl_name);
DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
- PATH_COMPONENT: foreach $component (File::Spec->path(),
- $Config::Config{'binexp'}) {
- next unless defined($component) && $component;
- my($abs) = File::Spec->catfile($component,$perl_name);
- if (MM->maybe_command($abs)) {
- $perl = $abs;
- last DIST_PERLNAME;
- }
- }
- }
+ PATH_COMPONENT: foreach $component (File::Spec->path(),
+ $Config::Config{'binexp'}) {
+ next unless defined($component) && $component;
+ my($abs) = File::Spec->catfile($component,$perl_name);
+ if (MM->maybe_command($abs)) {
+ $perl = $abs;
+ last DIST_PERLNAME;
+ }
+ }
+ }
}
return $perl;
### Carp::croak "exists called without class argument" unless $class;
$id ||= "";
$id =~ s/:+/::/g if $class eq "CPAN::Module";
- if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
- return (exists $META->{readonly}{$class}{$id} or
- $CPAN::SQLite->set($class, $id));
+ my $exists;
+ if (CPAN::_sqlite_running) {
+ $exists = (exists $META->{readonly}{$class}{$id} or
+ $CPAN::SQLite->set($class, $id));
} else {
- return (exists $META->{readonly}{$class}{$id} or
- exists $META->{readwrite}{$class}{$id}); # unsafe meta access, ok
+ $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 (CPAN::Version->vge(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 (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
+ for ("Will not use Archive::Tar, need 1.00\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ],
+ 'File::Temp' => [
+ # XXX we should probably delete from
+ # %INC too so we can load after we
+ # installed a new enough version --
+ # I'm not sure.
+ sub {require File::Temp;
+ unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
+ for ("Will not use File::Temp, need 0.16\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ]
};
if ($usable->{$mod}) {
for my $c (0..$#{$usable->{$mod}}) {
sub has_inst {
my($self,$mod,$message) = @_;
Carp::croak("CPAN->has_inst() called without an argument")
- unless defined $mod;
+ unless defined $mod;
my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
keys %{$CPAN::Config->{dontload_hash}||{}},
@{$CPAN::Config->{dontload_list}||[]};
$file =~ s|::|/|g;
$file .= ".pm";
if ($INC{$file}) {
- # checking %INC is wrong, because $INC{LWP} may be true
- # although $INC{"URI/URL.pm"} may have failed. But as
- # I really want to say "bla loaded OK", I have to somehow
- # cache results.
- ### warn "$file in %INC"; #debug
- return 1;
+ # checking %INC is wrong, because $INC{LWP} may be true
+ # although $INC{"URI/URL.pm"} may have failed. But as
+ # I really want to say "bla loaded OK", I have to somehow
+ # cache results.
+ ### warn "$file in %INC"; #debug
+ return 1;
} elsif (eval { require $file }) {
- # eval is good: if we haven't yet read the database it's
- # perfect and if we have installed the module in the meantime,
- # it tries again. The second require is only a NOOP returning
- # 1 if we had success, otherwise it's retrying
-
+ # eval is good: if we haven't yet read the database it's
+ # perfect and if we have installed the module in the meantime,
+ # it tries again. The second require is only a NOOP returning
+ # 1 if we had success, otherwise it's retrying
+
+ my $mtime = (stat $INC{$file})[9];
+ # privileged files loaded by has_inst; Note: we use $mtime
+ # as a proxy for a checksum.
+ $CPAN::Shell::reload->{$file} = $mtime;
my $v = eval "\$$mod\::VERSION";
$v = $v ? " (v$v)" : "";
- $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
- if ($mod eq "CPAN::WAIT") {
- push @CPAN::Shell::ISA, 'CPAN::WAIT';
- }
- return 1;
+ CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
+ if ($mod eq "CPAN::WAIT") {
+ push @CPAN::Shell::ISA, 'CPAN::WAIT';
+ }
+ return 1;
} elsif ($mod eq "Net::FTP") {
- $CPAN::Frontend->mywarn(qq{
+ $CPAN::Frontend->mywarn(qq{
Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
if you just type
install Bundle::libnet
}) unless $Have_warned->{"Net::FTP"}++;
- $CPAN::Frontend->mysleep(3);
- } elsif ($mod eq "Digest::SHA"){
+ $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->mywarn(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"){
+ } elsif ($mod eq "Module::Signature") {
# 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
- # reasonably install and use it.
- if (eval { require Crypt::OpenPGP; 1 } ||
- (
+ # No point in complaining unless the user can
+ # reasonably install and use it.
+ if (eval { require Crypt::OpenPGP; 1 } ||
+ (
defined $CPAN::Config->{'gpg'}
&&
$CPAN::Config->{'gpg'} =~ /\S/
)
) {
- $CPAN::Frontend->mywarn(qq{
+ $CPAN::Frontend->mywarn(qq{
CPAN: Module::Signature security checks disabled because Module::Signature
not installed. Please consider installing the Module::Signature module.
You may also need to be able to connect over the Internet to the public
keyservers like pgp.mit.edu (port 11371).
});
- $CPAN::Frontend->mysleep(2);
- }
- }
+ $CPAN::Frontend->mysleep(2);
+ }
+ }
} else {
- delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
+ delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
}
return 0;
}
my($subroutine);
while ((undef,undef,undef,$subroutine) = caller(++$i)) {
$ineval = 1, last if
- $subroutine eq '(eval)';
+ $subroutine eq '(eval)';
}
return if $ineval && !$CPAN::End;
return unless defined $META->{LOCK};
return unless -f $META->{LOCK};
$META->savehist;
+ close $META->{LOCKFH};
unlink $META->{LOCK};
# require Carp;
# Carp::cluck("DEBUGGING");
$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) = @_;
my($histfile,$histsize);
- unless ($histfile = $CPAN::Config->{'histfile'}){
+ unless ($histfile = $CPAN::Config->{'histfile'}) {
$CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
return;
}
$histsize = $CPAN::Config->{'histsize'} || 100;
- if ($CPAN::term){
+ if ($CPAN::term) {
unless ($CPAN::term->can("GetHistory")) {
$CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
return;
#-> 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
delete $self->{is_tested}{$what};
}
+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) = @_;
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")} sort keys %{$self->{is_tested}};
- if (@dirs < 15) {
- $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\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 @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
- sort keys %{$self->{is_tested}};
- $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ".
- "@d to PERL5LIB; ".
- "%BUILDDIR%=$CPAN::Config->{'build_dir'} ".
- "for $for\n"
+ my $cnt = keys %{$self->{is_tested}};
+ $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
+ "$cnt build dirs to PERL5LIB; ".
+ "for '$for'\n"
);
}
sub as_string {
eval { require Data::Dumper };
if ($@) {
- return shift->SUPER::as_string;
+ return shift->SUPER::as_string;
} else {
- return Data::Dumper::Dumper(shift);
+ return Data::Dumper::Dumper(shift);
}
}
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;
}
}
or Carp::croak("Couldn't opendir $dir: $!");
my(@entries);
for ($dh->read) {
- next if $_ eq "." || $_ eq "..";
- if (-f $_) {
- push @entries, File::Spec->catfile($dir,$_);
- } elsif (-d _) {
- push @entries, File::Spec->catdir($dir,$_);
- } else {
- $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
- }
+ next if $_ eq "." || $_ eq "..";
+ if (-f $_) {
+ push @entries, File::Spec->catfile($dir,$_);
+ } elsif (-d _) {
+ push @entries, File::Spec->catdir($dir,$_);
+ } else {
+ $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
+ }
}
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::Basename::dirname($dir) eq $CPAN::Config->{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 remove\n");
$CPAN::Frontend->mysleep(5);
return;
}
$self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
- if $CPAN::DEBUG;
+ if $CPAN::DEBUG;
File::Path::rmtree($dir);
- unlink "$dir.yml"; # may fail
+ 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'},
- MAX => $CPAN::Config->{'build_cache'},
- SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
- DU => 0
- };
+ ID => $CPAN::Config->{build_dir},
+ MAX => $CPAN::Config->{'build_cache'},
+ SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
+ DU => 0
+ };
File::Path::mkpath($self->{ID});
my $dh = DirHandle->new($self->{ID});
bless $self, $class;
my $self = shift;
return if $self->{SCAN} eq 'never';
$CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
- unless $self->{SCAN} eq 'atstart';
+ unless $self->{SCAN} eq 'atstart';
+ return unless $CPAN::META->{LOCK};
$CPAN::Frontend->myprint(
- sprintf("Scanning cache %s for sizes\n",
- $self->{ID}));
+ 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);
- return if $CPAN::Signal;
+ 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;
}
sub h {
my($class,$about) = @_;
if (defined $about) {
- $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
+ my $help;
+ if (exists $Help->{$about}) {
+ if (ref $Help->{$about}) { # aliases
+ $about = ${$Help->{$about}};
+ }
+ $help = $Help->{$about};
+ } else {
+ $help = "No help available";
+ }
+ $CPAN::Frontend->myprint("$about\: $help\n");
} else {
my $filler = " " x (80 - 28 - length($CPAN::VERSION));
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->myprint(qq{
Display Information $filler (ver $CPAN::VERSION)
command argument description
a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
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
my $silent = @accept>1;
my $last_alpha = "";
my @results;
- for my $a (@accept){
+ for my $a (@accept) {
my($author,$pathglob);
if ($a =~ m|(.*?)/(.*)|) {
my $a2 = $1;
$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;
for $entry ($dh->read) {
next if $entry =~ /^\./;
next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
- if (-d File::Spec->catdir($bdir,$entry)){
+ if (-d File::Spec->catdir($bdir,$entry)) {
push @bbase, "$bbase\::$entry";
} else {
next unless $entry =~ s/\.pm(?!\n)\Z//;
@args = '/./' unless @args;
my(@result);
for my $type (qw/Bundle Distribution Module/) {
- push @result, $self->expand($type,@args);
+ push @result, $self->expand($type,@args);
}
# Authors are always uppercase.
push @result, $self->expand("Author", map { uc $_ } @args);
my $result = @result == 1 ?
- $result[0]->as_string :
+ $result[0]->as_string :
@result == 0 ?
"No objects found of any type for argument @args\n" :
join("",
$o_type ||= "";
CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
if ($o_type eq 'conf') {
- if (!@o_what) { # print all things, "o conf"
- my($k,$v);
- $CPAN::Frontend->myprint("\$CPAN::Config options from ");
+ my($cfilter);
+ ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
+ if (!@o_what or $cfilter) { # print all things, "o conf"
+ $cfilter ||= "";
+ my $qrfilter = eval 'qr/$cfilter/';
+ my($k,$v);
+ $CPAN::Frontend->myprint("\$CPAN::Config options from ");
my @from;
- if (exists $INC{'CPAN/Config.pm'}) {
+ if (exists $INC{'CPAN/Config.pm'}) {
push @from, $INC{'CPAN/Config.pm'};
- }
- if (exists $INC{'CPAN/MyConfig.pm'}) {
+ }
+ if (exists $INC{'CPAN/MyConfig.pm'}) {
push @from, $INC{'CPAN/MyConfig.pm'};
- }
+ }
$CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
- $CPAN::Frontend->myprint(":\n");
- for $k (sort keys %CPAN::HandleConfig::can) {
- $v = $CPAN::HandleConfig::can{$k};
- $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
- }
- $CPAN::Frontend->myprint("\n");
- for $k (sort keys %$CPAN::Config) {
+ $CPAN::Frontend->myprint(":\n");
+ for $k (sort keys %CPAN::HandleConfig::can) {
+ next unless $k =~ /$qrfilter/;
+ $v = $CPAN::HandleConfig::can{$k};
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
+ }
+ $CPAN::Frontend->myprint("\n");
+ for $k (sort keys %CPAN::HandleConfig::keys) {
+ next unless $k =~ /$qrfilter/;
CPAN::HandleConfig->prettyprint($k);
- }
- $CPAN::Frontend->myprint("\n");
- } else {
+ }
+ $CPAN::Frontend->myprint("\n");
+ } else {
if (CPAN::HandleConfig->edit(@o_what)) {
- unless ($o_what[0] =~ /^(init|commit|defaults)$/) {
- $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
- "make the config permanent!\n\n");
- }
} else {
$CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
qq{items\n\n});
}
- }
+ }
} elsif ($o_type eq 'debug') {
- my(%valid);
- @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
- if (@o_what) {
- while (@o_what) {
- my($what) = shift @o_what;
+ my(%valid);
+ @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
+ if (@o_what) {
+ while (@o_what) {
+ my($what) = shift @o_what;
if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
$CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
next;
}
- if ( exists $CPAN::DEBUG{$what} ) {
- $CPAN::DEBUG |= $CPAN::DEBUG{$what};
- } elsif ($what =~ /^\d/) {
- $CPAN::DEBUG = $what;
- } elsif (lc $what eq 'all') {
- my($max) = 0;
- for (values %CPAN::DEBUG) {
- $max += $_;
- }
- $CPAN::DEBUG = $max;
- } else {
- my($known) = 0;
- for (keys %CPAN::DEBUG) {
- next unless lc($_) eq lc($what);
- $CPAN::DEBUG |= $CPAN::DEBUG{$_};
- $known = 1;
- }
- $CPAN::Frontend->myprint("unknown argument [$what]\n")
- unless $known;
- }
- }
- } else {
- my $raw = "Valid options for debug are ".
- join(", ",sort(keys %CPAN::DEBUG), 'all').
- qq{ or a number. Completion works on the options. }.
- qq{Case is ignored.};
- require Text::Wrap;
- $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
- $CPAN::Frontend->myprint("\n\n");
- }
- if ($CPAN::DEBUG) {
- $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
- my($k,$v);
- for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
- $v = $CPAN::DEBUG{$k};
- $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
+ if ( exists $CPAN::DEBUG{$what} ) {
+ $CPAN::DEBUG |= $CPAN::DEBUG{$what};
+ } elsif ($what =~ /^\d/) {
+ $CPAN::DEBUG = $what;
+ } elsif (lc $what eq 'all') {
+ my($max) = 0;
+ for (values %CPAN::DEBUG) {
+ $max += $_;
+ }
+ $CPAN::DEBUG = $max;
+ } else {
+ my($known) = 0;
+ for (keys %CPAN::DEBUG) {
+ next unless lc($_) eq lc($what);
+ $CPAN::DEBUG |= $CPAN::DEBUG{$_};
+ $known = 1;
+ }
+ $CPAN::Frontend->myprint("unknown argument [$what]\n")
+ unless $known;
+ }
+ }
+ } else {
+ my $raw = "Valid options for debug are ".
+ join(", ",sort(keys %CPAN::DEBUG), 'all').
+ qq{ or a number. Completion works on the options. }.
+ qq{Case is ignored.};
+ require Text::Wrap;
+ $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
+ $CPAN::Frontend->myprint("\n\n");
+ }
+ if ($CPAN::DEBUG) {
+ $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
+ my($k,$v);
+ for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
+ $v = $CPAN::DEBUG{$k};
+ $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
if $v & $CPAN::DEBUG;
- }
- } else {
- $CPAN::Frontend->myprint("Debugging turned off completely.\n");
- }
+ }
+ } else {
+ $CPAN::Frontend->myprint("Debugging turned off completely.\n");
+ }
} else {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->myprint(qq{
Known options:
conf set or get configuration variables
debug set or get debugging options
sub paintdots_onreload {
my($ref) = shift;
sub {
- if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
- my($subr) = $1;
- ++$$ref;
- local($|) = 1;
- # $CPAN::Frontend->myprint(".($subr)");
- $CPAN::Frontend->myprint(".");
+ if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
+ my($subr) = $1;
+ ++$$ref;
+ local($|) = 1;
+ # $CPAN::Frontend->myprint(".($subr)");
+ $CPAN::Frontend->myprint(".");
if ($subr =~ /\bshell\b/i) {
# warn "debug[$_[0]]";
$CPAN::GOTOSHELL=1;
}
- return;
- }
- warn @_;
+ return;
+ }
+ warn @_;
};
}
$S{end} ||= $last->{end};
my $dltime = $last->{end} - $start;
my $dlsize = $last->{filesize} || 0;
- my $url = $last->{thesiteurl}->text;
+ my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
my $s = $S{ok}{$url} ||= {};
$s->{n}++;
$s->{dlsize} ||= 0;
];
}
my $R = ""; # report
- $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown";
- $R .= sprintf "Log ends : %s\n", scalar(localtime $S{end}) || "unknown";
+ 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 $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/Config.pm",
+ "CPAN/Reporter/History.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
return;
}
my $mtime = (stat $file)[9];
- $reload->{$f} ||= $^T;
- my $must_reload = $mtime > $reload->{$f};
+ if ($reload->{$f}) {
+ } elsif ($^T < $mtime) {
+ # since we started the file has changed, force it to be reloaded
+ $reload->{$f} = -1;
+ } else {
+ $reload->{$f} = $mtime;
+ }
+ my $must_reload = $mtime != $reload->{$f};
$args ||= {};
- $must_reload ||= $args->{force};
+ $must_reload ||= $args->{reloforce}; # o conf defaults needs this
if ($must_reload) {
my $fh = FileHandle->new($file) or
$CPAN::Frontend->mydie("Could not open $file: $!");
delete $INC{$f};
local @INC = @inc;
eval "require '$f'";
- if ($@){
+ if ($@) {
warn $@;
return;
}
- $reload->{$f} = time;
+ $reload->{$f} = $mtime;
} else {
$CPAN::Frontend->myprint("__unchanged__");
}
my($self) = shift @_;
my(@result,$module,%seen,%need,$headerdone);
for $module ($self->expand('Module','/./')) {
- my $file = $module->cpan_file;
- next if $file eq "N/A";
- next if $file =~ /^Contact Author/;
+ my $file = $module->cpan_file;
+ next if $file eq "N/A";
+ next if $file =~ /^Contact Author/;
my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
- next if $dist->isa_perl;
- next unless $module->xs_file;
- local($|) = 1;
- $CPAN::Frontend->myprint(".");
- push @result, $module;
+ next if $dist->isa_perl;
+ next unless $module->xs_file;
+ local($|) = 1;
+ $CPAN::Frontend->myprint(".");
+ push @result, $module;
}
# print join " | ", @result;
$CPAN::Frontend->myprint("\n");
my($self) = shift @_;
my($module,@module,$cpan_file,%dist);
@module = $self->_binary_extensions();
- for $module (@module){ # we force now and compile later, so we
+ for $module (@module) { # we force now and compile later, so we
# don't do it twice
- $cpan_file = $module->cpan_file;
- my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->force;
- $dist{$cpan_file}++;
+ $cpan_file = $module->cpan_file;
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->force;
+ $dist{$cpan_file}++;
}
for $cpan_file (sort keys %dist) {
- $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
- my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->install;
- $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
+ $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->install;
+ $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
# stop a package from recompiling,
# e.g. IO-1.12 when we have perl5.003_10
}
# re-run (as documented)
}
+# compare with is_tested
#-> sub CPAN::Shell::install_tested
sub install_tested {
my($self,@some) = @_;
- $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
+ $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
return if @some;
CPAN::Index->reload;
- for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) {
- my $do = CPAN::Shell->expandany($d);
- next unless $do->{build_dir};
+ 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 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;
+ # @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->sleep(1);
+ $CPAN::Frontend->mysleep(1);
$self->install($d);
}
}
my(@args) = @_;
@args = '/./' unless @args;
my(@result,$module,%seen,%need,$headerdone,
- $version_undefs,$version_zeroes);
+ $version_undefs,$version_zeroes,
+ @version_undefs,@version_zeroes);
$version_undefs = $version_zeroes = 0;
my $sprintf = "%s%-25s%s %9s %9s %s\n";
my @expand = $self->expand('Module',@args);
$CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
}
MODULE: for $module (@expand) {
- my $file = $module->cpan_file;
- next MODULE unless defined $file; # ??
- $file =~ s|^./../||;
- my($latest) = $module->cpan_version;
- my($inst_file) = $module->inst_file;
- my($have);
- return if $CPAN::Signal;
- if ($inst_file){
- if ($what eq "a") {
- $have = $module->inst_version;
- } elsif ($what eq "r") {
- $have = $module->inst_version;
- local($^W) = 0;
- if ($have eq "undef"){
- $version_undefs++;
- } elsif ($have == 0){
- $version_zeroes++;
- }
- next MODULE unless CPAN::Version->vgt($latest, $have);
+ my $file = $module->cpan_file;
+ next MODULE unless defined $file; # ??
+ $file =~ s!^./../!!;
+ my($latest) = $module->cpan_version;
+ my($inst_file) = $module->inst_file;
+ my($have);
+ return if $CPAN::Signal;
+ if ($inst_file) {
+ if ($what eq "a") {
+ $have = $module->inst_version;
+ } elsif ($what eq "r") {
+ $have = $module->inst_version;
+ local($^W) = 0;
+ if ($have eq "undef") {
+ $version_undefs++;
+ push @version_undefs, $module->as_glimpse;
+ } elsif (CPAN::Version->vcmp($have,0)==0) {
+ $version_zeroes++;
+ push @version_zeroes, $module->as_glimpse;
+ }
+ next MODULE unless CPAN::Version->vgt($latest, $have);
# to be pedantic we should probably say:
# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
# to catch the case where CPAN has a version 0 and we have a version undef
- } elsif ($what eq "u") {
- next MODULE;
- }
- } else {
- if ($what eq "a") {
- next MODULE;
- } elsif ($what eq "r") {
- next MODULE;
- } elsif ($what eq "u") {
- $have = "-";
- }
- }
- return if $CPAN::Signal; # this is sometimes lengthy
- $seen{$file} ||= 0;
- if ($what eq "a") {
- push @result, sprintf "%s %s\n", $module->id, $have;
- } elsif ($what eq "r") {
- push @result, $module->id;
- next MODULE if $seen{$file}++;
- } elsif ($what eq "u") {
- push @result, $module->id;
- next MODULE if $seen{$file}++;
- next MODULE if $file =~ /^Contact/;
- }
- unless ($headerdone++){
- $CPAN::Frontend->myprint("\n");
- $CPAN::Frontend->myprint(sprintf(
+ } elsif ($what eq "u") {
+ next MODULE;
+ }
+ } else {
+ if ($what eq "a") {
+ next MODULE;
+ } elsif ($what eq "r") {
+ next MODULE;
+ } elsif ($what eq "u") {
+ $have = "-";
+ }
+ }
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $seen{$file} ||= 0;
+ if ($what eq "a") {
+ push @result, sprintf "%s %s\n", $module->id, $have;
+ } elsif ($what eq "r") {
+ push @result, $module->id;
+ next MODULE if $seen{$file}++;
+ } elsif ($what eq "u") {
+ push @result, $module->id;
+ next MODULE if $seen{$file}++;
+ next MODULE if $file =~ /^Contact/;
+ }
+ unless ($headerdone++) {
+ $CPAN::Frontend->myprint("\n");
+ $CPAN::Frontend->myprint(sprintf(
$sprintf,
"",
"Package namespace",
"latest",
"in CPAN file"
));
- }
+ }
my $color_on = "";
my $color_off = "";
if (
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
}
- $CPAN::Frontend->myprint(sprintf $sprintf,
+ $CPAN::Frontend->myprint(sprintf $sprintf,
$color_on,
$module->id,
$color_off,
$have,
$latest,
$file);
- $need{$module->id}++;
+ $need{$module->id}++;
}
unless (%need) {
- if ($what eq "u") {
- $CPAN::Frontend->myprint("No modules found for @args\n");
- } elsif ($what eq "r") {
- $CPAN::Frontend->myprint("All modules are up to date for @args\n");
- }
+ if ($what eq "u") {
+ $CPAN::Frontend->myprint("No modules found for @args\n");
+ } elsif ($what eq "r") {
+ $CPAN::Frontend->myprint("All modules are up to date for @args\n");
+ }
}
if ($what eq "r") {
- if ($version_zeroes) {
- my $s_has = $version_zeroes > 1 ? "s have" : " has";
- $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
- qq{a version number of 0\n});
- }
- if ($version_undefs) {
- my $s_has = $version_undefs > 1 ? "s have" : " has";
- $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
- qq{parseable version number\n});
- }
+ if ($version_zeroes) {
+ my $s_has = $version_zeroes > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
+ qq{a version number of 0\n});
+ if ($CPAN::Config->{show_zero_versions}) {
+ local $" = "\t";
+ $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
+ qq{to hide them)\n});
+ } else {
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
+ qq{to show them)\n});
+ }
+ }
+ if ($version_undefs) {
+ my $s_has = $version_undefs > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
+ qq{parseable version number\n});
+ if ($CPAN::Config->{show_unparsable_versions}) {
+ local $" = "\t";
+ $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
+ qq{to hide them)\n});
+ } else {
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
+ qq{to show them)\n});
+ }
+ }
}
@result;
}
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",
}
}
-#-> sub CPAN::Shell::autobundle ;
-sub autobundle {
- my($self) = shift;
- CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
- my(@bundle) = $self->_u_r_common("a",@_);
+# 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;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ my(@bundle) = $self->_u_r_common("a",@_);
my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
File::Path::mkpath($todir);
unless (-d $todir) {
- $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
- return;
+ $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
+ return;
}
my($y,$m,$d) = (localtime)[5,4,3];
$y+=1900;
my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
my($to) = File::Spec->catfile($todir,"$me.pm");
while (-f $to) {
- $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
- $to = File::Spec->catfile($todir,"$me.pm");
+ $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
+ $to = File::Spec->catfile($todir,"$me.pm");
}
my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
$fh->print(
- "package Bundle::$me;\n\n",
- "\$VERSION = '0.01';\n\n",
- "1;\n\n",
- "__END__\n\n",
- "=head1 NAME\n\n",
- "Bundle::$me - Snapshot of installation on ",
- $Config::Config{'myhostname'},
- " on ",
- scalar(localtime),
- "\n\n=head1 SYNOPSIS\n\n",
- "perl -MCPAN -e 'install Bundle::$me'\n\n",
- "=head1 CONTENTS\n\n",
- join("\n", @bundle),
- "\n\n=head1 CONFIGURATION\n\n",
- Config->myconfig,
- "\n\n=head1 AUTHOR\n\n",
- "This Bundle has been generated automatically ",
- "by the autobundle routine in CPAN.pm.\n",
- );
+ "package Bundle::$me;\n\n",
+ "\$VERSION = '0.01';\n\n",
+ "1;\n\n",
+ "__END__\n\n",
+ "=head1 NAME\n\n",
+ "Bundle::$me - Snapshot of installation on ",
+ $Config::Config{'myhostname'},
+ " on ",
+ scalar(localtime),
+ "\n\n=head1 SYNOPSIS\n\n",
+ "perl -MCPAN -e 'install Bundle::$me'\n\n",
+ "=head1 CONTENTS\n\n",
+ join("\n", @bundle),
+ "\n\n=head1 CONFIGURATION\n\n",
+ Config->myconfig,
+ "\n\n=head1 AUTHOR\n\n",
+ "This Bundle has been generated automatically ",
+ "by the autobundle routine in CPAN.pm.\n",
+ );
$fh->close;
$CPAN::Frontend->myprint("\nWrote bundle file
$to\n\n");
my($class,$methods,@args) = @_;
my($arg,@m);
for $arg (@args) {
- my($regex,$command);
- if ($arg =~ m|^/(.*)/$|) {
- $regex = $1;
- } elsif ($arg =~ m/=/) {
- $command = 1;
+ my($regex,$command);
+ if ($arg =~ m|^/(.*)/$|) {
+ $regex = $1;
+# FIXME: there seem to be some ='s in the author data, which trigger
+# a failure here. This needs to be contemplated.
+# } elsif ($arg =~ m/=/) {
+# $command = 1;
}
- my $obj;
+ my $obj;
CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
$class,
defined $regex ? $regex : "UNDEFINED",
defined $command ? $command : "UNDEFINED",
) if $CPAN::DEBUG;
- if (defined $regex) {
- if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
+ 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(
push @m, $self if $lhs eq $criterion;
}
}
- } else {
- my($xarg) = $arg;
- if ( $class eq 'CPAN::Bundle' ) {
- $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
- } elsif ($class eq "CPAN::Distribution") {
+ } else {
+ my($xarg) = $arg;
+ if ( $class eq 'CPAN::Bundle' ) {
+ $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
+ } elsif ($class eq "CPAN::Distribution") {
$xarg = CPAN::Distribution->normalize($arg);
} else {
$xarg =~ s/:+/::/g;
}
- if ($CPAN::META->exists($class,$xarg)) {
- $obj = $CPAN::META->instance($class,$xarg);
- } elsif ($CPAN::META->exists($class,$arg)) {
- $obj = $CPAN::META->instance($class,$arg);
- } else {
- next;
- }
- push @m, $obj;
- }
+ if ($CPAN::META->exists($class,$xarg)) {
+ $obj = $CPAN::META->instance($class,$xarg);
+ } elsif ($CPAN::META->exists($class,$arg)) {
+ $obj = $CPAN::META->instance($class,$arg);
+ } else {
+ next;
+ }
+ push @m, $obj;
+ }
}
@m = sort {$a->id cmp $b->id} @m;
if ( $CPAN::DEBUG ) {
@args = '/./' unless @args;
my(@result) = $self->expand($type,@args);
my $result = @result == 1 ?
- $result[0]->as_string :
+ $result[0]->as_string :
@result == 0 ?
"No objects of type $type found for argument @args\n" :
join("",
sub report_fh {
return $installation_report_fh if $installation_report_fh;
- if ($CPAN::META->has_inst("File::Temp")) {
+ if ($CPAN::META->has_usable("File::Temp")) {
$installation_report_fh
= File::Temp->new(
+ dir => File::Spec->tmpdir,
template => 'cpan_install_XXXX',
suffix => '.txt',
unlink => 0,
return;
}
my $swhat = "$what"; # stringify if it is an object
- if ($CPAN::Config->{term_is_latin}){
+ if ($CPAN::Config->{term_is_latin}) {
+ # note: deprecated, need to switch to $LANG and $LC_*
# courtesy jhi:
$swhat
=~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
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";
+ }
+ # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
+ # $trailer construct. We want the newline be the last thing if
+ # there is a newline at the end ensuring that the next line is
+ # empty for other players
+ my $trailer = "";
+ $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
print $color_on,
$swhat,
- Term::ANSIColor::color("reset");
+ Term::ANSIColor::color("reset"),
+ $trailer;
} else {
print $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
-# attention. Yes, this is our working contract for now.
+# where is myprint/mywarn/Frontend/etc. documented? 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 attention. Yes, this is our
+# working contract for now.
sub myprint {
my($self,$what) = @_;
+ $self->print_ornamented($what,
+ $CPAN::Config->{colorize_print}||'bold blue on_white',
+ );
+}
- $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
+sub optprint {
+ my($self,$category,$what) = @_;
+ my $vname = $category . "_verbosity";
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ if (!$CPAN::Config->{$vname}
+ || $CPAN::Config->{$vname} =~ /^v/
+ ) {
+ $CPAN::Frontend->myprint($what);
+ }
}
#-> sub CPAN::Shell::myexit ;
#-> 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?
}
$longest = 62 if $longest > 62;
for my $l (@lines) {
- if ($l =~ /^\s*$/){
+ if ($l =~ /^\s*$/) {
$l = "\n";
next;
}
#-> 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 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)$/) {
- push @pragma, $meth;
- $meth = shift @some or
+ while($meth =~ /^(ff?orce|notest)$/) {
+ push @pragma, $meth;
+ $meth = shift @some or
$CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
"cannot continue");
}
# enter the queue but not its copy. How do they get a sensible
# test_count?
+ # With configure_requires, "get" is vulnerable in recursion.
+
+ my $needs_recursion_protection = "get|make|test|install";
+
# construct the queue
my($s,@s,@qcopy);
STHING: foreach $s (@some) {
- my $obj;
- if (ref $s) {
+ my $obj;
+ if (ref $s) {
CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
- $obj = $s;
- } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
- } elsif ($s =~ m|^/|) { # looks like a regexp
+ $obj = $s;
+ } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
+ } elsif ($s =~ m|^/|) { # looks like a regexp
if (substr($s,-1,1) eq ".") {
$obj = CPAN::Shell->expandany($s);
} else {
$CPAN::Frontend->mysleep(2);
next;
}
- } elsif ($meth eq "ls") {
+ } elsif ($meth eq "ls") {
$self->globls($s,\@pragma);
next STHING;
} else {
CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
- $obj = CPAN::Shell->expandany($s);
- }
- if (0) {
+ $obj = CPAN::Shell->expandany($s);
+ }
+ if (0) {
} elsif (ref $obj) {
- $obj->color_cmd_tmps(0,1);
- CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
+ 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->queue_item(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)$/) {
+ } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
+ $obj = $CPAN::META->instance('CPAN::Author',uc($s));
+ if ($meth =~ /^(dump|ls|reports)$/) {
$obj->$meth();
} else {
$CPAN::Frontend->mywarn(
);
$CPAN::Frontend->mysleep(2);
}
- } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
+ } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
CPAN::InfoObj->dump($s);
} else {
- $CPAN::Frontend
- ->mywarn(qq{Warning: Cannot $meth $s, }.
- qq{don't know what it is.
+ $CPAN::Frontend
+ ->mywarn(qq{Warning: Cannot $meth $s, }.
+ qq{don't know what it is.
Try the command
i /$s/
to find objects with matching identifiers.
});
$CPAN::Frontend->mysleep(2);
- }
+ }
}
# queuerunner (please be warned: when I started to change the
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;
$obj->{reqtype} = $reqtype;
}
- for my $pragma (@pragma) {
- if ($pragma
- &&
- $obj->can($pragma)){
- $obj->$pragma($meth);
- }
+ for my $pragma (@pragma) {
+ if ($pragma
+ &&
+ $obj->can($pragma)) {
+ $obj->$pragma($meth);
+ }
}
- if ($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 ($meth =~ /^(report)$/) { # they came here with a pragma?
+ $self->$meth($obj);
+ } elsif (! 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) {
+ for my $pragma (@pragma) {
my $unpragma = "un$pragma";
- if ($obj->can($unpragma)) {
- $obj->$unpragma();
- }
+ if ($obj->can($unpragma)) {
+ $obj->$unpragma();
+ }
}
- CPAN::Queue->delete_first($s);
+ CPAN::Queue->delete_first($s);
}
- for my $obj (@qcopy) {
- $obj->color_cmd_tmps(0,0);
+ if ($meth =~ /^($needs_recursion_protection)$/) {
+ for my $obj (@qcopy) {
+ $obj->color_cmd_tmps(0,0);
+ }
}
}
#-> sub CPAN::Shell::recent ;
sub recent {
my($self) = @_;
+ if ($CPAN::META->has_inst("XML::LibXML")) {
+ my $url = $CPAN::Defaultrecent;
+ $CPAN::Frontend->myprint("Going to fetch '$url'\n");
+ unless ($CPAN::META->has_usable("LWP")) {
+ $CPAN::Frontend->mydie("LWP not installed; cannot continue");
+ }
+ CPAN::LWP::UserAgent->config;
+ my $Ua;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ 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 $xml = XML::LibXML->new->parse_string($resp->content);
+ if (0) {
+ my $s = $xml->serialize(2);
+ $s =~ s/\n\s*\n/\n/g;
+ $CPAN::Frontend->myprint($s);
+ return;
+ }
+ my @distros;
+ if ($url =~ /winnipeg/) {
+ my $pubdate = $xml->findvalue("/rss/channel/pubDate");
+ $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
+ for my $eitem ($xml->findnodes("/rss/channel/item")) {
+ my $distro = $eitem->findvalue("enclosure/\@url");
+ $distro =~ s|.*?/authors/id/./../||;
+ my $size = $eitem->findvalue("enclosure/\@length");
+ my $desc = $eitem->findvalue("description");
+\0 $desc =~ s/.+? - //;
+ $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
+ push @distros, $distro;
+ }
+ } elsif ($url =~ /search.*uploads.rdf/) {
+ # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ # xmlns="http://purl.org/rss/1.0/"
+ # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
+ # xmlns:dc="http://purl.org/dc/elements/1.1/"
+ # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
+ # xmlns:admin="http://webns.net/mvcb/"
+
+
+ my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
+ $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
+ my $finish_eitem = 0;
+ local $SIG{INT} = sub { $finish_eitem = 1 };
+ EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
+ my $distro = $eitem->findvalue("\@rdf:about");
+ $distro =~ s|.*~||; # remove up to the tilde before the name
+ $distro =~ s|/$||; # remove trailing slash
+ $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
+ my $author = uc $1 or die "distro[$distro] without author, cannot continue";
+ my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
+ my $i = 0;
+ SUBDIRTEST: while () {
+ last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
+ if (my @ret = $self->globls("$distro*")) {
+ @ret = grep {$_->[2] !~ /meta/} @ret;
+ @ret = grep {length $_->[2]} @ret;
+ if (@ret) {
+ $distro = "$author/$ret[0][2]";
+ last SUBDIRTEST;
+ }
+ }
+ $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
+ }
+
+ next EITEM if $distro =~ m|\*|; # did not find the thing
+ $CPAN::Frontend->myprint("____$desc\n");
+ push @distros, $distro;
+ last EITEM if $finish_eitem;
+ }
+ }
+ return \@distros;
+ } else {
+ # deprecated old version
+ $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
+ }
+}
- CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
- return;
+#-> sub CPAN::Shell::smoke ;
+sub smoke {
+ my($self) = @_;
+ my $distros = $self->recent;
+ DISTRO: for my $distro (@$distros) {
+ $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
+ {
+ my $skip = 0;
+ local $SIG{INT} = sub { $skip = 1 };
+ for (0..9) {
+ $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
+ sleep 1;
+ if ($skip) {
+ $CPAN::Frontend->myprint(" skipped\n");
+ next DISTRO;
+ }
+ }
+ }
+ $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
+ $self->test($distro);
+ }
}
{
cvs_import
dump
force
+ fforce
get
install
look
notest
perldoc
readme
+ reports
test
)) {
*$command = sub { shift->rematein($command, @_); };
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;
- while (!flock $fh, $locktype|LOCK_NB) {
+ my $waitstart;
+ while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
+ $waitstart ||= localtime();
if ($sleep>3) {
- $CPAN::Frontend->mywarn("Waiting for a read lock on '$file'\n");
+ $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 = CPAN->_yaml_loadfile($file);
- if ($locktype == LOCK_SH) {
- } else {
- seek $fh, 0, 0;
- if (@$stats){ # no yaml no write
- truncate $fh, 0;
+ 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();
}
}
+#-> sub CPAN::FTP::_new_stats
sub _new_stats {
my($self,$file) = @_;
my $ret = {
$ret;
}
+#-> sub CPAN::FTP::_add_to_statistics
sub _add_to_statistics {
my($self,$stats) = @_;
- $stats->{thesiteurl} = $ThesiteURL;
- if (CPAN->has_inst("Time::HiRes")) {
- $stats->{end} = Time::HiRes::time();
- } else {
- $stats->{end} = time;
+ 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");
}
- my $fh = FileHandle->new;
- my $fullstats = $self->_ftp_statistics($fh);
- push @{$fullstats->{history}}, $stats;
- my $time = time;
- shift @{$fullstats->{history}}
- while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
- CPAN->_yaml_dumpfile($fh,$fullstats);
}
# 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;
}
}
+#-> sub CPAN::FTP::_get_urllist
sub _get_urllist {
my($self) = @_;
$CPAN::Config->{urllist} ||= [];
return 0 unless defined $ftp;
$ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
$class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
- unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
+ unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
my $msg = $ftp->message;
$CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
return;
}
- unless ( $ftp->cwd($dir) ){
+ unless ( $ftp->cwd($dir) ) {
my $msg = $ftp->message;
$CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
return;
}
$ftp->binary;
$class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
- unless ( $ftp->get($file,$target) ){
+ unless ( $ftp->get($file,$target) ) {
my $msg = $ftp->message;
$CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
return;
my($self,$file,$aslocal,$force) = @_;
$force ||= 0;
Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
- unless defined $aslocal;
+ unless defined $aslocal;
$self->debug("file[$file] aslocal[$aslocal] force[$force]")
- if $CPAN::DEBUG;
+ if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
# Comment by AK on 2000-09-03: Uniq short filenames would be
}
}
- if (-f $aslocal && -r _ && !($force & 1)){
+ if (-f $aslocal && -r _ && !($force & 1)) {
my $size;
if ($size = -s $aslocal) {
$self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
}
}
my($maybe_restore) = 0;
- if (-f $aslocal){
- rename $aslocal, "$aslocal.bak$$";
- $maybe_restore++;
+ if (-f $aslocal) {
+ rename $aslocal, "$aslocal.bak$$";
+ $maybe_restore++;
}
my($aslocal_dir) = File::Basename::dirname($aslocal);
- File::Path::mkpath($aslocal_dir);
- $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
- qq{directory "$aslocal_dir".
- I\'ll continue, but if you encounter problems, they may be due
- to insufficient permissions.\n}) unless -w $aslocal_dir;
-
+ $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
# Inheritance is not easier to manage than a few if/else branches
if ($CPAN::META->has_usable('LWP::UserAgent')) {
- unless ($Ua) {
+ unless ($Ua) {
CPAN::LWP::UserAgent->config;
- eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
+ eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
if ($@) {
$CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
if $CPAN::DEBUG;
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};
}
- }
+ }
}
for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
$ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
my $ccurllist = $self->_get_urllist;
$last = $#$ccurllist;
if ($force & 2) { # local cpans probably out of date, don't reorder
- @reordered = (0..$last);
+ @reordered = (0..$last);
} else {
- @reordered =
- sort {
- (substr($ccurllist->[$b],0,4) eq "file")
- <=>
- (substr($ccurllist->[$a],0,4) eq "file")
- or
- defined($ThesiteURL)
- and
+ @reordered =
+ sort {
+ (substr($ccurllist->[$b],0,4) eq "file")
+ <=>
+ (substr($ccurllist->[$a],0,4) eq "file")
+ or
+ defined($ThesiteURL)
+ and
($ccurllist->[$b] eq $ThesiteURL)
- <=>
+ <=>
($ccurllist->[$a] eq $ThesiteURL)
- } 0..$last;
+ } 0..$last;
}
my(@levels);
$Themethod ||= "";
$self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
+ my @all_levels = (
+ ["dleasy", "file"],
+ ["dleasy"],
+ ["dlhard"],
+ ["dlhardest"],
+ ["dleasy", "http","defaultsites"],
+ ["dlhard", "http","defaultsites"],
+ ["dleasy", "ftp", "defaultsites"],
+ ["dlhard", "ftp", "defaultsites"],
+ ["dlhardest","", "defaultsites"],
+ );
if ($Themethod) {
- @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
+ @levels = grep {$_->[0] eq $Themethod} @all_levels;
+ push @levels, grep {$_->[0] ne $Themethod} @all_levels;
} else {
- @levels = qw/easy hard hardest/;
+ @levels = @all_levels;
}
- @levels = qw/easy/ if $^O eq 'MacOS';
+ @levels = qw/dleasy/ if $^O eq 'MacOS';
my($levelno);
- local $ENV{FTP_PASSIVE} =
+ local $ENV{FTP_PASSIVE} =
exists $CPAN::Config->{ftp_passive} ?
$CPAN::Config->{ftp_passive} : 1;
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 { $ccurllist->[$_] } @host_seq;
- for my $u (@CPAN::Defaultsites) {
- push @urllist, $u unless grep { $_ eq $u } @urllist;
+ my $level_tuple = $levels[$levelno];
+ my($level,$scheme,$sitetag) = @$level_tuple;
+ my $defaultsites = $sitetag && $sitetag eq "defaultsites";
+ my @urllist;
+ if ($defaultsites) {
+ unless (defined $connect_to_internet_ok) {
+ $CPAN::Frontend->myprint(sprintf qq{
+I would like to connect to one of the following sites to get '%s':
+
+%s
+},
+ $file,
+ join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
+ );
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
+ if ($answer =~ /^y/i) {
+ $connect_to_internet_ok = 1;
+ } else {
+ $connect_to_internet_ok = 0;
+ }
+ }
+ if ($connect_to_internet_ok) {
+ @urllist = @CPAN::Defaultsites;
+ } else {
+ @urllist = ();
+ }
+ } else {
+ my @host_seq = $level =~ /dleasy/ ?
+ @reordered : 0..$last; # reordered has file and $Thesiteurl first
+ @urllist = map { $ccurllist->[$_] } @host_seq;
}
$self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
my $aslocal_tempfile = $aslocal . ".tmp" . $$;
unshift @urllist, $recommend;
}
$self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
- $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
- if ($ret) {
+ $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
+ if ($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
# might alter a local mirror
$self->debug("level[$level]") if $CPAN::DEBUG;
last LEVEL;
- } else {
+ } else {
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;
$CPAN::Frontend->mysleep(2);
}
if ($maybe_restore) {
- rename "$aslocal.bak$$", $aslocal;
- $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
- $self->ls($aslocal));
- return $aslocal;
+ rename "$aslocal.bak$$", $aslocal;
+ $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
+ $self->ls($aslocal));
+ return $aslocal;
}
return;
}
+sub mymkpath {
+ my($self, $aslocal_dir) = @_;
+ File::Path::mkpath($aslocal_dir);
+ $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
+ qq{directory "$aslocal_dir".
+ I\'ll continue, but if you encounter problems, they may be due
+ to insufficient permissions.\n}) unless -w $aslocal_dir;
+}
+
+sub hostdlxxx {
+ my $self = shift;
+ my $level = shift;
+ my $scheme = shift;
+ my $h = shift;
+ $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
+ my $method = "host$level";
+ $self->$method($h, @_);
+}
+
sub _set_attempt {
my($self,$stats,$method,$url) = @_;
push @{$stats->{attempts}}, {
}
# package CPAN::FTP;
-sub hosteasy {
+sub hostdleasy {
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:/) {
- my $l;
- if ($CPAN::META->has_inst('URI::URL')) {
- my $u = URI::URL->new($url);
- $l = $u->path;
- } else { # works only on Unix, is poorly constructed, but
- # hopefully better than nothing.
- # RFC 1738 says fileurl BNF is
- # fileurl = "file://" [ host | "localhost" ] "/" fpath
- # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
- # the code
- ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
- $l =~ s|^file:||; # assume they
+ $self->_set_attempt($stats,"dleasy",$ro_url);
+ my $url .= "$ro_url$file";
+ $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
+ if ($url =~ /^file:/) {
+ my $l;
+ if ($CPAN::META->has_inst('URI::URL')) {
+ my $u = URI::URL->new($url);
+ $l = $u->path;
+ } else { # works only on Unix, is poorly constructed, but
+ # hopefully better than nothing.
+ # RFC 1738 says fileurl BNF is
+ # fileurl = "file://" [ host | "localhost" ] "/" fpath
+ # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
+ # the code
+ ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
+ $l =~ s|^file:||; # assume they
# meant
# file://localhost
- $l =~ s|^/||s
+ $l =~ s|^/||s
if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
- }
+ }
$self->debug("local file[$l]") if $CPAN::DEBUG;
- if ( -f $l && -r _) {
- $ThesiteURL = $ro_url;
- return $l;
- }
+ if ( -f $l && -r _) {
+ $ThesiteURL = $ro_url;
+ return $l;
+ }
if ($l =~ /(.+)\.gz$/) {
my $ungz = $1;
if ( -f $ungz && -r _) {
return $ungz;
}
}
- # Maybe mirror has compressed it?
- if (-f "$l.gz") {
- $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
- 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;
+ # Maybe mirror has compressed it?
+ if (-f "$l.gz") {
+ $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
+ eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
+ if ( -f $aslocal) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ }
+ $CPAN::Frontend->mywarn("Could not find '$l'\n");
+ }
+ $self->debug("it was not a file URL") if $CPAN::DEBUG;
if ($CPAN::META->has_usable('LWP')) {
$CPAN::Frontend->myprint("Fetching with LWP:
$url
}
} 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
+ 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;
- $CPAN::Frontend->myprint("Fetching with Net::FTP:
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ if ($CPAN::META->has_usable('Net::FTP')) {
+ $dir =~ s|/+|/|g;
+ $CPAN::Frontend->myprint("Fetching with Net::FTP:
$url
");
- $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
- "aslocal[$aslocal]") if $CPAN::DEBUG;
- if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
- $ThesiteURL = $ro_url;
- return $aslocal;
- }
- if ($aslocal !~ /\.gz(?!\n)\Z/) {
- my $gz = "$aslocal.gz";
- $CPAN::Frontend->myprint("Fetching with Net::FTP
+ $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
+ "aslocal[$aslocal]") if $CPAN::DEBUG;
+ if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ if ($aslocal !~ /\.gz(?!\n)\Z/) {
+ my $gz = "$aslocal.gz";
+ $CPAN::Frontend->myprint("Fetching with Net::FTP
$url.gz
");
if (CPAN::FTP->ftp_get($host,
$dir,
"$getfile.gz",
$gz) &&
- eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
- ){
- $ThesiteURL = $ro_url;
- return $aslocal;
- }
- }
- # next HOSTEASY;
- } else {
+ 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);
+ my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
return $ret if $ret;
}
return if $CPAN::Signal;
}
# package CPAN::FTP;
-sub hosthard {
- 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
- # gave us a socksified (or other) ftp program...
-
- my($ro_url);
- my($devnull) = $CPAN::Config->{devnull} || "";
- # < /dev/null ";
- my($aslocal_dir) = File::Basename::dirname($aslocal);
- File::Path::mkpath($aslocal_dir);
+sub hostdlhard {
+ 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
+ # gave us a socksified (or other) ftp program...
+
+ my($ro_url);
+ my($devnull) = $CPAN::Config->{devnull} || "";
+ # < /dev/null ";
+ 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);
-
- # Courtesy Mark Conty mark_conty@cargill.com change from
- # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
- # to
- if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
- # proto not yet used
- ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
- } else {
- next HOSTHARD; # who said, we could ftp anything except ftp?
- }
+ $self->_set_attempt($stats,"dlhard",$ro_url);
+ my $url = "$ro_url$file";
+ my($proto,$host,$dir,$getfile);
+
+ # Courtesy Mark Conty mark_conty@cargill.com change from
+ # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # to
+ if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
+ # proto not yet used
+ ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
+ } else {
+ next HOSTHARD; # who said, we could ftp anything except ftp?
+ }
next HOSTHARD if $proto eq "file"; # file URLs would have had
# success above. Likely a bogus URL
- $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
+ $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
- # Try the most capable first and leave ncftp* for last as it only
+ # Try the most capable first and leave ncftp* for last as it only
# does FTP.
DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
- my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
- next unless defined $funkyftp;
- next if $funkyftp =~ /^\s*$/;
-
- my($asl_ungz, $asl_gz);
- ($asl_ungz = $aslocal) =~ s/\.gz//;
- $asl_gz = "$asl_ungz.gz";
-
- my($src_switch) = "";
- my($chdir) = "";
- my($stdout_redir) = " > $asl_ungz";
- if ($f eq "lynx"){
- $src_switch = " -source";
- } elsif ($f eq "ncftp"){
- $src_switch = " -c";
- } elsif ($f eq "wget"){
- $src_switch = " -O $asl_ungz";
- $stdout_redir = "";
- } elsif ($f eq 'curl'){
- $src_switch = ' -L -f -s -S --netrc-optional';
- }
-
- if ($f eq "ncftpget"){
- $chdir = "cd $aslocal_dir && ";
- $stdout_redir = "";
- }
- $CPAN::Frontend->myprint(
- qq[
+ my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
+ next unless defined $funkyftp;
+ next if $funkyftp =~ /^\s*$/;
+
+ my($asl_ungz, $asl_gz);
+ ($asl_ungz = $aslocal) =~ s/\.gz//;
+ $asl_gz = "$asl_ungz.gz";
+
+ my($src_switch) = "";
+ my($chdir) = "";
+ my($stdout_redir) = " > $asl_ungz";
+ if ($f eq "lynx") {
+ $src_switch = " -source";
+ } elsif ($f eq "ncftp") {
+ $src_switch = " -c";
+ } elsif ($f eq "wget") {
+ $src_switch = " -O $asl_ungz";
+ $stdout_redir = "";
+ } elsif ($f eq 'curl') {
+ $src_switch = ' -L -f -s -S --netrc-optional';
+ }
+
+ if ($f eq "ncftpget") {
+ $chdir = "cd $aslocal_dir && ";
+ $stdout_redir = "";
+ }
+ $CPAN::Frontend->myprint(
+ qq[
Trying with "$funkyftp$src_switch" to get
$url
]);
- my($system) =
- "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
- $self->debug("system[$system]") if $CPAN::DEBUG;
- my($wstatus) = system($system);
- 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]|Error [45])/si) {
- $CPAN::Frontend->mywarn(qq{
-No success, the file that lynx has has downloaded looks like an error message:
+ my($system) =
+ "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
+ $self->debug("system[$system]") if $CPAN::DEBUG;
+ my($wstatus) = system($system);
+ 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]|Error [45])/si) {
+ $CPAN::Frontend->mywarn(qq{
+No success, the file that lynx has downloaded looks like an error message:
$content
});
- $CPAN::Frontend->mysleep(1);
- next DLPRG;
- }
- } else {
- $CPAN::Frontend->myprint(qq{
-No success, the file that lynx has has downloaded is an empty file.
-});
- next DLPRG;
- }
- }
- if ($wstatus == 0) {
- if (-s $aslocal) {
- # Looks good
- } elsif ($asl_ungz ne $aslocal) {
- # test gzip integrity
- if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
- # e.g. foo.tar is gzipped --> foo.tar.gz
- rename $asl_ungz, $aslocal;
- } else {
- eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
- }
- }
- $ThesiteURL = $ro_url;
- return $aslocal;
- } elsif ($url !~ /\.gz(?!\n)\Z/) {
- unlink $asl_ungz if
- -f $asl_ungz && -s _ == 0;
- my $gz = "$aslocal.gz";
- my $gzurl = "$url.gz";
- $CPAN::Frontend->myprint(
- qq[
-Trying with "$funkyftp$src_switch" to get
- $url.gz
-]);
- my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
- $self->debug("system[$system]") if $CPAN::DEBUG;
- my($wstatus);
- if (($wstatus = system($system)) == 0
- &&
- -s $asl_gz
- ) {
- # test gzip integrity
- my $ct = eval{CPAN::Tarzip->new($asl_gz)};
- if ($ct && $ct->gtest) {
- $ct->gunzip($aslocal);
+ $CPAN::Frontend->mysleep(1);
+ next DLPRG;
+ }
} else {
- # somebody uncompressed file for us?
- rename $asl_ungz, $aslocal;
+ $CPAN::Frontend->myprint(qq{
+No success, the file that lynx has downloaded is an empty file.
+});
+ next DLPRG;
+ }
+ }
+ if ($wstatus == 0) {
+ if (-s $aslocal) {
+ # Looks good
+ } elsif ($asl_ungz ne $aslocal) {
+ # test gzip integrity
+ if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
+ # e.g. foo.tar is gzipped --> foo.tar.gz
+ rename $asl_ungz, $aslocal;
+ } else {
+ eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
+ }
}
$ThesiteURL = $ro_url;
return $aslocal;
- } else {
- unlink $asl_gz if -f $asl_gz;
- }
- } else {
- my $estatus = $wstatus >> 8;
- my $size = -f $aslocal ?
- ", left\n$aslocal with size ".-s _ :
- "\nWarning: expected file [$aslocal] doesn't exist";
- $CPAN::Frontend->myprint(qq{
-System call "$system"
-returned status $estatus (wstat $wstatus)$size
-});
- }
- return if $CPAN::Signal;
- } # transfer programs
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
+ unlink $asl_ungz if
+ -f $asl_ungz && -s _ == 0;
+ my $gz = "$aslocal.gz";
+ my $gzurl = "$url.gz";
+ $CPAN::Frontend->myprint(
+ qq[
+ Trying with "$funkyftp$src_switch" to get
+ $url.gz
+ ]);
+ my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
+ $self->debug("system[$system]") if $CPAN::DEBUG;
+ my($wstatus);
+ if (($wstatus = system($system)) == 0
+ &&
+ -s $asl_gz
+ ) {
+ # test gzip integrity
+ 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;
+ }
+ } else {
+ my $estatus = $wstatus >> 8;
+ my $size = -f $aslocal ?
+ ", left\n$aslocal with size ".-s _ :
+ "\nWarning: expected file [$aslocal] doesn't exist";
+ $CPAN::Frontend->myprint(qq{
+ System call "$system"
+ returned status $estatus (wstat $wstatus)$size
+ });
+ }
+ return if $CPAN::Signal;
+ } # transfer programs
} # host
}
# package CPAN::FTP;
-sub hosthardest {
+sub hostdlhardest {
my($self,$host_seq,$file,$aslocal,$stats) = @_;
+ return unless @$host_seq;
my($ro_url);
my($aslocal_dir) = File::Basename::dirname($aslocal);
File::Path::mkpath($aslocal_dir);
});
$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://(.*?)/(.*)/(.*)|) {
- next;
- }
- my($host,$dir,$getfile) = ($1,$2,$3);
- my $timestamp = 0;
- my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
- $ctime,$blksize,$blocks) = stat($aslocal);
- $timestamp = $mtime ||= 0;
- my($netrc) = CPAN::FTP::netrc->new;
- my($netrcfile) = $netrc->netrc;
- my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
- my $targetfile = File::Basename::basename($aslocal);
- my(@dialog);
- push(
- @dialog,
- "lcd $aslocal_dir",
- "cd /",
- map("cd $_", split /\//, $dir), # RFC 1738
- "bin",
- "get $getfile $targetfile",
- "quit"
- );
- if (! $netrcfile) {
- CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
- } elsif ($netrc->hasdefault || $netrc->contains($host)) {
- CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
- $netrc->hasdefault,
- $netrc->contains($host))) if $CPAN::DEBUG;
- if ($netrc->protected) {
+ $self->_set_attempt($stats,"dlhardest",$ro_url);
+ my $url = "$ro_url$file";
+ $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
+ unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ next;
+ }
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ my $timestamp = 0;
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
+ $ctime,$blksize,$blocks) = stat($aslocal);
+ $timestamp = $mtime ||= 0;
+ my($netrc) = CPAN::FTP::netrc->new;
+ my($netrcfile) = $netrc->netrc;
+ my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
+ my $targetfile = File::Basename::basename($aslocal);
+ my(@dialog);
+ push(
+ @dialog,
+ "lcd $aslocal_dir",
+ "cd /",
+ map("cd $_", split /\//, $dir), # RFC 1738
+ "bin",
+ "get $getfile $targetfile",
+ "quit"
+ );
+ if (! $netrcfile) {
+ CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
+ } elsif ($netrc->hasdefault || $netrc->contains($host)) {
+ CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
+ $netrc->hasdefault,
+ $netrc->contains($host))) if $CPAN::DEBUG;
+ if ($netrc->protected) {
my $dialog = join "", map { " $_\n" } @dialog;
my $netrc_explain;
if ($netrc->contains($host)) {
$netrc_explain = "Relying that your default .netrc entry ".
"manages the login";
}
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->myprint(qq{
Trying with external ftp to get
$url
$netrc_explain
Going to send the dialog
$dialog
}
- );
- $self->talk_ftp("$ftpbin$verbose $host",
- @dialog);
- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
- $mtime ||= 0;
- if ($mtime > $timestamp) {
- $CPAN::Frontend->myprint("GOT $aslocal\n");
- $ThesiteURL = $ro_url;
- return $aslocal;
- } else {
- $CPAN::Frontend->myprint("Hmm... Still failed!\n");
- }
- return if $CPAN::Signal;
- } else {
- $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
- qq{correctly protected.\n});
- }
- } else {
- $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
+ );
+ $self->talk_ftp("$ftpbin$verbose $host",
+ @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Hmm... Still failed!\n");
+ }
+ return if $CPAN::Signal;
+ } else {
+ $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
+ qq{correctly protected.\n});
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
nor does it have a default entry\n");
- }
-
- # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
- # then and login manually to host, using e-mail as
- # password.
- $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
- unshift(
- @dialog,
- "open $host",
- "user anonymous $Config::Config{'cf_email'}"
- );
+ }
+
+ # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
+ # then and login manually to host, using e-mail as
+ # password.
+ $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
+ unshift(
+ @dialog,
+ "open $host",
+ "user anonymous $Config::Config{'cf_email'}"
+ );
my $dialog = join "", map { " $_\n" } @dialog;
$CPAN::Frontend->myprint(qq{
Trying with external ftp to get
Going to send the dialog
$dialog
}
- );
- $self->talk_ftp("$ftpbin$verbose -n", @dialog);
- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
- $mtime ||= 0;
- if ($mtime > $timestamp) {
- $CPAN::Frontend->myprint("GOT $aslocal\n");
- $ThesiteURL = $ro_url;
- return $aslocal;
- } else {
- $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
- }
+ );
+ $self->talk_ftp("$ftpbin$verbose -n", @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
+ }
return if $CPAN::Signal;
- $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
- $CPAN::Frontend->mysleep(2);
+ $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
+ $CPAN::Frontend->mysleep(2);
} # host
}
my $fh = FileHandle->new;
$fh->open("|$command") or die "Couldn't open ftp: $!";
foreach (@dialog) { $fh->print("$_\n") }
- $fh->close; # Wait for process to complete
+ $fh->close; # Wait for process to complete
my $wstatus = $?;
my $estatus = $wstatus >> 8;
$CPAN::Frontend->myprint(qq{
my $pname = $name;
if ($blocks) {
- $blocks = int(($blocks + 1) / 2);
+ $blocks = int(($blocks + 1) / 2);
}
else {
- $blocks = int(($sizemm + 1023) / 1024);
+ $blocks = int(($sizemm + 1023) / 1024);
}
if (-f _) { $perms = '-'; }
my($timeyear);
my($moname) = $moname[$mon];
if (-M _ > 365.25 / 2) {
- $timeyear = $year + 1900;
+ $timeyear = $year + 1900;
}
else {
- $timeyear = sprintf("%02d:%02d", $hour, $min);
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
}
sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
- $ino,
- $blocks,
- $perms,
- $nlink,
- $user,
- $group,
- $sizemm,
- $moname,
- $mday,
- $timeyear,
- $pname;
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $sizemm,
+ $moname,
+ $mday,
+ $timeyear,
+ $pname;
}
package CPAN::FTP::netrc;
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
- = stat($file);
+ = stat($file);
$mode ||= 0;
my $protected = 0;
$hasdefault = 0;
$fh = FileHandle->new or die "Could not create a filehandle";
- if($fh->open($file)){
- $protected = ($mode & 077) == 0;
- local($/) = "";
+ if($fh->open($file)) {
+ $protected = ($mode & 077) == 0;
+ local($/) = "";
NETRC: while (<$fh>) {
- my(@tokens) = split " ", $_;
- TOKEN: while (@tokens) {
- my($t) = shift @tokens;
- if ($t eq "default"){
- $hasdefault++;
- last NETRC;
- }
- last TOKEN if $t eq "macdef";
- if ($t eq "machine") {
- push @machines, shift @tokens;
- }
- }
- }
+ my(@tokens) = split " ", $_;
+ TOKEN: while (@tokens) {
+ my($t) = shift @tokens;
+ if ($t eq "default") {
+ $hasdefault++;
+ last NETRC;
+ }
+ last TOKEN if $t eq "macdef";
+ if ($t eq "machine") {
+ push @machines, shift @tokens;
+ }
+ }
+ }
} else {
- $file = $hasdefault = $protected = "";
+ $file = $hasdefault = $protected = "";
}
bless {
- 'mach' => [@machines],
- 'netrc' => $file,
- 'hasdefault' => $hasdefault,
- 'protected' => $protected,
- }, $class;
+ 'mach' => [@machines],
+ 'netrc' => $file,
+ 'hasdefault' => $hasdefault,
+ 'protected' => $protected,
+ }, $class;
}
# CPAN::FTP::netrc::hasdefault;
sub contains {
my($self,$mach) = @_;
for ( @{$self->{'mach'}} ) {
- return 1 if $_ eq $mach;
+ return 1 if $_ eq $mach;
}
return 0;
}
return () unless @perlret;
my($newtext) = $text;
for (my $i = length($text)+1;;$i++) {
- last unless length($perlret[0]) && length($perlret[0]) >= $i;
- my $try = substr($perlret[0],0,$i);
- my @tries = grep {substr($_,0,$i) eq $try} @perlret;
- # warn "try[$try]tries[@tries]";
- if (@tries == @perlret) {
- $newtext = $try;
- } else {
- last;
- }
+ last unless length($perlret[0]) && length($perlret[0]) >= $i;
+ my $try = substr($perlret[0],0,$i);
+ my @tries = grep {substr($_,0,$i) eq $try} @perlret;
+ # warn "try[$try]tries[@tries]";
+ if (@tries == @perlret) {
+ $newtext = $try;
+ } else {
+ last;
+ }
}
($newtext,@perlret);
}
$pos ||= 0;
CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
$line =~ s/^\s*//;
- if ($line =~ s/^(force\s*)//) {
- $pos -= length($1);
+ if ($line =~ s/^((?:notest|f?force)\s*)//) {
+ $pos -= length($1);
}
my @return;
- if ($pos == 0) {
- @return = grep /^$word/, @CPAN::Complete::COMMANDS;
+ if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
+ @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
} elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
- @return = ();
+ @return = ();
} elsif ($line =~ /^(a|ls)\s/) {
- @return = cplx('CPAN::Author',uc($word));
+ @return = cplx('CPAN::Author',uc($word));
} elsif ($line =~ /^b\s/) {
CPAN::Shell->local_bundles;
- @return = cplx('CPAN::Bundle',$word);
+ @return = cplx('CPAN::Bundle',$word);
} elsif ($line =~ /^d\s/) {
- @return = cplx('CPAN::Distribution',$word);
+ @return = cplx('CPAN::Distribution',$word);
} elsif ($line =~ m/^(
[mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
)\s/x ) {
if ($word =~ /^Bundle::/) {
CPAN::Shell->local_bundles;
}
- @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
+ @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
} elsif ($line =~ /^i\s/) {
- @return = cpl_any($word);
+ @return = cpl_any($word);
} elsif ($line =~ /^reload\s/) {
- @return = cpl_reload($word,$line,$pos);
+ @return = cpl_reload($word,$line,$pos);
} elsif ($line =~ /^o\s/) {
- @return = cpl_option($word,$line,$pos);
+ @return = cpl_option($word,$line,$pos);
} elsif ($line =~ m/^\S+\s/ ) {
# fallback for future commands and what we have forgotten above
- @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
+ @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
} else {
- @return = ();
+ @return = ();
}
return @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 cpl_any {
my($word) = shift;
return (
- cplx('CPAN::Author',$word),
- cplx('CPAN::Bundle',$word),
- cplx('CPAN::Distribution',$word),
- cplx('CPAN::Module',$word),
- );
+ cplx('CPAN::Author',$word),
+ cplx('CPAN::Bundle',$word),
+ cplx('CPAN::Distribution',$word),
+ cplx('CPAN::Module',$word),
+ );
}
#-> sub CPAN::Complete::cpl_reload ;
return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
if (0) {
} elsif ($words[1] eq 'index') {
- return ();
+ return ();
} elsif ($words[1] eq 'conf') {
- return CPAN::HandleConfig::cpl(@_);
+ return CPAN::HandleConfig::cpl(@_);
} elsif ($words[1] eq 'debug') {
- return sort grep /^\Q$word\E/i,
+ return sort grep /^\Q$word\E/i,
sort keys %CPAN::DEBUG, 'all';
}
}
# XXX check if a newer one is available. (We currently read it
# from time to time)
for ($CPAN::Config->{index_expire}) {
- $_ = 0.001 unless $_ && $_ > 0.001;
+ $_ = 0.001 unless $_ && $_ > 0.001;
}
unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
# debug here when CPAN doesn't seem to read the Metadata
$LAST_TIME = 0; # No warning necessary
}
if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
- and ! $force){
+ and ! $force) {
# called too often
# CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
} elsif (0) {
if ($CPAN::Config->{build_dir_reuse}) {
$self->reanimate_build_dir;
}
- if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
+ if (CPAN::_sqlite_running) {
$CPAN::SQLite->reload(time => $time, force => $force)
if not $LAST_TIME;
}
sort { $b->[1] <=> $a->[1] }
map { [ $_, -M File::Spec->catfile($d,$_) ] }
grep {/\.yml$/} readdir $dh;
- DISTRO: for $dirent (@candidates) {
- my $c = CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))->[0];
+ 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}}) {
#we tried to restore only if element already
#exists; but then we do not work with metadata
#turned off.
- $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} = $c->{distribution};
+ my $do
+ = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
+ = $c->{distribution};
+ for my $skipper (qw(
+ badtestcnt
+ configure_requires_later
+ configure_requires_later_for
+ force_update
+ later
+ later_for
+ notest
+ should_report
+ sponsored_mods
+ )) {
+ 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++;
}
}
$CPAN::Frontend->myprint(sprintf(
- "DONE\nFound %s old builds, restored the state of %s\n",
+ "DONE\nFound %s old build%s, restored the state of %s\n",
@candidates ? sprintf("%d",scalar @candidates) : "no",
+ @candidates==1 ? "" : "s",
$restored || "none",
));
}
# we rely on Config XXX
$localname ||= $wanted;
my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
- $localname);
+ $localname);
if (
- -f $abs_wanted &&
- -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
- !($force & 1)
+ -f $abs_wanted &&
+ -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
+ !($force & 1)
) {
- my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
- $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
- qq{day$s. I\'ll use that.});
- return $abs_wanted;
+ my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
+ $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
+ qq{day$s. I\'ll use that.});
+ return $abs_wanted;
} else {
- $force |= 1; # means we're quite serious about it.
+ $force |= 1; # means we're quite serious about it.
}
return CPAN::FTP->localize($wanted,$abs_wanted,$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;
my $i = 0;
my $painted = 0;
foreach (@lines) {
- my($userid,$fullname,$email) =
- m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
+ my($userid,$fullname,$email) =
+ m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
$fullname ||= $email;
- if ($userid && $fullname && $email){
+ if ($userid && $fullname && $email) {
my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
$userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
} else {
$CPAN::Frontend->myprint(".");
$painted++;
}
- return if $CPAN::Signal;
+ 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 $_;
# read header
my($line_count,$last_updated);
while (@lines) {
- my $shift = shift(@lines);
- last if $shift =~ /^\s*$/;
- $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
+ my $shift = shift(@lines);
+ last if $shift =~ /^\s*$/;
+ $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
$shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
}
CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
if (not defined $line_count) {
- $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
- $CPAN::Frontend->mysleep(5);
+ $CPAN::Frontend->mysleep(5);
} elsif ($line_count != scalar @lines) {
- $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
+ $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
contains a Line-Count header of %d but I see %d lines there. Please
check the validity of the index file by comparing it to more than one
CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
}
if (not defined $last_updated) {
- $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
- $CPAN::Frontend->mysleep(5);
+ $CPAN::Frontend->mysleep(5);
} else {
- $CPAN::Frontend
+ $CPAN::Frontend
->myprint(sprintf qq{ Database was generated on %s\n},
$last_updated);
$DATE_OF_02 = $last_updated;
# before 1.56 we split into 3 and discarded the rest. From
# 1.57 we assign remaining text to $comment thus allowing to
# influence isa_perl
- my($mod,$version,$dist,$comment) = split " ", $_, 4;
- my($bundle,$id,$userid);
-
- if ($mod eq 'CPAN' &&
- ! (
- CPAN::Queue->exists('Bundle::CPAN') ||
- CPAN::Queue->exists('CPAN')
- )
- ) {
+ my($mod,$version,$dist,$comment) = split " ", $_, 4;
+ my($bundle,$id,$userid);
+
+ if ($mod eq 'CPAN' &&
+ ! (
+ CPAN::Queue->exists('Bundle::CPAN') ||
+ CPAN::Queue->exists('CPAN')
+ )
+ ) {
local($^W)= 0;
- if ($version > $CPAN::VERSION){
+ if ($version > $CPAN::VERSION) {
$CPAN::Frontend->mywarn(qq{
New CPAN.pm version (v$version) available.
[Currently running version is v$CPAN::VERSION]
}); #});
$CPAN::Frontend->mysleep(2);
- $CPAN::Frontend->myprint(qq{\n});
- }
- last if $CPAN::Signal;
- } elsif ($mod =~ /^Bundle::(.*)/) {
- $bundle = $1;
- }
-
- if ($bundle){
- $id = $CPAN::META->instance('CPAN::Bundle',$mod);
- # Let's make it a module too, because bundles have so much
- # in common with modules.
+ $CPAN::Frontend->myprint(qq{\n});
+ }
+ last if $CPAN::Signal;
+ } elsif ($mod =~ /^Bundle::(.*)/) {
+ $bundle = $1;
+ }
+
+ if ($bundle) {
+ $id = $CPAN::META->instance('CPAN::Bundle',$mod);
+ # Let's make it a module too, because bundles have so much
+ # in common with modules.
# Changed in 1.57_63: seems like memory bloat now without
# any value, so commented out
- # $CPAN::META->instance('CPAN::Module',$mod);
+ # $CPAN::META->instance('CPAN::Module',$mod);
- } else {
+ } else {
- # instantiate a module object
- $id = $CPAN::META->instance('CPAN::Module',$mod);
+ # instantiate a module object
+ $id = $CPAN::META->instance('CPAN::Module',$mod);
- }
+ }
# Although CPAN prohibits same name with different version the
# indexer may have changed the version for the same distro
# since the last time ("Force Reindexing" feature)
- if ($id->cpan_file ne $dist
+ if ($id->cpan_file ne $dist
||
$id->cpan_version ne $version
- ){
- $userid = $id->userid || $self->userid($dist);
- $id->set(
- 'CPAN_USERID' => $userid,
- 'CPAN_VERSION' => $version,
- 'CPAN_FILE' => $dist,
- );
- }
-
- # instantiate a distribution object
- if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
- # we do not need CONTAINSMODS unless we do something with
- # this dist, so we better produce it on demand.
-
- ## my $obj = $CPAN::META->instance(
- ## 'CPAN::Distribution' => $dist
- ## );
- ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
- } else {
- $CPAN::META->instance(
- 'CPAN::Distribution' => $dist
- )->set(
- 'CPAN_USERID' => $userid,
- 'CPAN_COMMENT' => $comment,
- );
- }
+ ) {
+ $userid = $id->userid || $self->userid($dist);
+ $id->set(
+ 'CPAN_USERID' => $userid,
+ 'CPAN_VERSION' => $version,
+ 'CPAN_FILE' => $dist,
+ );
+ }
+
+ # instantiate a distribution object
+ if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
+ # we do not need CONTAINSMODS unless we do something with
+ # this dist, so we better produce it on demand.
+
+ ## my $obj = $CPAN::META->instance(
+ ## 'CPAN::Distribution' => $dist
+ ## );
+ ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
+ } else {
+ $CPAN::META->instance(
+ 'CPAN::Distribution' => $dist
+ )->set(
+ 'CPAN_USERID' => $userid,
+ 'CPAN_COMMENT' => $comment,
+ );
+ }
if ($secondtime) {
for my $name ($mod,$dist) {
# $self->debug("exists name[$name]") if $CPAN::DEBUG;
$CPAN::Frontend->myprint(".");
$painted++;
}
- return if $CPAN::Signal;
+ return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
if ($secondtime) {
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 $_;
my @eval2 = split /\012/, $slurp;
while (@eval2) {
- my $shift = shift(@eval2);
- if ($shift =~ /^Date:\s+(.*)/){
- if ($DATE_OF_03 eq $1){
+ my $shift = shift(@eval2);
+ if ($shift =~ /^Date:\s+(.*)/) {
+ if ($DATE_OF_03 eq $1) {
$CPAN::Frontend->myprint("Unchanged.\n");
return;
}
- ($DATE_OF_03) = $1;
- }
- last if $shift =~ /^\s*$/;
+ ($DATE_OF_03) = $1;
+ }
+ last if $shift =~ /^\s*$/;
}
push @eval2, q{CPAN::Modulelist->data;};
local($^W) = 0;
my $painted = 0;
CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
for (keys %$ret) {
- my $obj = $CPAN::META->instance("CPAN::Module",$_);
+ my $obj = $CPAN::META->instance("CPAN::Module",$_);
delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
- $obj->set(%{$ret->{$_}});
+ $obj->set(%{$ret->{$_}});
$i++;
while (($painted/76) < ($i/$until)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
- return if $CPAN::Signal;
+ 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
- CPAN::Distribution)) {
- $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
+ CPAN::Distribution)) {
+ $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
}
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
$cache->{last_time} = $LAST_TIME;
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;
my $cache;
eval { $cache = Storable::retrieve($metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
- if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
+ if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
$LAST_TIME = 0;
return;
}
my $clcnt = 0;
my $idcnt = 0;
while(my($class,$v) = each %$cache) {
- next unless $class =~ /^CPAN::/;
- $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
+ next unless $class =~ /^CPAN::/;
+ $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
while (my($id,$ro) = each %$v) {
$CPAN::META->{readwrite}{$class}{$id} ||=
$class->new(ID=>$id, RO=>$ro);
$LAST_TIME = $cache->{last_time};
$DATE_OF_02 = $cache->{DATE_OF_02};
$CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
- if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
+ if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
return;
}
if (substr($self->{ID},-1,1) eq ".") { # directory
$ro = +{};
} else {
- $CPAN::Frontend->mydie("Unknown object $self->{ID}");
+ $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
}
}
for (sort keys %$ro) {
- # next if m/^(ID|RO)$/;
- my $extra = "";
- if ($_ eq "CPAN_USERID") {
+ # next if m/^(ID|RO)$/;
+ my $extra = "";
+ if ($_ eq "CPAN_USERID") {
$extra .= " (";
$extra .= $self->fullname;
my $email; # old perls!
push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
}
KEY: for (sort keys %$self) {
- next if m/^(ID|RO)$/;
+ 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") {
+ 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->{$_}});
} else {
$value = $self->{$_};
}
- push @m, sprintf(
- " %-12s %s\n",
- $_,
- $value,
- );
- } else {
- push @m, sprintf " %-12s %s\n", $_, $self->{$_};
- }
+ push @m, sprintf(
+ " %-12s %s\n",
+ $_,
+ $value,
+ );
+ } else {
+ push @m, sprintf " %-12s %s\n", $_, $self->{$_};
+ }
}
join "", @m, "\n";
}
#-> sub CPAN::InfoObj::dump ;
sub dump {
- my($self, $what) = @_;
- unless ($CPAN::META->has_inst("Data::Dumper")) {
- $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
- }
- local $Data::Dumper::Sortkeys;
- $Data::Dumper::Sortkeys = 1;
- my $out = Data::Dumper::Dumper($what ? eval $what : $self);
- if (length $out > 100000) {
- my $fh_pager = FileHandle->new;
- local($SIG{PIPE}) = "IGNORE";
- my $pager = $CPAN::Config->{'pager'} || "cat";
- $fh_pager->open("|$pager")
- or die "Could not open pager $pager\: $!";
- $fh_pager->print($out);
- close $fh_pager;
- } else {
- $CPAN::Frontend->myprint($out);
- }
+ my($self, $what) = @_;
+ unless ($CPAN::META->has_inst("Data::Dumper")) {
+ $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
+ }
+ local $Data::Dumper::Sortkeys;
+ $Data::Dumper::Sortkeys = 1;
+ my $out = Data::Dumper::Dumper($what ? eval $what : $self);
+ if (length $out > 100000) {
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ my $pager = $CPAN::Config->{'pager'} || "cat";
+ $fh_pager->open("|$pager")
+ or die "Could not open pager $pager\: $!";
+ $fh_pager->print($out);
+ close $fh_pager;
+ } else {
+ $CPAN::Frontend->myprint($out);
+ }
}
package CPAN::Author;
$CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
}
}
- $CPAN::Frontend->myprint(join "", map {
- sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
- } sort { $a->[2] cmp $b->[2] } @dl);
+ unless ($silent >= 2) {
+ $CPAN::Frontend->myprint(join "", map {
+ sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
+ } sort { $a->[2] cmp $b->[2] } @dl);
+ }
@dl;
}
my $may_ftp = shift;
my $lc_want =
- File::Spec->catfile($CPAN::Config->{keep_source_where},
- "authors", "id", @$chksumfile);
+ File::Spec->catfile($CPAN::Config->{keep_source_where},
+ "authors", "id", @$chksumfile);
my $fh;
# though.)
$fh = FileHandle->new;
if (open($fh, $lc_want)) {
- my $line = <$fh>; close $fh;
- unlink($lc_want) unless $line =~ /PGP/;
+ my $line = <$fh>; close $fh;
+ unlink($lc_want) unless $line =~ /PGP/;
}
local($") = "/";
# adapted from CPAN::Distribution::CHECKSUM_check_file ;
$fh = FileHandle->new;
my($cksum);
- if (open $fh, $lc_file){
- local($/);
- my $eval = <$fh>;
- $eval =~ s/\015?\012/\n/g;
- close $fh;
- my($comp) = Safe->new();
- $cksum = $comp->reval($eval);
- if ($@) {
- rename $lc_file, "$lc_file.bad";
- Carp::confess($@) if $@;
- }
+ if (open $fh, $lc_file) {
+ local($/);
+ my $eval = <$fh>;
+ $eval =~ s/\015?\012/\n/g;
+ close $fh;
+ my($comp) = Safe->new();
+ $cksum = $comp->reval($eval);
+ if ($@) {
+ rename $lc_file, "$lc_file.bad";
+ Carp::confess($@) if $@;
+ }
} elsif ($may_ftp) {
- Carp::carp "Could not open '$lc_file' for reading.";
+ Carp::carp "Could not open '$lc_file' for reading.";
} else {
# Maybe should warn: "You may want to set show_upload_date to a true value"
- return;
+ return;
}
my(@result,$f);
for $f (sort keys %$cksum) {
@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};
+ for my $delayer (
+ "configure_requires_later",
+ "configure_requires_later_for",
+ "later",
+ "later_for",
+ ) {
+ delete $self->{$delayer};
+ }
+}
+
+#-> 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;
my($local_file);
my($local_wanted) =
File::Spec->catfile(
- $CPAN::Config->{keep_source_where},
- "authors",
- "id",
- split(/\//,$norm)
- );
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$norm)
+ );
$self->debug("Doing localize") if $CPAN::DEBUG;
unless ($local_file =
CPAN::FTP->localize("authors/id/$norm",
substr($id,5);
}
-# mark as dirty/clean
-#-> sub CPAN::Distribution::color_cmd_tmps ;
-sub color_cmd_tmps {
- my($self) = shift;
+#-> sub CPAN::Distribution::base_id
+sub base_id {
+ my $self = shift;
+ my $id = $self->pretty_id();
+ my $base_id = File::Basename::basename($id);
+ $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
+ return $base_id;
+}
+
+# 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;
my($depth) = shift || 0;
my($color) = shift || 0;
my($ancestors) = 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;
#-> sub CPAN::Distribution::as_string ;
sub as_string {
- my $self = shift;
- $self->containsmods;
- $self->upload_date;
- $self->SUPER::as_string(@_);
+ my $self = shift;
+ $self->containsmods;
+ $self->upload_date;
+ $self->SUPER::as_string(@_);
}
#-> sub CPAN::Distribution::containsmods ;
sub containsmods {
- my $self = shift;
- return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
- my $dist_id = $self->{ID};
- for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
- my $mod_file = $mod->cpan_file or next;
- my $mod_id = $mod->{ID} or next;
- # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
- # sleep 1;
- $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
- }
- keys %{$self->{CONTAINSMODS}};
+ my $self = shift;
+ return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
+ my $dist_id = $self->{ID};
+ for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
+ my $mod_file = $mod->cpan_file or next;
+ 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}||={}};
}
#-> sub CPAN::Distribution::upload_date ;
sub upload_date {
- my $self = shift;
- return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
- my(@local_wanted) = split(/\//,$self->id);
- my $filename = pop @local_wanted;
- push @local_wanted, "CHECKSUMS";
- my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
- return unless $author;
- my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
- return unless @dl;
- my($dirent) = grep { $_->[2] eq $filename } @dl;
- # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
- return unless $dirent->[1];
- return $self->{UPLOAD_DATE} = $dirent->[1];
+ my $self = shift;
+ return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
+ my(@local_wanted) = split(/\//,$self->id);
+ my $filename = pop @local_wanted;
+ push @local_wanted, "CHECKSUMS";
+ my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
+ return unless $author;
+ my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
+ return unless @dl;
+ my($dirent) = grep { $_->[2] eq $filename } @dl;
+ # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
+ return unless $dirent->[1];
+ return $self->{UPLOAD_DATE} = $dirent->[1];
}
#-> sub CPAN::Distribution::uptodate ;
my $c;
foreach $c ($self->containsmods) {
my $obj = CPAN::Shell->expandany($c);
- unless ($obj->uptodate){
+ unless ($obj->uptodate) {
my $id = $self->pretty_id;
$self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
return 0;
#-> 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(
local $ENV{MAKEFLAGS}; # protect us from outer make calls
EXCUSE: {
- my @e;
+ my @e;
+ my $goodbye_message;
+ $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
if ($self->prefs->{disabled}) {
- push @e, sprintf(
- "disabled via prefs file '%s' doc %d",
- $self->{prefs_file},
- $self->{prefs_file_doc},
- );
+ 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;
}
- exists $self->{build_dir} and push @e,
- "Is already unwrapped into directory $self->{build_dir}";
+ }
+ my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
- 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";
+ my($local_file);
+ unless ($self->{build_dir} && -d $self->{build_dir}) {
+ $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};
+ $self->{build_dir} = $packagedir;
+ }
- $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
+ if ($CPAN::Signal) {
+ $self->safe_chdir($sub_wd);
+ return;
}
- my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
+ return $self->run_MM_or_MB($local_file);
+}
- #
- # Get the file on local disk
- #
+#-> 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::Config->{keep_source_where},
- "authors",
- "id",
- split(/\//,$self->id)
- );
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$self->id)
+ );
$self->debug("Doing localize") if $CPAN::DEBUG;
unless ($local_file =
$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;
+ $self->debug("Digest::SHA is installed, verifying");
+ $self->verifyCHECKSUM;
} else {
- $self->debug("Digest::SHA is NOT installed");
+ $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);
EOF
}
- if ($CPAN::Signal){
- $self->safe_chdir($sub_wd);
+ if ($CPAN::Signal) {
return;
}
$self->safe_chdir("tmp-$$");
#
# Unpack the goods
#
+ 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){
+ if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
$self->{was_uncompressed}++ unless eval{$ct->gtest()};
- $self->untar_me($ct);
+ $self->untar_me($ct);
} elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
- $self->unzip_me($ct);
+ $self->unzip_me($ct);
} else {
$self->{was_uncompressed}++ unless $ct->gtest();
- $local_file = $self->handle_singlefile($local_file);
-# } else {
-# $self->{archived} = "NO";
-# $self->safe_chdir($sub_wd);
-# return;
+ $local_file = $self->handle_singlefile($local_file);
}
# we are still in the tmp directory!
$dh->close;
my ($packagedir);
# XXX here we want in each branch File::Temp to protect all build_dir directories
- if (CPAN->has_inst("File::Temp")) {
+ if (CPAN->has_usable("File::Temp")) {
my $tdir_base;
my $from_dir;
my @dirents;
for $f (@dirents) { # is already without "." and ".."
my $from = File::Spec->catdir($from_dir,$f);
my $to = File::Spec->catdir($packagedir,$f);
- File::Copy::move($from,$to) or Carp::confess("Couldn't move $from to $to: $!");
+ 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 $CPAN::DEBUG;
} else {
my $userid = $self->cpan_userid;
- CPAN->debug("userid[$userid]");
+ CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
if (!$userid or $userid eq "N/A") {
$userid = "anon";
}
}
}
}
- 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-$$");
$self->safe_chdir($packagedir);
$self->_signature_business();
$self->safe_chdir($builddir);
- return if $CPAN::Signal;
+ return($packagedir,$local_file);
+}
+
+#-> sub CPAN::Distribution::parse_meta_yml ;
+sub parse_meta_yml {
+ my($self) = @_;
+ my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
+ my $yaml = File::Spec->catfile($build_dir,"META.yml");
+ $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
+ return unless -f $yaml;
+ my $early_yaml;
+ eval {
+ require Parse::Metayaml; # hypothetical
+ $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
+ };
+ unless ($early_yaml) {
+ eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
+ }
+ unless ($early_yaml) {
+ return;
+ }
+ return $early_yaml;
+}
+
+#-> sub CPAN::Distribution::satisfy_configure_requires ;
+sub satisfy_configure_requires {
+ my($self) = @_;
+ my $enable_configure_requires = 1;
+ if (!$enable_configure_requires) {
+ return 1;
+ # if we return 1 here, everything is as before we introduced
+ # configure_requires that means, things with
+ # configure_requires simply fail, all others succeed
+ }
+ my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
+ if ($self->{configure_requires_later}) {
+ for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
+ if ($self->{configure_requires_later_for}{$k}>1) {
+ # we must not come here a second time
+ $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
+ require YAML::Syck;
+ $CPAN::Frontend->mydie
+ (
+ YAML::Syck::Dump
+ ({self=>$self, prereq=>\@prereq})
+ );
+ }
+ }
+ }
+ if ($prereq[0][0] eq "perl") {
+ my $need = "requires perl '$prereq[0][1]'";
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
+ $self->{make} = CPAN::Distrostatus->new("NO $need");
+ $self->store_persistent_state;
+ return $self->goodbye("[prereq] -- NOT OK");
+ } else {
+ my $follow = eval {
+ $self->follow_prereqs("configure_requires_later", @prereq);
+ };
+ if (0) {
+ } elsif ($follow) {
+ return;
+ } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ return $self->goodbye("[depend] -- NOT OK");
+ }
+ }
+ die "never reached";
+}
- my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
+#-> sub CPAN::Distribution::run_MM_or_MB ;
+sub run_MM_or_MB {
+ my($self,$local_file) = @_;
+ $self->satisfy_configure_requires() or return;
+ my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
my($mpl_exists) = -f $mpl;
unless ($mpl_exists) {
# NFS has been reported to have racing problems after the
# renaming of a directory in some environments.
# This trick helps.
$CPAN::Frontend->mysleep(1);
- my $mpldh = DirHandle->new($packagedir)
- or Carp::croak("Couldn't opendir $packagedir: $!");
+ my $mpldh = DirHandle->new($self->{build_dir})
+ or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
$mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
$mpldh->close;
}
my $prefer_installer = "eumm"; # eumm|mb
- if (-f File::Spec->catfile($packagedir,"Build.PL")) {
+ if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
if ($mpl_exists) { # they *can* choose
- $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
- q{prefer_installer});
+ if ($CPAN::META->has_inst("Module::Build")) {
+ $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
+ q{prefer_installer});
+ }
} else {
$prefer_installer = "mb";
}
}
return unless $self->patch;
+ if (lc($prefer_installer) eq "rand") {
+ $prefer_installer = rand()<.5 ? "eumm" : "mb";
+ }
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->_edge_cases($mpl,$packagedir,$local_file);
+ $self->_edge_cases($mpl,$local_file);
}
if ($self->{build_dir}
&&
) {
$self->store_persistent_state;
}
-
return $self;
}
sub store_persistent_state {
my($self) = @_;
my $dir = $self->{build_dir};
- unless (File::Basename::dirname($dir) eq $CPAN::Config->{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;
- CPAN->_yaml_dumpfile(
- $file,
- {
- time => time,
- perl => CPAN::_perl_fingerprint,
- distribution => $self,
- }
- );
+ 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
+#-> CPAN::Distribution::try_download
sub try_download {
my($self,$patch) = @_;
my $norm = $self->normalize($patch);
"authors",
"id",
split(/\//,$norm),
- );
+ );
$self->debug("Doing localize") if $CPAN::DEBUG;
return CPAN::FTP->localize("authors/id/$norm",
$local_wanted);
}
-#-> CPAN::Distribution::patch
-sub patch {
- my($self) = @_;
- if (my $patches = $self->prefs->{patches}) {
- return unless @$patches;
- $self->safe_chdir($self->{build_dir});
- CPAN->debug("patches[$patches]");
- 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; # shall replace -g0 which is not
- # supported everywhere (and then,
- # not ever necessary there)
- my $stdpatchargs = "-N --fuzz=3";
- 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;
+{
+ 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 $fail = "Could not find patch '$patch'";
+ 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;
}
}
- $CPAN::Frontend->myprint(" $patch\n");
- my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
- my $thispatchargs = join " ", $stdpatchargs, $self->_patch_p_parameter($readfh);
- CPAN->debug("thispatchargs[$thispatchargs]") if $CPAN::DEBUG;
- $readfh = CPAN::Tarzip->TIEHANDLE($patch);
- my $writefh = FileHandle->new;
- unless (open $writefh, "|$patchbin $thispatchargs") {
- my $fail = "Could not fork '$patchbin $thispatchargs'";
- $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}++;
}
- $self->{patched}++;
+ return 1;
}
- return 1;
}
sub _patch_p_parameter {
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;
+ 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) = @_;
+ my($self,$mpl,$local_file) = @_;
$self->debug(sprintf("makefilepl[%s]anycwd[%s]",
$mpl,
CPAN::anycwd(),
)) if $CPAN::DEBUG;
- my($configure) = File::Spec->catfile($packagedir,"Configure");
+ my $build_dir = $self->{build_dir};
+ my($configure) = File::Spec->catfile($build_dir,"Configure");
if (-f $configure) {
# do we have anything to do?
$self->{configure} = $configure;
- } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
+ } elsif (-f File::Spec->catfile($build_dir,"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.
my $script = "";
if ($self->{archived} eq "maybe_pl") {
my $fh = FileHandle->new;
- my $script_file = File::Spec->catfile($packagedir,$local_file);
+ my $script_file = File::Spec->catfile($build_dir,$local_file);
$fh->open($script_file)
- or Carp::croak("Could not open $script_file: $!");
+ or Carp::croak("Could not open script '$script_file': $!");
local $/ = "\n";
# name parsen und prereq
my($state) = "poddir";
},
";
if ($name) {
- my $to_file = File::Spec->catfile($packagedir, $name);
+ my $to_file = File::Spec->catfile($build_dir, $name);
rename $script_file, $to_file
or die "Can't rename $script_file to $to_file: $!";
}
);
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
+ 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 there run
+and run
cpansign -v
},
$self->{localfile},
my($self,$ct) = @_;
$self->{archived} = "tar";
if ($ct->untar()) {
- $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
}
}
my($self,$ct) = @_;
$self->{archived} = "zip";
if ($ct->unzip()) {
- $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
}
return;
}
sub handle_singlefile {
my($self,$local_file) = @_;
- if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
- $self->{archived} = "pm";
+ 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";
+ $self->{archived} = "maybe_pl";
}
my $to = File::Basename::basename($local_file);
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
}
} else {
- File::Copy::cp($local_file,".");
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
+ if (File::Copy::cp($local_file,".")) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
+ }
}
return $to;
}
}
if ( $CPAN::Config->{'shell'} ) {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->myprint(qq{
Trying to open a subshell in the build directory...
});
} else {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->myprint(qq{
Your configuration does not define a value for subshells.
Please define it with "o conf shell <your shell>"
});
- return;
+ return;
}
my $dist = $self->id;
my $dir;
$self->get;
}
unless ($dir ||= $self->dir) {
- $CPAN::Frontend->mywarn(qq{
+ $CPAN::Frontend->mywarn(qq{
Could not determine which directory to use for looking at $dist.
});
- return;
+ return;
}
my $pwd = CPAN::anycwd();
$self->safe_chdir($dir);
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
{
- local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
+ local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
$ENV{CPAN_SHELL_LEVEL} += 1;
- my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
- unless (system($shell) == 0) {
- my $code = $? >> 8;
- $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
- }
+ my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
+ unless (system($shell) == 0) {
+ my $code = $? >> 8;
+ $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+ }
}
$self->safe_chdir($pwd);
}
my $cvs_dir = (split /\//, $dir)[-1];
$cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
- my $cvs_root =
+ my $cvs_root =
$CPAN::Config->{cvsroot} || $ENV{CVSROOT};
- my $cvs_site_perl =
+ my $cvs_site_perl =
$CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
if ($cvs_site_perl) {
- $cvs_dir = "$cvs_site_perl/$cvs_dir";
+ $cvs_dir = "$cvs_site_perl/$cvs_dir";
}
my $cvs_log = qq{"imported $package $version sources"};
$version =~ s/\./_/g;
# XXX cvs: undocumented and unclear how it was meant to work
my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
- "$cvs_dir", $userid, "v$version");
+ "$cvs_dir", $userid, "v$version");
my $pwd = CPAN::anycwd();
chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
$CPAN::Frontend->myprint(qq{@cmd\n});
system(@cmd) == 0 or
# XXX cvs
- $CPAN::Frontend->mydie("cvs import failed");
+ $CPAN::Frontend->mydie("cvs import failed");
chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
}
$self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
my($local_file);
my($local_wanted) =
- File::Spec->catfile(
- $CPAN::Config->{keep_source_where},
- "authors",
- "id",
- split(/\//,"$sans.readme"),
- );
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,"$sans.readme"),
+ );
$self->debug("Doing localize") if $CPAN::DEBUG;
$local_file = CPAN::FTP->localize("authors/id/$sans.readme",
- $local_wanted)
- or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
+ $local_wanted)
+ or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
if ($^O eq 'MacOS') {
Mac::BuildTools::launch_file($local_file);
local($SIG{PIPE}) = "IGNORE";
my $pager = $CPAN::Config->{'pager'} || "cat";
$fh_pager->open("|$pager")
- or die "Could not open pager $pager\: $!";
+ or die "Could not open pager $pager\: $!";
my $fh_readme = FileHandle->new;
$fh_readme->open($local_file)
- or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
+ or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
$CPAN::Frontend->myprint(qq{
Displaying file
$local_file
sub verifyCHECKSUM {
my($self) = @_;
EXCUSE: {
- my @e;
- $self->{CHECKSUM_STATUS} ||= "";
- $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
- $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ my @e;
+ $self->{CHECKSUM_STATUS} ||= "";
+ $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
my($lc_want,$lc_file,@local,$basename);
@local = split(/\//,$self->id);
pop @local;
push @local, "CHECKSUMS";
$lc_want =
- File::Spec->catfile($CPAN::Config->{keep_source_where},
- "authors", "id", @local);
+ File::Spec->catfile($CPAN::Config->{keep_source_where},
+ "authors", "id", @local);
local($") = "/";
if (my $size = -s $lc_want) {
$self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
}
}
$lc_file = CPAN::FTP->localize("authors/id/@local",
- $lc_want,1);
+ $lc_want,1);
unless ($lc_file) {
$CPAN::Frontend->myprint("Trying $lc_want.gz\n");
- $local[-1] .= ".gz";
- $lc_file = CPAN::FTP->localize("authors/id/@local",
- "$lc_want.gz",1);
- if ($lc_file) {
- $lc_file =~ s/\.gz(?!\n)\Z//;
- eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
- } else {
- return;
- }
+ $local[-1] .= ".gz";
+ $lc_file = CPAN::FTP->localize("authors/id/@local",
+ "$lc_want.gz",1);
+ if ($lc_file) {
+ $lc_file =~ s/\.gz(?!\n)\Z//;
+ eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
+ } else {
+ return;
+ }
}
if ($self->CHECKSUM_check_file($lc_file)) {
return $self->{CHECKSUM_STATUS} = "OK";
my $rv = eval { Module::Signature::_verify($chk_file) };
if ($rv == Module::Signature::SIGNATURE_OK()) {
- $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
- return $self->{SIG_STATUS} = "OK";
+ $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
+ return $self->{SIG_STATUS} = "OK";
} else {
- $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 = qq{I\'d recommend removing $chk_file. Its signature
+ $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 = qq{I\'d recommend removing $chk_file. Its signature
is invalid. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
retry.};
- $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
}
}
q{check_sigs});
if ($check_sigs) {
if ($CPAN::META->has_inst("Module::Signature")) {
- $self->debug("Module::Signature is installed, verifying");
+ $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;
}
}
$file = $self->{localfile};
$basename = File::Basename::basename($file);
my $fh = FileHandle->new;
- if (open $fh, $chk_file){
- local($/);
- my $eval = <$fh>;
- $eval =~ s/\015?\012/\n/g;
- close $fh;
- my($comp) = Safe->new();
- $cksum = $comp->reval($eval);
- if ($@) {
- rename $chk_file, "$chk_file.bad";
- Carp::confess($@) if $@;
- }
+ if (open $fh, $chk_file) {
+ local($/);
+ my $eval = <$fh>;
+ $eval =~ s/\015?\012/\n/g;
+ close $fh;
+ my($comp) = Safe->new();
+ $cksum = $comp->reval($eval);
+ if ($@) {
+ rename $chk_file, "$chk_file.bad";
+ Carp::confess($@) if $@;
+ }
} else {
- Carp::carp "Could not open $chk_file for reading";
+ Carp::carp "Could not open $chk_file for reading";
}
if (! ref $cksum or ref $cksum ne "HASH") {
$self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
return;
} elsif (exists $cksum->{$basename}{sha256}) {
- $self->debug("Found checksum for $basename:" .
- "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
-
- open($fh, $file);
- binmode $fh;
- my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
- $fh->close;
- $fh = CPAN::Tarzip->TIEHANDLE($file);
-
- unless ($eq) {
- my $dg = Digest::SHA->new(256);
- my($data,$ref);
- $ref = \$data;
- while ($fh->READ($ref, 4096) > 0){
- $dg->add($data);
- }
- my $hexdigest = $dg->hexdigest;
- $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
- }
-
- if ($eq) {
- $CPAN::Frontend->myprint("Checksum for $file ok\n");
- return $self->{CHECKSUM_STATUS} = "OK";
- } else {
- $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
- qq{distribution file. }.
- qq{Please investigate.\n\n}.
- $self->as_string,
- $CPAN::META->instance(
- 'CPAN::Author',
- $self->cpan_userid
- )->as_string);
-
- my $wrap = qq{I\'d recommend removing $file. Its
+ $self->debug("Found checksum for $basename:" .
+ "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
+
+ open($fh, $file);
+ binmode $fh;
+ my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
+ $fh->close;
+ $fh = CPAN::Tarzip->TIEHANDLE($file);
+
+ unless ($eq) {
+ my $dg = Digest::SHA->new(256);
+ my($data,$ref);
+ $ref = \$data;
+ while ($fh->READ($ref, 4096) > 0) {
+ $dg->add($data);
+ }
+ my $hexdigest = $dg->hexdigest;
+ $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
+ }
+
+ if ($eq) {
+ $CPAN::Frontend->myprint("Checksum for $file ok\n");
+ return $self->{CHECKSUM_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid
+ )->as_string);
+
+ my $wrap = qq{I\'d recommend removing $file. Its
checksum is incorrect. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
retry.};
# former versions just returned here but this seems a
# serious threat that deserves a die
- # $CPAN::Frontend->myprint("\n\n");
- # sleep 3;
- # return;
- }
- # close $fh if fileno($fh);
+ # $CPAN::Frontend->myprint("\n\n");
+ # sleep 3;
+ # return;
+ }
+ # close $fh if fileno($fh);
} else {
return if $sloppy;
- unless ($self->{CHECKSUM_STATUS}) {
- $CPAN::Frontend->mywarn(qq{
+ unless ($self->{CHECKSUM_STATUS}) {
+ $CPAN::Frontend->mywarn(qq{
Warning: No checksum for $basename in $chk_file.
The cause for this may be that the file is very new and the checksum
});
my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
$answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
- }
+ }
$self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
- return;
+ return;
}
}
if ($CPAN::META->has_inst("Digest::SHA")) {
my $dg = Digest::SHA->new(256);
my($data);
- while (read($fh, $data, 4096)){
+ while (read($fh, $data, 4096)) {
$dg->add($data);
}
my $hexdigest = $dg->hexdigest;
# "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
- badtestcnt
- build_dir
- install
- localfile
- make
- make_test
- modulebuild
- prefs
- prefs_file
- prereq_pm
- prereq_pm_detected
- reqtype
- signature_verify
- unwrapped
- writemakefile
- yaml_content
- )) {
- delete $self->{$att};
- CPAN->debug(sprintf "att[%s]", $att) if $CPAN::DEBUG;
+ 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 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 ;
my $file = File::Basename::basename($self->id);
if ($file =~ m{ ^ perl
-?
- (5)
- ([._-])
- (
+ (5)
+ ([._-])
+ (
\d{3}(_[0-4][0-9])?
|
\d+\.\d+
)
- \.tar[._-](?:gz|bz2)
- (?!\n)\Z
- }xs){
+ \.tar[._-](?:gz|bz2)
+ (?!\n)\Z
+ }xs) {
return "$1.$3";
} elsif ($self->cpan_comment
&&
- $self->cpan_comment =~ /isa_perl\(.+?\)/){
+ $self->cpan_comment =~ /isa_perl\(.+?\)/) {
return $1;
}
}
my $make = $self->{modulebuild} ? "Build" : "make";
# Emergency brake if they said install Pippi and get newest perl
if ($self->isa_perl) {
- if (
- $self->called_for ne $self->id &&
- ! $self->{force_update}
- ) {
- # if we die here, we break bundles
- $CPAN::Frontend
- ->mywarn(sprintf(
- qq{The most recent version "%s" of the module "%s"
+ if (
+ $self->called_for ne $self->id &&
+ ! $self->{force_update}
+ ) {
+ # if we die here, we break bundles
+ $CPAN::Frontend
+ ->mywarn(sprintf(
+ qq{The most recent version "%s" of the module "%s"
is part of the perl-%s distribution. To install that, you need to run
force install %s --or--
install %s
$self->called_for,
$self->id,
));
- $self->{make} = CPAN::Distrostatus->new("NO isa perl");
- $CPAN::Frontend->mysleep(1);
- return;
- }
+ $self->{make} = CPAN::Distrostatus->new("NO isa perl");
+ $CPAN::Frontend->mysleep(1);
+ return;
+ }
}
$CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
$self->get;
+ if ($self->{configure_requires_later}) {
+ return;
+ }
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;
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
}
+
+ my $builddir;
EXCUSE: {
my @e;
if (!$self->{archived} || $self->{archived} eq "NO") {
push @e, $err;
}
- defined $self->{make} and push @e,
- "Has already been processed within this session";
-
- if (exists $self->{later} and length($self->{later})) {
- 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.
+ 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";
+ }
+ }
-# } else {
-# delete $self->{later};
+ my $later = $self->{later} || $self->{configure_requires_later};
+ if ($later) { # see also undelay
+ if ($later) {
+ push @e, $later;
}
}
- $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ $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;
+ 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";
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
$system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
} else {
- my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
- my $switch = "";
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
+ my $switch = "";
# This needs a handler that can be turned on or off:
-# $switch = "-MExtUtils::MakeMaker ".
-# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
-# if $] > 5.00310;
+# $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",
+ $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
+ "Makefile.PL");
+ $system = sprintf("%s%s Makefile.PL%s",
$perl,
$switch ? " $switch" : "",
$makepl_arg ? " $makepl_arg" : "",
);
}
- my %env;
- while (my($k,$v) = each %ENV) {
- next unless defined $v;
- $env{$k} = $v;
- }
- local %ENV = %env;
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);
- $@ = "";
+ local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
+ my($ret,$pid,$output);
+ $@ = "";
my $go_via_alarm;
- if ($CPAN::Config->{inactivity_timeout}) {
+ if ($CPAN::Config->{inactivity_timeout}) {
require Config;
if ($Config::Config{d_alarm}
&&
}
}
if ($go_via_alarm) {
- eval {
- alarm $CPAN::Config->{inactivity_timeout};
- local $SIG{CHLD}; # = sub { wait };
- if (defined($pid = fork)) {
- if ($pid) { #parent
- # wait;
- waitpid $pid, 0;
- } else { #child
- # note, this exec isn't necessary if
- # inactivity_timeout is 0. On the Mac I'd
- # suggest, we set it always to 0.
- exec $system;
+ if ( $self->_should_report('pl') ) {
+ ($output, $ret) = CPAN::Reporter::record_command(
+ $system,
+ $CPAN::Config->{inactivity_timeout},
+ );
+ CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
+ }
+ else {
+ eval {
+ alarm $CPAN::Config->{inactivity_timeout};
+ local $SIG{CHLD}; # = sub { wait };
+ if (defined($pid = fork)) {
+ if ($pid) { #parent
+ # wait;
+ waitpid $pid, 0;
+ } else { #child
+ # note, this exec isn't necessary if
+ # inactivity_timeout is 0. On the Mac I'd
+ # suggest, we set it always to 0.
+ exec $system;
+ }
+ } else {
+ $CPAN::Frontend->myprint("Cannot fork: $!");
+ return;
}
- } else {
- $CPAN::Frontend->myprint("Cannot fork: $!");
- return;
+ };
+ alarm 0;
+ if ($@) {
+ kill 9, $pid;
+ waitpid $pid, 0;
+ my $err = "$@";
+ $CPAN::Frontend->myprint($err);
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
+ $@ = "";
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- TIMED OUT");
}
- };
- alarm 0;
- if ($@){
- kill 9, $pid;
- waitpid $pid, 0;
- my $err = "$@";
- $CPAN::Frontend->myprint($err);
- $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
- $@ = "";
- return;
}
- } else {
+ } else {
if (my $expect_model = $self->_prefs_with_expect("pl")) {
+ # XXX probably want to check _should_report here and warn
+ # about not being able to use CPAN::Reporter with expect
$ret = $self->_run_via_expect($system,$expect_model);
if (! defined $ret
&& $self->{writemakefile}
# timeout
return;
}
- } else {
+ }
+ elsif ( $self->_should_report('pl') ) {
+ ($output, $ret) = CPAN::Reporter::record_command($system);
+ CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
+ }
+ else {
$ret = system($system);
}
if ($ret != 0) {
->new("NO '$system' returned status $ret");
$CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
$self->store_persistent_state;
- $self->store_persistent_state;
- return;
+ return $self->goodbye("$system -- NOT OK");
}
- }
- 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});
- }
+ }
+ if (-f "Makefile" || -f "Build") {
+ $self->{writemakefile} = CPAN::Distrostatus->new("YES");
+ delete $self->{make_clean}; # if cleaned before, enable next
+ } else {
+ my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new(qq{NO -- No $makefile created});
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- NO $makefile created");
+ }
}
- if ($CPAN::Signal){
- delete $self->{force_update};
- return;
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
}
- if (my @prereq = $self->unsat_prereq){
+ if (my @prereq = $self->unsat_prereq("later")) {
if ($prereq[0][0] eq "perl") {
my $need = "requires perl '$prereq[0][1]'";
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
$self->{make} = CPAN::Distrostatus->new("NO $need");
$self->store_persistent_state;
- return;
+ return $self->goodbye("[prereq] -- NOT OK");
} else {
- return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
+ my $follow = eval { $self->follow_prereqs("later",@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");
+ }
}
}
- if ($CPAN::Signal){
- delete $self->{force_update};
- return;
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
}
- 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);
- }
- $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
+ if (my $commandline = $self->prefs->{make}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = CPAN::find_perl;
} else {
- $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
+ 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" : "",
+ );
}
- 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
}
my $system_ok;
if ($want_expect) {
+ # XXX probably want to check _should_report here and
+ # warn about not being able to use CPAN::Reporter with expect
$system_ok = $self->_run_via_expect($system,$expect_model) == 0;
- } else {
+ }
+ elsif ( $self->_should_report('make') ) {
+ my ($output, $ret) = CPAN::Reporter::record_command($system);
+ CPAN::Reporter::grade_make( $self, $system, $output, $ret );
+ $system_ok = ! $ret;
+ }
+ else {
$system_ok = system($system) == 0;
}
$self->introduce_myself;
if ( $system_ok ) {
- $CPAN::Frontend->myprint(" $system -- OK\n");
- $self->{make} = CPAN::Distrostatus->new("YES");
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{make} = CPAN::Distrostatus->new("YES");
} else {
- $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
- $self->{make} = CPAN::Distrostatus->new("NO");
- $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
+ $self->{make} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
}
$self->store_persistent_state;
}
-# CPAN::Distribution::_run_via_expect
+# CPAN::Distribution::goodbye ;
+sub goodbye {
+ my($self,$goodbye) = @_;
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn(" $id\n $goodbye\n");
+ 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);
- my $expecta = $expect_model->{talk};
- if ($expect_model->{mode} eq "expect") {
- return $self->_run_via_expect_deterministic($expo,$expecta);
- } elsif ($expect_model->{mode} eq "expect-in-any-order") {
- return $self->_run_via_expect_anyorder($expo,$expecta);
+ $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}";
}
}
sub _run_via_expect_anyorder {
- my($self,$expo,$expecta) = @_;
- my $timeout = 3; # currently unsettable
- my @expectacopy = @$expecta; # we trash it!
+ my($self,$expo,$expect_model) = @_;
+ my $timeout = $expect_model->{timeout} || 5;
+ my $reuse = $expect_model->{reuse};
+ my @expectacopy = @{$expect_model->{talk}}; # we trash it!
my $but = "";
EXPECT: while () {
my($eof,$ran_into_timeout);
if ($but =~ /$regex/) {
# warn "DEBUG: will send send[$send]";
$expo->send($send);
- splice @expectacopy, $i, 2; # never allow reusing an QA pair
+ # never allow reusing an QA pair unless they told us
+ splice @expectacopy, $i, 2 unless $reuse;
next EXPECT;
}
}
}
sub _run_via_expect_deterministic {
- my($self,$expo,$expecta) = @_;
+ 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($next,$send) = @$expecta[$i,$i+1];
- my($timeout,$re);
- if (ref $next) {
- $timeout = $next->{timeout};
- $re = $next->{expect};
- } else {
- $timeout = 15;
- $re = $next;
- }
+ my($re,$send) = @$expecta[$i,$i+1];
CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
my $regex = eval "qr{$re}";
$expo->expect($timeout,
$ran_into_timeout++;
} ],
-re => $regex);
- if ($ran_into_timeout){
+ if ($ran_into_timeout) {
# note that the caller expects 0 for success
$self->{writemakefile} =
CPAN::Distrostatus->new("NO timeout during expect dialog");
return $expo->exitstatus();
}
-# CPAN::Distribution::_find_prefs
+#-> 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;
+ #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
my $prefs_dir = $CPAN::Config->{prefs_dir};
+ return if $prefs_dir =~ /^\s*$/;
eval { File::Path::mkpath($prefs_dir); };
if ($@) {
$CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
}
- my $yaml_module = CPAN->_yaml_module;
+ my $yaml_module = CPAN::_yaml_module;
my @extensions;
if ($CPAN::META->has_inst($yaml_module)) {
push @extensions, "yml";
my $thisexte = $1;
my $abs = File::Spec->catfile($prefs_dir, $_);
if (-f $abs) {
- CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
+ #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;
}
}
# $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");
+ #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
next ELEMENT;
}
my $ok = 1;
- for my $sub_attribute (keys %$match) {
+ # 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 "abs[%s]distropref[%d]", $abs, scalar @distropref) if $CPAN::DEBUG;
+ #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
my @modules = $self->containsmods;
- CPAN->debug(sprintf "abs[%s]distropref[%d]modules[%s]", $abs, scalar @distropref, join(",",@modules)) if $CPAN::DEBUG;
+ #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
MODULE: for my $module (@modules) {
$okm ||= $module =~ /$qr/;
last MODULE if $okm;
my $okd = $distroid =~ /$qr/;
$ok &&= $okd;
} elsif ($sub_attribute eq "perl") {
- my $okp = $^X =~ /$qr/;
+ my $okp = CPAN::find_perl =~ /$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
}
- CPAN->debug(sprintf "abs[%s]distropref[%d]ok[%d]", $abs, scalar @distropref, $ok) if $CPAN::DEBUG;
+ 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,
}
}
}
+ $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};
return $self->{prefs};
}
}
- return +{};
+ $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
+ return $self->{prefs} = +{};
}
# CPAN::Distribution::make_x_arg
#-> sub CPAN::Distribution::follow_prereqs ;
sub follow_prereqs {
my($self) = shift;
+ my($slot) = shift;
my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
return unless @prereq_tuples;
my @prereq = map { $_->[0] } @prereq_tuples;
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 $follow = 0;
if ($CPAN::Config->{prerequisites_policy} eq "follow") {
- $follow = 1;
+ $follow = 1;
} elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
- my $answer = CPAN::Shell::colorable_makemaker_prompt(
+ 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;
+ $follow = $answer =~ /^\s*y/i;
} else {
- local($") = ", ";
- $CPAN::Frontend->
+ local($") = ", ";
+ $CPAN::Frontend->
myprint(" Ignoring dependencies on modules @prereq\n");
}
if ($follow) {
# 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);
+ $self->{$slot . "_for"}{$any->id}++;
+ 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}],
- reverse @prereq_tuples);
- $self->{later} = "Delayed until after prerequisites";
+ CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
+ map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples);
+ $self->{$slot} = "Delayed until after prerequisites";
return 1; # signal success to the queuerunner
}
+ return;
}
#-> sub CPAN::Distribution::unsat_prereq ;
# return ([Foo=>1],[Bar=>1.2]) for normal modules
# return ([perl=>5.008]) if we need a newer perl than we are running under
sub unsat_prereq {
- my($self) = @_;
- my $prereq_pm = $self->prereq_pm or return;
+ my($self,$slot) = @_;
+ my(%merged,$prereq_pm);
+ my $prefs_depends = $self->prefs->{depends}||{};
+ if ($slot eq "configure_requires_later") {
+ my $meta_yml = $self->parse_meta_yml();
+ %merged = (%{$meta_yml->{configure_requires}||{}},
+ %{$prefs_depends->{configure_requires}||{}});
+ $prereq_pm = {}; # configure_requires defined as "b"
+ } elsif ($slot eq "later") {
+ my $prereq_pm_0 = $self->prereq_pm || {};
+ for my $reqtype (qw(requires build_requires)) {
+ $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
+ for my $k (keys %{$prefs_depends->{$reqtype}||{}}) {
+ $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k};
+ }
+ }
+ %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
+ } else {
+ die "Panic: illegal slot '$slot'";
+ }
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 = CPAN::find_perl;
} 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 ($need_module eq "perl") {
return ["perl", $need_version];
}
- if ($self->{sponsored_mods}{$need_module}++){
+ $self->{sponsored_mods}{$need_module} ||= 0;
+ CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") 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
+ if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$self->{ID}' seems ".
+ "not available according to the indexes\n"
+ );
+ next NEED;
+ }
+ 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;
}
return unless -f $yaml;
eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
if ($@) {
- $CPAN::Frontend->mywarn("Warning (probably harmless): Could not read ".
+ $CPAN::Frontend->mywarn("Could not read ".
"'$yaml'. Falling back to other ".
"methods to determine prerequisites\n");
- return; # if we die, then we cannot read YAML's own META.yml
+ 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}
) {
sub prereq_pm {
my($self) = @_;
$self->{prereq_pm_detected} ||= 0;
- CPAN->debug("prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
+ 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
$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
# 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;
}
return $self->goto($goto);
}
$self->make;
- if ($CPAN::Signal){
+ if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
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
- }
- }
+
EXCUSE: {
- my @e;
- unless (exists $self->{make} or exists $self->{later}) {
+ my @e;
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
push @e,
"Make had some problems, won't test";
}
- exists $self->{make} and
- (
+ exists $self->{make} and
+ (
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};
+ push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
if (exists $self->{build_dir}) {
- if ($CPAN::META->{is_tested}{$self->{build_dir}}
- &&
- exists $self->{make_test}
- &&
- !(
- UNIVERSAL::can($self->{make_test},"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;
+ $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'}")
- if $CPAN::DEBUG;
+ $self->debug("Changed directory to $self->{build_dir}")
+ if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_test($self);
}
my $system;
- if ($self->{modulebuild}) {
+ my $prefs_test = $self->prefs->{test};
+ if (my $commandline
+ = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
+ $system = $commandline;
+ $ENV{PERL} = CPAN::find_perl;
+ } elsif ($self->{modulebuild}) {
$system = sprintf "%s test", $self->_build_command();
} else {
$system = join " ", $self->_make_command(), "test";
}
+ 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) {
"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
- && (
- substr($self->id,-1,1) eq "."
- ||
- $self->author->id eq "LOCAL"
- )
- ) {
- $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) {
+ if ($self->_should_report('test')) {
$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 ) {
+ } elsif ( $self->_should_report('test') ) {
$tests_ok = CPAN::Reporter::test($self, $system);
} else {
$tests_ok = system($system) == 0;
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);
- my $d_obj = $m_obj->distribution;
- if ($d_obj) {
- if (!$d_obj->{make_test}
- ||
- $d_obj->{make_test}->failed){
- #$m_obj->dump;
- push @prereq, $m;
- }
+ next unless $self->{sponsored_mods}{$m} > 0;
+ 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){
+ 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");
+ $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO $but");
$self->store_persistent_state;
- return;
+ 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");
+ CPAN::Shell->optprint
+ ("hint",
+ sprintf
+ ("//hint// to see the cpan-testers results for installing this module, try:
+ reports %s\n",
+ $self->pretty_id));
}
$self->store_persistent_state;
}
return unless my $where_prefs = $prefs->{$where};
if ($where_prefs->{expect}) {
return {
- mode => "expect",
+ mode => "deterministic",
+ timeout => 15,
talk => $where_prefs->{expect},
};
- } elsif ($where_prefs->{"expect-in-any-order"}) {
- return {
- mode => "expect-in-any-order",
- talk => $where_prefs->{"expect-in-any-order"},
- };
+ } elsif ($where_prefs->{"eexpect"}) {
+ return $where_prefs->{"eexpect"};
}
return;
}
$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;
+ 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;
+ $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);
$self->store_persistent_state;
}
-#-> sub CPAN::Distribution::install ;
+#-> sub CPAN::Distribution::goto ;
sub goto {
my($self,$goto) = @_;
+ $goto = $self->normalize($goto);
+ my $why = sprintf(
+ "Goto '$goto' via prefs file '%s' doc %d",
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ );
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
+ # 2007-07-16 akoenig : Better than NA would be if we could inherit
+ # the status of the $goto distro but given the exceptional nature
+ # of 'goto' I feel reluctant to implement it
+ my $goodbye_message = "[goto] -- NA $why";
+ $self->goodbye($goodbye_message);
+
+ # inject into the queue
+
+ CPAN::Queue->delete($self->id);
+ CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
+
+ # and run where we left off
+
my($method) = (caller(1))[3];
- CPAN->instance("CPAN::Distribution",$goto)->$method;
+ CPAN->instance("CPAN::Distribution",$goto)->$method();
+ CPAN::Queue->delete_first($goto);
}
#-> sub CPAN::Distribution::install ;
if (my $goto = $self->prefs->{goto}) {
return $self->goto($goto);
}
- $self->test;
- if ($CPAN::Signal){
+ # $DB::single=1;
+ unless ($self->{badtestcnt}) {
+ $self->test;
+ }
+ if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
my $make = $self->{modulebuild} ? "Build" : "make";
$CPAN::Frontend->myprint("Running $make install\n");
EXCUSE: {
- my @e;
- unless (exists $self->{make} or exists $self->{later}) {
+ my @e;
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
push @e,
"Make had some problems, won't install";
}
- exists $self->{make} and
- (
+ exists $self->{make} and
+ (
UNIVERSAL::can($self->{make},"failed") ?
$self->{make}->failed :
$self->{make} =~ /^NO/
) and
- push @e, "Make had returned bad status, install seems impossible";
+ push @e, "Make had returned bad status, install seems impossible";
if (exists $self->{build_dir}) {
} elsif (!@e) {
}
if (exists $self->{make_test} and
- (
+ (
UNIVERSAL::can($self->{make_test},"failed") ?
$self->{make_test}->failed :
$self->{make_test} =~ /^NO/
- )){
- if ($self->{force_update}) {
+ )) {
+ if ($self->{force_update}) {
$self->{make_test}->text("FAILED but failure ignored because ".
"'force' in effect");
} else {
"won't install without force"
}
}
- if (exists $self->{install}) {
+ 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};
+ push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
- $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ $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'}")
- if $CPAN::DEBUG;
+ $self->debug("Changed directory to $self->{build_dir}")
+ if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_install($self);
}
my $system;
- if ($self->{modulebuild}) {
+ if (my $commandline = $self->prefs->{install}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = CPAN::find_perl;
+ } elsif ($self->{modulebuild}) {
my($mbuild_install_build_command) =
exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
$CPAN::Config->{mbuild_install_build_command} ?
delete $self->{force_update};
return;
}
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ $CPAN::META->set_perl5lib;
my($pipe) = FileHandle->new("$system $stderr |");
my($makeout) = "";
- while (<$pipe>){
- print $_; # intentionally NOT use Frontend->myprint because it
+ while (<$pipe>) {
+ print $_; # intentionally NOT use Frontend->myprint because it
# looks irritating when we markup in color what we
# just pass through from an external program
- $makeout .= $_;
+ $makeout .= $_;
}
$pipe->close;
my $close_ok = $? == 0;
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");
}
}
delete $self->{force_update};
+ # $DB::single = 1;
$self->store_persistent_state;
}
#-> sub CPAN::Distribution::dir ;
sub dir {
- shift->{'build_dir'};
+ shift->{build_dir};
}
#-> sub CPAN::Distribution::perldoc ;
if $CPAN::DEBUG;
# should we define it in the config instead?
- my $html_converter = "html2text";
+ my $html_converter = "html2text.pl";
my $web_browser = $CPAN::Config->{'lynx'} || undef;
my $web_browser_out = $web_browser
- ? CPAN::Distribution->_check_binary($self,$web_browser)
- : undef;
+ ? CPAN::Distribution->_check_binary($self,$web_browser)
+ : undef;
if ($web_browser_out) {
# web browser found, run the action
- my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
+ my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
$CPAN::Frontend->myprint(qq{system[$browser $url]})
- if $CPAN::DEBUG;
- $CPAN::Frontend->myprint(qq{
+ if $CPAN::DEBUG;
+ $CPAN::Frontend->myprint(qq{
Displaying URL
$url
with browser $browser
});
- $CPAN::Frontend->mysleep(1);
+ $CPAN::Frontend->mysleep(1);
system("$browser $url");
- if ($saved_file) { 1 while unlink($saved_file) }
+ if ($saved_file) { 1 while unlink($saved_file) }
} else {
# web browser not found, let's try text only
- my $html_converter_out =
- CPAN::Distribution->_check_binary($self,$html_converter);
+ my $html_converter_out =
+ CPAN::Distribution->_check_binary($self,$html_converter);
$html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
if ($html_converter_out ) {
unless defined($saved_file);
local *README;
- $pid = open README, "$html_converter $saved_file |"
- or $CPAN::Frontend->mydie(qq{
+ $pid = open README, "$html_converter $saved_file |"
+ or $CPAN::Frontend->mydie(qq{
Could not fork '$html_converter $saved_file': $!});
my($fh,$filename);
- if ($CPAN::META->has_inst("File::Temp")) {
+ if ($CPAN::META->has_usable("File::Temp")) {
$fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
template => 'cpan_htmlconvert_XXXX',
suffix => '.txt',
unlink => 0,
if $CPAN::DEBUG;
my($fh,$filename);
- if ($CPAN::META->has_inst("File::Temp")) {
+ if ($CPAN::META->has_usable("File::Temp")) {
$fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
template => "cpan_getsave_url_XXXX",
suffix => ".html",
unlink => 0,
}
}
-# sub CPAN::Distribution::_build_command
+#-> sub CPAN::Distribution::_build_command
sub _build_command {
my($self) = @_;
if ($^O eq "MSWin32") { # special code needed at least up to
return "./Build";
}
+#-> sub CPAN::Distribution::_should_report
+sub _should_report {
+ my($self, $phase) = @_;
+ die "_should_report() requires a 'phase' argument"
+ if ! defined $phase;
+
+ # configured
+ my $test_report = CPAN::HandleConfig->prefs_lookup($self,
+ q{test_report});
+ return unless $test_report;
+
+ # don't repeat if we cached a result
+ return $self->{should_report}
+ if exists $self->{should_report};
+
+ # available
+ if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
+ $CPAN::Frontend->mywarn(
+ "CPAN::Reporter not installed. No reports will be sent.\n"
+ );
+ return $self->{should_report} = 0;
+ }
+
+ # capable
+ my $crv = CPAN::Reporter->VERSION;
+ if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
+ # don't cache $self->{should_report} -- need to check each phase
+ if ( $phase eq 'test' ) {
+ return 1;
+ }
+ else {
+ $CPAN::Frontend->mywarn(
+ "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
+ "you only have version $crv\. Only 'test' phase reports will be sent.\n"
+ );
+ return;
+ }
+ }
+
+ # appropriate
+ if ($self->is_dot_dist) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "for local directories\n");
+ return $self->{should_report} = 0;
+ }
+ if ($self->prefs->{patches}
+ &&
+ @{$self->prefs->{patches}}
+ &&
+ $self->{patched}
+ ) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "when the source has been patched\n");
+ return $self->{should_report} = 0;
+ }
+
+ # proceed and cache success
+ return $self->{should_report} = 1;
+}
+
+#-> 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_usable("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)
### return $bu if -f $bu;
my $manifest = File::Spec->catfile($where,"MANIFEST");
unless (-f $manifest) {
- require ExtUtils::Manifest;
- my $cwd = CPAN::anycwd();
- $self->safe_chdir($where);
- ExtUtils::Manifest::mkmanifest();
- $self->safe_chdir($cwd);
+ require ExtUtils::Manifest;
+ my $cwd = CPAN::anycwd();
+ $self->safe_chdir($where);
+ ExtUtils::Manifest::mkmanifest();
+ $self->safe_chdir($cwd);
}
my $fh = FileHandle->new($manifest)
- or Carp::croak("Couldn't open $manifest: $!");
+ or Carp::croak("Couldn't open $manifest: $!");
local($/) = "\n";
my $bundle_filename = $what;
$bundle_filename =~ s|Bundle.*/||;
my $bundle_unixpath;
while (<$fh>) {
- next if /^\s*\#/;
- my($file) = /(\S+)/;
- if ($file =~ m|\Q$what\E$|) {
- $bundle_unixpath = $file;
- # return File::Spec->catfile($where,$bundle_unixpath); # bad
- last;
- }
- # retry if she managed to have no Bundle directory
- $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
+ next if /^\s*\#/;
+ my($file) = /(\S+)/;
+ if ($file =~ m|\Q$what\E$|) {
+ $bundle_unixpath = $file;
+ # return File::Spec->catfile($where,$bundle_unixpath); # bad
+ last;
+ }
+ # retry if she managed to have no Bundle directory
+ $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
}
return File::Spec->catfile($where, split /\//, $bundle_unixpath)
if $bundle_unixpath;
$self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
my($id) = $self->id;
Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
- unless $self->inst_file || $self->cpan_file;
+ unless $self->inst_file || $self->cpan_file;
my($s,%fail);
for $s ($self->contains) {
- my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
- $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
- if ($type eq 'CPAN::Distribution') {
- $CPAN::Frontend->mywarn(qq{
+ my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
+ $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
+ if ($type eq 'CPAN::Distribution') {
+ $CPAN::Frontend->mywarn(qq{
The Bundle }.$self->id.qq{ contains
explicitly a file '$s'.
Going to $meth that.
});
- $CPAN::Frontend->mysleep(5);
- }
- # possibly noisy action:
+ $CPAN::Frontend->mysleep(5);
+ }
+ # possibly noisy action:
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
- my $obj = $CPAN::META->instance($type,$s);
+ 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';
- }
+ $obj->$meth();
}
}
}
#-> 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;
}
$color_off = Term::ANSIColor::color("reset");
}
my $uptodateness = " ";
- if ($class eq "Bundle") {
- } elsif ($self->uptodate) {
- $uptodateness = "=";
- } elsif ($self->inst_version) {
- $uptodateness = "<";
- }
+ unless ($class eq "Bundle") {
+ my $u = $self->uptodate;
+ $uptodateness = $u ? "=" : "<" if defined $u;
+ };
+ my $id = do {
+ my $d = $self->distribution;
+ $d ? $d -> pretty_id : $self->cpan_userid;
+ };
push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
$class,
$uptodateness,
$color_on,
$self->id,
$color_off,
- ($self->distribution ?
- $self->distribution->pretty_id :
- $self->cpan_userid
- ),
+ $id,
);
join "", @m;
}
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,;
- @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
+ # public licence
+ @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
GPL LGPL
- BSD Artistic
+ BSD Artistic Artistic_2
open-source
distribution_allowed
restricted_distribution
push @m, $class, " id = $self->{ID}\n";
my $sprintf = " %-12s %s\n";
push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
- if $self->description;
+ if $self->description;
my $sprintf2 = " %-12s %s (%s)\n";
my($userid);
$userid = $self->userid;
- if ( $userid ){
- my $author;
- if ($author = CPAN::Shell->expand('Author',$userid)) {
- my $email = "";
- my $m; # old perls
- if ($m = $author->email) {
- $email = " <$m>";
- }
- push @m, sprintf(
- $sprintf2,
- 'CPAN_USERID',
- $userid,
- $author->fullname . $email
- );
- }
+ if ( $userid ) {
+ my $author;
+ if ($author = CPAN::Shell->expand('Author',$userid)) {
+ my $email = "";
+ my $m; # old perls
+ if ($m = $author->email) {
+ $email = " <$m>";
+ }
+ push @m, sprintf(
+ $sprintf2,
+ 'CPAN_USERID',
+ $userid,
+ $author->fullname . $email
+ );
+ }
}
push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
- if $self->cpan_version;
- if (my $cpan_file = $self->cpan_file){
+ if $self->cpan_version;
+ if (my $cpan_file = $self->cpan_file) {
push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
my $upload_date = $dist->upload_date;
}
my($item);
for $item (qw/MANPAGE/) {
- push @m, sprintf($sprintf, $item, $self->{$item})
- if exists $self->{$item};
+ push @m, sprintf($sprintf, $item, $self->{$item})
+ if exists $self->{$item};
}
for $item (qw/CONTAINS/) {
- push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
- if exists $self->{$item} && @{$self->{$item}};
+ push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
+ if exists $self->{$item} && @{$self->{$item}};
}
push @m, sprintf($sprintf, 'INST_FILE',
- $local_file || "(not installed)");
+ $local_file || "(not installed)");
push @m, sprintf($sprintf, 'INST_VERSION',
- $self->inst_version) if $local_file;
+ $self->inst_version) if $local_file;
join "", @m, "\n";
}
+#-> sub CPAN::Module::manpage_headline
sub manpage_headline {
- my($self,$local_file) = @_;
- my(@local_file) = $local_file;
- $local_file =~ s/\.pm(?!\n)\Z/.pod/;
- push @local_file, $local_file;
- my(@result,$locf);
- for $locf (@local_file) {
- next unless -f $locf;
- my $fh = FileHandle->new($locf)
- or $Carp::Frontend->mydie("Couldn't open $locf: $!");
- my $inpod = 0;
- local $/ = "\n";
- while (<$fh>) {
- $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
- m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
- next unless $inpod;
- next if /^=/;
- next if /^\s+$/;
- chomp;
- push @result, $_;
- }
- close $fh;
- last if @result;
- }
- for (@result) {
- s/^\s+//;
- s/\s+$//;
- }
- join " ", @result;
+ my($self,$local_file) = @_;
+ my(@local_file) = $local_file;
+ $local_file =~ s/\.pm(?!\n)\Z/.pod/;
+ push @local_file, $local_file;
+ my(@result,$locf);
+ for $locf (@local_file) {
+ next unless -f $locf;
+ my $fh = FileHandle->new($locf)
+ or $Carp::Frontend->mydie("Couldn't open $locf: $!");
+ my $inpod = 0;
+ local $/ = "\n";
+ while (<$fh>) {
+ $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
+ m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
+ next unless $inpod;
+ next if /^=/;
+ next if /^\s+$/;
+ chomp;
+ push @result, $_;
+ }
+ close $fh;
+ last if @result;
+ }
+ for (@result) {
+ s/^\s+//;
+ s/\s+$//;
+ }
+ join " ", @result;
}
#-> sub CPAN::Module::cpan_file ;
my $self = shift;
# CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
unless ($self->ro) {
- CPAN::Index->reload;
+ CPAN::Index->reload;
}
my $ro = $self->ro;
- if ($ro && defined $ro->{CPAN_FILE}){
- return $ro->{CPAN_FILE};
+ if ($ro && defined $ro->{CPAN_FILE}) {
+ return $ro->{CPAN_FILE};
} else {
my $userid = $self->userid;
if ( $userid ) {
$ro = {};
}
$ro->{CPAN_VERSION} = 'undef'
- unless defined $ro->{CPAN_VERSION};
+ unless defined $ro->{CPAN_VERSION};
$ro->{CPAN_VERSION};
}
#-> 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 ;
$meth,
$self->id));
my $cpan_file = $self->cpan_file;
- if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
- $CPAN::Frontend->mywarn(sprintf qq{
+ if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
+ $CPAN::Frontend->mywarn(sprintf qq{
The module %s isn\'t available on CPAN.
Either the module has not yet been uploaded to CPAN, or it is
temporary unavailable. Please contact the author to find out
more about the status. Try 'i %s'.
},
- $self->id,
- $self->id,
- );
- return;
+ $self->id,
+ $self->id,
+ );
+ return;
}
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}]".
$pack->{reqtype} = $self->{reqtype};
}
- eval {
- $pack->$meth();
+ 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;
+ 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 ;
sub uptodate {
- my($self) = @_;
- local($_); # protect against a bug in MakeMaker 6.17
- my($latest) = $self->cpan_version;
- $latest ||= 0;
- my($inst_file) = $self->inst_file;
- my($have) = 0;
- if (defined $inst_file) {
- $have = $self->inst_version;
- }
- local($^W)=0;
- if ($inst_file
- &&
- ! CPAN::Version->vgt($latest, $have)
- ) {
- CPAN->debug("returning uptodate. inst_file[$inst_file] ".
- "latest[$latest] have[$have]") if $CPAN::DEBUG;
- return 1;
- }
- return;
+ my ($self) = @_;
+ local ($_);
+ my $inst = $self->inst_version or return undef;
+ my $cpan = $self->cpan_version;
+ local ($^W) = 0;
+ CPAN::Version->vgt($cpan,$inst) and return 0;
+ CPAN->debug(join("",
+ "returning uptodate. inst_file[",
+ $self->inst_file,
+ "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
+ return 1;
}
+
#-> sub CPAN::Module::install ;
sub install {
my($self) = @_;
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",
+ $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
$self->id,
$self->inst_version,
));
} else {
- $doit = 1;
+ $doit = 1;
}
my $ro = $self->ro;
if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
#-> 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) {
- my $pmfile = File::Spec->catfile($dir,@packpath);
- if (-f $pmfile){
- return $pmfile;
- }
+ foreach $dir (@$path) {
+ my $pmfile = File::Spec->catfile($dir,@packpath);
+ if (-f $pmfile) {
+ return $pmfile;
+ }
}
return;
}
push @packpath, $packpath[-1];
$packpath[-1] .= "." . $Config::Config{'dlext'};
foreach $dir (@INC) {
- my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
- if (-f $xsfile){
- return $xsfile;
- }
+ my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
+ if (-f $xsfile) {
+ return $xsfile;
+ }
}
return;
}
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;
+}
+
+#-> sub CPAN::Module::inst_version ;
+sub available_version {
+ my($self) = @_;
+ my $parsefile = $self->available_file or return;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
- $have = MM->parse_version($parsefile);
+#-> 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
+
+Basic commands:
# Modules:
$do = CPAN::Shell->expand("Distribution",
$distro); # same thing
-=head1 STATUS
-
-This module and its competitor, the CPANPLUS module, are both much
-cooler than the other.
-
-=head1 COMPATIBILITY
-
-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.
-
=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
+
+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 'h' and the rest should be
-self-explanatory.
+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
The second form allows to limit or expand the output with shell
globbing as in the following examples:
- ls JV/make*
- ls GSAR/*make*
- ls */*make*
+ ls JV/make*
+ ls GSAR/*make*
+ ls */*make*
The last example is very slow and outputs extra progress indicators
that break the alignment of the result.
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>.
SIGTERM by sending two consecutive SIGINTs, which usually means by
pressing C<^C> twice.
-CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
+CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
Build.PL> subprocess.
=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
directory so that you can save your own preferences instead of the
system wide ones.
+=head2 recent ***EXPERIMENTAL COMMAND***
+
+The C<recent> command downloads a list of recent uploads to CPAN and
+displays them I<slowly>. While the command is running $SIG{INT} is
+defined to mean that the loop shall be left after having displayed the
+current item.
+
+B<Note>: This command requires XML::LibXML installed.
+
+B<Note>: This whole command currently is a bit klunky and will
+probably change in future versions of CPAN.pm but the general
+approach will likely stay.
+
+B<Note>: See also L<smoke>
+
=head2 recompile
recompile() is a very special command in that it takes no argument and
arguments. The C<force> pragma is used to re-run the tests and repeat
every step that might have failed before.
+=head2 smoke ***EXPERIMENTAL COMMAND***
+
+B<*** WARNING: this command downloads and executes software from CPAN to
+your computer of completely unknown status. You should never do
+this with your normal account and better have a dedicated well
+separated and secured machine to do this. ***>
+
+The C<smoke> command takes the list of recent uploads to CPAN as
+provided by the C<recent> command and tests them all. While the
+command is running $SIG{INT} is defined to mean that the current item
+shall be skipped.
+
+B<Note>: This whole command currently is a bit klunky and will
+probably change in future versions of CPAN.pm but the general
+approach will likely stay.
+
+B<Note>: See also L<recent>
+
=head2 upgrade [Module|/Regex/]...
The C<upgrade> command first runs an C<r> command with the given
=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,
-normally only needed by developers. If a distribution object ends with
-a dot or is a dot by itself, then it represents a local directory and
-all actions such as C<make>, C<test>, and C<install> are applied
+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
installation of the module in the current directory, be it a CPAN
module or not.
-=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(...)>). 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
-methods of the class CPAN::Shell. Each of the commands that produce
-listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
-the IDs of all modules within the list.
-
-=over 2
-
-=item expand($type,@things)
-
-The IDs of all objects available within a program are strings that can
-be expanded to the corresponding real objects with the
-C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
-list of CPAN::Module objects according to the C<@things> arguments
-given. In scalar context it only returns the first element of the
-list.
-
-=item expandany(@things)
-
-Like expand, but returns objects of the appropriate type, i.e.
-CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
-CPAN::Distribution objects for distributions. Note: it does not expand
-to CPAN::Author objects.
-
-=item Programming Examples
-
-This enables the programmer to do operations that combine
-functionalities that are available in the shell.
-
- # install everything that is outdated on my disk:
- perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
-
- # install my favorite programs if necessary:
- for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
- CPAN::Shell->install($mod);
- }
-
- # list all modules on my disk that have no VERSION number
- for $mod (CPAN::Shell->expand("Module","/./")){
- next unless $mod->inst_file;
- # MakeMaker convention for undefined $VERSION:
- next unless $mod->inst_version eq "undef";
- print "No VERSION in ", $mod->id, "\n";
- }
-
- # find out which distribution on CPAN contains a module:
- print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
-
-Or if you want to write a cronjob to watch The CPAN, you could list
-all modules that need updating. First a quick and dirty way:
-
- perl -e 'use CPAN; CPAN::Shell->r;'
-
-If you don't want to get any output in the case that all modules are
-up to date, you can parse the output of above command for the regular
-expression //modules are up to date// and decide to mail the output
-only if it doesn't match. Ick?
-
-If you prefer to do it more in a programmer style in one single
-process, maybe something like this suits you better:
-
- # list all modules on my disk that have newer versions on CPAN
- for $mod (CPAN::Shell->expand("Module","/./")){
- next unless $mod->inst_file;
- next if $mod->uptodate;
- printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
- $mod->id, $mod->inst_version, $mod->cpan_version;
- }
-
-If that gives you too much output every day, you maybe only want to
-watch for three modules. You can write
-
- for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
-
-as the first line instead. Or you can combine some of the above
-tricks:
-
- # watch only for a new mod_perl module
- $mod = CPAN::Shell->expand("Module","mod_perl");
- exit if $mod->uptodate;
- # new mod_perl arrived, let me know all update recommendations
- CPAN::Shell->r;
-
-=back
-
-=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()
+The typical usage case is for private modules or working copies of
+projects from remote repositories on the local disk.
-Returns a one-line description of the author
+=head1 CONFIGURATION
-=item CPAN::Author::as_string()
+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.
-Returns a multi-line description of the author
+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.
-=item CPAN::Author::email()
+The C<o conf> command has various bells and whistles:
-Returns the author's email address
+=over
-=item CPAN::Author::fullname()
+=item completion support
-Returns the author's name
+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 CPAN::Author::name()
+=item displaying some help: o conf help
-An alias for fullname
+Displays a short help
-=item CPAN::Bundle::as_glimpse()
+=item displaying current values: o conf [KEY]
-Returns a one-line description of the bundle
+Displays the current value(s) for this config variable. Without KEY
+displays all subcommands and config variables.
-=item CPAN::Bundle::as_string()
+Example:
-Returns a multi-line description of the bundle
+ o conf shell
-=item CPAN::Bundle::clean()
+If KEY starts and ends with a slash the string in between is
+interpreted as a regular expression and only keys matching this regex
+are displayed
-Recursively runs the C<clean> method on all items contained in the bundle.
+Example:
-=item CPAN::Bundle::contains()
+ o conf /color/
-Returns a list of objects' IDs contained in a bundle. The associated
-objects may be bundles, modules or distributions.
+=item changing of scalar values: o conf KEY VALUE
-=item CPAN::Bundle::force($method,@args)
+Sets the config variable KEY to VALUE. The empty string can be
+specified as usual in shells, with C<''> or C<"">
-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.
+Example:
-=item CPAN::Bundle::get()
+ o conf wget /usr/bin/wget
-Recursively runs the C<get> method on all items contained in the bundle
+=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
-=item CPAN::Bundle::inst_file()
+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.
-Returns the highest installed version of the bundle in either @INC or
-C<$CPAN::Config->{cpan_home}>. Note that this is different from
-CPAN::Module::inst_file.
+Likewise, C<o conf KEY splice LIST> passes the LIST to the according
+splice command.
-=item CPAN::Bundle::inst_version()
+Finally, any other list of arguments is taken as a new list value for
+the KEY variable discarding the previous value.
-Like CPAN::Bundle::inst_file, but returns the $VERSION
+Examples:
-=item CPAN::Bundle::uptodate()
+ 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
-Returns 1 if the bundle itself and all its members are uptodate.
+=item reverting to saved: o conf defaults
-=item CPAN::Bundle::install()
+Reverts all config variables to the state in the saved config file.
-Recursively runs the C<install> method on all items contained in the bundle
+=item saving the config: o conf commit
-=item CPAN::Bundle::make()
+Saves all config variables to the current config file (CPAN/Config.pm
+or CPAN/MyConfig.pm that was loaded at start).
-Recursively runs the C<make> method on all items contained in the bundle
+=back
-=item CPAN::Bundle::readme()
+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.
-Recursively runs the C<readme> method on all items contained in the bundle
+=head2 Config Variables
-=item CPAN::Bundle::test()
+Currently the following keys in the hash reference $CPAN::Config are
+defined:
-Recursively runs the C<test> method on all items contained in the bundle
+ 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)
+ load_module_verbosity
+ report loading of optional modules used by CPAN.pm
+ 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_unparsable_versions
+ boolean if r command tells which modules are versionless
+ show_upload_date boolean if commands should try to determine upload date
+ show_zero_versions boolean if r command tells for which modules $version==0
+ tar location of external program tar
+ tar_verbosity verbosity level for the tar command
+ term_is_latin deprecated: if true Unicode 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_load_code enable YAML code deserialisation
+ yaml_module which module to use to read/write YAML files
-=item CPAN::Distribution::as_glimpse()
+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.
-Returns a one-line description of the distribution
+=over 2
-=item CPAN::Distribution::as_string()
+=item C<o conf E<lt>scalar optionE<gt>>
-Returns a multi-line description of the distribution
+prints the current value of the I<scalar option>
-=item CPAN::Distribution::author
+=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
-Returns the CPAN::Author object of the maintainer who uploaded this
-distribution
+Sets the value of the I<scalar option> to I<value>
-=item CPAN::Distribution::clean()
+=item C<o conf E<lt>list optionE<gt>>
-Changes to the directory where the distribution has been unpacked and
-runs C<make clean> there.
+prints the current value of the I<list option> in MakeMaker's
+neatvalue format.
-=item CPAN::Distribution::containsmods()
+=item C<o conf E<lt>list optionE<gt> [shift|pop]>
-Returns a list of IDs of modules contained in a distribution file.
-Only works for distributions listed in the 02packages.details.txt.gz
-file. This typically means that only the most recent version of a
-distribution is covered.
+shifts or pops the array in the I<list option> variable
-=item CPAN::Distribution::cvs_import()
+=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
-Changes to the directory where the distribution has been unpacked and
-runs something like
+works like the corresponding perl commands.
- cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
+=item interactive editing: o conf init [MATCH|LIST]
-there.
+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.
-=item CPAN::Distribution::dir()
+Examples:
-Returns the directory into which this distribution has been unpacked.
+ o conf init ftp_passive ftp_proxy
+ o conf init /color/
-=item CPAN::Distribution::force($method,@args)
+Note: this method of setting config variables often provides more
+explanation about the functioning of a variable than the manpage.
-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.
+=back
-=item CPAN::Distribution::get()
+=head2 CPAN::anycwd($path): Note on config variable getcwd
-Downloads the distribution from CPAN and unpacks it. Does nothing if
-the distribution has already been downloaded and unpacked within the
-current session.
+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:
-=item CPAN::Distribution::install()
+=over 4
-Changes to the directory where the distribution has been unpacked and
-runs the external command C<make install> there. If C<make> has not
-yet been run, it will be run first. A C<make test> will be issued in
-any case and if this fails, the install will be canceled. The
-cancellation can be avoided by letting C<force> run the C<install> for
-you.
+=item cwd
-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.
+Calls Cwd::cwd
-Note that install() gives no meaningful return value. See uptodate().
+=item getcwd
-=item CPAN::Distribution::isa_perl()
+Calls Cwd::getcwd
-Returns 1 if this distribution file seems to be a perl distribution.
-Normally this is derived from the file name only, but the index from
-CPAN can contain a hint to achieve a return value of true for other
-filenames too.
+=item fastcwd
-=item CPAN::Distribution::look()
+Calls Cwd::fastcwd
-Changes to the directory where the distribution has been unpacked and
-opens a subshell there. Exiting the subshell returns.
+=item backtickcwd
-=item CPAN::Distribution::make()
+Calls the external command cwd.
-First runs the C<get> method to make sure the distribution is
-downloaded and unpacked. Changes to the directory where the
-distribution has been unpacked and runs the external commands C<perl
-Makefile.PL> or C<perl Build.PL> and C<make> there.
+=back
-=item CPAN::Distribution::perldoc()
+=head2 Note on the format of the urllist parameter
-Downloads the pod documentation of the file associated with a
-distribution (in html format) and runs it through the external
-command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
-isn't available, it converts it to plain text with external
-command html2text and runs it through the pager specified
-in C<$CPAN::Config->{pager}>
+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:
-=item CPAN::Distribution::prefs()
+ file://localhost/whatever/ftp/pub/CPAN/
-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.
+or
-=item CPAN::Distribution::prereq_pm()
+ file:///home/ftp/pub/CPAN/
-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.
+=head2 The urllist parameter has CD-ROM support
-=item CPAN::Distribution::readme()
+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.
-Downloads the README file associated with a distribution and runs it
-through the pager specified in C<$CPAN::Config->{pager}>.
+ o conf urllist push file://localhost/CDROM/CPAN
-=item CPAN::Distribution::read_yaml()
+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.
-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. Also returns undef if the content of META.yml
-is dynamic.
+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.
-=item CPAN::Distribution::test()
+=head2 Maintaining the urllist parameter
-Changes to the directory where the distribution has been unpacked and
-runs C<make test> there.
+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.
-=item CPAN::Distribution::uptodate()
+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.
-Returns 1 if all the modules contained in the distribution are
-uptodate. Relies on containsmods.
+=head2 The C<requires> and C<build_requires> dependency declarations
-=item CPAN::Index::force_reload()
+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.
-Forces a reload of all indices.
+=head2 Configuration for individual distributions (I<Distroprefs>)
-=item CPAN::Index::reload()
+(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
+still considered beta quality)
-Reloads all indices if they have not been read for more than
-C<$CPAN::Config->{index_expire}> days.
+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:
-=item CPAN::InfoObj::dump()
+ perl Makefile.PL perl Build.PL
+ make ./Build
+ make test ./Build test
+ make install ./Build install
-CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
-inherit this method. It prints the data structure associated with an
-object. Useful for debugging. Note: the data structure is considered
-internal and thus subject to change without notice.
+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.
-=item CPAN::Module::as_glimpse()
+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
-Returns a one-line description of the module in four columns: The
-first column contains the word C<Module>, the second column consists
-of one character: an equals sign if this module is already installed
-and uptodate, a less-than sign if this module is installed but can be
-upgraded, and a space if the module is not installed. The third column
-is the name of the module and the fourth column gives maintainer or
-distribution information.
+=over
-=item CPAN::Module::as_string()
+=item
-Returns a multi-line description of the module
+pass additional arguments to one of the four commands,
-=item CPAN::Module::clean()
+=item
-Runs a clean on the distribution associated with this module.
+set environment variables
-=item CPAN::Module::cpan_file()
+=item
-Returns the filename on CPAN that is associated with the module.
+instantiate an Expect object that reads from the console, waits for
+some regular expressions and enters some answers
-=item CPAN::Module::cpan_version()
+=item
-Returns the latest version of this module available on CPAN.
+temporarily override assorted C<CPAN.pm> configuration variables
-=item CPAN::Module::cvs_import()
+=item
-Runs a cvs_import on the distribution associated with this module.
+specify dependencies that the original maintainer forgot to specify
-=item CPAN::Module::description()
+=item
-Returns a 44 character description of this module. Only available for
-modules listed in The Module List (CPAN/modules/00modlist.long.html
-or 00modlist.long.txt.gz)
+disable the installation of an object altogether
-=item CPAN::Module::distribution()
+=back
-Returns the CPAN::Distribution object that contains the current
-version of this module.
+See the YAML and Data::Dumper files that come with the C<CPAN.pm>
+distribution in the C<distroprefs/> directory for examples.
-=item CPAN::Module::dslip_status()
+=head2 Filenames
-Returns a hash reference. The keys of the hash are the letters C<D>,
-C<S>, C<L>, C<I>, and <P>, for development status, support level,
-language, interface and public licence respectively. The data for the
-DSLIP status are collected by pause.perl.org when authors register
-their namespaces. The values of the 5 hash elements are one-character
-words whose meaning is described in the table below. There are also 5
-hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
-verbose value of the 5 status variables.
+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.
-Where the 'DSLIP' characters have the following meanings:
+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.
- D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
- i - Idea, listed to gain consensus or as a placeholder
- c - under construction but pre-alpha (not yet released)
- a/b - Alpha/Beta testing
- R - Released
- M - Mature (no rigorous definition)
- S - Standard, supplied with Perl 5
+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.
- S - Support Level:
- m - Mailing-list
- d - Developer
- u - Usenet newsgroup comp.lang.perl.modules
- n - None known, try comp.lang.perl.modules
- a - abandoned; volunteers welcome to take over maintainance
+=head2 Fallback Data::Dumper and Storable
- L - Language Used:
- p - Perl-only, no compiler needed, should be platform independent
- c - C and perl, a C compiler will be needed
- h - Hybrid, written in perl with optional C code, no compiler needed
- + - C++ and perl, a C++ compiler will be needed
- o - perl and another language other than C or C++
+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
- I - Interface Style
- f - plain Functions, no references used
- h - hybrid, object and function interfaces available
- n - no interface at all (huh?)
- r - some use of unblessed References or ties
- O - Object oriented using blessed references and/or inheritance
+ ysh < somefile.yml > somefile.dd
- P - Public License
- p - Standard-Perl: user may choose between GPL and Artistic
- g - GPL: GNU General Public License
- l - LGPL: "GNU Lesser General Public License" (previously known as
- "GNU Library General Public License")
- b - BSD: The BSD License
- a - Artistic license alone
- o - open source: appoved by www.opensource.org
- d - allows distribution without restrictions
- r - restricted distribtion
- n - no license at all
+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:
-=item CPAN::Module::force($method,@args)
+ perl -MYAML=LoadFile -MStorable=nstore -e '
+ @y=LoadFile(shift);
+ nstore(\@y, shift)' somefile.yml somefile.st
-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.
+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.
-=item CPAN::Module::get()
+=head2 Blueprint
-Runs a get on the distribution associated with this module.
+The following example contains all supported keywords and structures
+with the exception of C<eexpect> which can be used instead of
+C<expect>.
-=item CPAN::Module::inst_file()
+ ---
+ 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"
-Returns the filename of the module found in @INC. The first file found
-is reported just like perl itself stops searching @INC when it finds a
-module.
+ env: {}
-=item CPAN::Module::inst_version()
+ expect:
+ - "Which is your favorite fruit"
+ - "apple\n"
-Returns the version number of the module in readable format.
+ make:
+ args:
+ - all
+ - extra-all
-=item CPAN::Module::install()
+ env: {}
-Runs an C<install> on the distribution associated with this module.
+ expect: []
-=item CPAN::Module::look()
+ commendline: "echo SKIPPING make"
-Changes to the directory where the distribution associated with this
-module has been unpacked and opens a subshell there. Exiting the
-subshell returns.
+ test:
+ args: []
-=item CPAN::Module::make()
+ env: {}
-Runs a C<make> on the distribution associated with this module.
+ expect: []
-=item CPAN::Module::manpage_headline()
+ install:
+ args: []
-If module is installed, peeks into the module's manpage, reads the
-headline and returns it. Moreover, if the module has been downloaded
-within this session, does the equivalent on the downloaded module even
-if it is not installed.
+ env:
+ WANT_TO_INSTALL: YES
-=item CPAN::Module::perldoc()
+ expect:
+ - "Do you really want to install"
+ - "y\n"
-Runs a C<perldoc> on this module.
+ patches:
+ - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
-=item CPAN::Module::readme()
+ depends:
+ configure_requires:
+ LWP: 5.8
+ build_requires:
+ Test::Exception: 0.25
+ requires:
+ Spiffy: 0.30
-Runs a C<readme> on the distribution associated with this module.
-=item CPAN::Module::test()
+=head2 Language Specs
-Runs a C<test> on the distribution associated with this module.
+Every YAML document represents a single hash reference. The valid keys
+in this hash are as follows:
-=item CPAN::Module::uptodate()
+=over
-Returns 1 if the module is installed and up-to-date.
+=item comment [scalar]
-=item CPAN::Module::userid()
+A comment
-Returns the author's ID of the module.
+=item cpanconfig [hash]
-=back
+Temporarily override assorted C<CPAN.pm> configuration variables.
-=head2 Cache Manager
+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.
-Currently the cache manager only keeps track of the build directory
-($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
-deletes complete directories below C<build_dir> as soon as the size of
-all directories there gets bigger than $CPAN::Config->{build_cache}
-(in MB). The contents of this cache may be used for later
-re-installations that you intend to do manually, but will never be
-trusted by CPAN itself. This is due to the fact that the user might
-use these directories for building modules on different architectures.
+=item depends [hash] *** EXPERIMENTAL FEATURE ***
-There is another directory ($CPAN::Config->{keep_source_where}) where
-the original distribution files are kept. This directory is not
-covered by the cache manager and must be controlled by the user. If
-you choose to have the same directory as build_dir and as
-keep_source_where directory, then your sources will be deleted with
-the same fifo mechanism.
+All three types, namely C<configure_requires>, C<build_requires>, and
+C<requires> are supported in the way specified in the META.yml
+specification. The current implementation I<merges> the specified
+dependencies with those declared by the package maintainer. In a
+future implementation this may be changed to override the original
+declaration.
-=head2 Bundles
+=item disabled [boolean]
-A bundle is just a perl module in the namespace Bundle:: that does not
-define any functions or methods. It usually only contains documentation.
+Specifies that this distribution shall not be processed at all.
-It starts like a perl module with a package declaration and a $VERSION
-variable. After that the pod section looks like any other pod with the
-only difference being that I<one special pod section> exists starting with
-(verbatim):
+=item goto [string]
- =head1 CONTENTS
+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.
-In this pod section each line obeys the format
+=item install [hash]
- Module_Name [Version_String] [- optional text]
+Processing instructions for the C<make install> or C<./Build install>
+phase of the CPAN mantra. See below under I<Processiong Instructions>.
-The only required part is the first field, the name of a module
-(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
-of the line is optional. The comment part is delimited by a dash just
-as in the man page header.
+=item make [hash]
-The distribution of a bundle should follow the same convention as
-other distributions.
+Processing instructions for the C<make> or C<./Build> phase of the
+CPAN mantra. See below under I<Processiong Instructions>.
-Bundles are treated specially in the CPAN package. If you say 'install
-Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
-the modules in the CONTENTS section of the pod. You can install your
-own Bundles locally by placing a conformant Bundle file somewhere into
-your @INC path. The autobundle() command which is available in the
-shell interface does that for you by including all currently installed
-modules in a snapshot bundle file.
+=item match [hash]
-=head1 PREREQUISITES
+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.
-If you have a local mirror of CPAN and can access all files with
-"file:" URLs, then you only need a perl better than perl5.003 to run
-this module. Otherwise Net::FTP is strongly recommended. LWP may be
-required for non-UNIX systems or if your nearest CPAN site is
-associated with a URL that is not C<ftp:>.
+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".
-If you have neither Net::FTP nor LWP, there is a fallback mechanism
-implemented for an external ftp command or for an external lynx
-command.
+The C<module> related one will be matched against I<all> modules
+contained in the distribution until one module matches.
-=head1 UTILITIES
+The C<perl> related one will be matched against C<$^X> (but with the
+absolute path).
-=head2 Finding packages and VERSION
+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.
-This module presumes that all packages on CPAN
+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.
-=over 2
+=item patches [array]
-=item *
+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.
-declare their $VERSION variable in an easy to parse manner. This
-prerequisite can hardly be relaxed because it consumes far too much
-memory to load all packages into the running program just to determine
-the $VERSION variable. Currently all programs that are dealing with
-version use something like this
+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.
- perl -MExtUtils::MakeMaker -le \
- 'print MM->parse_version(shift)' filename
+=item pl [hash]
-If you are author of a package and wonder if your $VERSION can be
-parsed, please try the above method.
+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 *
+=item test [hash]
-come as compressed or gzipped tarfiles or as zip files and contain a
-C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
-without much enthusiasm).
+Processing instructions for the C<make test> or C<./Build test> phase
+of the CPAN mantra. See below under I<Processiong Instructions>.
=back
-=head2 Debugging
-
-The debugging of this module is a bit complex, because we have
-interferences of the software producing the indices on CPAN, of the
-mirroring process on CPAN, of packaging, of configuration, of
-synchronicity, and of bugs within CPAN.pm.
+=head2 Processing Instructions
-For debugging the code of CPAN.pm itself in interactive mode some more
-or less useful debugging aid can be turned on for most packages within
-CPAN.pm with one of
+=over
-=over 2
+=item args [array]
-=item o debug package...
+Arguments to be added to the command line
-sets debug mode for packages.
+=item commandline
-=item o debug -package...
+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 (but with an absolute path). If C<commandline> is specified,
+the content of C<args> is not used.
-unsets debug mode for packages.
+=item eexpect [hash]
-=item o debug all
+Extended C<expect>. This is a hash reference with four allowed keys,
+C<mode>, C<timeout>, C<reuse>, and C<talk>.
-turns debugging on for all packages.
+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>.
-=item o debug number
+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.
-=back
+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.).
-which sets the debugging packages directly. Note that C<o debug 0>
-turns debugging off.
+In the case of C<mode=deterministic> the CPAN.pm will inject the
+according answer as soon as the stream matches the regular expression.
-What seems quite a successful strategy is the combination of C<reload
-cpan> and the debugging switches. Add a new debug statement while
-running in the shell and then issue a C<reload cpan> and see the new
-debugging messages immediately without losing the current context.
+In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
+as the timeout is reached for the next byte in the input stream. In
+this mode you can use the C<reuse> parameter to decide what shall
+happen with a question-answer pair after it has been used. In the
+default case (reuse=0) it is removed from the array, so it cannot be
+used again accidentally. In this case, 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. Setting the parameter C<reuse> to 1 makes this repetition
+unnecessary.
-C<o debug> without an argument lists the valid package names and the
-current set of packages in debugging mode. C<o debug> has built-in
-completion support.
+=item env [hash]
-For debugging of CPAN data there is the C<dump> command which takes
-the same arguments as make/test/install and outputs each object's
-Data::Dumper dump. If an argument looks like a perl variable and
-contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
-Data::Dumper directly.
+Environment variables to be set during the command
-=head2 Floppy, Zip, Offline Mode
+=item expect [array]
-CPAN.pm works nicely without network too. If you maintain machines
-that are not networked at all, you should consider working with file:
-URLs. Of course, you have to collect your modules somewhere first. So
-you might use CPAN.pm to put together all you need on a networked
-machine. Then copy the $CPAN::Config->{keep_source_where} (but not
-$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
-of a personal CPAN. CPAN.pm on the non-networked machines works nicely
-with this floppy. See also below the paragraph about CD-ROM support.
+C<< expect: <array> >> is a short notation for
-=head2 Basic Utilities for Programmers
+ eexpect:
+ mode: deterministic
+ timeout: 15
+ talk: <array>
-=over 2
+=back
-=item has_inst($module)
+=head2 Schema verification with C<Kwalify>
-Returns true if the module is installed. See the source for details.
+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.
-=item has_usable($module)
+=head2 Example Distroprefs Files
-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.
+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:-)
-=item instance($module)
+=head1 PROGRAMMER'S INTERFACE
-The constructor for all the singletons used to represent modules,
-distributions, authors and bundles. If the object already exists, this
-method returns the object, otherwise it calls the constructor.
+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(...)>). Before calling low-level
+commands it makes sense to initialize components of CPAN you need, e.g.:
-=back
+ CPAN::HandleConfig->load;
+ CPAN::Shell::setup_output;
+ CPAN::Index->reload;
-=head1 CONFIGURATION
+High-level commands do such initializations automatically.
-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.
+There's currently only one class that has a stable interface -
+CPAN::Shell. All commands that are available in the CPAN shell are
+methods of the class CPAN::Shell. Each of the commands that produce
+listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
+the IDs of all modules within the list.
-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.
+=over 2
-The C<o conf> command has various bells and whistles:
+=item expand($type,@things)
-=over
+The IDs of all objects available within a program are strings that can
+be expanded to the corresponding real objects with the
+C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
+list of CPAN::Module objects according to the C<@things> arguments
+given. In scalar context it only returns the first element of the
+list.
-=item completion support
+=item expandany(@things)
-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.
+Like expand, but returns objects of the appropriate type, i.e.
+CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
+CPAN::Distribution objects for distributions. Note: it does not expand
+to CPAN::Author objects.
-=item displaying some help: o conf help
+=item Programming Examples
-Displays a short help
+This enables the programmer to do operations that combine
+functionalities that are available in the shell.
-=item displaying current values: o conf [KEY]
+ # install everything that is outdated on my disk:
+ perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
-Displays the current value(s) for this config variable. Without KEY
-displays all subcommands and config variables.
+ # install my favorite programs if necessary:
+ for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
+ CPAN::Shell->install($mod);
+ }
-Example:
+ # list all modules on my disk that have no VERSION number
+ for $mod (CPAN::Shell->expand("Module","/./")) {
+ next unless $mod->inst_file;
+ # MakeMaker convention for undefined $VERSION:
+ next unless $mod->inst_version eq "undef";
+ print "No VERSION in ", $mod->id, "\n";
+ }
- o conf shell
+ # find out which distribution on CPAN contains a module:
+ print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
-=item changing of scalar values: o conf KEY VALUE
+Or if you want to write a cronjob to watch The CPAN, you could list
+all modules that need updating. First a quick and dirty way:
-Sets the config variable KEY to VALUE. The empty string can be
-specified as usual in shells, with C<''> or C<"">
+ perl -e 'use CPAN; CPAN::Shell->r;'
-Example:
+If you don't want to get any output in the case that all modules are
+up to date, you can parse the output of above command for the regular
+expression //modules are up to date// and decide to mail the output
+only if it doesn't match. Ick?
- o conf wget /usr/bin/wget
+If you prefer to do it more in a programmer style in one single
+process, maybe something like this suits you better:
-=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
+ # list all modules on my disk that have newer versions on CPAN
+ for $mod (CPAN::Shell->expand("Module","/./")) {
+ next unless $mod->inst_file;
+ next if $mod->uptodate;
+ printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
+ $mod->id, $mod->inst_version, $mod->cpan_version;
+ }
-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.
+If that gives you too much output every day, you maybe only want to
+watch for three modules. You can write
-Likewise, C<o conf KEY splice LIST> passes the LIST to the according
-splice command.
+ for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
-Finally, any other list of arguments is taken as a new list value for
-the KEY variable discarding the previous value.
+as the first line instead. Or you can combine some of the above
+tricks:
-Examples:
+ # watch only for a new mod_perl module
+ $mod = CPAN::Shell->expand("Module","mod_perl");
+ exit if $mod->uptodate;
+ # new mod_perl arrived, let me know all update recommendations
+ CPAN::Shell->r;
- 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
+=back
-=item interactive editing: o conf init [MATCH|LIST]
+=head2 Methods in the other Classes
-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.
+=over 4
-Examples:
+=item CPAN::Author::as_glimpse()
- o conf init ftp_passive ftp_proxy
- o conf init /color/
+Returns a one-line description of the author
-=item reverting to saved: o conf defaults
+=item CPAN::Author::as_string()
-Reverts all config variables to the state in the saved config file.
+Returns a multi-line description of the author
-=item saving the config: o conf commit
+=item CPAN::Author::email()
-Saves all config variables to the current config file (CPAN/Config.pm
-or CPAN/MyConfig.pm that was loaded at start).
+Returns the author's email address
-=back
+=item CPAN::Author::fullname()
-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.
+Returns the author's name
-=head2 Config Variables
+=item CPAN::Author::name()
-Currently the following keys in the hash reference $CPAN::Config are
-defined:
+An alias for fullname
- 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_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)
- 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
+=item CPAN::Bundle::as_glimpse()
+
+Returns a one-line description of the bundle
+
+=item CPAN::Bundle::as_string()
+
+Returns a multi-line description of the bundle
+
+=item CPAN::Bundle::clean()
+
+Recursively runs the C<clean> method on all items contained in the bundle.
+
+=item CPAN::Bundle::contains()
+
+Returns a list of objects' IDs contained in a bundle. The associated
+objects may be bundles, modules or distributions.
+
+=item CPAN::Bundle::force($method,@args)
+
+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()
+
+Recursively runs the C<get> method on all items contained in the bundle
+
+=item CPAN::Bundle::inst_file()
+
+Returns the highest installed version of the bundle in either @INC or
+C<$CPAN::Config->{cpan_home}>. Note that this is different from
+CPAN::Module::inst_file.
+
+=item CPAN::Bundle::inst_version()
+
+Like CPAN::Bundle::inst_file, but returns the $VERSION
+
+=item CPAN::Bundle::uptodate()
+
+Returns 1 if the bundle itself and all its members are uptodate.
+
+=item CPAN::Bundle::install()
+
+Recursively runs the C<install> method on all items contained in the bundle
+
+=item CPAN::Bundle::make()
+
+Recursively runs the C<make> method on all items contained in the bundle
+
+=item CPAN::Bundle::readme()
+
+Recursively runs the C<readme> method on all items contained in the bundle
+
+=item CPAN::Bundle::test()
+
+Recursively runs the C<test> method on all items contained in the bundle
+
+=item CPAN::Distribution::as_glimpse()
+
+Returns a one-line description of the distribution
+
+=item CPAN::Distribution::as_string()
+
+Returns a multi-line description of the distribution
+
+=item CPAN::Distribution::author
+
+Returns the CPAN::Author object of the maintainer who uploaded this
+distribution
+
+=item CPAN::Distribution::pretty_id()
+
+Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
+author's PAUSE ID and TARBALL is the distribution filename.
+
+=item CPAN::Distribution::base_id()
+
+Returns the distribution filename without any archive suffix. E.g
+"Foo-Bar-0.01"
+
+=item CPAN::Distribution::clean()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make clean> there.
+
+=item CPAN::Distribution::containsmods()
+
+Returns a list of IDs of modules contained in a distribution file.
+Only works for distributions listed in the 02packages.details.txt.gz
+file. This typically means that only the most recent version of a
+distribution is covered.
+
+=item CPAN::Distribution::cvs_import()
+
+Changes to the directory where the distribution has been unpacked and
+runs something like
+
+ cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
+
+there.
+
+=item CPAN::Distribution::dir()
+
+Returns the directory into which this distribution has been unpacked.
+
+=item CPAN::Distribution::force($method,@args)
+
+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()
+
+Downloads the distribution from CPAN and unpacks it. Does nothing if
+the distribution has already been downloaded and unpacked within the
+current session.
+
+=item CPAN::Distribution::install()
+
+Changes to the directory where the distribution has been unpacked and
+runs the external command C<make install> there. If C<make> has not
+yet been run, it will be run first. A C<make test> will be issued in
+any case and if this fails, the install will be canceled. The
+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.
+Normally this is derived from the file name only, but the index from
+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
+opens a subshell there. Exiting the subshell returns.
+
+=item CPAN::Distribution::make()
+
+First runs the C<get> method to make sure the distribution is
+downloaded and unpacked. Changes to the directory where the
+distribution has been unpacked and runs the external commands C<perl
+Makefile.PL> or C<perl Build.PL> and C<make> there.
+
+=item CPAN::Distribution::perldoc()
+
+Downloads the pod documentation of the file associated with a
+distribution (in html format) and runs it through the external
+command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
+isn't available, it converts it to plain text with external
+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 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. 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()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make test> there.
+
+=item CPAN::Distribution::uptodate()
+
+Returns 1 if all the modules contained in the distribution are
+uptodate. Relies on containsmods.
+
+=item CPAN::Index::force_reload()
+
+Forces a reload of all indices.
+
+=item CPAN::Index::reload()
+
+Reloads all indices if they have not been read for more than
+C<$CPAN::Config->{index_expire}> days.
+
+=item CPAN::InfoObj::dump()
+
+CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
+inherit this method. It prints the data structure associated with an
+object. Useful for debugging. Note: the data structure is considered
+internal and thus subject to change without notice.
+
+=item CPAN::Module::as_glimpse()
+
+Returns a one-line description of the module in four columns: The
+first column contains the word C<Module>, the second column consists
+of one character: an equals sign if this module is already installed
+and uptodate, a less-than sign if this module is installed but can be
+upgraded, and a space if the module is not installed. The third column
+is the name of the module and the fourth column gives maintainer or
+distribution information.
+
+=item CPAN::Module::as_string()
+
+Returns a multi-line description of the module
+
+=item CPAN::Module::clean()
+
+Runs a clean on the distribution associated with this module.
+
+=item CPAN::Module::cpan_file()
+
+Returns the filename on CPAN that is associated with the module.
+
+=item CPAN::Module::cpan_version()
+
+Returns the latest version of this module available on CPAN.
+
+=item CPAN::Module::cvs_import()
+
+Runs a cvs_import on the distribution associated with this module.
+
+=item CPAN::Module::description()
+
+Returns a 44 character description of this module. Only available for
+modules listed in The Module List (CPAN/modules/00modlist.long.html
+or 00modlist.long.txt.gz)
+
+=item CPAN::Module::distribution()
+
+Returns the CPAN::Distribution object that contains the current
+version of this module.
+
+=item CPAN::Module::dslip_status()
+
+Returns a hash reference. The keys of the hash are the letters C<D>,
+C<S>, C<L>, C<I>, and <P>, for development status, support level,
+language, interface and public licence respectively. The data for the
+DSLIP status are collected by pause.perl.org when authors register
+their namespaces. The values of the 5 hash elements are one-character
+words whose meaning is described in the table below. There are also 5
+hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
+verbose value of the 5 status variables.
+
+Where the 'DSLIP' characters have the following meanings:
+
+ D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
+ i - Idea, listed to gain consensus or as a placeholder
+ c - under construction but pre-alpha (not yet released)
+ a/b - Alpha/Beta testing
+ R - Released
+ M - Mature (no rigorous definition)
+ S - Standard, supplied with Perl 5
+
+ S - Support Level:
+ m - Mailing-list
+ d - Developer
+ u - Usenet newsgroup comp.lang.perl.modules
+ n - None known, try comp.lang.perl.modules
+ a - abandoned; volunteers welcome to take over maintainance
+
+ L - Language Used:
+ p - Perl-only, no compiler needed, should be platform independent
+ c - C and perl, a C compiler will be needed
+ h - Hybrid, written in perl with optional C code, no compiler needed
+ + - C++ and perl, a C++ compiler will be needed
+ o - perl and another language other than C or C++
+
+ I - Interface Style
+ f - plain Functions, no references used
+ h - hybrid, object and function interfaces available
+ n - no interface at all (huh?)
+ r - some use of unblessed References or ties
+ O - Object oriented using blessed references and/or inheritance
+
+ P - Public License
+ p - Standard-Perl: user may choose between GPL and Artistic
+ g - GPL: GNU General Public License
+ l - LGPL: "GNU Lesser General Public License" (previously known as
+ "GNU Library General Public License")
+ b - BSD: The BSD License
+ a - Artistic license alone
+ 2 - Artistic license 2.0 or later
+ o - open source: appoved by www.opensource.org
+ d - allows distribution without restrictions
+ r - restricted distribtion
+ n - no license at all
+
+=item CPAN::Module::force($method,@args)
+
+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()
+
+Runs a get on the distribution associated with this module.
+
+=item CPAN::Module::inst_file()
+
+Returns the filename of the module found in @INC. The first file found
+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 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 an C<install> on the distribution associated with this module.
+
+=item CPAN::Module::look()
+
+Changes to the directory where the distribution associated with this
+module has been unpacked and opens a subshell there. Exiting the
+subshell returns.
+
+=item CPAN::Module::make()
+
+Runs a C<make> on the distribution associated with this module.
+
+=item CPAN::Module::manpage_headline()
+
+If module is installed, peeks into the module's manpage, reads the
+headline and returns it. Moreover, if the module has been downloaded
+within this session, does the equivalent on the downloaded module even
+if it is not installed.
-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:
+=item CPAN::Module::perldoc()
-=over 2
+Runs a C<perldoc> on this module.
-=item C<o conf E<lt>scalar optionE<gt>>
+=item CPAN::Module::readme()
-prints the current value of the I<scalar option>
+Runs a C<readme> on the distribution associated with this module.
-=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
+=item CPAN::Module::reports()
-Sets the value of the I<scalar option> to I<value>
+Calls the reports() method on the associated distribution object.
-=item C<o conf E<lt>list optionE<gt>>
+=item CPAN::Module::test()
-prints the current value of the I<list option> in MakeMaker's
-neatvalue format.
+Runs a C<test> on the distribution associated with this module.
-=item C<o conf E<lt>list optionE<gt> [shift|pop]>
+=item CPAN::Module::uptodate()
-shifts or pops the array in the I<list option> variable
+Returns 1 if the module is installed and up-to-date.
-=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
+=item CPAN::Module::userid()
-works like the corresponding perl commands.
+Returns the author's ID of the module.
=back
-=head2 CPAN::anycwd($path): Note on config variable getcwd
+=head2 Cache Manager
-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:
+Currently the cache manager only keeps track of the build directory
+($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
+deletes complete directories below C<build_dir> as soon as the size of
+all directories there gets bigger than $CPAN::Config->{build_cache}
+(in MB). The contents of this cache may be used for later
+re-installations that you intend to do manually, but will never be
+trusted by CPAN itself. This is due to the fact that the user might
+use these directories for building modules on different architectures.
+
+There is another directory ($CPAN::Config->{keep_source_where}) where
+the original distribution files are kept. This directory is not
+covered by the cache manager and must be controlled by the user. If
+you choose to have the same directory as build_dir and as
+keep_source_where directory, then your sources will be deleted with
+the same fifo mechanism.
+
+=head2 Bundles
+
+A bundle is just a perl module in the namespace Bundle:: that does not
+define any functions or methods. It usually only contains documentation.
+
+It starts like a perl module with a package declaration and a $VERSION
+variable. After that the pod section looks like any other pod with the
+only difference being that I<one special pod section> exists starting with
+(verbatim):
+
+ =head1 CONTENTS
+
+In this pod section each line obeys the format
+
+ Module_Name [Version_String] [- optional text]
+
+The only required part is the first field, the name of a module
+(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
+of the line is optional. The comment part is delimited by a dash just
+as in the man page header.
+
+The distribution of a bundle should follow the same convention as
+other distributions.
+
+Bundles are treated specially in the CPAN package. If you say 'install
+Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
+the modules in the CONTENTS section of the pod. You can install your
+own Bundles locally by placing a conformant Bundle file somewhere into
+your @INC path. The autobundle() command which is available in the
+shell interface does that for you by including all currently installed
+modules in a snapshot bundle file.
+
+=head1 PREREQUISITES
+
+If you have a local mirror of CPAN and can access all files with
+"file:" URLs, then you only need a perl better than perl5.003 to run
+this module. Otherwise Net::FTP is strongly recommended. LWP may be
+required for non-UNIX systems or if your nearest CPAN site is
+associated with a URL that is not C<ftp:>.
+
+If you have neither Net::FTP nor LWP, there is a fallback mechanism
+implemented for an external ftp command or for an external lynx
+command.
+
+=head1 UTILITIES
+
+=head2 Finding packages and VERSION
+
+This module presumes that all packages on CPAN
=over 2
-=item cwd
+=item *
-Calls Cwd::cwd
+declare their $VERSION variable in an easy to parse manner. This
+prerequisite can hardly be relaxed because it consumes far too much
+memory to load all packages into the running program just to determine
+the $VERSION variable. Currently all programs that are dealing with
+version use something like this
-=item getcwd
+ perl -MExtUtils::MakeMaker -le \
+ 'print MM->parse_version(shift)' filename
-Calls Cwd::getcwd
+If you are author of a package and wonder if your $VERSION can be
+parsed, please try the above method.
-=item fastcwd
+=item *
-Calls Cwd::fastcwd
+come as compressed or gzipped tarfiles or as zip files and contain a
+C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
+without much enthusiasm).
-=item backtickcwd
+=back
-Calls the external command cwd.
+=head2 Debugging
+
+The debugging of this module is a bit complex, because we have
+interferences of the software producing the indices on CPAN, of the
+mirroring process on CPAN, of packaging, of configuration, of
+synchronicity, and of bugs within CPAN.pm.
+
+For debugging the code of CPAN.pm itself in interactive mode some more
+or less useful debugging aid can be turned on for most packages within
+CPAN.pm with one of
+
+=over 2
+
+=item o debug package...
+
+sets debug mode for packages.
+
+=item o debug -package...
+
+unsets debug mode for packages.
+
+=item o debug all
+
+turns debugging on for all packages.
+
+=item o debug number
=back
-=head2 Note on the format of the urllist parameter
+which sets the debugging packages directly. Note that C<o debug 0>
+turns debugging off.
-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:
+What seems quite a successful strategy is the combination of C<reload
+cpan> and the debugging switches. Add a new debug statement while
+running in the shell and then issue a C<reload cpan> and see the new
+debugging messages immediately without losing the current context.
- file://localhost/whatever/ftp/pub/CPAN/
+C<o debug> without an argument lists the valid package names and the
+current set of packages in debugging mode. C<o debug> has built-in
+completion support.
-or
+For debugging of CPAN data there is the C<dump> command which takes
+the same arguments as make/test/install and outputs each object's
+Data::Dumper dump. If an argument looks like a perl variable and
+contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
+Data::Dumper directly.
- file:///home/ftp/pub/CPAN/
+=head2 Floppy, Zip, Offline Mode
-=head2 urllist parameter has CD-ROM support
+CPAN.pm works nicely without network too. If you maintain machines
+that are not networked at all, you should consider working with file:
+URLs. Of course, you have to collect your modules somewhere first. So
+you might use CPAN.pm to put together all you need on a networked
+machine. Then copy the $CPAN::Config->{keep_source_where} (but not
+$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
+of a personal CPAN. CPAN.pm on the non-networked machines works nicely
+with this floppy. See also below the paragraph about 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.
+=head2 Basic Utilities for Programmers
- o conf urllist push file://localhost/CDROM/CPAN
+=over 2
-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.
+=item has_inst($module)
-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.
+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:
-=head2 Maintaining the urllist parameter
+ cpan> o conf dontload_list push YAML
-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.
+See the source for details.
-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.
+=item has_usable($module)
-=head2 prefs_dir for avoiding interactive questions (ALPHA)
+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.
-(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
-still considered experimental and may still be changed)
-
-The files in the directory specified in C<prefs_dir> are YAML files
-that specify how CPAN.pm shall treat distributions that deviate from
-the normal non-interactive model of building and installing CPAN
-modules.
-
-Some modules try to get some data from the user interactively thus
-disturbing the installation of large bundles like Phalanx100 or
-modules like Plagger.
-
-CPAN.pm can use YAML files to either pass additional arguments to one
-of the four commands, set environment variables or instantiate an
-Expect object that reads from the console and enters answers on your
-behalf (latter option requires Expect.pm installed). A further option
-is to apply patches from the local disk or from CPAN.
-
-CPAN.pm comes with a couple of such YAML files. The structure is
-currently not documented because in flux. Please see the distroprefs
-directory of the CPAN distribution for examples and follow the README
-in there.
-
-Please note that setting the environment variable PERL_MM_USE_DEFAULT
-to a true value can also get you a long way if you want to always pick
-the default answers. But this only works if the author of a package
-used the prompt function provided by ExtUtils::MakeMaker and if the
-defaults are OK for you.
+=item instance($module)
+
+The constructor for all the singletons used to represent modules,
+distributions, authors and bundles. If the object already exists, this
+method returns the object, otherwise it calls the constructor.
+
+=back
=head1 SECURITY
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 CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
+to the ID of the running process. It also sets
+PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
+happen with older versions of Module::Install.
+
+When running C<perl Makefile.PL>, the environment variable
+C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
+C<Makefile.PL> that is being executed. This prevents runaway processes
+with newer versions of Module::Install.
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
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. That would
+be
+
+ o conf mbuildpl_arg "--lib=~/myperl/lib \
+ --installman1dir=~/myperl/man/man1 \
+ --installman3dir=~/myperl/man/man3 \
+ --installscript=~/myperl/bin \
+ --installbin=~/myperl/bin"
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
equivalent to the concept of the home directory on Unix.
Another thing you should bear in mind is that the UNINST parameter can
-be dnagerous when you are installing into a private area because you
+be dangerous when you are installing into a private area because you
might accidentally remove modules that other people depend on that are
not using the private area.
CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
the support or maybe UTF-8 terminals become widely available.
+Note: this config variable is deprecated and will be removed in a
+future version of CPAN.pm. It will be replaced with the conventions
+around the family of $LANG and $LC_* environment variables.
+
=item 11)
When an install fails for some reason and then I correct the error
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?
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)
http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
+=item 16)
+
+Why do I get asked the same questions every time I start the shell?
+
+You can make your configuration changes permanent by calling the
+command C<o conf commit>. Alternatively set the C<auto_commit>
+variable to true by running C<o conf init auto_commit> and answering
+the following question with yes.
+
=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 L<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
+L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
=head1 SEE ALSO
-cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
+L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
=cut
+
+
https://perl5.git.perl.org / perl5.git / blobdiff