# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
use strict;
package CPAN;
-$CPAN::VERSION = '1.88_76';
-$CPAN::VERSION = eval $CPAN::VERSION;
+$CPAN::VERSION = '1.9301';
+$CPAN::VERSION =~ s/_//;
+# we need to run chdir all over and we would get at wrong libraries
+# there
+use File::Spec ();
+BEGIN {
+ if (File::Spec->can("rel2abs")) {
+ for my $inc (@INC) {
+ $inc = File::Spec->rel2abs($inc) unless ref $inc;
+ }
+ }
+}
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 Cwd qw(chdir);
use DirHandle ();
use Exporter ();
use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
use File::Copy ();
use File::Find;
use File::Path ();
-use File::Spec ();
use FileHandle ();
use Fcntl qw(:flock);
use Safe ();
use Text::ParseWords ();
use Text::Wrap ();
-# 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);
- }
- }
-}
+# protect against "called too early"
+sub find_perl ();
+sub anycwd ();
+
no lib ".";
require Mac::BuildTools if $^O eq 'MacOS';
-$ENV{PERL5_CPAN_IS_RUNNING}=1;
+if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
+ $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
+ my $rec = $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} .= ",$$";
+ my @rec = split /,/, $rec;
+ # warn "# Note: Recursive call of CPAN.pm detected\n";
+ my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
+ my %sleep = (
+ 5 => 30,
+ 6 => 60,
+ 7 => 120,
+ );
+ my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
+ my $verbose = @rec >= 4;
+ while (@rec) {
+ $w .= sprintf " which has been called by process %d", pop @rec;
+ }
+ if ($sleep) {
+ $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
+ }
+ if ($verbose) {
+ warn $w;
+ }
+ local $| = 1;
+ while ($sleep > 0) {
+ printf "\r#%5d", --$sleep;
+ sleep 1;
+ }
+ print "\n";
+}
+$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")
}
"http://www.perl.org/CPAN/",
"ftp://ftp.perl.org/pub/CPAN/";
}
-# $CPAN::iCwd (i for initial) is going to be initialized during find_perl
+# $CPAN::iCwd (i for initial)
+$CPAN::iCwd ||= CPAN::anycwd();
$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(
$Be_Silent
$CONFIG_DIRTY
$Defaultdocs
- $Defaultrecent
+ $Echo_readline
$Frontend
$GOTOSHELL
$HAS_USABLE
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". }.
}
}
+{
+ my $x = *SAVEOUT; # avoid warning
+ open($x,">&STDOUT") or die "dup failed";
+ my $redir = 0;
+ sub _redirect(@) {
+ #die if $redir;
+ local $_;
+ push(@_,undef);
+ while(defined($_=shift)) {
+ if (s/^\s*>//){
+ my ($m) = s/^>// ? ">" : "";
+ s/\s+//;
+ $_=shift unless length;
+ die "no dest" unless defined;
+ open(STDOUT,">$m$_") or die "open:$_:$!\n";
+ $redir=1;
+ } elsif ( s/^\s*\|\s*// ) {
+ my $pipe="| $_";
+ while(defined($_[0])){
+ $pipe .= ' ' . shift;
+ }
+ open(STDOUT,$pipe) or die "open:$pipe:$!\n";
+ $redir=1;
+ } else {
+ push(@_,$_);
+ }
+ }
+ return @_;
+ }
+ sub _unredirect {
+ return unless $redir;
+ $redir = 0;
+ ## redirect: unredirect and propagate errors. explicit close to wait for pipe.
+ close(STDOUT);
+ open(STDOUT,">&SAVEOUT");
+ die "$@" if "$@";
+ ## redirect: done
+ }
+}
+
#-> sub CPAN::shell ;
sub shell {
my($self) = @_;
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");
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;
}
$META->checklock();
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 ($@ && "$@" =~ /\S/){
- require Carp;
- Carp::cluck("Catching error: '$@'");
- }
- if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
+ $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
+ my $command = shift @line;
+ eval {
+ local (*STDOUT)=*STDOUT;
+ @line = _redirect(@line);
+ CPAN::Shell->$command(@line)
+ };
+ _unredirect;
+ if ($@) {
+ my $err = "$@";
+ if ($err =~ /\S/) {
+ require Carp;
+ require Dumpvalue;
+ my $dv = Dumpvalue->new(tick => '"');
+ 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 _flock {
+ my($fh,$mode) = @_;
+ if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) {
+ return flock $fh, $mode;
+ } elsif (!$Have_warned->{"d_flock"}++) {
+ $CPAN::Frontend->mywarn("Your OS does not seem to 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 (
# $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;
}
return +[] unless -s $local_file;
my $yaml_module = _yaml_module;
if ($CPAN::META->has_inst($yaml_module)) {
- my $code;
+ # temporarly enable yaml code deserialisation
+ no strict 'refs';
+ # 5.6.2 could not do the local() with the reference
+ # so we do it manually instead
+ my $old_loadcode = ${"$yaml_module\::LoadCode"};
+ ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
+
+ my ($code, @yaml);
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;
}
+ ${"$yaml_module\::LoadCode"} = $old_loadcode;
+ return \@yaml;
} else {
# this shall not be done by the frontend
die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
package CPAN::CacheMgr;
use strict;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
+use Cwd qw(chdir);
use File::Find;
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
mkmyconfig
notest
perldoc
+ quit
readme
recent
recompile
reload
report
+ reports
scripts
+ smoke
test
upgrade
);
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 overload '""' => "as_string";
sub new {
- my($class,$module,$file,$during,$error) = shift;
+ my($class,$module,$file,$during,$error) = @_;
+ # my $at = Carp::longmess(""); # XXX find something more beautiful
bless { module => $module,
file => $file,
during => $during,
- error => $error }, $class;
+ error => $error,
+ # at => $at,
+ }, $class;
}
sub as_string {
my($self) = shift;
- "Alert: While trying to $self->{during} YAML file\n".
- " $self->{file}\n".
- "with '$self->{module}' the following error was encountered:\n".
- " $self->{error}\n";
+ 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";
package CPAN::Distrostatus;
use overload '""' => "as_string",
fallback => 1;
+use vars qw($something_has_failed_at);
sub new {
my($class,$arg) = @_;
+ my $failed = substr($arg,0,2) eq "NO";
+ if ($failed) {
+ $something_has_failed_at = $CPAN::CurrentCommandId;
+ }
bless {
TEXT => $arg,
- FAILED => substr($arg,0,2) eq "NO",
+ FAILED => $failed,
COMMANDID => $CPAN::CurrentCommandId,
TIME => time,
}, $class;
}
+sub something_has_just_failed () {
+ defined $something_has_failed_at &&
+ $something_has_failed_at == $CPAN::CurrentCommandId;
+}
sub commandid { shift->{COMMANDID} }
sub failed { shift->{FAILED} }
sub text {
$ADVANCED_QUERY
$AUTOLOAD
$COLOR_REGISTERED
+ $Help
$autoload_recursion
$reload
@ISA
+ @relo
);
+@relo = (
+ "CPAN.pm",
+ "CPAN/Debug.pm",
+ "CPAN/Distroprefs.pm",
+ "CPAN/FirstTime.pm",
+ "CPAN/HandleConfig.pm",
+ "CPAN/Kwalify.pm",
+ "CPAN/Queue.pm",
+ "CPAN/Reporter/Config.pm",
+ "CPAN/Reporter/History.pm",
+ "CPAN/Reporter/PrereqCheck.pm",
+ "CPAN/Reporter.pm",
+ "CPAN/SQLite.pm",
+ "CPAN/Tarzip.pm",
+ "CPAN/Version.pm",
+ );
+# record the initial timestamp for reload.
+$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
@CPAN::Shell::ISA = qw(CPAN::Debug);
+use Cwd qw(chdir);
$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 $^X ? (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' => $mtime_perl,
'mtime_dll' => $mtime_dll,
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 or $!{EPERM}) {
+ $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");
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 $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
+ $^X = $perl = $candidate if MM->maybe_command($candidate);
+ }
+ unless ($perl) {
+ 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)) {
+ $^X = $perl = $abs;
+ last DIST_PERLNAME;
+ }
+ }
+ }
}
-
return $perl;
}
],
'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 (Archive::Tar::->VERSION >= 1.00) {
+ 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};
#-> sub CPAN::readhist
sub readhist {
my($self,$term,$histfile) = @_;
+ my $histsize = $CPAN::Config->{'histsize'} || 100;
+ $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
my($fh) = FileHandle->new;
- open $fh, "<$histfile" or last;
+ open $fh, "<$histfile" or return;
local $/ = "\n";
while (<$fh>) {
chomp;
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;
$self->{is_tested}{$what} = $when;
}
+#-> sub CPAN::reset_tested
+# forget all distributions tested -- resets what gets included in PERL5LIB
+sub reset_tested {
+ my ($self) = @_;
+ $self->{is_tested} = {};
+}
+
#-> sub CPAN::is_installed
# unsets the is_tested flag: as soon as the thing is installed, it is
# not needed in set_perl5lib anymore
}
#-> sub CPAN::set_perl5lib
+# Notes on max environment variable length:
+# - Win32 : XP or later, 8191; Win2000 or NT4, 2047
+{
+my $fh;
sub set_perl5lib {
my($self,$for) = @_;
unless ($for) {
my $env = $ENV{PERL5LIB};
$env = $ENV{PERLLIB} unless defined $env;
my @env;
- push @env, $env if defined $env and length $env;
+ push @env, split /\Q$Config::Config{path_sep}\E/, $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")} $self->_list_sorted_descending_is_tested;
+ return if !@dirs;
+
if (@dirs < 12) {
- $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
- } elsif (@dirs < 24) {
+ $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ } 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; ".
+ $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
"%BUILDDIR%=$CPAN::Config->{build_dir} ".
"for '$for'\n"
);
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
} else {
my $cnt = keys %{$self->{is_tested}};
- $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
+ $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
"$cnt build dirs to PERL5LIB; ".
"for '$for'\n"
);
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
}
-
- $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
-}
+}}
package CPAN::CacheMgr;
use strict;
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}};
- unless ($toremove =~ /\.yml$/) {
- $CPAN::Frontend->myprint(sprintf(
- "DEL(%.1f>%.1fMB): %s \n",
- $self->{DU},
- $self->{MAX},
- $toremove,
- )
- );
- }
+ my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
+ for my $current (0..$#toremove) {
+ my $toremove = $toremove[$current];
+ $CPAN::Frontend->myprint(sprintf(
+ "DEL(%d/%d): %s \n",
+ $current+1,
+ scalar @toremove,
+ $toremove,
+ )
+ );
return if $CPAN::Signal;
$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};
my($self,$dir) = @_;
return unless -e $dir;
unless (File::Spec->canonpath(File::Basename::dirname($dir))
- eq File::Spec->canonpath($CPAN::Config->{build_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);
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) = CPAN->_yaml_loadfile("$dir.yml");
- if (my $id = $peek_yaml->[0]{distribution}{ID}) {
+ 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++;
}
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;
- my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
+ my @entries = $self->entries($self->{ID});
my $i = 0;
my $painted = 0;
for $e (@entries) {
- # next if $e eq ".." || $e eq ".";
- $self->disk_usage($e);
+ 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(".");
+ $CPAN::Frontend->myprint($symbol);
$painted++;
}
- return if $CPAN::Signal;
+ 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
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;
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");
+ }
+ $CPAN::Frontend->myprint("\n");
} else {
if (CPAN::HandleConfig->edit(@o_what)) {
} else {
$CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
qq{items\n\n});
}
- }
+ }
} elsif ($o_type eq 'debug') {
- my(%valid);
- @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 @_;
};
}
$CPAN::Frontend->myprint($R);
}
+# here is where 'reload cpan' is done
#-> sub CPAN::Shell::reload ;
sub reload {
my($self,$command,@arg) = @_;
my $redef = 0;
chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
my $failed;
- my @relo = (
- "CPAN.pm",
- "CPAN/Debug.pm",
- "CPAN/FirstTime.pm",
- "CPAN/HandleConfig.pm",
- "CPAN/Kwalify.pm",
- "CPAN/Queue.pm",
- "CPAN/Reporter.pm",
- "CPAN/SQLite.pm",
- "CPAN/Tarzip.pm",
- "CPAN/Version.pm",
- );
MFILE: for my $f (@relo) {
next unless exists $INC{$f};
my $p = $f;
return;
}
my $mtime = (stat $file)[9];
- $reload->{$f} ||= $^T;
- my $must_reload = $mtime > $reload->{$f};
+ $reload->{$f} ||= -1;
+ my $must_reload = $mtime != $reload->{$f};
$args ||= {};
- $must_reload ||= $args->{reloforce};
+ $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
}
for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
my $yaml = "$b.yml";
- unless (-f $yaml){
+ 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){
+ unless ($id) {
$CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
next;
}
my $do = CPAN::Shell->expandany($id);
- unless ($do){
+ unless ($do) {
$CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
next;
}
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);
- my $expand = scalar @expand;
- if (0) { # Looks like noise to me, was very useful for debugging
+ if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
# for metadata cache
- $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);
-# 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(
+ my $expand = scalar @expand;
+ $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
+ }
+ my @sexpand;
+ if ($] < 5.008) {
+ # hard to believe that the more complex sorting can lead to
+ # stack curruptions on older perl
+ @sexpand = sort {$a->id cmp $b->id} @expand;
+ } else {
+ @sexpand = map {
+ $_->[1]
+ } sort {
+ $b->[0] <=> $a->[0]
+ ||
+ $a->[1]{ID} cmp $b->[1]{ID},
+ } map {
+ [$_->_is_representative_module,
+ $_
+ ]
+ } @expand;
+ }
+ if ($CPAN::DEBUG) {
+ $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
+ sleep 1;
+ }
+ MODULE: for $module (@sexpand) {
+ my $file = $module->cpan_file;
+ next MODULE unless defined $file; # ??
+ $file =~ s!^./../!!;
+ my($latest) = $module->cpan_version;
+ my($inst_file) = $module->inst_file;
+ CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
+ my($have);
+ return if $CPAN::Signal;
+ my($next_MODULE);
+ eval { # version.pm involved!
+ 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 = "-";
+ }
+ }
+ };
+ next MODULE if $next_MODULE;
+ if ($@) {
+ $CPAN::Frontend->mywarn
+ (sprintf("Error while comparing cpan/installed versions of '%s':
+INST_FILE: %s
+INST_VERSION: %s %s
+CPAN_VERSION: %s %s
+",
+ $module->id,
+ $inst_file || "",
+ (defined $have ? $have : "[UNDEFINED]"),
+ (ref $have ? ref $have : ""),
+ $latest,
+ (ref $latest ? ref $latest : ""),
+ ));
+ next MODULE;
+ }
+ 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($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 (defined $regex) {
if (CPAN::_sqlite_running) {
+ CPAN::Index->reload;
$CPAN::SQLite->search($class, $regex);
}
for $obj (
$CPAN::META->all_objects($class)
) {
- unless ($obj && UNIVERSAL::can($obj,"id") && $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 ) {
my $wantarray = wantarray;
my $join_m = join ",", map {$_->id} @m;
- $self->debug("wantarray[$wantarray]join_m[$join_m]");
+ # $self->debug("wantarray[$wantarray]join_m[$join_m]");
+ my $count = scalar @m;
+ $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
}
return wantarray ? @m : $m[0];
}
@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,
# to turn colordebugging on, write
# cpan> o conf colorize_output 1
-#-> sub CPAN::Shell::print_ornamented ;
+#-> sub CPAN::Shell::colorize_output ;
{
my $print_ornamented_have_warned = 0;
sub colorize_output {
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; #};
print "Term::ANSIColor rejects color[$ornament]: $@\n
Please choose a different color (Hint: try 'o conf init /color/')\n";
}
+ # GGOLDBACH/Test-GreaterVersion-0.008 broke without 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) = @_;
- use Time::HiRes qw(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 ;
my($meth,@some) = @_;
my @pragma;
while($meth =~ /^(ff?orce|notest)$/) {
- push @pragma, $meth;
- $meth = shift @some or
+ 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?
- my $needs_recursion_protection = "make|test|install";
+ # 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) {
if ($meth =~ /^($needs_recursion_protection)$/) {
- # silly for look or dump
- $obj->color_cmd_tmps(0,1);
+ # it would be silly to check for recursion for look or dump
+ # (we are in CPAN::Shell::rematein)
+ CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
+ eval { $obj->color_cmd_tmps(0,1); };
+ if ($@) {
+ if (ref $@
+ and $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ } else {
+ if (0) {
+ require Carp;
+ Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
+ }
+ die;
+ }
+ }
}
- CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
+ 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
# queue to hold objects instead of names, I made one or two
# mistakes and never found which. I reverted back instead)
- while (my $q = CPAN::Queue->first) {
+ QITEM: while (my $q = CPAN::Queue->first) {
my $obj;
my $s = $q->as_string;
my $reqtype = $q->reqtype || "";
# 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.");
+ "to an object. Skipping.\n");
$CPAN::Frontend->mysleep(5);
- next;
+ CPAN::Queue->delete_first($s);
+ next QITEM;
}
$obj->{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 (UNIVERSAL::can($obj, 'called_for')) {
$obj->called_for($s);
qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
push @qcopy, $obj;
- if (! UNIVERSAL::can($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) {
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()){
+ } 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();
+ }
+ }
+ if ($CPAN::Config->{halt_on_failure}
+ &&
+ CPAN::Distrostatus::something_has_just_failed()
+ ) {
+ $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
+ CPAN::Queue->nullify_queue;
+ last QITEM;
}
- CPAN::Queue->delete_first($s);
+ CPAN::Queue->delete_first($s);
}
if ($meth =~ /^($needs_recursion_protection)$/) {
for my $obj (@qcopy) {
#-> 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");
+ $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
+ }
- CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
- return;
+ 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");
+ }
}
-{
- # set up the dispatching methods
- no strict "refs";
- for my $command (qw(
+#-> sub CPAN::Shell::smoke ;
+sub smoke {
+ my($self) = @_;
+ my $distros = $self->recent;
+ DISTRO: for my $distro (@$distros) {
+ next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
+ $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);
+ }
+}
+
+{
+ # set up the dispatching methods
+ no strict "refs";
+ for my $command (qw(
clean
cvs_import
dump
notest
perldoc
readme
+ reports
test
)) {
*$command = sub { shift->rematein($command, @_); };
sub get_proxy_credentials {
my $self = shift;
my ($user, $password);
- if ( defined $CPAN::Config->{proxy_user} &&
- defined $CPAN::Config->{proxy_pass}) {
+ if ( defined $CPAN::Config->{proxy_user} ) {
$user = $CPAN::Config->{proxy_user};
- $password = $CPAN::Config->{proxy_pass};
+ $password = $CPAN::Config->{proxy_pass} || "";
return ($user, $password);
}
my $username_prompt = "\nProxy authentication needed!
sub get_non_proxy_credentials {
my $self = shift;
my ($user,$password);
- if ( defined $CPAN::Config->{username} &&
- defined $CPAN::Config->{password}) {
+ if ( defined $CPAN::Config->{username} ) {
$user = $CPAN::Config->{username};
- $password = $CPAN::Config->{password};
+ $password = $CPAN::Config->{password} || "";
return ($user, $password);
}
my $username_prompt = "\nAuthentication needed!
open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
my $sleep = 1;
my $waitstart;
- while (!flock $fh, $locktype|LOCK_NB) {
+ while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
$waitstart ||= localtime();
if ($sleep>3) {
$CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
$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;
- }
+ $stats->{end} = CPAN::FTP::_mytime();
my $fh = FileHandle->new;
my $time = time;
my $sdebug = 0;
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.pm 0.62 is unacceptably slow with 999;
# YAML::Syck 0.82 has no noticable performance problem with 999;
+ my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
+ my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
while (
- @{$fullstats->{history}} > 99
- || $time - $fullstats->{history}[0]{start} > 14*86400
+ @{$fullstats->{history}} > $ftpstats_size
+ || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
) {
shift @{$fullstats->{history}}
}
# 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||$CPAN::DEBUG ) {
+ if ( $sdebug ) {
local $CPAN::DEBUG = 512; # FTP
push @debug, time;
CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
}
# Win32 cannot rename a file to an existing filename
unlink($sfile) if ($^O eq 'MSWin32');
+ _copy_stat($sfile, "$sfile.$$") if -e $sfile;
rename "$sfile.$$", $sfile
or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
}
}
+# Copy some stat information (owner, group, mode and) from one file to
+# another.
+# This is a utility function which might be moved to a utility repository.
+#-> sub CPAN::FTP::_copy_stat
+sub _copy_stat {
+ my($src, $dest) = @_;
+ my @stat = stat($src);
+ if (!@stat) {
+ $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
+ return;
+ }
+
+ eval {
+ chmod $stat[2], $dest
+ or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
+ };
+ warn $@ if $@;
+ eval {
+ chown $stat[4], $stat[5], $dest
+ or do {
+ my $save_err = $!; # otherwise it's lost in the get... calls
+ $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
+ (getpwuid($stat[4]))[0] . "/" .
+ (getgrgid($stat[5]))[0] . ": $save_err\n"
+ );
+ };
+ };
+ warn $@ if $@;
+}
+
# 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
my($class,$host,$dir,$file,$target) = @_;
$class->debug(
qq[Going to fetch file [$file] from dir [$dir]
- on host [$host] as local [$target]\n]
+ on host [$host] as local [$target]\n]
) if $CPAN::DEBUG;
my $ftp = Net::FTP->new($host);
unless ($ftp) {
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;
# If more accuracy is wanted/needed, Chris Leach sent me this patch...
- # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
- # > --- /tmp/cp Wed Sep 24 13:26:40 1997
+ # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
+ # > --- /tmp/cp Wed Sep 24 13:26:40 1997
# > ***************
# > *** 1562,1567 ****
# > --- 1562,1580 ----
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);
+ for ($CPAN::Config->{connect_to_internet_ok}) {
+ $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
+ }
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;
$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.
+ my $proxy_vars = $self->_proxy_vars($ro_url);
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 ($proxy_vars->{http_proxy}) {
+ $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
+ }
+ }
+
+ 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
}
+#-> CPAN::FTP::_proxy_vars
+sub _proxy_vars {
+ my($self,$url) = @_;
+ my $ret = +{};
+ my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ if ($http_proxy) {
+ my($host) = $url =~ m|://([^/:]+)|;
+ my $want_proxy = 1;
+ my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
+ my @noproxy = split /\s*,\s*/, $noproxy;
+ if ($host) {
+ DOMAIN: for my $domain (@noproxy) {
+ if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
+ $want_proxy = 0;
+ last DOMAIN;
+ }
+ }
+ } else {
+ $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n");
+ }
+ if ($want_proxy) {
+ my($user, $pass) =
+ &CPAN::LWP::UserAgent::get_proxy_credentials();
+ $ret = {
+ proxy_user => $user,
+ proxy_pass => $pass,
+ http_proxy => $http_proxy
+ };
+ }
+ }
+ return $ret;
+}
+
# 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);
}
CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
$line =~ s/^\s*//;
if ($line =~ s/^((?:notest|f?force)\s*)//) {
- $pos -= length($1);
+ $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 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) {
my $i = 0;
my $painted = 0;
my $restored = 0;
- $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
my @candidates = map { $_->[0] }
sort { $b->[1] <=> $a->[1] }
map { [ $_, -M File::Spec->catfile($d,$_) ] }
grep {/\.yml$/} readdir $dh;
- DISTRO: for $dirent (@candidates) {
+ unless (@candidates) {
+ $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
+ return;
+ }
+ $CPAN::Frontend->myprint
+ (sprintf("Going to read %d yaml file%s from %s/\n",
+ scalar @candidates,
+ @candidates==1 ? "" : "s",
+ $CPAN::Config->{build_dir}
+ ));
+ my $start = CPAN::FTP::_mytime;
+ DISTRO: for $i (0..$#candidates) {
+ my $dirent = $candidates[$i];
my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
- die $@ if $@;
+ 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};
my $do
= $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
= $c->{distribution};
- delete $do->{badtestcnt};
+ for my $skipper (qw(
+ badtestcnt
+ configure_requires_later
+ configure_requires_later_for
+ force_update
+ later
+ later_for
+ notest
+ should_report
+ sponsored_mods
+ prefs
+ negative_prefs_cache
+ )) {
+ delete $do->{$skipper};
+ }
# $DB::single = 1;
- if ($do->{make_test}
- && $do->{build_dir}
- && !$do->{make_test}->failed
- && (
- !$do->{install}
- ||
- $do->{install}->failed
- )
- ) {
+ if ($do->tested_ok_but_not_installed) {
$CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
}
$restored++;
$painted++;
}
}
+ my $took = CPAN::FTP::_mytime - $start;
$CPAN::Frontend->myprint(sprintf(
- "DONE\nFound %s old builds, restored the state of %s\n",
- @candidates ? sprintf("%d",scalar @candidates) : "no",
+ "DONE\nRestored the state of %s (in %.4f secs)\n",
$restored || "none",
+ $took,
));
}
# 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);
}
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");
}
# 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;
+ unless ($mod && defined $version && $dist) {
+ $CPAN::Frontend->mywarn("Could not split line[$_]\n");
+ next;
+ }
+ 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) {
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($comp) = Safe->new("CPAN::Safe1");
+ my($compmt) = Safe->new("CPAN::Safe1");
my($eval2) = join("\n", @eval2);
CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
- my $ret = $comp->reval($eval2);
+ my $ret = $compmt->reval($eval2);
Carp::confess($@) if $@;
return if $CPAN::Signal;
my $i = 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");
}
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;
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;
}
package CPAN::InfoObj;
use strict;
+use Cwd qw(chdir);
sub ro {
my $self = shift;
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($compmt) = Safe->new();
+ $cksum = $compmt->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;
+use Cwd qw(chdir);
+use CPAN::Distroprefs;
# Accessors
sub cpan_comment {
$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;
$s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
) {
return $s if $s =~ m:^N/A|^Contact Author: ;
- $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
- $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
+ $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
CPAN->debug("s[$s]") if $CPAN::DEBUG;
}
$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);
}
+#-> 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;
+}
+
+#-> sub CPAN::Distribution::tested_ok_but_not_installed
+sub tested_ok_but_not_installed {
+ my $self = shift;
+ return (
+ $self->{make_test}
+ && $self->{build_dir}
+ && (UNIVERSAL::can($self->{make_test},"failed") ?
+ ! $self->{make_test}->failed :
+ $self->{make_test} =~ /^YES/
+ )
+ && (
+ !$self->{install}
+ ||
+ $self->{install}->failed
+ )
+ );
+}
+
+
# 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
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
- if ($depth>=$CPAN::MAX_RECURSION){
- $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;
#-> 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;
- if ($CPAN::Signal) {
- delete $self->{CONTAINSMODS};
- return;
+ 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;
}
- $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
- }
- keys %{$self->{CONTAINSMODS}||{}};
+ 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;
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
-
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
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}) {
+ if ($self->prefs->{disabled} && ! $self->{force_update}) {
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");
+ $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}) {
+ 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;
+ return 1;
}
# although we talk about 'force' we shall not test on
)
and push @e, "Unwrapping had some problem, won't try again without force";
}
-
- $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
+ if (@e) {
+ $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
+ if ($goodbye_message) {
+ $self->goodbye($goodbye_message);
+ }
+ return;
+ }
}
my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
- #
- # Get the file on local disk
- #
+ 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;
+ if (exists $self->{writemakefile} && ref $self->{writemakefile}
+ && $self->{writemakefile}->can("failed") &&
+ $self->{writemakefile}->failed) {
+ return;
+ }
+ $packagedir ||= $self->{build_dir};
+ $self->{build_dir} = $packagedir;
+ }
+ if ($CPAN::Signal) {
+ $self->safe_chdir($sub_wd);
+ return;
+ }
+ return $self->choose_MM_or_MB($local_file);
+}
+
+#-> 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
- #
- if ($CPAN::META->has_inst("Digest::SHA")) {
- $self->debug("Digest::SHA is installed, verifying");
- $self->verifyCHECKSUM;
+
+#-> CPAN::Distribution::check_integrity
+sub check_integrity {
+ my($self) = @_;
+
+ return if $self->is_dot_dist;
+ if ($CPAN::META->has_inst("Digest::SHA")) {
+ $self->debug("Digest::SHA is installed, verifying");
+ $self->verifyCHECKSUM;
} else {
- $self->debug("Digest::SHA is NOT installed");
+ $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!
my $dh = DirHandle->new(File::Spec->curdir)
or Carp::croak("Couldn't opendir .: $!");
my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
+ if (grep { $_ eq "pax_global_header" } @readdir) {
+ $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
+from the tarball '$local_file'.
+This is almost certainly an error. Please upgrade your tar.
+I'll ignore this file for now.
+See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
+ $CPAN::Frontend->mysleep(5);
+ @readdir = grep { $_ ne "pax_global_header" } @readdir;
+ }
$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;
if (@readdir == 1 && -d $readdir[0]) {
$tdir_base = $readdir[0];
$from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
- my $dh2 = DirHandle->new($from_dir)
- or Carp::croak("Couldn't opendir $from_dir: $!");
+ my $dh2;
+ unless ($dh2 = DirHandle->new($from_dir)) {
+ my($mode) = (stat $from_dir)[2];
+ my $why = sprintf
+ (
+ "Couldn't opendir '%s', mode '%o': %s",
+ $from_dir,
+ $mode,
+ $!,
+ );
+ $CPAN::Frontend->mywarn("$why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
+ return;
+ }
@dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
} else {
my $userid = $self->cpan_userid;
}
}
}
- if ($CPAN::Signal){
- $self->safe_chdir($sub_wd);
- return;
- }
-
$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;
+}
- my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
+#-> sub CPAN::Distribution::satisfy_requires ;
+sub satisfy_requires {
+ my ($self) = @_;
+ 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;
+ die "[prereq] -- NOT OK\n";
+ } else {
+ 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($@);
+ die "[depend] -- NOT OK\n";
+ }
+ }
+ }
+}
+
+#-> 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";
+}
+
+#-> sub CPAN::Distribution::choose_MM_or_MB ;
+sub choose_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
if ($CPAN::META->has_inst("Module::Build")) {
$prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
}
}
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;
}
my($self) = @_;
my $dir = $self->{build_dir};
unless (File::Spec->canonpath(File::Basename::dirname($dir))
- eq File::Spec->canonpath($CPAN::Config->{build_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;
}
}
-#-> 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) = @_;
- $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; # 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 $pcommand;
- my $ppp = $self->_patch_p_parameter($readfh);
- if ($ppp eq "applypatch") {
- $pcommand = "$CPAN::Config->{applypatch} -verbose";
- } else {
- my $thispatchargs = join " ", $stdpatchargs, $ppp;
- $pcommand = "$patchbin $thispatchargs";
- }
-
- $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
- my $writefh = FileHandle->new;
- $CPAN::Frontend->myprint(" $pcommand\n");
- unless (open $writefh, "|$pcommand") {
- my $fail = "Could not fork '$pcommand'";
- $CPAN::Frontend->mywarn("$fail; cannot continue\n");
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
- delete $self->{build_dir};
- return;
- }
- while (my $x = $readfh->READLINE) {
- print $writefh $x;
- }
- unless (close $writefh) {
- my $fail = "Could not apply patch '$patch'";
- $CPAN::Frontend->mywarn("$fail; cannot continue\n");
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
- delete $self->{build_dir};
- return;
- }
+ $self->{patched}++;
}
- $self->{patched}++;
+ return 1;
}
- return 1;
}
sub _patch_p_parameter {
#-> 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.
}
$cf =~ s|[/\\:]||g; # risk of filesystem damage
$cf = "unknown" unless length($cf);
+ if (my $crap = $self->_contains_crap($build_dir)) {
+ my $why = qq{Package contains $crap; not recognized as a perl package, giving up};
+ $CPAN::Frontend->mywarn("$why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
+ return;
+ }
$CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
(The test -f "$mpl" returned false.)
Writing one on our own (setting NAME to $cf)\a\n});
# Writing our own Makefile.PL
- my $script = "";
+ my $exefile_stanza = "";
if ($self->{archived} eq "maybe_pl") {
+ $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
+ }
+
+ my $fh = FileHandle->new;
+ $fh->open(">$mpl")
+ or Carp::croak("Could not open >$mpl: $!");
+ $fh->print(
+ qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
+# because there was no Makefile.PL supplied.
+# Autogenerated on: }.scalar localtime().qq{
+
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => q[$cf],$exefile_stanza
+ );
+});
+ $fh->close;
+ }
+}
+
+#-> CPAN;:Distribution::_contains_crap
+sub _contains_crap {
+ my($self,$dir) = @_;
+ my(@dirs, $dh, @files);
+ opendir $dh, $dir or return;
+ my $dirent;
+ for $dirent (readdir $dh) {
+ next if $dirent =~ /^\.\.?$/;
+ my $path = File::Spec->catdir($dir,$dirent);
+ if (-d $path) {
+ push @dirs, $dirent;
+ } elsif (-f $path) {
+ push @files, $dirent;
+ }
+ }
+ if (@dirs && @files) {
+ return "both files[@files] and directories[@dirs]";
+ } elsif (@files > 2) {
+ return "several files[@files] but no Makefile.PL or Build.PL";
+ }
+ return;
+}
+
+#-> CPAN;:Distribution::_exefile_stanza
+sub _exefile_stanza {
+ my($self,$build_dir,$local_file) = @_;
+
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";
}
} split /\s*,\s*/, $prereq);
- $script = "
- EXE_FILES => ['$name'],
- PREREQ_PM => {
-$PREREQ_PM
- },
-";
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 $fh = FileHandle->new;
- $fh->open(">$mpl")
- or Carp::croak("Could not open >$mpl: $!");
- $fh->print(
- qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
-# because there was no Makefile.PL supplied.
-# Autogenerated on: }.scalar localtime().qq{
-
-use ExtUtils::MakeMaker;
-WriteMakefile(
- NAME => q[$cf],$script
- );
-});
- $fh->close;
- }
+ return "
+ EXE_FILES => ['$name'],
+ PREREQ_PM => {
+$PREREQ_PM
+ },
+";
}
#-> CPAN::Distribution::_signature_business
);
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},
sub untar_me {
my($self,$ct) = @_;
$self->{archived} = "tar";
- if ($ct->untar()) {
- $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ my $result = eval { $ct->untar() };
+ if ($result) {
+ $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'});
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ 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));
}
}
$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($compmt) = Safe->new();
+ $cksum = $compmt->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;
#-> 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 ;
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;
+ return if $self->prefs->{disabled} && ! $self->{force_update};
+ if ($self->{configure_requires_later}) {
+ return;
+ }
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$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;
my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
$self->{writemakefile}->text :
$self->{writemakefile};
- $err =~ s/^NO\s*//;
+ $err =~ s/^NO\s*(--\s+)?//;
$err ||= "Had some problem writing Makefile";
$err .= ", won't make";
push @e, $err;
}
- defined $self->{make} and push @e,
- "Has already been made";
-
- 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";
+ my $wait_for_prereqs = eval { $self->satisfy_requires };
+ return 1 if $wait_for_prereqs; # tells queuerunner to continue
+ return $self->goodbye($@) if $@; # tells queuerunner to stop
+ }
+ }
-# } 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;
+ $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");
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
}
local %ENV = %env;
my $system;
- if (my $commandline = $self->prefs->{pl}{commandline}) {
- $system = $commandline;
+ my $pl_commandline;
+ if ($self->prefs->{pl}) {
+ $pl_commandline = $self->prefs->{pl}{commandline};
+ }
+ if ($pl_commandline) {
+ $system = $pl_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;
- my $makepl_arg = $self->make_x_arg("pl");
- $system = sprintf("%s%s Makefile.PL%s",
+# $switch = "-MExtUtils::MakeMaker ".
+# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
+# if $] > 5.00310;
+ my $makepl_arg = $self->_make_phase_arg("pl");
+ $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" : "",
);
}
- if (my $env = $self->prefs->{pl}{env}) {
- for my $e (keys %$env) {
- $ENV{$e} = $env->{$e};
+ my $pl_env;
+ if ($self->prefs->{pl}) {
+ $pl_env = $self->prefs->{pl}{env};
+ }
+ if ($pl_env) {
+ for my $e (keys %$pl_env) {
+ $ENV{$e} = $pl_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")) {
- $ret = $self->_run_via_expect($system,$expect_model);
+ # 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,'writemakefile',$expect_model);
if (! defined $ret
&& $self->{writemakefile}
&& $self->{writemakefile}->failed) {
# 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 ($CPAN::Signal){
- delete $self->{force_update};
- return;
- }
- if (my @prereq = $self->unsat_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;
+ }
+ if (-f "Makefile" || -f "Build") {
+ $self->{writemakefile} = CPAN::Distrostatus->new("YES");
+ delete $self->{make_clean}; # if cleaned before, enable next
} else {
- return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
+ my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
+ my $why = "No '$makefile' created";
+ $CPAN::Frontend->mywarn($why);
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new(qq{NO -- $why\n});
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- NOT OK");
}
}
- if ($CPAN::Signal){
- delete $self->{force_update};
- return;
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
}
- if (my $commandline = $self->prefs->{make}{commandline}) {
- $system = $commandline;
- $ENV{PERL} = $^X;
+ my $wait_for_prereqs = eval { $self->satisfy_requires };
+ return 1 if $wait_for_prereqs; # tells queuerunner to continue
+ return $self->goodbye($@) if $@; # tells queuerunner to stop
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+ my $make_commandline;
+ if ($self->prefs->{make}) {
+ $make_commandline = $self->prefs->{make}{commandline};
+ }
+ if ($make_commandline) {
+ $system = $make_commandline;
+ $ENV{PERL} = CPAN::find_perl;
} else {
if ($self->{modulebuild}) {
unless (-f "Build") {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
- " in cwd[$cwd]. Danger, Will Robinson!");
+ " in cwd[$cwd]. Danger, Will Robinson!\n");
$CPAN::Frontend->mysleep(5);
}
$system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
$system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
}
$system =~ s/\s+$//;
- my $make_arg = $self->make_x_arg("make");
+ my $make_arg = $self->_make_phase_arg("make");
$system = sprintf("%s%s",
$system,
$make_arg ? " $make_arg" : "",
);
}
- if (my $env = $self->prefs->{make}{env}) { # overriding the local
- # ENV of PL, not the
- # outer ENV, but
- # unlikely to be a risk
- for my $e (keys %$env) {
- $ENV{$e} = $env->{$e};
+ my $make_env;
+ if ($self->prefs->{make}) {
+ $make_env = $self->prefs->{make}{env};
+ }
+ if ($make_env) { # overriding the local ENV of PL, not the outer
+ # ENV, but unlikely to be a risk
+ for my $e (keys %$make_env) {
+ $ENV{$e} = $make_env->{$e};
}
}
my $expect_model = $self->_prefs_with_expect("make");
}
my $system_ok;
if ($want_expect) {
- $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
- } else {
+ # 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,'make',$expect_model) == 0;
+ }
+ 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) = @_;
+ my($self,$system,$phase,$expect_model) = @_;
CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
if ($CPAN::META->has_inst("Expect")) {
my $expo = Expect->new; # expo Expect object;
$expo->spawn($system);
$expect_model->{mode} ||= "deterministic";
if ($expect_model->{mode} eq "deterministic") {
- return $self->_run_via_expect_deterministic($expo,$expect_model);
+ return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
} elsif ($expect_model->{mode} eq "anyorder") {
- return $self->_run_via_expect_anyorder($expo,$expect_model);
+ return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
} else {
die "Panic: Illegal expect mode: $expect_model->{mode}";
}
}
sub _run_via_expect_anyorder {
- my($self,$expo,$expect_model) = @_;
+ my($self,$expo,$phase,$expect_model) = @_;
my $timeout = $expect_model->{timeout} || 5;
+ my $reuse = $expect_model->{reuse};
my @expectacopy = @{$expect_model->{talk}}; # we trash it!
my $but = "";
+ my $timeout_start = time;
EXPECT: while () {
my($eof,$ran_into_timeout);
- my @match = $expo->expect($timeout,
+ # XXX not up to the full power of expect. one could certainly
+ # wrap all of the talk pairs into a single expect call and on
+ # success tweak it and step ahead to the next question. The
+ # current implementation unnecessarily limits itself to a
+ # single match.
+ my @match = $expo->expect(1,
[ eof => sub {
$eof++;
} ],
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;
}
}
+ my $have_waited = time - $timeout_start;
+ if ($have_waited < $timeout) {
+ # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
+ next EXPECT;
+ }
my $why = "could not answer a question during the dialog";
$CPAN::Frontend->mywarn("Failing: $why\n");
- $self->{writemakefile} =
+ $self->{$phase} =
CPAN::Distrostatus->new("NO $why");
- return;
+ return 0;
}
}
}
sub _run_via_expect_deterministic {
- my($self,$expo,$expect_model) = @_;
+ my($self,$expo,$phase,$expect_model) = @_;
my $ran_into_timeout;
+ my $ran_into_eof;
my $timeout = $expect_model->{timeout} || 15; # currently unsettable
my $expecta = $expect_model->{talk};
EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
my $but = $expo->clear_accum;
$CPAN::Frontend->mywarn("EOF (maybe harmless)
expected[$regex]\nbut[$but]\n\n");
- last EXPECT;
+ $ran_into_eof++;
} ],
[ timeout => sub {
my $but = $expo->clear_accum;
$ran_into_timeout++;
} ],
-re => $regex);
- if ($ran_into_timeout){
+ if ($ran_into_timeout) {
# note that the caller expects 0 for success
- $self->{writemakefile} =
+ $self->{$phase} =
CPAN::Distrostatus->new("NO timeout during expect dialog");
- return;
+ return 0;
+ } elsif ($ran_into_eof) {
+ last EXPECT;
}
$expo->send($send);
}
my $distroid = $self->pretty_id;
#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 $ext_map = {};
my @extensions;
if ($CPAN::META->has_inst($yaml_module)) {
- push @extensions, "yml";
+ $ext_map->{yml} = 'CPAN';
} else {
my @fallbacks;
if ($CPAN::META->has_inst("Data::Dumper")) {
- push @extensions, "dd";
- push @fallbacks, "Data::Dumper";
+ push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
}
if ($CPAN::META->has_inst("Storable")) {
- push @extensions, "st";
- push @fallbacks, "Storable";
+ push @fallbacks, $ext_map->{st} = 'Storable';
}
if (@fallbacks) {
local $" = " and ";
}
}
}
- if (@extensions) {
- my $dh = DirHandle->new($prefs_dir)
- or die Carp::croak("Couldn't open '$prefs_dir': $!");
- DIRENT: for (sort $dh->read) {
- next if $_ eq "." || $_ eq "..";
- my $exte = join "|", @extensions;
- next unless /\.($exte)$/;
- my $thisexte = $1;
- my $abs = File::Spec->catfile($prefs_dir, $_);
- if (-f $abs) {
- #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
- my @distropref;
- if ($thisexte eq "yml") {
- # need no eval because if we have no YAML we do not try to read *.yml
- #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
- @distropref = @{CPAN->_yaml_loadfile($abs)};
- #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
- } elsif ($thisexte eq "dd") {
- package CPAN::Eval;
- no strict;
- open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
- local $/;
- my $eval = <FH>;
- close FH;
- eval $eval;
- if ($@) {
- $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
- }
- my $i = 1;
- while (${"VAR".$i}) {
- push @distropref, ${"VAR".$i};
- $i++;
- }
- } elsif ($thisexte eq "st") {
- # eval because Storable is never forward compatible
- eval { @distropref = @{scalar Storable::retrieve($abs)}; };
- if ($@) {
- $CPAN::Frontend->mywarn("Error reading distroprefs file ".
- "$_, skipping\: $@");
- $CPAN::Frontend->mysleep(4);
- next DIRENT;
- }
- }
- # $DB::single=1;
- #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
- ELEMENT: for my $y (0..$#distropref) {
- my $distropref = $distropref[$y];
- $self->_validate_distropref($distropref,$abs,$y);
- my $match = $distropref->{match};
- unless ($match) {
- #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
- next ELEMENT;
- }
- my $ok = 1;
- # do not take the order of C<keys %$match> because
- # "module" is by far the slowest
- for my $sub_attribute (qw(distribution perl module)) {
- next unless exists $match->{$sub_attribute};
- my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
- if ($sub_attribute eq "module") {
- my $okm = 0;
- #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
- my @modules = $self->containsmods;
- #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
- MODULE: for my $module (@modules) {
- $okm ||= $module =~ /$qr/;
- last MODULE if $okm;
- }
- $ok &&= $okm;
- } elsif ($sub_attribute eq "distribution") {
- my $okd = $distroid =~ /$qr/;
- $ok &&= $okd;
- } elsif ($sub_attribute eq "perl") {
- my $okp = $^X =~ /$qr/;
- $ok &&= $okp;
- } 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 "ok[%d]", $ok) if $CPAN::DEBUG;
- if ($ok) {
- return {
- prefs => $distropref,
- prefs_file => $abs,
- prefs_file_doc => $y,
- };
- }
+ my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
+ DIRENT: while (my $result = $finder->next) {
+ if ($result->is_warning) {
+ $CPAN::Frontend->mywarn($result->as_string);
+ $CPAN::Frontend->mysleep(1);
+ next DIRENT;
+ } elsif ($result->is_fatal) {
+ $CPAN::Frontend->mydie($result->as_string);
+ }
- }
+ my @prefs = @{ $result->prefs };
+
+ ELEMENT: for my $y (0..$#prefs) {
+ my $pref = $prefs[$y];
+ $self->_validate_distropref($pref->data, $result->abs, $y);
+
+ # I don't know why we silently skip when there's no match, but
+ # complain if there's an empty match hashref, and there's no
+ # comment explaining why -- hdp, 2008-03-18
+ unless ($pref->has_any_match) {
+ next ELEMENT;
+ }
+
+ unless ($pref->has_valid_subkeys) {
+ $CPAN::Frontend->mydie(sprintf
+ "Nonconforming .%s file '%s': " .
+ "missing match/* subattribute. " .
+ "Please remove, cannot continue.",
+ $result->ext, $result->abs,
+ );
+ }
+
+ my $arg = {
+ env => \%ENV,
+ distribution => $distroid,
+ perl => \&CPAN::find_perl,
+ perlconfig => \%Config::Config,
+ module => sub { [ $self->containsmods ] },
+ };
+
+ if ($pref->matches($arg)) {
+ return {
+ prefs => $pref->data,
+ prefs_file => $result->abs,
+ prefs_file_doc => $y,
+ };
}
+
}
- $dh->close;
}
return;
}
return $self->{prefs} = +{};
}
-# CPAN::Distribution::make_x_arg
-sub make_x_arg {
- my($self, $whixh) = @_;
- my $make_x_arg;
+# CPAN::Distribution::_make_phase_arg
+sub _make_phase_arg {
+ my($self, $phase) = @_;
+ my $_make_phase_arg;
my $prefs = $self->prefs;
if (
$prefs
- && exists $prefs->{$whixh}
- && exists $prefs->{$whixh}{args}
- && $prefs->{$whixh}{args}
+ && exists $prefs->{$phase}
+ && exists $prefs->{$phase}{args}
+ && $prefs->{$phase}{args}
) {
- $make_x_arg = join(" ",
+ $_make_phase_arg = join(" ",
map {CPAN::HandleConfig
- ->safe_quote($_)} @{$prefs->{$whixh}{args}},
+ ->safe_quote($_)} @{$prefs->{$phase}{args}},
);
}
- my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
- $make_x_arg ||= $CPAN::Config->{$what};
- return $make_x_arg;
+
+# cpan[2]> o conf make[TAB]
+# make make_install_make_command
+# make_arg makepl_arg
+# make_install_arg
+# cpan[2]> o conf mbuild[TAB]
+# mbuild_arg mbuild_install_build_command
+# mbuild_install_arg mbuildpl_arg
+
+ my $mantra; # must switch make/mbuild here
+ if ($self->{modulebuild}) {
+ $mantra = "mbuild";
+ } else {
+ $mantra = "make";
+ }
+ my %map = (
+ pl => "pl_arg",
+ make => "_arg",
+ test => "_test_arg", # does not really exist but maybe
+ # will some day and now protects
+ # us from unini warnings
+ install => "_install_arg",
+ );
+ my $phase_underscore_meshup = $map{$phase};
+ my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
+
+ $_make_phase_arg ||= $CPAN::Config->{$what};
+ return $_make_phase_arg;
}
# CPAN::Distribution::_make_command
#-> 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;
+ my(@good_prereq_tuples);
+ for my $p (@prereq_tuples) {
+ # XXX watch out for foul ones
+ # $DB::single++;
+ push @good_prereq_tuples, $p;
+ }
my $pretty_id = $self->pretty_id;
my %map = (
b => "build_requires",
c => "commandline",
);
my($filler1,$filler2,$filler3,$filler4);
- # $DB::single=1;
my $unsat = "Unsatisfied dependencies detected during";
my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
{
$CPAN::Frontend->
myprint("$filler1 $unsat $filler2".
"$filler3 $pretty_id $filler4".
- join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
+ join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
);
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->
+ my @prereq = map { $_=>[0] } @good_prereq_tuples;
+ local($") = ", ";
+ $CPAN::Frontend->
myprint(" Ignoring dependencies on modules @prereq\n");
}
if ($follow) {
my $id = $self->id;
# color them as dirty
- for my $p (@prereq) {
+ for my $gp (@good_prereq_tuples) {
# warn "calling color_cmd_tmps(0,1)";
+ my $p = $gp->[0];
my $any = CPAN::Shell->expandany($p);
+ $self->{$slot . "_for"}{$any->id}++;
if ($any) {
$any->color_cmd_tmps(0,2);
} else {
}
}
# 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 @good_prereq_tuples);
+ $self->{$slot} = "Delayed until after prerequisites";
return 1; # signal success to the queuerunner
}
+ return;
+}
+
+sub _feature_depends {
+ my($self) = @_;
+ my $meta_yml = $self->parse_meta_yml();
+ my $optf = $meta_yml->{optional_features} or return;
+ if (!ref $optf or ref $optf ne "HASH"){
+ $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
+ $optf = {};
+ }
+ my $wantf = $self->prefs->{features} or return;
+ if (!ref $wantf or ref $wantf ne "ARRAY"){
+ $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
+ $wantf = [];
+ }
+ my $dep = +{};
+ for my $wf (@$wantf) {
+ if (my $f = $optf->{$wf}) {
+ $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
+ "is accompanied by this description:\n".
+ $f->{description}.
+ "\n\n"
+ );
+ # configure_requires currently not in the spec, unlikely to be useful anyway
+ for my $reqtype (qw(configure_requires build_requires requires)) {
+ my $reqhash = $f->{$reqtype} or next;
+ while (my($k,$v) = each %$reqhash) {
+ $dep->{$reqtype}{$k} = $v;
+ }
+ }
+ } else {
+ $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
+ "found in the META.yml file".
+ "\n\n"
+ );
+ }
+ }
+ $dep;
}
#-> sub CPAN::Distribution::unsat_prereq ;
-# return ([Foo=>1],[Bar=>1.2]) for normal modules
+# return ([Foo,"r"],[Bar,"b"]) for normal modules
# return ([perl=>5.008]) if we need a newer perl than we are running under
+# (sorry for the inconsistency, it was an accident)
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}||{};
+ my $feature_depends = $self->_feature_depends();
+ if ($slot eq "configure_requires_later") {
+ my $meta_yml = $self->parse_meta_yml();
+ if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
+ $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
+ $meta_yml = +{};
+ }
+ %merged = (
+ %{$meta_yml->{configure_requires}||{}},
+ %{$prefs_depends->{configure_requires}||{}},
+ %{$feature_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 $dep ($prefs_depends,$feature_depends) {
+ for my $k (keys %{$dep->{$reqtype}||{}}) {
+ $prereq_pm->{$reqtype}{$k} = $dep->{$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($available_version,$available_file,$nmo);
if ($need_module eq "perl") {
$available_version = $];
- $available_file = $^X;
+ $available_file = CPAN::find_perl;
} else {
$nmo = $CPAN::META->instance("CPAN::Module",$need_module);
next if $nmo->uptodate;
$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 == 0 or
- $need_version eq "undef") {
- next if defined $available_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;
}
$available_version = $nmo->available_version;
# 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 $available_file) {
- my(@all_requirements) = split /\s*,\s*/, $need_version;
- local($^W) = 0;
- my $ok = 0;
- RQ: for my $rq (@all_requirements) {
- if ($rq =~ s|>=\s*||) {
- } elsif ($rq =~ s|>\s*||) {
- # 2005-12: one user
- if (CPAN::Version->vgt($available_version,$rq)){
- $ok++;
- }
- next RQ;
- } elsif ($rq =~ s|!=\s*||) {
- # 2005-12: no user
- if (CPAN::Version->vcmp($available_version,$rq)){
- $ok++;
- next RQ;
- } else {
- last RQ;
- }
- } elsif ($rq =~ m|<=?\s*|) {
- # 2005-12: no user
- $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
- $ok++;
- next RQ;
- }
- if (! CPAN::Version->vgt($rq, $available_version)){
- $ok++;
- }
- CPAN->debug(sprintf("need_module[%s]available_file[%s]".
- "available_version[%s]rq[%s]ok[%d]",
- $need_module,
- $available_file,
- $available_version,
- CPAN::Version->readable($rq),
- $ok,
- )) if $CPAN::DEBUG;
- }
- next NEED if $ok == @all_requirements;
+ my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
+ ($need_module,$available_file,$available_version,$need_version);
+ next NEED if $fulfills_all_version_rqs;
}
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 (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
# We have already sponsored it and for some reason it's still
# not available. So we do ... what??
# if we push it again, we have a potential infinite loop
# The following "next" was a very problematic construct.
- # It helped a lot but broke some day and must be replaced.
+ # 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
# The bug that brought this up is described in Todo under
# "5.8.9 cannot install Compress::Zlib"
- # next; # this is the next that must go away
+ # 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
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",
"install",
"make_clean",
) {
- if (
- $do->{$nosayer}
- &&(UNIVERSAL::can($do->{$nosayer},"failed") ?
- $do->{$nosayer}->failed :
- $do->{$nosayer} =~ /^NO/)
- ) {
- if ($nosayer eq "make_test"
- &&
- $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
- ) {
- next NOSAYER;
+ if ($do->{$nosayer}) {
+ my $selfid = $self->pretty_id;
+ my $did = $do->pretty_id;
+ 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 '$selfid' failed when ".
+ "processing '$did' with ".
+ "'$nosayer => $do->{$nosayer}'. Continuing, ".
+ "but chances to succeed are limited.\n"
+ );
+ $CPAN::Frontend->mysleep($sponsoring/10);
+ next NEED;
+ } else { # the other guy succeeded
+ if ($nosayer =~ /^(install|make_test)$/) {
+ # we had this with
+ # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
+ # in 2007-03 for 'make install'
+ # and 2008-04: #30464 (for 'make test')
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$selfid' already built ".
+ "but the result looks suspicious. ".
+ "Skipping another build attempt, ".
+ "to prevent looping endlessly.\n"
+ );
+ next NEED;
+ }
}
- $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;
}
}
}
@need;
}
+sub _fulfills_all_version_rqs {
+ my($self,$need_module,$available_file,$available_version,$need_version) = @_;
+ my(@all_requirements) = split /\s*,\s*/, $need_version;
+ local($^W) = 0;
+ my $ok = 0;
+ RQ: for my $rq (@all_requirements) {
+ if ($rq =~ s|>=\s*||) {
+ } elsif ($rq =~ s|>\s*||) {
+ # 2005-12: one user
+ if (CPAN::Version->vgt($available_version,$rq)) {
+ $ok++;
+ }
+ next RQ;
+ } elsif ($rq =~ s|!=\s*||) {
+ # 2005-12: no user
+ if (CPAN::Version->vcmp($available_version,$rq)) {
+ $ok++;
+ next RQ;
+ } else {
+ last RQ;
+ }
+ } elsif ($rq =~ m|<=?\s*|) {
+ # 2005-12: no user
+ $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
+ $ok++;
+ next RQ;
+ }
+ if (! CPAN::Version->vgt($rq, $available_version)) {
+ $ok++;
+ }
+ CPAN->debug(sprintf("need_module[%s]available_file[%s]".
+ "available_version[%s]rq[%s]ok[%d]",
+ $need_module,
+ $available_file,
+ $available_version,
+ CPAN::Version->readable($rq),
+ $ok,
+ )) if $CPAN::DEBUG;
+ }
+ return $ok == @all_requirements;
+}
+
#-> sub CPAN::Distribution::read_yaml ;
sub read_yaml {
my($self) = @_;
return $self->{yaml_content} if exists $self->{yaml_content};
- my $build_dir = $self->{build_dir};
+ my $build_dir;
+ unless ($build_dir = $self->{build_dir}) {
+ # maybe permission on build_dir was missing
+ $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
+ return;
+ }
my $yaml = File::Spec->catfile($build_dir,"META.yml");
$self->debug("yaml[$yaml]") if $CPAN::DEBUG;
return unless -f $yaml;
# META.yml
}
# not "authoritative"
+ for ($self->{yaml_content}) {
+ if (defined $_ && (! ref $_ || ref $_ ne "HASH")) {
+ $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
+ $self->{yaml_content} = +{};
+ }
+ }
if (not exists $self->{yaml_content}{dynamic_config}
or $self->{yaml_content}{dynamic_config}
) {
return unless $self->{writemakefile} # no need to have succeeded
# but we must have run it
|| $self->{modulebuild};
+ unless ($self->{build_dir}) {
+ return;
+ }
CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
$self->{writemakefile}||"",
$self->{modulebuild}||"",
}
}
unless ($req || $breq) {
- my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
+ my $build_dir;
+ unless ( $build_dir = $self->{build_dir} ) {
+ return;
+ }
my $makefile = File::Spec->catfile($build_dir,"Makefile");
my $fh;
if (-f $makefile
# 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\[.*?\]|undef),?/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, ".
return $self->goto($goto);
}
$self->make;
- if ($CPAN::Signal){
+ return if $self->prefs->{disabled} && ! $self->{force_update};
+ if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
$CPAN::Frontend->myprint("Running $make test\n");
-# if (my @prereq = $self->unsat_prereq){
-# if ( $CPAN::DEBUG ) {
-# require Data::Dumper;
-# CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
-# }
-# unless ($prereq[0][0] eq "perl") {
-# return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
-# }
-# }
-
EXCUSE: {
- my @e;
- unless (exists $self->{make} or exists $self->{later}) {
+ 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;
if ($self->{badtestcnt} > 0) {
require Data::Dumper;
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, "Has already been 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";
+ # if global "is_tested" has been cleared, we need to mark this to
+ # be added to PERL5LIB if not already installed
+ if ($self->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ }
+ }
}
} 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;
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
$self->debug("Changed directory to $self->{build_dir}")
- if $CPAN::DEBUG;
+ if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_test($self);
}
if ($self->{modulebuild}) {
- my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
+ my $thm = CPAN::Shell->expand("Module","Test::Harness");
+ my $v = $thm->inst_version;
if (CPAN::Version->vlt($v,2.62)) {
- $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
+ # XXX Eric Wilhelm reported this as a bug: klapperl:
+ # Test::Harness 3.0 self-tests, so that should be 'unless
+ # installing Test::Harness'
+ unless ($self->id eq $thm->distribution->id) {
+ $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
'$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
- $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
- return;
+ $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
+ return;
+ }
+ }
+ }
+
+ if ( ! $self->{force_update} ) {
+ # bypass actual tests if "trust_test_report_history" and have a report
+ my $have_tested_fcn;
+ if ( $CPAN::Config->{trust_test_report_history}
+ && $CPAN::META->has_inst("CPAN::Reporter::History")
+ && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
+ if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
+ # Do nothing if grade was DISCARD
+ if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
+ # if global "is_tested" has been cleared, we need to mark this to
+ # be added to PERL5LIB if not already installed
+ if ($self->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ }
+ $CPAN::Frontend->myprint("Found prior test report -- OK\n");
+ return;
+ }
+ elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
+ $self->{badtestcnt}++;
+ $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
+ return;
+ }
+ }
}
}
my $system;
- if (my $commandline = $self->prefs->{test}{commandline}) {
+ my $prefs_test = $self->prefs->{test};
+ if (my $commandline
+ = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
$system = $commandline;
- $ENV{PERL} = $^X;
+ $ENV{PERL} = CPAN::find_perl;
} elsif ($self->{modulebuild}) {
$system = sprintf "%s test", $self->_build_command();
+ unless (-e "Build") {
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
+ }
} else {
$system = join " ", $self->_make_command(), "test";
}
- my $make_test_arg = $self->make_x_arg("test");
+ my $make_test_arg = $self->_make_phase_arg("test");
$system = sprintf("%s%s",
$system,
$make_test_arg ? " $make_test_arg" : "",
$env{$k} = $v;
}
local %ENV = %env;
- if (my $env = $self->prefs->{test}{env}) {
- for my $e (keys %$env) {
- $ENV{$e} = $env->{$e};
+ my $test_env;
+ if ($self->prefs->{test}) {
+ $test_env = $self->prefs->{test}{env};
+ }
+ if ($test_env) {
+ for my $e (keys %$test_env) {
+ $ENV{$e} = $test_env->{$e};
}
}
my $expect_model = $self->_prefs_with_expect("test");
"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 ) {
+ $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
+ } elsif ( $self->_should_report('test') ) {
$tests_ok = CPAN::Reporter::test($self, $system);
} else {
$tests_ok = system($system) == 0;
# local $CPAN::DEBUG = 16; # Distribution
for my $m (keys %{$self->{sponsored_mods}}) {
+ 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
push @prereq, $m;
}
}
- if (@prereq){
+ if (@prereq) {
my $cnt = @prereq;
my $which = join ",", @prereq;
my $but = $cnt == 1 ? "one dependency not OK ($which)" :
$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");
}
}
$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;
}
$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::confess("Couldn't chdir to $self->{build_dir}: $!");
+ Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
$self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
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([$goto,$self->{reqtype}]);
+ 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);
}
if (my $goto = $self->prefs->{goto}) {
return $self->goto($goto);
}
- $DB::single=1;
+ # $DB::single=1;
unless ($self->{badtestcnt}) {
$self->test;
}
- if ($CPAN::Signal){
+ 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;
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
$self->debug("Changed directory to $self->{build_dir}")
- if $CPAN::DEBUG;
+ if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_install($self);
my $system;
if (my $commandline = $self->prefs->{install}{commandline}) {
$system = $commandline;
- $ENV{PERL} = $^X;
+ $ENV{PERL} = CPAN::find_perl;
} elsif ($self->{modulebuild}) {
my($mbuild_install_build_command) =
exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
delete $self->{force_update};
return;
}
- my($pipe) = FileHandle->new("$system $stderr |");
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ $CPAN::META->set_perl5lib;
+ my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
+("Can't execute $system: $!");
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 $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};
+
+ # don't report if we generated a Makefile.PL
+ if ( $self->{had_no_makefile_pl} ) {
+ $CPAN::Frontend->mywarn(
+ "Will not send CPAN Testers report with generated Makefile.PL.\n"
+ );
+ return $self->{should_report} = 0;
+ }
+
+ # 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};
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
- if ($depth>=$CPAN::MAX_RECURSION){
- $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 $in_cont = 0;
$self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
while (<$fh>) {
- $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
- m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
+ $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
+ m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
next unless $in_cont;
next if /^=/;
s/\#.*//;
### 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;
$me[-1] .= ".pm";
my($incdir,$bestv);
foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
- my $bfile = File::Spec->catfile($incdir, @me);
- CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
- next unless -f $bfile;
- my $foundv = MM->parse_version($bfile);
- if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
- $self->{INST_FILE} = $bfile;
- $self->{INST_VERSION} = $bestv = $foundv;
+ my $parsefile = File::Spec->catfile($incdir, @me);
+ CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
+ next unless -f $parsefile;
+ my $have = eval { MM->parse_version($parsefile); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
+ }
+ if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
+ $self->{INST_FILE} = $parsefile;
+ $self->{INST_VERSION} = $bestv = $have;
}
}
$self->{INST_FILE};
$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();
+ $obj->$meth();
}
}
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::_is_representative_module
+sub _is_representative_module {
+ my($self) = @_;
+ return $self->{_is_representative_module} if defined $self->{_is_representative_module};
+ my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
+ $pm =~ s|.+/||;
+ $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
+ $pm =~ s|-\d+\.\d+.+$||;
+ $pm =~ s|-[\d\.]+$||;
+ $pm =~ s/-/::/g;
+ $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
+ # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
+ $self->{_is_representative_module};
+}
+
+#-> sub CPAN::Module::undelay
sub undelay {
my $self = shift;
delete $self->{later};
$self->{incommandcolor} = $color; # set me before recursion,
# so we can break it
}
- if ($depth>=$CPAN::MAX_RECURSION){
- $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;
$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;
}
object-oriented pragma
hybrid none,;
# public licence
- @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
+ @{$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;
+ if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
+ my $available_file = $self->available_file;
+ if ($available_file && $available_file ne $local_file) {
+ push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
+ push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
+ }
+ }
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, $_;
+ 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;
}
- close $fh;
- last if @result;
- }
- for (@result) {
- s/^\s+//;
- s/\s+$//;
- }
- join " ", @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};
}
$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);
- if (exists $self->{force_update}){
+ if (exists $self->{force_update}) {
if ($self->{force_update} == 2) {
$pack->fforce($meth);
} else {
$pack->force($meth);
}
}
- $pack->notest($meth) if exists $self->{'notest'};
+ $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'};
+ $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
delete $self->{force_update};
- delete $self->{'notest'};
+ delete $self->{notest};
if ($err) {
- die $err;
+ die $err;
}
+ return $success;
}
#-> sub CPAN::Module::perldoc ;
# $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") {
});
$CPAN::Frontend->mysleep(5);
}
- $self->rematein('install') if $doit;
+ return $doit ? $self->rematein('install') : 1;
}
#-> sub CPAN::Module::clean ;
sub clean { shift->rematein('clean') }
my $perllib = $ENV{PERL5LIB};
$perllib = $ENV{PERLLIB} unless defined $perllib;
my @perllib = split(/$sep/,$perllib) if defined $perllib;
- $self->_file_in_path([@perllib,@INC]);
+ my @cpan_perl5inc;
+ if ($CPAN::Perl5lib_tempfile) {
+ my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
+ @cpan_perl5inc = @{$yaml->[0]{inc} || []};
+ }
+ $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
}
#-> sub CPAN::Module::file_in_path ;
unshift @packpath, "Term", "ReadLine"; # historical reasons
}
foreach $dir (@$path) {
- my $pmfile = File::Spec->catfile($dir,@packpath);
- if (-f $pmfile){
- return $pmfile;
- }
+ 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 CPAN::Module::parse_version ;
sub parse_version {
my($self,$parsefile) = @_;
- my $have = MM->parse_version($parsefile);
- $have = "undef" unless defined $have && length $have;
+ my $have = eval { MM->parse_version($parsefile); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
+ }
+ my $leastsanity = eval { defined $have && length $have; };
+ $have = "undef" unless $leastsanity;
$have =~ s/^ //; # since the %vd hack these two lines here are needed
$have =~ s/ $//; # trailing whitespace happens all the time
$have; # no stringify needed, \s* above matches always
}
+#-> sub CPAN::Module::reports
+sub reports {
+ my($self) = @_;
+ $self->distribution->reports;
+}
+
package CPAN;
use strict;
more than one, we display each object with the terse method
C<as_glimpse>.
+Examples:
+
+ cpan> m Acme::MetaSyntactic
+ Module id = Acme::MetaSyntactic
+ CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
+ CPAN_VERSION 0.99
+ CPAN_FILE B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ UPLOAD_DATE 2006-11-06
+ MANPAGE Acme::MetaSyntactic - Themed metasyntactic variables names
+ INST_FILE /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm
+ INST_VERSION 0.99
+ cpan> a BOOK
+ Author id = BOOK
+ EMAIL [...]
+ FULLNAME Philippe Bruhat (BooK)
+ cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
+ CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...]
+ UPLOAD_DATE 2006-11-06
+ cpan> m /lorem/
+ Module = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz)
+ Module Text::Lorem (ADEOLA/Text-Lorem-0.3.tar.gz)
+ Module Text::Lorem::More (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
+ Module Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
+ cpan> i /berlin/
+ Distribution BEATNIK/Filter-NumberLines-0.02.tar.gz
+ Module = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz)
+ Module Filter::NumberLines (BEATNIK/Filter-NumberLines-0.02.tar.gz)
+ Author [...]
+
+The examples illustrate several aspects: the first three queries
+target modules, authors, or distros directly and yield exactly one
+result. The last two use regular expressions and yield several
+results. The last one targets all of bundles, modules, authors, and
+distros simultaneously. When more than one result is available, they
+are printed in one-line format.
+
=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
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.
=item Persistence between sessions
-If the C<YAML> or the c<YAML::Syck> module is installed a record of
+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.
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.
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 just a hack 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 just a hack 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
The typical usage case is for private modules or working copies of
projects from remote repositories on the local disk.
+=head2 Redirection
+
+The usual shell redirection symbols C< | > and C<< > >> are recognized
+by the cpan shell when surrounded by whitespace. So piping into a
+pager and redirecting output into a file works quite similar to any
+shell.
+
=head1 CONFIGURATION
When the CPAN module is used for the first time, a configuration
o conf shell
+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
+
+Example:
+
+ o conf /color/
+
=item changing of scalar values: o conf KEY VALUE
Sets the config variable KEY to VALUE. The empty string can be
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_warn Term::ANSIColor attributes for warnings
commandnumber_in_prompt
boolean if you want to see current command number
+ 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
+ connect_to_internet_ok
+ if we shall ask if opening a connection is ok before
+ urllist is specified
cpan_home local directory reserved for this package
curl path to external prg
dontload_hash DEPRECATED
ftp path to external prg
ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
ftp_proxy proxy host for ftp requests
+ ftpstats_period max number of days to keep download statistics
+ ftpstats_size max number of items to keep in the download statistics
getcwd see below
gpg path to external prg
- gzip location of external program gzip
+ gzip location of external program gzip
+ halt_on_failure stop processing after the first failure of queued
+ items or dependencies
histfile file to maintain history between sessions
histsize maximum number of lines to keep in histfile
http_proxy proxy host for http requests
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_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'
+ 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
pager location of external program more (or any pager)
password your password if you CPAN server wants one
patch path to external prg
+ perl5lib_verbosity verbosity level for PERL5LIB additions
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
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')
+ 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
- term_is_latin if true internal UTF-8 is translated to ISO-8859-1
+ 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)
+ trust_test_report_history
+ skip testing when previously tested ok (according to
+ CPAN::Reporter history)
unzip location of external program unzip
- urllist arrayref to nearby CPAN sites (or equivalent locations)
+ 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 via CPAN::DeferedCode
yaml_module which module to use to read/write YAML files
You can set and query each of these options interactively in the cpan
=item
+specify dependencies that the original maintainer forgot to specify
+
+=item
+
disable the installation of an object altogether
=back
module: "Dancing::Queen"
distribution: "^CHACHACHA/Dancing-"
perl: "/usr/local/cariba-perl/bin/perl"
+ perlconfig:
+ archname: "freebsd"
+ env:
+ DANCING_FLOOR: "Shubiduh"
disabled: 1
cpanconfig:
make: gmake
patches:
- "ABCDE/Fedcba-3.14-ABCDE-01.patch"
+ depends:
+ configure_requires:
+ LWP: 5.8
+ build_requires:
+ Test::Exception: 0.25
+ requires:
+ Spiffy: 0.30
+
=head2 Language Specs
C<test_report>. Please report as a bug when you need another one
supported.
+=item depends [hash] *** EXPERIMENTAL FEATURE ***
+
+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.
+
=item disabled [boolean]
Specifies that this distribution shall not be processed at all.
+=item features [array] *** EXPERIMENTAL FEATURE ***
+
+Experimental implementation to deal with optional_features from
+META.yml. Still needs coordination with installer software and
+currently only works for META.yml declaring C<dynamic_config=0>. Use
+with caution.
+
=item goto [string]
The canonical name of a delegate distribution that shall be installed
=item install [hash]
Processing instructions for the C<make install> or C<./Build install>
-phase of the CPAN mantra. See below under I<Processiong Instructions>.
+phase of the CPAN mantra. See below under I<Processing Instructions>.
=item make [hash]
Processing instructions for the C<make> or C<./Build> phase of the
-CPAN mantra. See below under I<Processiong Instructions>.
+CPAN mantra. See below under I<Processing Instructions>.
=item match [hash]
-A hashref with one or more of the keys C<distribution>, C<modules>, or
-C<perl> that specify if a document is targeted at a specific CPAN
-distribution.
+A hashref with one or more of the keys C<distribution>, C<modules>,
+C<perl>, C<perlconfig>, and C<env> that specify if a document is
+targeted at a specific CPAN distribution or installation.
The corresponding values are interpreted as regular expressions. The
C<distribution> related one will be matched against the canonical
The C<module> related one will be matched against I<all> modules
contained in the distribution until one module matches.
-The C<perl> related one will be matched against C<$^X>.
+The C<perl> related one will be matched against C<$^X> (but with the
+absolute path).
+
+The value associated with C<perlconfig> is itself a hashref that is
+matched against corresponding values in the C<%Config::Config> hash
+living in the C<Config.pm> module.
-If more than one restriction of C<module>, C<distribution>, and
-C<perl> is specified, the results of the separately computed match
-values must all match. If this is the case then the hashref
-represented by the YAML document is returned as the preference
-structure for the current distribution.
+The value associated with C<env> is itself a hashref that is
+matched against corresponding values in the C<%ENV> hash.
+
+If more than one restriction of C<module>, C<distribution>, etc. is
+specified, the results of the separately computed match values must
+all match. If this is the case then the hashref represented by the
+YAML document is returned as the preference structure for the current
+distribution.
=item patches [array]
=item pl [hash]
Processing instructions for the C<perl Makefile.PL> or C<perl
-Build.PL> phase of the CPAN mantra. See below under I<Processiong
+Build.PL> phase of the CPAN mantra. See below under I<Processing
Instructions>.
=item test [hash]
Processing instructions for the C<make test> or C<./Build test> phase
-of the CPAN mantra. See below under I<Processiong Instructions>.
+of the CPAN mantra. See below under I<Processing Instructions>.
=back
A full commandline that will be executed as it stands by a system
call. During the execution the environment variable PERL will is set
-to $^X. If C<commandline> is specified, the content of C<args> is not
-used.
+to $^X (but with an absolute path). If C<commandline> is specified,
+the content of C<args> is not used.
=item eexpect [hash]
-Extended C<expect>. This is a hash reference with three allowed keys,
-C<mode>, C<timeout>, and C<talk>.
+Extended C<expect>. This is a hash reference with four allowed keys,
+C<mode>, C<timeout>, C<reuse>, and C<talk>.
C<mode> may have the values C<deterministic> for the case where all
questions come in the order written down and C<anyorder> for the case
In the case of C<mode=deterministic> the CPAN.pm will inject the
according answer as soon as the stream matches the regular expression.
-In the case of C<mode=anyorder> the CPAN.pm will answer a question as
-soon as the timeout is reached for the next byte in the input stream.
-In the latter case it removes the according question/answer pair from
-the array, so if you want to answer the question C<Do you really want
-to do that> several times, then it must be included in the array at
-least as often as you want this answer to be given.
+
+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.
=item env [hash]
perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
# install my favorite programs if necessary:
- for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
+ 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;
+ 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";
+ next unless $mod->inst_version eq "undef";
+ print "No VERSION in ", $mod->id, "\n";
}
# find out which distribution on CPAN contains a module:
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","/./")){
+ 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",
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/")){
+ for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
as the first line instead. Or you can combine some of the above
tricks:
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
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
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:
"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
Runs a C<readme> on the distribution associated with this module.
+=item CPAN::Module::reports()
+
+Calls the reports() method on the associated distribution object.
+
=item CPAN::Module::test()
Runs a C<test> on the distribution associated with this module.
only difference being that I<one special pod section> exists starting with
(verbatim):
- =head1 CONTENTS
+ =head1 CONTENTS
In this pod section each line obeys the format
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
INSTALLSCRIPT=~/myperl/bin \
INSTALLBIN=~/myperl/bin"
-and then (oh joy) the equivalent command for Module::Build.
+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> or by setting C<auto_commit> beforehand.
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
http://search.cpan.org/search?query=Module::Build::Convert
-http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
+http://www.refcnt.org/papers/module-build-convert
=item 15)
-What's the best CPAN site for me?
+I'm frequently irritated with the CPAN shell's inability to help me
+select a good mirror.
The urllist config parameter is yours. You can add and remove sites at
will. You should find out which sites have the best uptodateness,
http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
+Also, feel free to play with experimental features. Run
+
+ o conf init randomize_urllist ftpstats_period ftpstats_size
+
+and choose your favorite parameters. After a few downloads running the
+C<hosts> command will probably assist you in choosing the best mirror
+sites.
+
+=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.
+
+=item 17)
+
+Older versions of CPAN.pm had the original root directory of all
+tarballs in the build directory. Now there are always random
+characters appended to these directory names. Why was this done?
+
+The random characters are provided by File::Temp and ensure that each
+module's individual build directory is unique. This makes running
+CPAN.pm in concurrent processes simultaneously safe.
+
+=item 18)
+
+Speaking of the build directory. Do I have to clean it up myself?
+
+You have the choice to set the config variable C<scan_cache> to
+C<never>. Then you must clean it up yourself. The other possible
+value, C<atstart> only cleans up the build directory when you start
+the CPAN shell. If you never start up the CPAN shell, you probably
+also have to clean up the build directory yourself.
+
=back
=head1 COMPATIBILITY
=head1 BUGS
-Please report bugs via http://rt.cpan.org/
+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
=head1 TRANSLATIONS
Kawai,Takanori provides a Japanese translation of this manpage at
-http://homepage3.nifty.com/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
projects / p5sagit/p5-mst-13.2.git / blobdiff