# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN;
-$CPAN::VERSION = '1.88_63';
+$CPAN::VERSION = '1.88_66';
$CPAN::VERSION = eval $CPAN::VERSION;
use CPAN::HandleConfig;
select $odef;
}
- # no strict; # I do not recall why no strict was here (2000-09-03)
$META->checklock();
my @cwd = grep { defined $_ and length $_ }
CPAN::anycwd(),
require Carp;
Carp::cluck($@);
}
- if ($command =~ /^(make|test|install|force|notest|clean|report|upgrade)$/) {
+ if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
CPAN::Shell->failed($CPAN::CurrentCommandId,1);
}
soft_chdir_with_alternatives(\@cwd);
}
sub _init_sqlite () {
- unless ($CPAN::META->has_inst("CPAN::SQLite")
- &&
- $CPAN::META->has_inst("CPAN::SQLite::META")
- ) {
- $CPAN::Frontend->mywarn(qq{SQLite not installed, cannot work with CPAN::SQLite});
+ unless ($CPAN::META->has_inst("CPAN::SQLite")) {
+ $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, cannot work with it\n})
+ unless $Have_warned->{"CPAN::SQLite"}++;
return;
}
+ require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
$CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
}
+{
+ my $negative_cache = {};
+ sub _sqlite_running {
+ if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
+ # need to cache the result, otherwise too slow
+ return $negative_cache->{fact};
+ } else {
+ $negative_cache = {}; # reset
+ }
+ my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
+ return $ret if $ret; # fast anyway
+ $negative_cache->{time} = time;
+ return $negative_cache->{fact} = $ret;
+ }
+}
+
package CPAN::CacheMgr;
use strict;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
### Carp::croak "exists called without class argument" unless $class;
$id ||= "";
$id =~ s/:+/::/g if $class eq "CPAN::Module";
- if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
- return (exists $META->{readonly}{$class}{$id} or
- $CPAN::SQLite->set($class, $id));
+ my $exists;
+ if (CPAN::_sqlite_running) {
+ $exists = (exists $META->{readonly}{$class}{$id} or
+ $CPAN::SQLite->set($class, $id));
} else {
- return (exists $META->{readonly}{$class}{$id} or
- exists $META->{readwrite}{$class}{$id}); # unsafe meta access, ok
+ $exists = exists $META->{readonly}{$class}{$id};
}
+ $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
}
#-> sub CPAN::delete ;
return unless -d $self->{ID};
while ($self->{DU} > $self->{'MAX'} ) {
my($toremove) = shift @{$self->{FIFO}};
- $CPAN::Frontend->myprint(sprintf(
- "Deleting from cache".
- ": $toremove (%.1f>%.1f MB)\n",
- $self->{DU}, $self->{'MAX'})
- );
+ unless ($toremove =~ /\.yml$/) {
+ $CPAN::Frontend->myprint(sprintf(
+ "Deleting from cache".
+ ": $toremove (%.1f>%.1f MB)\n",
+ $self->{DU}, $self->{'MAX'})
+ );
+ }
return if $CPAN::Signal;
- $self->force_clean_cache($toremove);
+ $self->_clean_cache($toremove);
return if $CPAN::Signal;
}
}
$self->{DU};
}
-#-> sub CPAN::CacheMgr::force_clean_cache ;
-sub force_clean_cache {
+#-> sub CPAN::CacheMgr::_clean_cache ;
+sub _clean_cache {
my($self,$dir) = @_;
return unless -e $dir;
- unless (File::Basename::dirname($dir) eq $CPAN::Config->{build_dir}) {
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
"will not remove\n");
$CPAN::Frontend->mysleep(5);
upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
Pragmas
- force COMMAND unconditionally do command
- notest COMMAND skip testing
+ force CMD try hard to do command
+ notest CMD skip testing
Other
h,? display this menu ! perl-code eval a perl command
my $failed;
my @relo = (
"CPAN.pm",
- "CPAN/HandleConfig.pm",
- "CPAN/FirstTime.pm",
- "CPAN/Tarzip.pm",
"CPAN/Debug.pm",
- "CPAN/Version.pm",
+ "CPAN/FirstTime.pm",
+ "CPAN/HandleConfig.pm",
+ "CPAN/Kwalify.pm",
"CPAN/Queue.pm",
"CPAN/Reporter.pm",
+ "CPAN/Tarzip.pm",
+ "CPAN/Version.pm",
);
MFILE: for my $f (@relo) {
next unless exists $INC{$f};
$p =~ s|/|::|g;
$CPAN::Frontend->myprint("($p");
local($SIG{__WARN__}) = paintdots_onreload(\$redef);
- $self->reload_this($f) or $failed++;
+ $self->_reload_this($f) or $failed++;
my $v = eval "$p\::->VERSION";
$CPAN::Frontend->myprint("v$v)");
}
}
# reload means only load again what we have loaded before
-#-> sub CPAN::Shell::reload_this ;
-sub reload_this {
+#-> sub CPAN::Shell::_reload_this ;
+sub _reload_this {
my($self,$f,$args) = @_;
CPAN->debug("f[$f]") if $CPAN::DEBUG;
return 1 unless $INC{$f}; # we never loaded this, so we do not
$reload->{$f} ||= $^T;
my $must_reload = $mtime > $reload->{$f};
$args ||= {};
- $must_reload ||= $args->{force};
+ $must_reload ||= $args->{reloforce};
if ($must_reload) {
my $fh = FileHandle->new($file) or
$CPAN::Frontend->mydie("Could not open $file: $!");
# don't do it twice
$cpan_file = $module->cpan_file;
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->force;
+ $pack->force; #
$dist{$cpan_file}++;
}
for $cpan_file (sort keys %dist) {
my @failed;
DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
my $failed = "";
- NAY: for my $nosayer (
+ NAY: for my $nosayer ( # order matters!
"unwrapped",
"writemakefile",
"signature_verify",
defined $command ? $command : "UNDEFINED",
) if $CPAN::DEBUG;
if (defined $regex) {
- if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
+ if (CPAN::_sqlite_running) {
$CPAN::SQLite->search($class, $regex);
}
for $obj (
}
#-> sub CPAN::Shell::rematein ;
-# RE-adme||MA-ke||TE-st||IN-stall
+# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
sub rematein {
my $self = shift;
my($meth,@some) = @_;
my $reqtype = $q->reqtype || "";
$obj = CPAN::Shell->expandany($s);
$obj->{reqtype} ||= "";
- CPAN->debug("obj-reqtype[$obj->{reqtype}]".
- "q-reqtype[$reqtype]") if $CPAN::DEBUG;
+ {
+ # force debugging because CPAN::SQLite somehow delivers us
+ # an empty object;
+
+ # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
+
+ CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
+ "q-reqtype[$reqtype]") if $CPAN::DEBUG;
+ }
if ($obj->{reqtype}) {
if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
$obj->{reqtype} = $reqtype;
$obj->$pragma($meth);
}
}
- if ($obj->can('called_for')) {
+ if (UNIVERSAL::can($obj, 'called_for')) {
$obj->called_for($s);
}
CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
push @qcopy, $obj;
- if ($obj->$meth()){
+ if (! UNIVERSAL::can($obj,$meth)) {
+ # Must never happen
+ my $serialized = "";
+ if (0) {
+ } elsif ($CPAN::META->has_inst("YAML::Syck")) {
+ $serialized = YAML::Syck::Dump($obj);
+ } elsif ($CPAN::META->has_inst("YAML")) {
+ $serialized = YAML::Dump($obj);
+ } elsif ($CPAN::META->has_inst("Data::Dumper")) {
+ $serialized = Data::Dumper::Dumper($obj);
+ } else {
+ require overload;
+ $serialized = overload::StrVal($obj);
+ }
+ $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
+ } elsif ($obj->$meth()){
CPAN::Queue->delete($s);
} else {
CPAN->debug("failed");
my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
my $sleep = 1;
+ my $waitstart;
while (!flock $fh, $locktype|LOCK_NB) {
+ $waitstart ||= localtime();
if ($sleep>3) {
- $CPAN::Frontend->mywarn("Waiting for a read lock on '$file'\n");
+ $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
}
$CPAN::Frontend->mysleep($sleep);
if ($sleep <= 3) {
$sleep+=0.33;
+ } elsif ($sleep <=6) {
+ $sleep+=0.11;
}
}
my $stats = CPAN->_yaml_loadfile($file);
- if ($locktype == LOCK_SH) {
- } else {
- seek $fh, 0, 0;
- if (@$stats){ # no yaml no write
- truncate $fh, 0;
- }
- }
return $stats->[0];
}
+#-> sub CPAN::FTP::_mytime
sub _mytime () {
if (CPAN->has_inst("Time::HiRes")) {
return Time::HiRes::time();
}
}
+#-> sub CPAN::FTP::_new_stats
sub _new_stats {
my($self,$file) = @_;
my $ret = {
$ret;
}
+#-> sub CPAN::FTP::_add_to_statistics
sub _add_to_statistics {
my($self,$stats) = @_;
- $stats->{thesiteurl} = $ThesiteURL;
- if (CPAN->has_inst("Time::HiRes")) {
- $stats->{end} = Time::HiRes::time();
- } else {
- $stats->{end} = time;
+ my $yaml_module = $self->CPAN::_yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ $stats->{thesiteurl} = $ThesiteURL;
+ if (CPAN->has_inst("Time::HiRes")) {
+ $stats->{end} = Time::HiRes::time();
+ } else {
+ $stats->{end} = time;
+ }
+ my $fh = FileHandle->new;
+ my $fullstats = $self->_ftp_statistics($fh);
+ $fullstats->{history} ||= [];
+ my @debug = scalar @{$fullstats->{history}};
+ push @{$fullstats->{history}}, $stats;
+ my $time = time;
+ shift @{$fullstats->{history}}
+ while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
+ push @debug, scalar @{$fullstats->{history}};
+ push @debug, scalar localtime($fullstats->{history}[0]{start});
+ {
+ # local $CPAN::DEBUG = 512;
+ CPAN->debug(sprintf("DEBUG history: before[%d]after[%d]oldest[%s]",
+ @debug,
+ )) if $CPAN::DEBUG;
+ }
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ CPAN->_yaml_dumpfile($fh,$fullstats);
}
- my $fh = FileHandle->new;
- my $fullstats = $self->_ftp_statistics($fh);
- push @{$fullstats->{history}}, $stats;
- my $time = time;
- shift @{$fullstats->{history}}
- while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
- CPAN->_yaml_dumpfile($fh,$fullstats);
}
# if file is CHECKSUMS, suggest the place where we got the file to be
# checked from, maybe only for young files?
+#-> sub CPAN::FTP::_recommend_url_for
sub _recommend_url_for {
my($self, $file) = @_;
my $urllist = $self->_get_urllist;
}
}
+#-> sub CPAN::FTP::_get_urllist
sub _get_urllist {
my($self) = @_;
$CPAN::Config->{urllist} ||= [];
if ($CPAN::Config->{build_dir_reuse}) {
$self->reanimate_build_dir;
}
- if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
+ if (CPAN::_sqlite_running) {
$CPAN::SQLite->reload(time => $time, force => $force)
if not $LAST_TIME;
}
#-> sub CPAN::Index::rd_authindex ;
sub rd_authindex {
my($cl, $index_target) = @_;
- my @lines;
return unless defined $index_target;
+ return if CPAN::_sqlite_running;
+ my @lines;
$CPAN::Frontend->myprint("Going to read $index_target\n");
local(*FH);
tie *FH, 'CPAN::Tarzip', $index_target;
sub rd_modpacks {
my($self, $index_target) = @_;
return unless defined $index_target;
+ return if CPAN::_sqlite_running;
$CPAN::Frontend->myprint("Going to read $index_target\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
sub rd_modlist {
my($cl,$index_target) = @_;
return unless defined $index_target;
+ return if CPAN::_sqlite_running;
$CPAN::Frontend->myprint("Going to read $index_target\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
sub write_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running;
return unless $CPAN::META->has_usable("Storable");
my $cache;
foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
sub read_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running;
return unless $CPAN::META->has_usable("Storable");
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
return unless -r $metadata_file and -f $metadata_file;
EXCUSE: {
my @e;
if ($self->prefs->{disabled}) {
- push @e, sprintf(
- "disabled via prefs file '%s' doc %d",
- $self->{prefs_file},
- $self->{prefs_file_doc},
- );
- }
- exists $self->{build_dir} and push @e,
- "Is already unwrapped into directory $self->{build_dir}";
+ 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");
+ # note: not intended to be persistent but at least visible
+ # during this session
+ } else {
+ exists $self->{build_dir} and push @e,
+ "Is already unwrapped into directory $self->{build_dir}";
- exists $self->{unwrapped} and (
- UNIVERSAL::can($self->{unwrapped},"failed") ?
- $self->{unwrapped}->failed :
- $self->{unwrapped} =~ /^NO/
- )
- and push @e, "Unwrapping had some problem, won't try again without force";
+ exists $self->{unwrapped} and (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )
+ and push @e, "Unwrapping had some problem, won't try again without force";
+ }
- $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
+ $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
}
my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
for $f (@dirents) { # is already without "." and ".."
my $from = File::Spec->catdir($from_dir,$f);
my $to = File::Spec->catdir($packagedir,$f);
- File::Copy::move($from,$to) or Carp::confess("Couldn't move $from to $to: $!");
+ unless (File::Copy::move($from,$to)) {
+ my $err = $!;
+ $from = File::Spec->rel2abs($from);
+ Carp::confess("Couldn't move $from to $to: $err");
+ }
}
} else { # older code below, still better than nothing when there is no File::Temp
my($distdir);
sub store_persistent_state {
my($self) = @_;
my $dir = $self->{build_dir};
- unless (File::Basename::dirname($dir) eq $CPAN::Config->{build_dir}) {
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
"will not store persistent state\n");
return;
#-> sub CPAN::Distribution::force ;
sub force {
my($self, $method) = @_;
- for my $att (qw(
- CHECKSUM_STATUS
- archived
- badtestcnt
- build_dir
- install
- localfile
- make
- make_test
- modulebuild
- prefs
- prefs_file
- prereq_pm
- prereq_pm_detected
- reqtype
- signature_verify
- unwrapped
- writemakefile
- yaml_content
- )) {
- delete $self->{$att};
- CPAN->debug(sprintf "att[%s]", $att) if $CPAN::DEBUG;
+ my %phase_map = (
+ get => [
+ "unwrapped",
+ "build_dir",
+ "archived",
+ "localfile",
+ "CHECKSUM_STATUS",
+ "signature_verify",
+ "prefs",
+ "prefs_file",
+ "prefs_file_doc",
+ ],
+ make => [
+ "writemakefile",
+ "make",
+ "modulebuild",
+ "prereq_pm",
+ "prereq_pm_detected",
+ ],
+ test => [
+ "badtestcnt",
+ "make_test",
+ ],
+ install => [
+ "install",
+ ],
+ unknown => [
+ "reqtype",
+ "yaml_content",
+ ],
+ );
+ PHASE: for my $phase (qw(get make test install unknown)) { # tentative
+ ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
+ if ($phase eq "get" && $self->id =~ /\.$/ && $att =~ /(unwrapped|build_dir)/ ) {
+ # cannot be undone for local distros
+ next ATTRIBUTE;
+ }
+ delete $self->{$att};
+ CPAN->debug(sprintf "phase[%s]att[%s]", $phase, $att) if $CPAN::DEBUG;
+ }
}
if ($method && $method =~ /make|test|install/) {
$self->{"force_update"}++; # name should probably have been force_install
return;
}
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next unless defined $v;
+ $env{$k} = $v;
+ }
+ local %ENV = %env;
my $system;
- if ($self->{'configure'}) {
+ if (my $commandline = $self->prefs->{pl}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{'configure'}) {
$system = $self->{'configure'};
} elsif ($self->{modulebuild}) {
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
$makepl_arg ? " $makepl_arg" : "",
);
}
- my %env;
- while (my($k,$v) = each %ENV) {
- next unless defined $v;
- $env{$k} = $v;
- }
- local %ENV = %env;
if (my $env = $self->prefs->{pl}{env}) {
for my $e (keys %$env) {
$ENV{$e} = $env->{$e};
delete $self->{force_update};
return;
}
- if ($self->{modulebuild}) {
- unless (-f "Build") {
- my $cwd = Cwd::cwd;
- $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
- " in cwd[$cwd]. Danger, Will Robinson!");
- $CPAN::Frontend->mysleep(5);
- }
- $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
+ if (my $commandline = $self->prefs->{make}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
} else {
- $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
+ if ($self->{modulebuild}) {
+ unless (-f "Build") {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
+ " in cwd[$cwd]. Danger, Will Robinson!");
+ $CPAN::Frontend->mysleep(5);
+ }
+ $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
+ } else {
+ $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
+ }
+ my $make_arg = $self->make_x_arg("make");
+ $system = sprintf("%s%s",
+ $system,
+ $make_arg ? " $make_arg" : "",
+ );
}
- my $make_arg = $self->make_x_arg("make");
- $system = sprintf("%s%s",
- $system,
- $make_arg ? " $make_arg" : "",
- );
if (my $env = $self->prefs->{make}{env}) { # overriding the local
# ENV of PL, not the
# outer ENV, but
if ($CPAN::META->has_inst("Expect")) {
my $expo = Expect->new; # expo Expect object;
$expo->spawn($system);
- my $expecta = $expect_model->{talk};
- if ($expect_model->{mode} eq "expect") {
- return $self->_run_via_expect_deterministic($expo,$expecta);
- } elsif ($expect_model->{mode} eq "expect-in-any-order") {
- return $self->_run_via_expect_anyorder($expo,$expecta);
+ $expect_model->{mode} ||= "deterministic";
+ if ($expect_model->{mode} eq "deterministic") {
+ return $self->_run_via_expect_deterministic($expo,$expect_model);
+ } elsif ($expect_model->{mode} eq "anyorder") {
+ return $self->_run_via_expect_anyorder($expo,$expect_model);
} else {
die "Panic: Illegal expect mode: $expect_model->{mode}";
}
}
sub _run_via_expect_anyorder {
- my($self,$expo,$expecta) = @_;
- my $timeout = 3; # currently unsettable
- my @expectacopy = @$expecta; # we trash it!
+ my($self,$expo,$expect_model) = @_;
+ my $timeout = $expect_model->{timeout} || 5;
+ my @expectacopy = @{$expect_model->{talk}}; # we trash it!
my $but = "";
EXPECT: while () {
my($eof,$ran_into_timeout);
}
sub _run_via_expect_deterministic {
- my($self,$expo,$expecta) = @_;
+ my($self,$expo,$expect_model) = @_;
my $ran_into_timeout;
+ my $timeout = $expect_model->{timeout} || 15; # currently unsettable
+ my $expecta = $expect_model->{talk};
EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
- my($next,$send) = @$expecta[$i,$i+1];
- my($timeout,$re);
- if (ref $next) {
- $timeout = $next->{timeout};
- $re = $next->{expect};
- } else {
- $timeout = 15;
- $re = $next;
- }
+ my($re,$send) = @$expecta[$i,$i+1];
CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
my $regex = eval "qr{$re}";
$expo->expect($timeout,
return $expo->exitstatus();
}
+sub _validate_distropref {
+ my($self,@args) = @_;
+ if (
+ $CPAN::META->has_inst("CPAN::Kwalify")
+ &&
+ $CPAN::META->has_inst("Kwalify")
+ ) {
+ eval {CPAN::Kwalify::_validate("distroprefs",@args);};
+ if ($@) {
+ $CPAN::Frontend->mywarn($@);
+ }
+ } else {
+ CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
+ }
+}
+
# CPAN::Distribution::_find_prefs
sub _find_prefs {
my($self) = @_;
# $DB::single=1;
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");
# color them as dirty
for my $p (@prereq) {
# warn "calling color_cmd_tmps(0,1)";
- CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
+ my $any = CPAN::Shell->expandany($p);
+ if ($any) {
+ $any->color_cmd_tmps(0,1);
+ } else {
+ $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
+ $CPAN::Frontend->mysleep(2);
+ }
}
# queue them and re-queue yourself
CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
}
} elsif ($rq =~ m|<=?\s*|) {
# 2005-12: no user
- $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
+ $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
$ok++;
next RQ;
}
$breq = $yaml->{build_requires} || {};
undef $req unless ref $req eq "HASH" && %$req;
if ($req) {
- if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
+ if ($yaml->{generated_by} &&
+ $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
my $eummv = do { local $^W = 0; $1+0; };
if ($eummv < 6.2501) {
# thanks to Slaven for digging that out: MM before
}
my $system;
- if ($self->{modulebuild}) {
+ if (my $commandline = $self->prefs->{test}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{modulebuild}) {
$system = sprintf "%s test", $self->_build_command();
} else {
$system = join " ", $self->_make_command(), "test";
if ( $tests_ok ) {
{
my @prereq;
+
for my $m (keys %{$self->{sponsored_mods}}) {
my $m_obj = CPAN::Shell->expand("Module",$m);
- my $d_obj = $m_obj->distribution;
- if ($d_obj) {
- if (!$d_obj->{make_test}
- ||
- $d_obj->{make_test}->failed){
- #$m_obj->dump;
- push @prereq, $m;
- }
+ # XXX we need available_version which reflects
+ # $ENV{PERL5LIB} so that already tested but not yet
+ # installed modules are counted.
+ my $available_version = $m_obj->available_version;
+ if ($available_version &&
+ !CPAN::Version->vlt($available_version,$self->{PREREQ_PM}{$m})
+ ) {
+ CPAN->debug("m[$m] good enough available_version[$available_version]")
+ if $CPAN::DEBUG;
+ } else {
+ push @prereq, $m;
}
}
if (@prereq){
my $cnt = @prereq;
my $which = join ",", @prereq;
- my $verb = $cnt == 1 ? "one dependency not OK ($which)" :
+ my $but = $cnt == 1 ? "one dependency not OK ($which)" :
"$cnt dependencies missing ($which)";
- $CPAN::Frontend->mywarn("Tests succeeded but $verb\n");
- $self->{make_test} = CPAN::Distrostatus->new("NO $verb");
+ $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO $but");
$self->store_persistent_state;
return;
}
return unless my $where_prefs = $prefs->{$where};
if ($where_prefs->{expect}) {
return {
- mode => "expect",
+ mode => "deterministic",
+ timeout => 15,
talk => $where_prefs->{expect},
};
- } elsif ($where_prefs->{"expect-in-any-order"}) {
- return {
- mode => "expect-in-any-order",
- talk => $where_prefs->{"expect-in-any-order"},
- };
+ } elsif ($where_prefs->{"eexpect"}) {
+ return $where_prefs->{"eexpect"};
}
return;
}
my $system;
if ($self->{modulebuild}) {
unless (-f "Build") {
- my $cwd = Cwd::cwd;
+ my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
" in cwd[$cwd]. Danger, Will Robinson!");
$CPAN::Frontend->mysleep(5);
$self->store_persistent_state;
}
-#-> sub CPAN::Distribution::install ;
+#-> sub CPAN::Distribution::goto ;
sub goto {
my($self,$goto) = @_;
+ $goto = $self->normalize($goto);
+
+ # inject into the queue
+
+ CPAN::Queue->delete($self->id);
+ CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
+
+ # and run where we left off
+
my($method) = (caller(1))[3];
CPAN->instance("CPAN::Distribution",$goto)->$method;
+
}
#-> sub CPAN::Distribution::install ;
}
my $system;
- if ($self->{modulebuild}) {
+ if (my $commandline = $self->prefs->{install}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{modulebuild}) {
my($mbuild_install_build_command) =
exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
$CPAN::Config->{mbuild_install_build_command} ?
#-> sub CPAN::Module::inst_file ;
sub inst_file {
my($self) = @_;
+ $self->_file_in_path([@INC]);
+}
+
+#-> sub CPAN::Module::available_file ;
+sub available_file {
+ my($self) = @_;
+ my $sep = $Config::Config{path_sep};
+ my $perllib = $ENV{PERL5LIB};
+ $perllib = $ENV{PERLLIB} unless defined $perllib;
+ my @perllib = split(/$sep/,$perllib) if defined $perllib;
+ $self->_file_in_path([@perllib,@INC]);
+}
+
+#-> sub CPAN::Module::file_in_path ;
+sub _file_in_path {
+ my($self,$path) = @_;
my($dir,@packpath);
@packpath = split /::/, $self->{ID};
$packpath[-1] .= ".pm";
if (@packpath == 1 && $packpath[0] eq "readline.pm") {
unshift @packpath, "Term", "ReadLine"; # historical reasons
}
- foreach $dir (@INC) {
+ foreach $dir (@$path) {
my $pmfile = File::Spec->catfile($dir,@packpath);
if (-f $pmfile){
return $pmfile;
sub inst_version {
my($self) = @_;
my $parsefile = $self->inst_file or return;
- local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
- my $have;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
+
+#-> sub CPAN::Module::inst_version ;
+sub available_version {
+ my($self) = @_;
+ my $parsefile = $self->available_file or return;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
- $have = MM->parse_version($parsefile);
+#-> sub CPAN::Module::parse_version ;
+sub parse_version {
+ my($self,$parsefile) = @_;
+ my $have = MM->parse_version($parsefile);
$have = "undef" unless defined $have && length $have;
$have =~ s/^ //; # since the %vd hack these two lines here are needed
$have =~ s/ $//; # trailing whitespace happens all the time
- # My thoughts about why %vd processing should happen here
-
- # Alt1 maintain it as string with leading v:
- # read index files do nothing
- # compare it use utility for compare
- # print it do nothing
-
- # Alt2 maintain it as what it is
- # read index files convert
- # compare it use utility because there's still a ">" vs "gt" issue
- # print it use CPAN::Version for print
-
- # Seems cleaner to hold it in memory as a string starting with a "v"
-
- # If the author of this module made a mistake and wrote a quoted
- # "v1.13" instead of v1.13, we simply leave it at that with the
- # effect that *we* will treat it like a v-tring while the rest of
- # perl won't. Seems sensible when we consider that any action we
- # could take now would just add complexity.
-
$have = CPAN::Version->readable($have);
$have =~ s/\s*//g; # stringify to float around floating point issues
=head2 Methods in the other Classes
-The programming interface for the classes CPAN::Module,
-CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
-beta and partially even alpha. In the following paragraphs only those
-methods are documented that have proven useful over a longer time and
-thus are unlikely to change.
-
=over 4
=item CPAN::Author::as_glimpse()
=item CPAN::Bundle::force($method,@args)
-Forces CPAN to perform a task that normally would have failed. Force
-takes as arguments a method name to be called and any number of
-additional arguments that should be passed to the called method. The
-internals of the object get the needed changes so that CPAN.pm does
-not refuse to take the action. The C<force> is passed recursively to
-all contained objects.
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. The C<force> is passed recursively
+to all contained objects.
=item CPAN::Bundle::get()
is reported just like perl itself stops searching @INC when it finds a
module.
+=item CPAN::Module::available_file()
+
+Returns the filename of the module found in PERL5LIB or @INC. The
+first file found is reported. The advantage of this method over
+C<inst_file> is that modules that have been tested but not yet
+installed are included because PERL5LIB keeps track of tested modules.
+
=item CPAN::Module::inst_version()
-Returns the version number of the module in readable format.
+Returns the version number of the installed module in readable format.
+
+=item CPAN::Module::available_version()
+
+Returns the version number of the available module in readable format.
=item CPAN::Module::install()
test_report email test reports (if CPAN::Reporter is installed)
unzip location of external program unzip
urllist arrayref to nearby CPAN sites (or equivalent locations)
+ use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
username your username if you CPAN server wants one
wait_list arrayref to a wait server to try (See CPAN::WAIT)
wget path to external prg
=head1 TRANSLATIONS
Kawai,Takanori provides a Japanese translation of this manpage at
-http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
+http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
=head1 SEE ALSO
cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
=cut
+
+
projects / platform / upstream / perl.git / commitdiff