In perl.git, the branch maint-5.10 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0d8b5309784f490d7ae813aceed2b1fdbbfaa7a3?hp=e77551595e1d5a685d01dd31ad3caf4377936e55>
- Log ----------------------------------------------------------------- commit 0d8b5309784f490d7ae813aceed2b1fdbbfaa7a3 Author: Andreas J Koenig <[email protected]> Date: Sat Jun 27 09:53:54 2009 +0200 Update CPAN.pm to 1.9402 (cherry picked from commit 6b1bef9ae6121c8c1e2db34b236572e438bab9a7) M lib/CPAN.pm M lib/CPAN/Distribution.pm M lib/CPAN/Exception/blocked_urllist.pm M lib/CPAN/FTP.pm M lib/CPAN/FirstTime.pm M lib/CPAN/HandleConfig.pm M lib/CPAN/Index.pm M lib/CPAN/Tarzip.pm commit 4ba582361421f579047f16a09800dbf28a4fede1 Author: Jos I. Boumans <[email protected]> Date: Sat Jun 27 17:35:17 2009 +0200 Upgrade to File::Fetch 0.20 (cherry picked from commit 8d16e270aaf343d05def7ca91debc167b1188b25) M lib/File/Fetch.pm M lib/File/Fetch/t/01_File-Fetch.t ----------------------------------------------------------------------- Summary of changes: lib/CPAN.pm | 17 ++++++--- lib/CPAN/Distribution.pm | 13 ++++--- lib/CPAN/Exception/blocked_urllist.pm | 12 +++++-- lib/CPAN/FTP.pm | 28 ++++++++++++--- lib/CPAN/FirstTime.pm | 25 +++++++++++--- lib/CPAN/HandleConfig.pm | 10 +++-- lib/CPAN/Index.pm | 10 ++++-- lib/CPAN/Tarzip.pm | 9 +++-- lib/File/Fetch.pm | 60 ++++++++++++++++++++++++++------ lib/File/Fetch/t/01_File-Fetch.t | 30 ++++++++++++---- 10 files changed, 159 insertions(+), 55 deletions(-) diff --git a/lib/CPAN.pm b/lib/CPAN.pm index ca8f596..1196cb0 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -2,7 +2,7 @@ # vim: ts=4 sts=4 sw=4: use strict; package CPAN; -$CPAN::VERSION = '1.94'; +$CPAN::VERSION = '1.9402'; $CPAN::VERSION =~ s/_//; # we need to run chdir all over and we would get at wrong libraries @@ -313,7 +313,7 @@ sub shell { $CPAN::Frontend->myprint( sprintf qq{ cpan shell -- CPAN exploration and modules installation (v%s) -ReadLine support %s +Enter 'h' for help. }, $CPAN::VERSION, @@ -374,10 +374,11 @@ ReadLine support %s @line = _redirect(@line); CPAN::Shell->$command(@line) }; + my $command_error = $@; _unredirect; my $reported_error; - if ($@) { - my $err = $@; + if ($command_error) { + my $err = $command_error; if (ref $err and $err->isa('CPAN::Exception::blocked_urllist')) { $CPAN::Frontend->mywarn("Client not fully configured, please proceed with configuring.$err"); $reported_error = ref $err; @@ -1006,12 +1007,16 @@ sub has_usable { ], 'Archive::Tar' => [ sub {require Archive::Tar; - unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) { + unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) { for ("Will not use Archive::Tar, need 1.00\n") { $CPAN::Frontend->mywarn($_); die $_; } } + unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) { + my $atv = Archive::Tar->VERSION; + $CPAN::Frontend->mywarn("You have Archive::Tar $atv, but 1.50 or later is recommended. Please upgrade.\n"); + } }, ], 'File::Temp' => [ @@ -2111,7 +2116,7 @@ C<ask/no>, CPAN.pm asks the user and sets the default accordingly. still considered beta quality) Distributions on CPAN usually behave according to what we call the -CPAN mantra. Or since the event of Module::Build, we should talk about +CPAN mantra. Or since the advent of Module::Build we should talk about two mantras: perl Makefile.PL perl Build.PL diff --git a/lib/CPAN/Distribution.pm b/lib/CPAN/Distribution.pm index 0433e33..45192bd 100644 --- a/lib/CPAN/Distribution.pm +++ b/lib/CPAN/Distribution.pm @@ -3809,15 +3809,18 @@ sub reports { unless ($this_version_seen++) { $CPAN::Frontend->myprint ("$rep->{version}:\n"); } + my $arch = $rep->{archname} || $rep->{platform} || '????'; + my $grade = $rep->{action} || $rep->{status} || '????'; + my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????'; $CPAN::Frontend->myprint (sprintf("%1s%1s%-4s %s on %s %s (%s)\n", - $rep->{archname} eq $Config::Config{archname}?"*":"", - $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"", - $rep->{action}, + $arch eq $Config::Config{archname}?"*":"", + $grade eq "PASS"?"+":$grade eq"FAIL"?"-":"", + $grade, $rep->{perl}, - ucfirst $rep->{osname}, + $ostext, $rep->{osvers}, - $rep->{archname}, + $arch, )); } else { $other_versions{$rep->{version}}++; diff --git a/lib/CPAN/Exception/blocked_urllist.pm b/lib/CPAN/Exception/blocked_urllist.pm index 0df385b..102c194 100644 --- a/lib/CPAN/Exception/blocked_urllist.pm +++ b/lib/CPAN/Exception/blocked_urllist.pm @@ -20,7 +20,7 @@ sub as_string { if ($CPAN::Config->{connect_to_internet_ok}) { return qq{ -You have not configured a urllist. Please consider to set it with +You have not configured a urllist for CPAN mirrors. Configure it with o conf init urllist @@ -28,11 +28,17 @@ You have not configured a urllist. Please consider to set it with } else { return qq{ -You have not configured a urllist and did not allow to connect to the -internet. Please consider to call +You have not configured a urllist and do not allow connections to the +internet to get a list of mirrors. If you wish to get a list of CPAN +mirrors to pick from, use this command o conf init connect_to_internet_ok urllist +If you do not wish to get a list of mirrors and would prefer to set +your urllist manually, use just this command instead + + o conf init urllist + }; } } diff --git a/lib/CPAN/FTP.pm b/lib/CPAN/FTP.pm index d8fb593..e4e462a 100644 --- a/lib/CPAN/FTP.pm +++ b/lib/CPAN/FTP.pm @@ -485,8 +485,7 @@ I would like to connect to one of the following sites to get '%s': push @mess, qq{The urllist can be edited.}, qq{E.g. with 'o conf urllist push ftp://myurl/'}; $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n"); - $CPAN::Frontend->mywarn("Could not fetch $file\n"); - $CPAN::Frontend->mysleep(2); + $CPAN::Frontend->mydie("Could not fetch $file\n"); } if ($maybe_restore) { rename "$aslocal.bak$$", $aslocal; @@ -682,7 +681,8 @@ sub hostdlhard { # < /dev/null "; my($aslocal_dir) = dirname($aslocal); mkpath($aslocal_dir); - HOSTHARD: for $ro_url (@$host_seq) { + my $some_dl_success = 0; + HOSTHARD: for $ro_url (@$host_seq) { $self->_set_attempt($stats,"dlhard",$ro_url); my $url = "$ro_url$file"; my($proto,$host,$dir,$getfile); @@ -706,8 +706,8 @@ sub hostdlhard { my $proxy_vars = $self->_proxy_vars($ro_url); DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) { my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f}); - next unless defined $funkyftp; - next if $funkyftp =~ /^\s*$/; + next DLPRG unless defined $funkyftp; + next DLPRG if $funkyftp =~ /^\s*$/; my($asl_ungz, $asl_gz); ($asl_ungz = $aslocal) =~ s/\.gz//; @@ -758,6 +758,7 @@ $content $CPAN::Frontend->mysleep(1); next DLPRG; } + $some_dl_success++; } else { $CPAN::Frontend->myprint(qq{ No success, the file that lynx has downloaded is an empty file. @@ -768,13 +769,20 @@ No success, the file that lynx has downloaded is an empty file. if ($wstatus == 0) { if (-s $aslocal) { # Looks good + $some_dl_success++; } elsif ($asl_ungz ne $aslocal) { # test gzip integrity if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) { # e.g. foo.tar is gzipped --> foo.tar.gz rename $asl_ungz, $aslocal; + $some_dl_success++; } else { eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)}; + if ($@) { + warn "Warning: $@"; + } else { + $some_dl_success++; + } } } $ThesiteURL = $ro_url; @@ -820,8 +828,16 @@ No success, the file that lynx has downloaded is an empty file. }); } return if $CPAN::Signal; - } # transfer programs + } # download/transfer programs (DLPRG) } # host + require Carp; + if ($some_dl_success) { + Carp::cluck("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed."); + } else { + Carp::cluck("Warning: no success downloading '$aslocal'. Giving up on it."); + } + $CPAN::Frontend->mysleep(5); + return; } #-> CPAN::FTP::_proxy_vars diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 8b5f6ba..50bebc3 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -771,6 +771,7 @@ sub init { } else { $fastread = 1; $CPAN::Config->{urllist} ||= []; + $CPAN::Config->{connect_to_internet_ok} ||= 1; local $^W = 0; # prototype should match that of &MakeMaker::prompt @@ -1509,7 +1510,10 @@ sub picklist { } my $i = scalar @$items; unrangify(\...@nums); - if (grep (/\D/ || $_ < 1 || $_ > $i, @nums)) { + if (0 == @nums) { + # cannot allow nothing because nothing means paging! + # return; + } elsif (grep (/\D/ || $_ < 1 || $_ > $i, @nums)) { $CPAN::Frontend->mywarn("invalid items entered, try again\n"); if ("@nums" =~ /\D/) { $CPAN::Frontend->mywarn("(we are expecting only numbers between 1 and $i)\n"); @@ -1522,7 +1526,10 @@ sub picklist { $CPAN::Frontend->myprint("\n"); # a blank line continues... - next SELECTION unless @nums; + unless (@nums){ + $CPAN::Frontend->mysleep(0.1); # prevent hot spinning process on the next bug + next SELECTION; + } last; } for (@nums) { $_-- } @@ -1597,13 +1604,17 @@ sub read_mirrored_by { if (@previous_urls) { push @$offer_cont, "(edit previous picks)"; $default = @$offer_cont; + } else { + # cannot allow nothing because nothing means paging! + # push @$offer_cont, "(none of the above)"; } @cont = picklist($offer_cont, "Select your continent (or several nearby continents)", $default, ! @previous_urls, $no_previous_warn); - + # cannot allow nothing because nothing means paging! + # return unless @cont; foreach $cont (@cont) { my @c = sort keys %{$all{$cont}}; @@ -1646,7 +1657,11 @@ put them on one line, separated by blanks, hyphenated ranges allowed @urls = picklist (\...@urls, $prompt, $default); foreach (@urls) { s/ \(.*\)//; } - push @$urllist, @urls; + if (@urls) { + $urllist = \...@urls; + } else { + push @$urllist, @urls; + } } sub bring_your_own { @@ -1692,7 +1707,7 @@ later if you\'re sure it\'s right.\n}, @$urllist = CPAN::_uniq(@$urllist, @urls); $CPAN::Config->{urllist} = $urllist; # xxx delete or comment these out when you're happy that it works - $CPAN::Frontend->myprint("New set of picks:\n"); + $CPAN::Frontend->myprint("New urllist\n"); for ( @$urllist ) { $CPAN::Frontend->myprint(" $_\n") }; } diff --git a/lib/CPAN/HandleConfig.pm b/lib/CPAN/HandleConfig.pm index 7842472..903b414 100644 --- a/lib/CPAN/HandleConfig.pm +++ b/lib/CPAN/HandleConfig.pm @@ -123,8 +123,10 @@ sub edit { my($o,$str,$func,$args,$key_exists); $o = shift @args; if($can{$o}) { - $self->$o(args => \...@args); # o conf init => sub init => sub load - return 1; + my $success = $self->$o(args => \...@args); # o conf init => sub init => sub load + unless ($success) { + die "Panic: could not configure CPAN.pm for args [...@args]. Giving up."; + } } else { CPAN->debug("o[$o]") if $CPAN::DEBUG; unless (exists $keys{$o}) { @@ -572,9 +574,9 @@ some missing parameters... END $args{args} = \...@miss; } - CPAN::FirstTime::init($configpm, %args); + my $initialized = CPAN::FirstTime::init($configpm, %args); $loading--; - return; + return $initialized; } diff --git a/lib/CPAN/Index.pm b/lib/CPAN/Index.pm index e3ee232..3fa9e60 100644 --- a/lib/CPAN/Index.pm +++ b/lib/CPAN/Index.pm @@ -146,7 +146,7 @@ sub reanimate_build_dir { next DISTRO; } my $c = $y->[0]; - if ($c && CPAN->_perl_fingerprint($c->{perl})) { + if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) { my $key = $c->{distribution}{ID}; for my $k (keys %{$c->{distribution}}) { if ($c->{distribution}{$k} @@ -177,8 +177,12 @@ sub reanimate_build_dir { )) { delete $do->{$skipper}; } - if ($do->tested_ok_but_not_installed) { - $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME}); + if ($do->can("tested_ok_but_not_installed")) { + if ($do->tested_ok_but_not_installed) { + $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME}); + } else { + next DISTRO; + } } $restored++; } diff --git a/lib/CPAN/Tarzip.pm b/lib/CPAN/Tarzip.pm index 40d5e52..17b3cd7 100644 --- a/lib/CPAN/Tarzip.pm +++ b/lib/CPAN/Tarzip.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION @ISA $BUGHUNTING); use CPAN::Debug; use File::Basename qw(basename); -$VERSION = "5.5"; +$VERSION = "5.501"; # module is internal to CPAN.pm @ISA = qw(CPAN::Debug); ## no critic @@ -311,9 +311,12 @@ Can't continue cutting file '$file'. unless ($CPAN::META->has_usable("Archive::Tar")) { $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue"); } - # Make sure AT does not use permissions in the archive + # Make sure AT does not use uid/gid/permissions in the archive # This leaves it to the user's umask instead - local $Archive::Tar::CHMOD = 0; + local $Archive::Tar::CHMOD = 1; + local $Archive::Tar::SAME_PERMISSIONS = 0; + # Make sure AT leaves current user as owner + local $Archive::Tar::CHOWN = 0; my $tar = Archive::Tar->new($file,1); my $af; # archive file my @af; diff --git a/lib/File/Fetch.pm b/lib/File/Fetch.pm index 03bf147..d093560 100644 --- a/lib/File/Fetch.pm +++ b/lib/File/Fetch.pm @@ -12,6 +12,7 @@ use Cwd qw[cwd]; use Carp qw[carp]; use IPC::Cmd qw[can_run run QUOTE]; use File::Path qw[mkpath]; +use File::Temp qw[tempdir]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Style => 'gettext'; @@ -21,7 +22,7 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $FTP_PASSIVE $TIMEOUT $DEBUG $WARN ]; -$VERSION = '0.18'; +$VERSION = '0.20'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = '[email protected]'; @@ -397,10 +398,19 @@ sub _parse_uri { return $href; } -=head2 $ff->fetch( [to => /my/output/dir/] ) +=head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] ) -Fetches the file you requested. By default it writes to C<cwd()>, -but you can override that by specifying the C<to> argument. +Fetches the file you requested and returns the full path to the file. + +By default it writes to C<cwd()>, but you can override that by specifying +the C<to> argument: + + ### file fetch to /tmp, full path to the file in $where + $where = $ff->fetch( to => '/tmp' ); + + ### file slurped into $scalar, full path to the file in $where + ### file is downloaded to a temp directory and cleaned up at exit time + $where = $ff->fetch( to => \$scalar ); Returns the full path to the downloaded file on success, and false on failure. @@ -411,21 +421,31 @@ sub fetch { my $self = shift or return; my %hash = @_; - my $to; + my $target; my $tmpl = { - to => { default => cwd(), store => \$to }, + to => { default => cwd(), store => \$target }, }; check( $tmpl, \%hash ) or return; - ### On VMS force to VMS format so File::Spec will work. - $to = VMS::Filespec::vmspath($to) if ON_VMS; + my ($to, $fh); + ### you want us to slurp the contents + if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { + $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 ); + + ### plain old fetch + } else { + $to = $target; - ### create the path if it doesn't exist yet ### - unless( -d $to ) { - eval { mkpath( $to ) }; + ### On VMS force to VMS format so File::Spec will work. + $to = VMS::Filespec::vmspath($to) if ON_VMS; - return $self->_error(loc("Could not create path '%1'",$to)) if $@; + ### create the path if it doesn't exist yet ### + unless( -d $to ) { + eval { mkpath( $to ) }; + + return $self->_error(loc("Could not create path '%1'",$to)) if $@; + } } ### set passive ftp if required ### @@ -474,8 +494,24 @@ sub fetch { } else { + ### slurp mode? + if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { + + ### open the file + open my $fh, $file or do { + $self->_error( + loc("Could not open '%1': %2", $file, $!)); + return; + }; + + ### slurp + $$target = do { local $/; <$fh> }; + + } + my $abs = File::Spec->rel2abs( $file ); return $abs; + } } } diff --git a/lib/File/Fetch/t/01_File-Fetch.t b/lib/File/Fetch/t/01_File-Fetch.t index 519ca27..1cd7e8d 100644 --- a/lib/File/Fetch/t/01_File-Fetch.t +++ b/lib/File/Fetch/t/01_File-Fetch.t @@ -204,29 +204,43 @@ sub _fetch_uri { $File::Fetch::METHODS = $File::Fetch::METHODS = { $type => [$method] }; + ### fetch regularly my $ff = File::Fetch->new( uri => $uri ); - + ok( $ff, "FF object for $uri (fetch with $method)" ); - - my $file = $ff->fetch( to => 'tmp' ); - - SKIP: { - skip "You do not have '$method' installed/available", 3 + + for my $to ( 'tmp', do { \my $o } ) { SKIP: { + + + my $how = ref $to ? 'slurp' : 'file'; + my $skip = ref $to ? 4 : 3; + + ok( 1, " Fetching '$uri' in $how mode" ); + + my $file = $ff->fetch( to => $to ); + + skip "You do not have '$method' installed/available", $skip if $File::Fetch::METHOD_FAIL->{$method} && $File::Fetch::METHOD_FAIL->{$method}; ### if the file wasn't fetched, it may be a network/firewall issue - skip "Fetch failed; no network connectivity for '$type'?", 3 + skip "Fetch failed; no network connectivity for '$type'?", $skip unless $file; ok( $file, " File ($file) fetched with $method ($uri)" ); + + ### check we got some contents if we were meant to slurp + if( ref $to ) { + ok( $$to, " Contents slurped" ); + } + ok( $file && -s $file, " File has size" ); is( $file && basename($file), $ff->output_file, " File has expected name" ); unlink $file; - } + }} } } -- Perl5 Master Repository
