From: Steve Peters Date: Sat, 20 Jan 2007 03:20:11 +0000 (+0000) Subject: Upgrade to CPAN-1.88_69. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b72dd56fb0d60fb6da69e621d692ef4dc931ad43;p=p5sagit%2Fp5-mst-13.2.git Upgrade to CPAN-1.88_69. p4raw-id: //depot/perl@29892 --- diff --git a/lib/CPAN.pm b/lib/CPAN.pm index dfd0b38..434fc16 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,7 +1,7 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- use strict; package CPAN; -$CPAN::VERSION = '1.88_66'; +$CPAN::VERSION = '1.88_69'; $CPAN::VERSION = eval $CPAN::VERSION; use CPAN::HandleConfig; @@ -94,6 +94,7 @@ use vars qw( cvs_import expand force + fforce get install install_tested @@ -263,9 +264,9 @@ ReadLine support %s $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; my $command = shift @line; eval { CPAN::Shell->$command(@line) }; - if ($@){ + if ($@ && "$@" =~ /\S/){ require Carp; - Carp::cluck($@); + Carp::cluck("Catching error: '$@'"); } if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) { CPAN::Shell->failed($CPAN::CurrentCommandId,1); @@ -354,7 +355,7 @@ Trying to chdir to "$cwd->[1]" instead. } } -sub _yaml_module { +sub _yaml_module () { my $yaml_module = $CPAN::Config->{yaml_module} || "YAML"; if ( $yaml_module ne "YAML" @@ -371,57 +372,50 @@ sub _yaml_module { sub _yaml_loadfile { my($self,$local_file) = @_; return +[] unless -s $local_file; - my $yaml_module = $self->_yaml_module; + my $yaml_module = _yaml_module; if ($CPAN::META->has_inst($yaml_module)) { my $code = UNIVERSAL::can($yaml_module, "LoadFile"); my @yaml; eval { @yaml = $code->($local_file); }; if ($@) { - $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n". - " $local_file\n". - "with $yaml_module the following error was encountered:\n". - " $@\n" - ); + # this shall not be done by the frontend + die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); } return \@yaml; } else { - $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n"); + # this shall not be done by the frontend + die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse"); } return +[]; } # CPAN::_yaml_dumpfile sub _yaml_dumpfile { - my($self,$to_local_file,@what) = @_; - my $yaml_module = $self->_yaml_module; + my($self,$local_file,@what) = @_; + my $yaml_module = _yaml_module; if ($CPAN::META->has_inst($yaml_module)) { - if (UNIVERSAL::isa($to_local_file, "FileHandle")) { + if (UNIVERSAL::isa($local_file, "FileHandle")) { my $code = UNIVERSAL::can($yaml_module, "Dump"); - eval { print $to_local_file $code->(@what) }; + eval { print $local_file $code->(@what) }; } else { my $code = UNIVERSAL::can($yaml_module, "DumpFile"); - eval { $code->($to_local_file,@what); }; + eval { $code->($local_file,@what); }; } if ($@) { - $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n". - " $to_local_file\n". - "with $yaml_module the following error was encountered:\n". - " $@\n" - ); + die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@); } } else { - if (UNIVERSAL::isa($to_local_file, "FileHandle")) { + if (UNIVERSAL::isa($local_file, "FileHandle")) { # I think this case does not justify a warning at all } else { - $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' ". - "not installed, not dumping to '$to_local_file'\n"); + die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump"); } } } sub _init_sqlite () { unless ($CPAN::META->has_inst("CPAN::SQLite")) { - $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, cannot work with it\n}) + $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n}) unless $Have_warned->{"CPAN::SQLite"}++; return; } @@ -473,6 +467,7 @@ use strict; cvs_import dump force + fforce hosts install install_tested @@ -544,6 +539,40 @@ sub as_string { ".\nCannot continue.\n"; } +package CPAN::Exception::yaml_not_installed; +use strict; +use overload '""' => "as_string"; + +sub new { + my($class,$module,$file,$during) = @_; + bless { module => $module, file => $file, during => $during }, $class; +} + +sub as_string { + my($self) = shift; + "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n"; +} + +package CPAN::Exception::yaml_process_error; +use strict; +use overload '""' => "as_string"; + +sub new { + my($class,$module,$file,$during,$error) = shift; + bless { module => $module, + file => $file, + during => $during, + error => $error }, $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"; +} + package CPAN::Prompt; use overload '""' => "as_string"; use vars qw($prompt); $prompt = "cpan> "; @@ -778,6 +807,7 @@ Please report if something unexpected happens\n"); $_->{commandnumber_in_prompt} = 0; # visibility $_->{histfile} = ""; # who should win otherwise? $_->{cache_metadata} = 0; # better would be a lock? + $_->{use_sqlite} = 0; # better would be a write lock! } } else { $CPAN::Frontend->mydie(" @@ -1170,6 +1200,7 @@ sub cleanup { return unless defined $META->{LOCK}; return unless -f $META->{LOCK}; $META->savehist; + close $META->{LOCKFH}; unlink $META->{LOCK}; # require Carp; # Carp::cluck("DEBUGGING"); @@ -1207,8 +1238,12 @@ sub savehist { #-> sub CPAN::is_tested sub is_tested { - my($self,$what) = @_; - $self->{is_tested}{$what} = 1; + my($self,$what,$when) = @_; + unless ($what) { + Carp::cluck("DEBUG: empty what"); + return; + } + $self->{is_tested}{$what} = $when; } #-> sub CPAN::is_installed @@ -1219,6 +1254,13 @@ sub is_installed { delete $self->{is_tested}{$what}; } +sub _list_sorted_descending_is_tested { + my($self) = @_; + sort + { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) } + keys %{$self->{is_tested}} +} + #-> sub CPAN::set_perl5lib sub set_perl5lib { my($self,$for) = @_; @@ -1234,16 +1276,24 @@ sub set_perl5lib { push @env, $env if defined $env and length $env; #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}}; #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n"); - my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}}; - if (@dirs < 15) { - $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\n"); + + my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested; + if (@dirs < 12) { + $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n"); + } elsif (@dirs < 24) { + my @d = map {my $cp = $_; + $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/; + $cp + } @dirs; + $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ". + "%BUILDDIR%=$CPAN::Config->{build_dir} ". + "for '$for'\n" + ); } else { - my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ } - sort keys %{$self->{is_tested}}; - $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ". - "@d to PERL5LIB; ". - "%BUILDDIR%=$CPAN::Config->{'build_dir'} ". - "for $for\n" + my $cnt = keys %{$self->{is_tested}}; + $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ". + "$cnt build dirs to PERL5LIB; ". + "for '$for'\n" ); } @@ -1277,8 +1327,7 @@ sub tidyup { my($toremove) = shift @{$self->{FIFO}}; unless ($toremove =~ /\.yml$/) { $CPAN::Frontend->myprint(sprintf( - "Deleting from cache". - ": $toremove (%.1f>%.1f MB)\n", + "DEL: $toremove (%.1f>%.1f MB)\n", $self->{DU}, $self->{'MAX'}) ); } @@ -1399,7 +1448,7 @@ sub new { my($debug,$t2); $debug = ""; my $self = { - ID => $CPAN::Config->{'build_dir'}, + ID => $CPAN::Config->{build_dir}, MAX => $CPAN::Config->{'build_cache'}, SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', DU => 0 @@ -1425,11 +1474,20 @@ sub scan_cache { sprintf("Scanning cache %s for sizes\n", $self->{ID})); my $e; - for $e ($self->entries($self->{ID})) { - next if $e eq ".." || $e eq "."; + my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID}); + my $i = 0; + my $painted = 0; + for $e (@entries) { + # next if $e eq ".." || $e eq "."; $self->disk_usage($e); + $i++; + while (($painted/76) < ($i/@entries)) { + $CPAN::Frontend->myprint("."); + $painted++; + } return if $CPAN::Signal; } + $CPAN::Frontend->myprint("DONE\n"); $self->tidyup; } @@ -1463,7 +1521,7 @@ Upgrade upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules Pragmas - force CMD try hard to do command + force CMD try hard to do command fforce CMD try harder notest CMD skip testing Other @@ -1531,11 +1589,13 @@ sub globls { $pathglob = $2; $author = CPAN::Shell->expand_by_method('CPAN::Author', ['id'], - $a2) or die "No author found for $a2"; + $a2) + or $CPAN::Frontend->mydie("No author found for $a2\n"); } else { $author = CPAN::Shell->expand_by_method('CPAN::Author', ['id'], - $a) or die "No author found for $a"; + $a) + or $CPAN::Frontend->mydie("No author found for $a\n"); } if ($silent) { my $alpha = substr $author->id, 0, 1; @@ -1666,10 +1726,6 @@ sub o { $CPAN::Frontend->myprint("\n"); } else { if (CPAN::HandleConfig->edit(@o_what)) { - unless ($o_what[0] =~ /^(init|commit|defaults)$/) { - $CPAN::Frontend->myprint("Please use 'o conf commit' to ". - "make the config permanent!\n\n"); - } } else { $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }. qq{items\n\n}); @@ -1807,8 +1863,10 @@ sub hosts { ]; } my $R = ""; # report - $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown"; - $R .= sprintf "Log ends : %s\n", scalar(localtime $S{end}) || "unknown"; + if ($S{start} && $S{end}) { + $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown"; + $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown"; + } if ($res->{ok} && @{$res->{ok}}) { $R .= sprintf "\nSuccessful downloads: N kB secs kB/s url\n"; @@ -2069,16 +2127,39 @@ sub report { # re-run (as documented) } +# experimental (compare with _is_tested) #-> sub CPAN::Shell::install_tested sub install_tested { my($self,@some) = @_; - $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"), + $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"), return if @some; CPAN::Index->reload; - for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) { - my $do = CPAN::Shell->expandany($d); - next unless $do->{build_dir}; + for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { + my $yaml = "$b.yml"; + unless (-f $yaml){ + $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n"); + next; + } + my $yaml_content = CPAN::_yaml_loadfile($yaml); + my $id = $yaml_content->[0]{ID}; + unless ($id){ + $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n"); + next; + } + my $do = CPAN::Shell->expandany($id); + unless ($do){ + $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n"); + next; + } + unless ($do->{build_dir}) { + $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n"); + next; + } + unless ($do->{build_dir} eq $b) { + $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n"); + next; + } push @some, $do; } @@ -2089,15 +2170,15 @@ sub install_tested { $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"), return unless @some; - @some = grep { not $_->uptodate } @some; - $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"), - return unless @some; + # @some = grep { not $_->uptodate } @some; + # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"), + # return unless @some; CPAN->debug("some[@some]"); for my $d (@some) { my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id; $CPAN::Frontend->myprint("install_tested: Running for $id\n"); - $CPAN::Frontend->sleep(1); + $CPAN::Frontend->mysleep(1); $self->install($d); } } @@ -2361,6 +2442,23 @@ sub status { } } +# experimental (must run after failed or similar [I think]) +# intended as a preparation ot install_tested +#-> sub CPAN::Shell::is_tested +sub _is_tested { + my($self) = @_; + for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { + my $time; + if ($CPAN::META->{is_tested}{$b}) { + $time = scalar(localtime $CPAN::META->{is_tested}{$b}); + } else { + $time = scalar localtime; + $time =~ s/\S/?/g; + } + $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b); + } +} + #-> sub CPAN::Shell::autobundle ; sub autobundle { my($self) = shift; @@ -2468,7 +2566,7 @@ sub expand_by_method { for $obj ( $CPAN::META->all_objects($class) ) { - unless ($obj->id){ + unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){ # BUG, we got an empty object somewhere require Data::Dumper; CPAN->debug(sprintf( @@ -2624,7 +2722,7 @@ sub print_ornamented { if ($self->colorize_output) { if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) { # if you want to have this configurable, please file a bugreport - $ornament = "black on_cyan"; + $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan"; } my $color_on = eval { Term::ANSIColor::color($ornament) } || ""; if ($@) { @@ -2740,7 +2838,7 @@ sub rematein { my $self = shift; my($meth,@some) = @_; my @pragma; - while($meth =~ /^(force|notest)$/) { + while($meth =~ /^(ff?orce|notest)$/) { push @pragma, $meth; $meth = shift @some or $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ". @@ -2925,6 +3023,7 @@ sub recent { cvs_import dump force + fforce get install look @@ -3094,7 +3193,19 @@ sub _ftp_statistics { $sleep+=0.11; } } - my $stats = CPAN->_yaml_loadfile($file); + my $stats = eval { CPAN->_yaml_loadfile($file); }; + if ($@) { + if (ref $@) { + if (ref $@ eq "CPAN::Exception::yaml_not_installed") { + $CPAN::Frontend->myprint("Warning (usually harmless): $@"); + return; + } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") { + $CPAN::Frontend->mydie($@); + } + } else { + $CPAN::Frontend->mydie($@); + } + } return $stats->[0]; } @@ -3121,7 +3232,7 @@ sub _new_stats { #-> sub CPAN::FTP::_add_to_statistics sub _add_to_statistics { my($self,$stats) = @_; - my $yaml_module = $self->CPAN::_yaml_module; + my $yaml_module = CPAN::_yaml_module; if ($CPAN::META->has_inst($yaml_module)) { $stats->{thesiteurl} = $ThesiteURL; if (CPAN->has_inst("Time::HiRes")) { @@ -3130,24 +3241,42 @@ sub _add_to_statistics { $stats->{end} = time; } my $fh = FileHandle->new; + my $time = time; + my $sdebug = 0; + my @debug; + @debug = $time if $sdebug; my $fullstats = $self->_ftp_statistics($fh); + close $fh; $fullstats->{history} ||= []; - my @debug = scalar @{$fullstats->{history}}; + push @debug, scalar @{$fullstats->{history}} if $sdebug; + push @debug, time if $sdebug; 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]", + # arbitrary hardcoded constants until somebody demands to have + # them settable + while ( + @{$fullstats->{history}} > 9999 + || $time - $fullstats->{history}[0]{start} > 30*86400 # one month + ) { + shift @{$fullstats->{history}} + } + push @debug, scalar @{$fullstats->{history}} if $sdebug; + push @debug, time if $sdebug; + push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug; + # need no eval because if this fails, it is serious + my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); + CPAN->_yaml_dumpfile("$sfile.$$",$fullstats); + if ( $sdebug||$CPAN::DEBUG ) { + local $CPAN::DEBUG = 512; # FTP + push @debug, time; + CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]". + "after[%d]at[%d]oldest[%s]dumped backat[%d]", @debug, - )) if $CPAN::DEBUG; + )); } - seek $fh, 0, 0; - truncate $fh, 0; - CPAN->_yaml_dumpfile($fh,$fullstats); + # Win32 cannot rename a file to an existing filename + unlink($sfile) if ($^O eq 'MSWin32'); + rename "$sfile.$$", $sfile + or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n"); } } @@ -4113,10 +4242,9 @@ sub cpl { #-> sub CPAN::Complete::cplx ; sub cplx { my($class, $word) = @_; - # I believed for many years that this was sorted, today I - # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I - # make it sorted again. Maybe sort was dropped when GNU-readline - # support came in? The RCS file is difficult to read on that:-( + if (CPAN::_sqlite_running) { + $CPAN::SQLite->search($class, "^\Q$word\E"); + } sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); } @@ -4277,7 +4405,9 @@ sub reanimate_build_dir { map { [ $_, -M File::Spec->catfile($d,$_) ] } grep {/\.yml$/} readdir $dh; DISTRO: for $dirent (@candidates) { - my $c = CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))->[0]; + my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))}; + die $@ if $@; + my $c = $y->[0]; if ($c && CPAN->_perl_fingerprint($c->{perl})) { my $key = $c->{distribution}{ID}; for my $k (keys %{$c->{distribution}}) { @@ -4291,7 +4421,22 @@ sub reanimate_build_dir { #we tried to restore only if element already #exists; but then we do not work with metadata #turned off. - $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} = $c->{distribution}; + my $do + = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} + = $c->{distribution}; + delete $do->{badtestcnt}; + # $DB::single = 1; + if ($do->{make_test} + && $do->{build_dir} + && !$do->{make_test}->failed + && ( + !$do->{install} + || + $do->{install}->failed + ) + ) { + $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME}); + } $restored++; } $i++; @@ -5258,6 +5403,11 @@ sub color_cmd_tmps { } if ($color==0) { delete $self->{sponsored_mods}; + + # as we are at the end of a command, we'll give up this + # reminder of a broken test. Other commands may test this guy + # again. Maybe 'badtestcnt' should be renamed to + # 'makte_test_failed_within_command'? delete $self->{badtestcnt}; } $self->{incommandcolor} = $color; @@ -5281,9 +5431,13 @@ sub containsmods { my $mod_id = $mod->{ID} or next; # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]"; # sleep 1; + if ($CPAN::Signal) { + delete $self->{CONTAINSMODS}; + return; + } $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; } - keys %{$self->{CONTAINSMODS}}; + keys %{$self->{CONTAINSMODS}||{}}; } #-> sub CPAN::Distribution::upload_date ; @@ -5328,6 +5482,7 @@ sub called_for { #-> sub CPAN::Distribution::get ; sub get { my($self) = @_; + $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { $CPAN::Frontend->mywarn (sprintf( @@ -5347,6 +5502,7 @@ sub get { EXCUSE: { my @e; + $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG; if ($self->prefs->{disabled}) { my $why = sprintf( "Disabled via prefs file '%s' doc %d", @@ -5358,9 +5514,17 @@ sub get { # 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}"; + if (exists $self->{build_dir}) { + # this deserves print, not warn: + $CPAN::Frontend->myprint(" Has already been unwrapped into directory ". + "$self->{build_dir}\n" + ); + return; + } + # although we talk about 'force' we shall not test on + # force directly. New model of force tries to refrain from + # direct checking of force. exists $self->{unwrapped} and ( UNIVERSAL::can($self->{unwrapped},"failed") ? $self->{unwrapped}->failed : @@ -5534,7 +5698,7 @@ EOF )) if $CPAN::DEBUG; } else { my $userid = $self->cpan_userid; - CPAN->debug("userid[$userid]"); + CPAN->debug("userid[$userid]") if $CPAN::DEBUG; if (!$userid or $userid eq "N/A") { $userid = "anon"; } @@ -5556,7 +5720,7 @@ EOF return; } - $self->{'build_dir'} = $packagedir; + $self->{build_dir} = $packagedir; $self->safe_chdir($builddir); File::Path::rmtree("tmp-$$"); @@ -5614,14 +5778,20 @@ sub store_persistent_state { return; } my $file = sprintf "%s.yml", $dir; - CPAN->_yaml_dumpfile( - $file, - { - time => time, - perl => CPAN::_perl_fingerprint, - distribution => $self, - } - ); + my $yaml_module = CPAN::_yaml_module; + if ($CPAN::META->has_inst($yaml_module)) { + CPAN->_yaml_dumpfile( + $file, + { + time => time, + perl => CPAN::_perl_fingerprint, + distribution => $self, + } + ); + } else { + $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ". + "will not store persistent state\n"); + } } #-> CPAN::Distribution::patch @@ -5643,10 +5813,14 @@ sub try_download { #-> CPAN::Distribution::patch sub patch { my($self) = @_; - if (my $patches = $self->prefs->{patches}) { + $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]"); + 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". @@ -5677,12 +5851,21 @@ sub patch { } $CPAN::Frontend->myprint(" $patch\n"); my $readfh = CPAN::Tarzip->TIEHANDLE($patch); - my $thispatchargs = join " ", $stdpatchargs, $self->_patch_p_parameter($readfh); - CPAN->debug("thispatchargs[$thispatchargs]") if $CPAN::DEBUG; - $readfh = CPAN::Tarzip->TIEHANDLE($patch); + + my $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; - unless (open $writefh, "|$patchbin $thispatchargs") { - my $fail = "Could not fork '$patchbin $thispatchargs'"; + $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}; @@ -5710,11 +5893,19 @@ sub _patch_p_parameter { my $cnt_p0files = 0; local($_); while ($_ = $fh->READLINE) { + if ( + $CPAN::Config->{applypatch} + && + /\#\#\#\# ApplyPatch data follows \#\#\#\#/ + ) { + return "applypatch" + } next unless /^[\*\+]{3}\s(\S+)/; my $file = $1; $cnt_files++; $cnt_p0files++ if -f $file; - CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") if $CPAN::DEBUG; + CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") + if $CPAN::DEBUG; } return "-p1" unless $cnt_files; return $cnt_files==$cnt_p0files ? "-p0" : "-p1"; @@ -6149,10 +6340,10 @@ sub CHECKSUM_check_file { q{check_sigs}); if ($check_sigs) { if ($CPAN::META->has_inst("Module::Signature")) { - $self->debug("Module::Signature is installed, verifying"); + $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; $self->SIG_check_file($chk_file); } else { - $self->debug("Module::Signature is NOT installed"); + $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; } } @@ -6282,9 +6473,15 @@ sub eq_CHECKSUM { # "Force get forgets previous error conditions" +#-> sub CPAN::Distribution::fforce ; +sub fforce { + my($self, $method) = @_; + $self->force($method,1); +} + #-> sub CPAN::Distribution::force ; sub force { - my($self, $method) = @_; + my($self, $method,$fforce) = @_; my %phase_map = ( get => [ "unwrapped", @@ -6316,18 +6513,43 @@ sub force { "yaml_content", ], ); - PHASE: for my $phase (qw(get make test install unknown)) { # tentative + my $methodmatch = 0; + my $ldebug = 0; + PHASE: for my $phase (qw(unknown get make test install)) { # order matters + $methodmatch = 1 if $fforce || $phase eq $method; + next unless $methodmatch; ATTRIBUTE: for my $att (@{$phase_map{$phase}}) { - if ($phase eq "get" && $self->id =~ /\.$/ && $att =~ /(unwrapped|build_dir)/ ) { - # cannot be undone for local distros - next ATTRIBUTE; + if ($phase eq "get") { + if (substr($self->id,-1,1) eq "." + && $att =~ /(unwrapped|build_dir|archived)/ ) { + # cannot be undone for local distros + next ATTRIBUTE; + } + if ($att eq "build_dir" + && $self->{build_dir} + && $CPAN::META->{is_tested} + ) { + delete $CPAN::META->{is_tested}{$self->{build_dir}}; + } + } elsif ($phase eq "test") { + if ($att eq "make_test" + && $self->{make_test} + && $self->{make_test}{COMMANDID} + && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId + ) { + # endless loop too likely + next ATTRIBUTE; + } } delete $self->{$att}; - CPAN->debug(sprintf "phase[%s]att[%s]", $phase, $att) if $CPAN::DEBUG; + if ($ldebug || $CPAN::DEBUG) { + # local $CPAN::DEBUG = 16; # Distribution + CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att); + } } } if ($method && $method =~ /make|test|install/) { - $self->{"force_update"}++; # name should probably have been force_install + $self->{force_update} = 1; # name should probably have been force_install } } @@ -6348,7 +6570,7 @@ sub unnotest { #-> sub CPAN::Distribution::unforce ; sub unforce { my($self) = @_; - delete $self->{'force_update'}; + delete $self->{force_update}; } #-> sub CPAN::Distribution::isa_perl ; @@ -6427,7 +6649,6 @@ is part of the perl-%s distribution. To install that, you need to run local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) ? $ENV{PERL5LIB} : ($ENV{PERLLIB} || ""); - $CPAN::META->set_perl5lib; local $ENV{MAKEFLAGS}; # protect us from outer make calls @@ -6435,6 +6656,8 @@ is part of the perl-%s distribution. To install that, you need to run delete $self->{force_update}; return; } + + my $builddir; EXCUSE: { my @e; if (!$self->{archived} || $self->{archived} eq "NO") { @@ -6477,7 +6700,7 @@ is part of the perl-%s distribution. To install that, you need to run } defined $self->{make} and push @e, - "Has already been processed within this session"; + "Has already been made"; if (exists $self->{later} and length($self->{later})) { if ($self->unsat_prereq) { @@ -6494,15 +6717,18 @@ is part of the perl-%s distribution. To install that, you need to run } $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + $builddir = $self->dir or + $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n"); + unless (chdir $builddir) { + push @e, "Couldn't chdir to '$builddir': $!"; + } + $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; } if ($CPAN::Signal){ delete $self->{force_update}; return; } $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); - my $builddir = $self->dir or - $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n"); - chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; if ($^O eq 'MacOS') { @@ -6658,10 +6884,11 @@ is part of the perl-%s distribution. To install that, you need to run " in cwd[$cwd]. Danger, Will Robinson!"); $CPAN::Frontend->mysleep(5); } - $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg}; + $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg}; } else { - $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg}; + $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg}; } + $system =~ s/\s+$//; my $make_arg = $self->make_x_arg("make"); $system = sprintf("%s%s", $system, @@ -6806,6 +7033,7 @@ expected[$regex]\nbut[$but]\n\n"); return $expo->exitstatus(); } +#-> CPAN::Distribution::_validate_distropref sub _validate_distropref { my($self,@args) = @_; if ( @@ -6822,17 +7050,17 @@ sub _validate_distropref { } } -# CPAN::Distribution::_find_prefs +#-> CPAN::Distribution::_find_prefs sub _find_prefs { my($self) = @_; my $distroid = $self->pretty_id; - CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG; + #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG; my $prefs_dir = $CPAN::Config->{prefs_dir}; eval { File::Path::mkpath($prefs_dir); }; if ($@) { $CPAN::Frontend->mydie("Cannot create directory $prefs_dir"); } - my $yaml_module = CPAN->_yaml_module; + my $yaml_module = CPAN::_yaml_module; my @extensions; if ($CPAN::META->has_inst($yaml_module)) { push @extensions, "yml"; @@ -6869,10 +7097,13 @@ sub _find_prefs { my $thisexte = $1; my $abs = File::Spec->catfile($prefs_dir, $_); if (-f $abs) { - CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG; + #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG; my @distropref; if ($thisexte eq "yml") { + # need no eval because if we have no YAML we do not try to read *.yml + #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG; @distropref = @{CPAN->_yaml_loadfile($abs)}; + #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG; } elsif ($thisexte eq "dd") { package CPAN::Eval; no strict; @@ -6900,22 +7131,26 @@ sub _find_prefs { } } # $DB::single=1; + #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG; ELEMENT: for my $y (0..$#distropref) { my $distropref = $distropref[$y]; $self->_validate_distropref($distropref,$abs,$y); my $match = $distropref->{match}; unless ($match) { - CPAN->debug("no 'match' in abs[$abs], skipping"); + #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG; next ELEMENT; } my $ok = 1; - for my $sub_attribute (keys %$match) { + # do not take the order of C 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 "abs[%s]distropref[%d]", $abs, scalar @distropref) if $CPAN::DEBUG; + #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG; my @modules = $self->containsmods; - CPAN->debug(sprintf "abs[%s]distropref[%d]modules[%s]", $abs, scalar @distropref, join(",",@modules)) if $CPAN::DEBUG; + #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG; MODULE: for my $module (@modules) { $okm ||= $module =~ /$qr/; last MODULE if $okm; @@ -6933,8 +7168,9 @@ sub _find_prefs { "Please ". "remove, cannot continue."); } + last if $ok == 0; # short circuit } - CPAN->debug(sprintf "abs[%s]distropref[%d]ok[%d]", $abs, scalar @distropref, $ok) if $CPAN::DEBUG; + #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG; if ($ok) { return { prefs => $distropref, @@ -6946,6 +7182,7 @@ sub _find_prefs { } } } + $dh->close; } return; } @@ -6959,6 +7196,8 @@ sub prefs { if ($CPAN::Config->{prefs_dir}) { CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG; my $prefs = $self->_find_prefs(); + $prefs ||= ""; # avoid warning next line + CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG; if ($prefs) { for my $x (qw(prefs prefs_file prefs_file_doc)) { $self->{$x} = $prefs->{$x}; @@ -7103,29 +7342,29 @@ sub unsat_prereq { my(@need); my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}}); NEED: while (my($need_module, $need_version) = each %merged) { - my($have_version,$inst_file); + my($available_version,$available_file); if ($need_module eq "perl") { - $have_version = $]; - $inst_file = $^X; + $available_version = $]; + $available_file = $^X; } else { my $nmo = $CPAN::META->instance("CPAN::Module",$need_module); next if $nmo->uptodate; - $inst_file = $nmo->inst_file; + $available_file = $nmo->available_file; # if they have not specified a version, we accept any installed one if (not defined $need_version or $need_version eq "0" or $need_version eq "undef") { - next if defined $inst_file; + next if defined $available_file; } - $have_version = $nmo->inst_version; + $available_version = $nmo->available_version; } # We only want to install prereqs if either they're not installed # or if the installed version is too old. We cannot omit this # check, because if 'force' is in effect, nobody else will check. - if (defined $inst_file) { + if (defined $available_file) { my(@all_requirements) = split /\s*,\s*/, $need_version; local($^W) = 0; my $ok = 0; @@ -7133,13 +7372,13 @@ sub unsat_prereq { if ($rq =~ s|>=\s*||) { } elsif ($rq =~ s|>\s*||) { # 2005-12: one user - if (CPAN::Version->vgt($have_version,$rq)){ + if (CPAN::Version->vgt($available_version,$rq)){ $ok++; } next RQ; } elsif ($rq =~ s|!=\s*||) { # 2005-12: no user - if (CPAN::Version->vcmp($have_version,$rq)){ + if (CPAN::Version->vcmp($available_version,$rq)){ $ok++; next RQ; } else { @@ -7151,14 +7390,14 @@ sub unsat_prereq { $ok++; next RQ; } - if (! CPAN::Version->vgt($rq, $have_version)){ + if (! CPAN::Version->vgt($rq, $available_version)){ $ok++; } - CPAN->debug(sprintf("need_module[%s]inst_file[%s]". - "inst_version[%s]rq[%s]ok[%d]", + CPAN->debug(sprintf("need_module[%s]available_file[%s]". + "available_version[%s]rq[%s]ok[%d]", $need_module, - $inst_file, - $have_version, + $available_file, + $available_version, CPAN::Version->readable($rq), $ok, )) if $CPAN::DEBUG; @@ -7191,10 +7430,12 @@ sub read_yaml { return unless -f $yaml; eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; }; if ($@) { - $CPAN::Frontend->mywarn("Warning (probably harmless): Could not read ". + $CPAN::Frontend->mywarn("Could not read ". "'$yaml'. Falling back to other ". "methods to determine prerequisites\n"); - return; # if we die, then we cannot read YAML's own META.yml + return $self->{yaml_content} = undef; # if we die, then we + # cannot read YAML's own + # META.yml } if (not exists $self->{yaml_content}{dynamic_config} or $self->{yaml_content}{dynamic_config} @@ -7393,17 +7634,18 @@ sub test { $self->{make_test} =~ /^NO/ ) ) { - push @e, "Already tested successfully"; + push @e, "Has already been tested successfully"; } } elsif (!@e) { push @e, "Has no own directory"; } - $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + unless (chdir $self->{build_dir}) { + push @e, "Couldn't chdir to '$self->{build_dir}': $!"; + } + $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; } - chdir $self->{'build_dir'} or - Carp::croak("Couldn't chdir to $self->{'build_dir'}"); - $self->debug("Changed directory to $self->{'build_dir'}") + $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; if ($^O eq 'MacOS') { @@ -7506,17 +7748,29 @@ sub test { { my @prereq; + # local $CPAN::DEBUG = 16; # Distribution for my $m (keys %{$self->{sponsored_mods}}) { my $m_obj = CPAN::Shell->expand("Module",$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; + my $available_file = $m_obj->available_file; if ($available_version && - !CPAN::Version->vlt($available_version,$self->{PREREQ_PM}{$m}) + !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m}) ) { CPAN->debug("m[$m] good enough available_version[$available_version]") if $CPAN::DEBUG; + } elsif ($available_file + && ( + !$self->{prereq_pm}{$m} + || + $self->{prereq_pm}{$m} == 0 + ) + ) { + # lex Class::Accessor::Chained::Fast which has no $VERSION + CPAN->debug("m[$m] have available_file[$available_file]") + if $CPAN::DEBUG; } else { push @prereq, $m; } @@ -7534,8 +7788,11 @@ sub test { } $CPAN::Frontend->myprint(" $system -- OK\n"); - $CPAN::META->is_tested($self->{'build_dir'}); $self->{make_test} = CPAN::Distrostatus->new("YES"); + $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); + # probably impossible to need the next line because badtestcnt + # has a lifespan of one command + delete $self->{badtestcnt}; } else { $self->{make_test} = CPAN::Distrostatus->new("NO"); $self->{badtestcnt}++; @@ -7580,9 +7837,9 @@ sub clean { push @e, "make clean already called once"; $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } - chdir $self->{'build_dir'} or - Carp::croak("Couldn't chdir to $self->{'build_dir'}"); - $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + chdir $self->{build_dir} or + Carp::confess("Couldn't chdir to $self->{build_dir}: $!"); + $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; if ($^O eq 'MacOS') { Mac::BuildTools::make_clean($self); @@ -7651,7 +7908,7 @@ sub goto { my($method) = (caller(1))[3]; CPAN->instance("CPAN::Distribution",$goto)->$method; - + CPAN::Queue->delete_first($goto); } #-> sub CPAN::Distribution::install ; @@ -7717,10 +7974,12 @@ sub install { push @e, $self->{later}; $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + unless (chdir $self->{build_dir}) { + push @e, "Couldn't chdir to '$self->{build_dir}': $!"; + } + $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; } - chdir $self->{'build_dir'} or - Carp::croak("Couldn't chdir to $self->{'build_dir'}"); - $self->debug("Changed directory to $self->{'build_dir'}") + $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; if ($^O eq 'MacOS') { @@ -7794,7 +8053,7 @@ sub install { if ( $close_ok ) { $CPAN::Frontend->myprint(" $system -- OK\n"); $CPAN::META->is_installed($self->{build_dir}); - return $self->{install} = CPAN::Distrostatus->new("YES"); + $self->{install} = CPAN::Distrostatus->new("YES"); } else { $self->{install} = CPAN::Distrostatus->new("NO"); $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); @@ -7821,6 +8080,7 @@ sub install { } } delete $self->{force_update}; + # $DB::single = 1; $self->store_persistent_state; } @@ -7831,7 +8091,7 @@ sub introduce_myself { #-> sub CPAN::Distribution::dir ; sub dir { - shift->{'build_dir'}; + shift->{build_dir}; } #-> sub CPAN::Distribution::perldoc ; @@ -8084,9 +8344,10 @@ sub color_cmd_tmps { CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG; $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); } - if ($color==0) { - delete $self->{badtestcnt}; - } + # never reached code? + #if ($color==0) { + #delete $self->{badtestcnt}; + #} $self->{incommandcolor} = $color; } @@ -8120,14 +8381,15 @@ sub contains { } my $dist = $CPAN::META->instance('CPAN::Distribution', $self->cpan_file); + $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG; $dist->get; - $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG; + $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG; my($todir) = $CPAN::Config->{'cpan_home'}; my(@me,$from,$to,$me); @me = split /::/, $self->id; $me[-1] .= ".pm"; $me = File::Spec->catfile(@me); - $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me)); + $from = $self->find_bundle_file($dist->{build_dir},join('/',@me)); $to = File::Spec->catfile($todir,$me); File::Path::mkpath(File::Basename::dirname($to)); File::Copy::copy($from, $to) @@ -8327,6 +8589,8 @@ sub xs_file { } #-> sub CPAN::Bundle::force ; +sub fforce { shift->rematein('fforce',@_); } +#-> sub CPAN::Bundle::force ; sub force { shift->rematein('force',@_); } #-> sub CPAN::Bundle::notest ; sub notest { shift->rematein('notest',@_); } @@ -8337,7 +8601,7 @@ sub make { shift->rematein('make',@_); } #-> sub CPAN::Bundle::test ; sub test { my $self = shift; - $self->{badtestcnt} ||= 0; + # $self->{badtestcnt} ||= 0; $self->rematein('test',@_); } #-> sub CPAN::Bundle::install ; @@ -8421,9 +8685,10 @@ sub color_cmd_tmps { if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); } - if ($color==0) { - delete $self->{badtestcnt}; - } + # unreached code? + # if ($color==0) { + # delete $self->{badtestcnt}; + # } $self->{incommandcolor} = $color; } @@ -8701,7 +8966,13 @@ sub cpan_version { #-> sub CPAN::Module::force ; sub force { my($self) = @_; - $self->{'force_update'}++; + $self->{force_update} = 1; +} + +#-> sub CPAN::Module::fforce ; +sub fforce { + my($self) = @_; + $self->{force_update} = 2; } sub notest { @@ -8732,7 +9003,13 @@ sub rematein { } my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); $pack->called_for($self->id); - $pack->force($meth) 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->{reqtype} ||= ""; @@ -8763,9 +9040,9 @@ sub rematein { $pack->$meth(); }; my $err = $@; - $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'}; + $pack->unforce if $pack->can("unforce") && exists $self->{force_update}; $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'}; - delete $self->{'force_update'}; + delete $self->{force_update}; delete $self->{'notest'}; if ($err) { die $err; @@ -8787,7 +9064,7 @@ sub make { shift->rematein('make') } #-> sub CPAN::Module::test ; sub test { my $self = shift; - $self->{badtestcnt} ||= 0; + # $self->{badtestcnt} ||= 0; $self->rematein('test',@_); } #-> sub CPAN::Module::uptodate ; @@ -8818,7 +9095,7 @@ sub install { my($doit) = 0; if ($self->uptodate && - not exists $self->{'force_update'} + not exists $self->{force_update} ) { $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n", $self->id, @@ -8967,24 +9244,6 @@ Batch mode: $do = CPAN::Shell->expand("Distribution", $distro); # same thing -=head1 STATUS - -This module and its competitor, the CPANPLUS module, are both much -cooler than the other. - -=head1 COMPATIBILITY - -CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted -newer versions. It is getting more and more difficult to get the -minimal prerequisites working on older perls. It is close to -impossible to get the whole Bundle::CPAN working there. If you're in -the position to have only these old versions, be advised that CPAN is -designed to work fine without the Bundle::CPAN installed. - -To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is -compatible with ancient perls and that File::Temp is listed as a -prerequisite but CPAN has reasonable workarounds if it is missing. - =head1 DESCRIPTION The CPAN module is designed to automate the make and install of perl @@ -8992,7 +9251,7 @@ modules and extensions. It includes some primitive searching capabilities and knows how to use Net::FTP or LWP (or some external download clients) to fetch the raw data from the net. -Modules are fetched from one or more of the mirrored CPAN +Distributions are fetched from one or more of the mirrored CPAN (Comprehensive Perl Archive Network) sites and unpacked in a dedicated directory. @@ -9000,12 +9259,11 @@ The CPAN module also supports the concept of named and versioned I of modules. Bundles simplify the handling of sets of related modules. See Bundles below. -The package contains a session manager and a cache manager. There is -no status retained between sessions. The session manager keeps track -of what has been fetched, built and installed in the current -session. The cache manager keeps track of the disk space occupied by -the make processes and deletes excess space according to a simple FIFO -mechanism. +The package contains a session manager and a cache manager. The +session manager keeps track of what has been fetched, built and +installed in the current session. The cache manager keeps track of the +disk space occupied by the make processes and deletes excess space +according to a simple FIFO mechanism. All methods provided are accessible in a programmer style and in an interactive shell style. @@ -9016,12 +9274,12 @@ The interactive mode is entered by running perl -MCPAN -e shell -which puts you into a readline interface. You will have the most fun if -you install Term::ReadKey and Term::ReadLine to enjoy both history and -command completion. +which puts you into a readline interface. If Term::ReadKey and either +Term::ReadLine::Perl or Term::ReadLine::Gnu are installed it supports +both history and command completion. -Once you are on the command line, type 'h' and the rest should be -self-explanatory. +Once you are on the command line, type 'h' to get a one page help +screen and the rest should be self-explanatory. The function call C takes two optional arguments, one is the prompt, the second is the default initial command line (the latter @@ -9050,7 +9308,7 @@ displayed with the rather verbose method C, but if we find more than one, we display each object with the terse method C. -=item make, test, install, clean modules or distributions +=item get, make, test, install, clean modules or distributions These commands take any number of arguments and investigate what is necessary to perform the action. If the argument is a distribution @@ -9060,6 +9318,9 @@ is included and processes that, following any dependencies named in the module's META.yml or Makefile.PL (this behavior is controlled by the configuration parameter C.) +C downloads a distribution file and untars or unzips it, C +builds it, C runs the test suite, and C installs it. + Any C or C are run unconditionally. An install @@ -9074,21 +9335,15 @@ the module doesn't need to be updated. CPAN also keeps track of what it has done within the current session and doesn't try to build a package a second time regardless if it -succeeded or not. The C pragma may precede another command -(currently: C, C, or C) and executes the -command from scratch and tries to continue in case of some errors. - -Example: +succeeded or not. It does not repeat a test run if the test +has been run successfully before. Same for install runs. - cpan> install OpenGL - OpenGL is up to date. - cpan> force install OpenGL - Running make - OpenGL-0.4/ - OpenGL-0.4/COPYRIGHT - [...] +The C pragma may precede another command (currently: C, +C, C, or C) and executes the command from scratch +and tries to continue in case of some errors. See the section below on +The C and the C pragma. -The C pragma may be set to skip the test part in the build +The C pragma may be used to skip the test part in the build process. Example: @@ -9101,14 +9356,13 @@ A C command results in a being executed within the distribution file's working directory. -=item get, readme, perldoc, look module or distribution +=item readme, perldoc, look module or distribution -C downloads a distribution file without further action. C -displays the README file of the associated distribution. C gets -and untars (if not yet done) the distribution file, changes to the -appropriate directory and opens a subshell process in that directory. -C displays the pod documentation of the module in html or -plain text format. +C displays the README file of the associated distribution. +C gets and untars (if not yet done) the distribution file, +changes to the appropriate directory and opens a subshell process in +that directory. C displays the pod documentation of the +module in html or plain text format. =item ls author @@ -9138,6 +9392,45 @@ The C command reports all distributions that failed on one of C, C or C for some reason in the currently running shell session. +=item Persistence between sessions + +If the C or the c module is installed a record of +the internal state of all modules is written to disk after each step. +The files contain a signature of the currently running perl version +for later perusal. + +If the configurations variable C is set to a true +value, then CPAN.pm reads the collected YAML files. If the stored +signature matches the currently running perl the stored state is +loaded into memory such that effectively persistence between sessions +is established. + +=item The C and the C pragma + +To speed things up in complex installation scenarios, CPAN.pm keeps +track of what it has already done and refuses to do some things a +second time. A C, a C, and an C are not repeated. +A C is only repeated if the previous test was unsuccessful. The +diagnostic message when CPAN.pm refuses to do something a second time +is one of IC or +something similar. Another situation where CPAN refuses to act is an +C if the according C was not successful. + +In all these cases, the user can override the goatish behaviour by +prepending the command with the word force, for example: + + cpan> force get Foo + cpan> force make AUTHOR/Bar-3.14.tar.gz + cpan> force test Baz + cpan> force install Acme::Meta + +Each I command is executed with the according part of its +memory erased. + +The C pragma is a variant that emulates a C which +erases the entire memory followed by the action specified, effectively +restarting the whole get/make/test/install procedure from scratch. + =item Lockfile Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>. @@ -9268,10 +9561,11 @@ CPAN::Module, the second by an object of class CPAN::Distribution. =head2 Integrating local directories Distribution objects are normally distributions from the CPAN, but -there is a slightly degenerate case for Distribution objects, too, -normally only needed by developers. If a distribution object ends with -a dot or is a dot by itself, then it represents a local directory and -all actions such as C, C, and C are applied +there is a slightly degenerate case for Distribution objects, too, of +projects held on the local disk. These distribution objects have the +same name as the local directory and end with a dot. A dot by itself +is also allowed for the current directory at the time CPAN.pm was +used. All actions such as C, C, and C are applied directly to that directory. This gives the command C an interesting touch: while the normal mantra of installing a CPAN module without CPAN.pm is one of @@ -9288,6 +9582,9 @@ prerequisites, cares for them recursively and finally finishes the installation of the module in the current directory, be it a CPAN module or not. +The typical usage case is for private modules or working copies of +projects from remote repositories on the local disk. + =head1 PROGRAMMER'S INTERFACE If you do not enter the shell, the available shell commands are both @@ -9434,7 +9731,8 @@ 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 is passed recursively -to all contained objects. +to all contained objects. See also the section above on the C +and the C pragma. =item CPAN::Bundle::get() @@ -9510,11 +9808,12 @@ Returns the directory into which this distribution has been unpacked. =item CPAN::Distribution::force($method,@args) -Forces CPAN to perform a task that normally would have failed. Force -takes as arguments a method name to be called and any number of -additional arguments that should be passed to the called method. The -internals of the object get the needed changes so that CPAN.pm does -not refuse to take the action. +Forces CPAN to perform a task that it normally would have refused to +do. Force takes as arguments a method name to be called and any number +of additional arguments that should be passed to the called method. +The internals of the object get the needed changes so that CPAN.pm +does not refuse to take the action. See also the section above on the +C and the C pragma. =item CPAN::Distribution::get() @@ -9721,11 +10020,12 @@ Where the 'DSLIP' characters have the following meanings: =item CPAN::Module::force($method,@args) -Forces CPAN to perform a task that normally would have failed. Force -takes as arguments a method name to be called and any number of -additional arguments that should be passed to the called method. The -internals of the object get the needed changes so that CPAN.pm does -not refuse to take the action. +Forces CPAN to perform a task that it normally would have refused to +do. Force takes as arguments a method name to be called and any number +of additional arguments that should be passed to the called method. +The internals of the object get the needed changes so that CPAN.pm +does not refuse to take the action. See also the section above on the +C and the C pragma. =item CPAN::Module::get() @@ -9951,14 +10251,23 @@ with this floppy. See also below the paragraph about CD-ROM support. =item has_inst($module) -Returns true if the module is installed. See the source for details. +Returns true if the module is installed. Used to load all modules into +the running CPAN.pm which are considered optional. The config variable +C can be used to intercept the C call such +that an optional module is not loaded despite being available. For +example the following command will prevent that C is being +loaded: -=item has_usable($module) + cpan> o conf dontload_list push YAML -Returns true if the module is installed and several and is in a usable -state. Only useful for a handful of modules that are used internally. See the source for details. +=item has_usable($module) + +Returns true if the module is installed and is in a usable state. Only +useful for a handful of modules that are used internally. See the +source for details. + =item instance($module) The constructor for all the singletons used to represent modules, @@ -10064,6 +10373,8 @@ where WORD is any valid config variable or a regular expression. Currently the following keys in the hash reference $CPAN::Config are defined: + applypatch path to external prg + auto_commit commit all changes to config variables to disk build_cache size of cache for directories to build modules build_dir locally accessible directory to build modules build_dir_reuse boolean if distros in build_dir are persistent @@ -10077,6 +10388,7 @@ defined: quote on Windows, single tick everywhere else; can be set to space to disable quoting check_sigs if signatures should be verified + colorize_debug Term::ANSIColor attributes for debugging output colorize_output boolean if Term::ANSIColor should colorize output colorize_print Term::ANSIColor attributes for normal output colorize_warn Term::ANSIColor attributes for warnings @@ -10275,8 +10587,8 @@ is to apply patches from the local disk or from CPAN. CPAN.pm comes with a couple of such YAML files. The structure is currently not documented because in flux. Please see the distroprefs -directory of the CPAN distribution for examples and follow the README -in there. +directory of the CPAN distribution for examples and follow the +C<00.README> file in there. Please note that setting the environment variable PERL_MM_USE_DEFAULT to a true value can also get you a long way if you want to always pick @@ -10619,32 +10931,12 @@ Use the force pragma like so force install Foo::Bar -This does a bit more than really needed because it untars the -distribution again and runs make and test and only then install. - -Or, if you find this is too fast and you would prefer to do smaller -steps, say - - force get Foo::Bar - -first and then continue as always. C I previous -error conditions. - Or you can use look Foo::Bar and then 'make install' directly in the subshell. -Or you leave the CPAN shell and start it again. - -For the really curious, by accessing internals directly, you I - - !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install} - -but this is neither guaranteed to work in the future nor is it a -decent command. - =item 12) How do I install a "DEVELOPER RELEASE" of a module? @@ -10696,14 +10988,26 @@ Henk P. Penning maintains a site that collects data about CPAN sites: =back -=head1 BUGS +=head1 COMPATIBILITY -Please report bugs via http://rt.cpan.org/ +=head2 OLD PERL VERSIONS -Before submitting a bug, please make sure that the traditional method -of building a Perl module package from a shell by following the -installation instructions of that package still works in your -environment. +CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted +newer versions. It is getting more and more difficult to get the +minimal prerequisites working on older perls. It is close to +impossible to get the whole Bundle::CPAN working there. If you're in +the position to have only these old versions, be advised that CPAN is +designed to work fine without the Bundle::CPAN installed. + +To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is +compatible with ancient perls and that File::Temp is listed as a +prerequisite but CPAN has reasonable workarounds if it is missing. + +=head2 CPANPLUS + +This module and its competitor, the CPANPLUS module, are both much +cooler than the other. CPAN.pm is older. CPANPLUS was designed to be +more modular but it was never tried to make it compatible with CPAN.pm. =head1 SECURITY ADVICE @@ -10712,6 +11016,15 @@ is inherently dangerous because the newly installed software may contain bugs and may alter the way your computer works or even make it unusable. Please consider backing up your data before every upgrade. +=head1 BUGS + +Please report bugs via http://rt.cpan.org/ + +Before submitting a bug, please make sure that the traditional method +of building a Perl module package from a shell by following the +installation instructions of that package still works in your +environment. + =head1 AUTHOR Andreas Koenig C<< >> diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 9490934..8b412ab 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -19,7 +19,7 @@ use File::Basename (); use File::Path (); use File::Spec (); use vars qw($VERSION $urllist); -$VERSION = sprintf "%.6f", substr(q$Rev: 1379 $,4)/1000000 + 5.4; +$VERSION = sprintf "%.6f", substr(q$Rev: 1457 $,4)/1000000 + 5.4; =head1 NAME @@ -242,6 +242,12 @@ Shall we use it as the general CPAN build and cache directory? } # + #= Config: auto_commit + # + + my_yn_prompt(auto_commit => 0, $matcher); + + # #= Cache size, Index expire # @@ -318,9 +324,16 @@ Shall we use it as the general CPAN build and cache directory? #= External programs # - my @external_progs = qw/bzip2 gzip tar unzip make - curl lynx wget ncftpget ncftp ftp - gpg patch/; + my @external_progs = qw/bzip2 gzip tar unzip + + make + + curl lynx wget ncftpget ncftp ftp + + gpg + + patch applypatch + /; my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; if (!$matcher or "@external_progs" =~ /$matcher/) { $CPAN::Frontend->myprint($prompts{external_progs}); @@ -507,17 +520,40 @@ Shall we use it as the general CPAN build and cache directory? } # - #= the CPAN shell itself + #= the CPAN shell itself (prompt, color) # my_yn_prompt(commandnumber_in_prompt => 1, $matcher); my_yn_prompt(term_ornaments => 1, $matcher); - if ("colorize_output colorize_print colorize_warn" =~ $matcher) { + if ("colorize_output colorize_print colorize_warn colorize_debug" =~ $matcher) { my_yn_prompt(colorize_output => 0, $matcher); if ($CPAN::Config->{colorize_output}) { + if ($CPAN::META->has_inst("Term::ANSIColor")) { + my $T="gYw"; + print " on_ on_y ". + " on_ma on_\n"; + print " on_black on_red green ellow ". + "on_blue genta on_cyan white\n"; + + for my $FG ("", "bold", + map {$_,"bold $_"} "black","red","green", + "yellow","blue", + "magenta", + "cyan","white"){ + printf "%12s ", $FG; + for my $BG ("",map {"on_$_"} qw(black red green yellow + blue magenta cyan white)){ + print $FG||$BG ? + Term::ANSIColor::colored(" $T ","$FG $BG") : " $T "; + } + print "\n"; + } + print "\n"; + } for my $tuple ( ["colorize_print", "bold blue on_white"], ["colorize_warn", "bold red on_white"], + ["colorize_debug", "black on_cyan"], ) { my_dflt_prompt($tuple->[0] => $tuple->[1], $matcher); if ($CPAN::META->has_inst("Term::ANSIColor")) { @@ -598,7 +634,7 @@ Shall we use it as the general CPAN build and cache directory? $CPAN::Config->{inhibit_startup_message} = 0; $CPAN::Frontend->myprint("\n\n"); - if ($matcher) { + if ($matcher && !$CPAN::Config->{auto_commit}) { $CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ". "make the config permanent!\n\n"); } else { @@ -1417,14 +1453,16 @@ colorize_output => qq{ When you have Term::ANSIColor installed, you can turn on colorized output to have some visual differences between normal CPAN.pm output, -warnings, and the output of the modules being installed. Set your -favorite colors after some experimenting with the Term::ANSIColor -module. Do you want to turn on colored output?}, +warnings, debugging output, and the output of the modules being +installed. Set your favorite colors after some experimenting with the +Term::ANSIColor module. Do you want to turn on colored output?}, colorize_print => qq{Color for normal output?}, colorize_warn => qq{Color for warnings?}, +colorize_debug => qq{Color for debugging messages?}, + build_requires_install_policy_intro => qq{ When a module declares another one as a 'build_requires' prerequisite @@ -1471,7 +1509,18 @@ host should be tried first. randomize_urllist => "Randomize parameter", -); +auto_commit_intro => qq{ + +Normally CPAN.pm keeps config variables in memory and changes need to +be saved in a separate 'o conf commit' command to make them permanent +between sessions. If you set the 'auto_commit' option to true, changes +to a config variable are always automatically committed to disk. + +}, + +auto_commit => qq{Always commit changes to config variables to disk?}, + + ); die "Coding error in \@prompts declaration. Odd number of elements, above" if (@prompts % 2); diff --git a/lib/CPAN/HandleConfig.pm b/lib/CPAN/HandleConfig.pm index 3d03b56..e8859fc 100644 --- a/lib/CPAN/HandleConfig.pm +++ b/lib/CPAN/HandleConfig.pm @@ -2,7 +2,7 @@ package CPAN::HandleConfig; use strict; use vars qw(%can %keys $VERSION); -$VERSION = sprintf "%.6f", substr(q$Rev: 1379 $,4)/1000000 + 5.4; +$VERSION = sprintf "%.6f", substr(q$Rev: 1467 $,4)/1000000 + 5.4; %can = ( commit => "Commit changes to disk", @@ -16,6 +16,8 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 1379 $,4)/1000000 + 5.4; # A2: svn diff -r 985:986 # where andk added yaml_module %keys = map { $_ => undef } ( + "applypatch", + "auto_commit", "build_cache", "build_dir", "build_dir_reuse", @@ -23,6 +25,7 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 1379 $,4)/1000000 + 5.4; "bzip2", "cache_metadata", "check_sigs", + "colorize_debug", "colorize_output", "colorize_print", "colorize_warn", @@ -124,13 +127,21 @@ sub edit { unless (exists $keys{$o}) { $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n"); } + my $changed; + + # one day I used randomize_urllist for a boolean, so we must # list them explicitly --ak - if ($o =~ /^(wait_list|urllist|dontload_list)$/) { + if (0) { + } elsif ($o =~ /^(wait_list|urllist|dontload_list)$/) { + + # + # ARRAYS + # + $func = shift @args; $func ||= ""; CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG; - my $changed; # Let's avoid eval, it's easier to comprehend without. if ($func eq "push") { push @{$CPAN::Config->{$o}}, @args; @@ -156,7 +167,6 @@ sub edit { $self->prettyprint($o); } if ($changed) { - $CPAN::CONFIG_DIRTY = 1; if ($o eq "urllist") { # reset the cached values undef $CPAN::FTP::Thesite; @@ -166,24 +176,42 @@ sub edit { $CPAN::META->{dontload_hash} = {}; } } - return $changed; } elsif ($o =~ /_hash$/) { + + # + # HASHES + # + if (@args==1 && $args[0] eq ""){ @args = (); } elsif (@args % 2) { push @args, ""; } $CPAN::Config->{$o} = { @args }; - $CPAN::CONFIG_DIRTY = 1; + $changed = 1; } else { + + # + # SCALARS + # + if (defined $args[0]){ $CPAN::CONFIG_DIRTY = 1; $CPAN::Config->{$o} = $args[0]; + $changed = 1; } $self->prettyprint($o) if exists $keys{$o} or defined $CPAN::Config->{$o}; - return 1; } + if ($changed) { + if ($CPAN::Config->{auto_commit}) { + $self->commit; + } else { + $CPAN::CONFIG_DIRTY = 1; + $CPAN::Frontend->myprint("Please use 'o conf commit' to ". + "make the config permanent!\n\n"); + } + } } } @@ -530,9 +558,12 @@ $configpm initialized. CPAN::FirstTime::init($configpm, %args); } + +# returns mandatory but missing entries in the Config sub missing_config_data { my(@miss); for ( + "auto_commit", "build_cache", "build_dir", "cache_metadata", @@ -653,7 +684,7 @@ sub prefs_lookup { use strict; use vars qw($AUTOLOAD $VERSION); - $VERSION = sprintf "%.2f", substr(q$Rev: 1379 $,4)/100; + $VERSION = sprintf "%.2f", substr(q$Rev: 1467 $,4)/100; # formerly CPAN::HandleConfig was known as CPAN::Config sub AUTOLOAD {