cpan/CPAN/lib/CPAN/Exception/blocked_urllist.pm helper package for CPAN.pm
cpan/CPAN/lib/CPAN/Exception/RecursiveDependency.pm helper package for CPAN.pm
cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm helper package for CPAN.pm
+cpan/CPAN/lib/CPAN/Exception/yaml_process_error.pm helper package for CPAN.pm
cpan/CPAN/lib/CPAN/FirstTime.pm Utility for creating CPAN config files
cpan/CPAN/lib/CPAN/FTP/netrc.pm helper package for CPAN.pm
cpan/CPAN/lib/CPAN/FTP.pm helper package for CPAN.pm
'CPAN' =>
{
'MAINTAINER' => 'andk',
- 'DISTRIBUTION' => 'ANDK/CPAN-1.9600.tar.gz',
+ 'DISTRIBUTION' => 'ANDK/CPAN-1.9800.tar.gz',
'FILES' => q[cpan/CPAN],
'EXCLUDED' => [ qr{^distroprefs/},
qr{^inc/Test/},
+2011-08-07 Andreas J. Koenig <andk@cpan.org>
+
+ * release 1.9800
+
+ * RT #69463: fix memory leak in CacheMgr (Serguei Trouchelle)
+
+2011-06-27 Andreas J. Koenig <andk@cpan.org>
+
+ * release 1.97_51
+
+ * address #68835: Changed read_meta to ignore dynamic_config (David Golden)
+
+ * bugfix: refuse to store_persistent if the own build_dir is not
+ available (Andreas Koenig)
+
+ * cosmetics: remove "Going to" from the beginning of user-visible
+ strings (Jesse Vincent)
+
+ * flock adjustments for Win32 from activestate (Christian Walde)
+
2011-03-12 Andreas J. Koenig <andk@cpan.org>
* release 1.9600
# use local::lib
cpan -l module_name [ module_name ... ]
-
+
# with just the dot, install from the distribution in the
# current directory
cpan .
-
+
# without arguments, starts CPAN.pm shell
cpan
=item -F
-Turn off CPAN.pm's attempts to lock anything. You should be careful with
+Turn off CPAN.pm's attempts to lock anything. You should be careful with
this since you might end up with multiple scripts trying to muck in the
same directory. This isn't so much of a concern if you're loading a special
config with C<-j>, and that config sets up its own work directories.
=item -j Config.pm
Load the file that has the CPAN configuration data. This should have the
-same format as the standard F<CPAN/Config.pm> file, which defines
+same format as the standard F<CPAN/Config.pm> file, which defines
C<$CPAN::Config> as an anonymous hash.
=item -J
use Getopt::Std;
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Internal constants
use constant TRUE => 1;
use constant FALSE => 0;
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# The return values
-use constant HEY_IT_WORKED => 0;
+use constant HEY_IT_WORKED => 0;
use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001
use constant ITS_NOT_MY_FAULT => 2;
use constant THE_PROGRAMMERS_AN_IDIOT => 4;
use constant A_MODULE_FAILED_TO_INSTALL => 8;
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# set up the order of options that we layer over CPAN::Shell
BEGIN { # most of this should be in methods
use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order
%Method_table %Method_table_index );
-
+
@META_OPTIONS = qw( h v g G C A D O l L a r j: J );
$Default = 'default';
@option_order = ( @META_OPTIONS, @CPAN_OPTIONS );
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# map switches to the subroutines in this script, along with other information.
# use this stuff instead of hard-coded indices and values
sub NO_ARGS () { 0 }
# options that do their one thing
g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ],
G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
-
+
C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ],
A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ],
D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ],
);
}
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# finally, do some argument processing
sub _stupid_interface_hack_for_non_rtfmers
no warnings 'uninitialized';
shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
}
-
+
sub _process_options
{
my %options;
-
+
# if no arguments, just drop into the shell
if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
else
{
Getopt::Std::getopts(
- join( '', @option_order ), \%options );
+ join( '', @option_order ), \%options );
\%options;
}
}
sub _process_setup_options
{
my( $class, $options ) = @_;
-
+
if( $options->{j} )
{
$Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
write_file => 0,
);
}
-
+
if( $options->{F} )
{
$Method_table{F}[ $Method_table_index{code} ]->( $options->{F} );
my $option_count = grep { $options->{$_} } @option_order;
no warnings 'uninitialized';
$option_count -= $options->{'f'}; # don't count force
-
+
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# if there are no options, set -i (this line fixes RT ticket 16915)
$options->{i}++ unless $option_count;
Just do it.
-The C<run> method returns 0 on success and a postive number on
+The C<run> method returns 0 on success and a postive number on
failure. See the section on EXIT CODES for details on the values.
=cut
$class->_process_setup_options( $options );
OPTION: foreach my $option ( @option_order )
- {
+ {
next unless $options->{$option};
- my( $sub, $takes_args, $description ) =
+ my( $sub, $takes_args, $description ) =
map { $Method_table{$option}[ $Method_table_index{$_} ] }
qw( code takes_args );
$logger->info( "$description -- ignoring other arguments" )
if( @ARGV && ! $takes_args );
-
+
$return_value = $sub->( \ @ARGV, $options );
last;
sub _init_logger
{
my $log4perl_loaded = eval "require Log::Log4perl; 1";
-
+
unless( $log4perl_loaded )
{
$logger = Local::Null::Logger->new;
return $logger;
}
-
+
my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';
-
+
Log::Log4perl::init( \ <<"HERE" );
log4perl.rootLogger=$LEVEL, A1
log4perl.appender.A1=Log::Log4perl::Appender::Screen
log4perl.appender.A1.layout=PatternLayout
log4perl.appender.A1.layout.ConversionPattern=%m%n
HERE
-
+
$logger = Log::Log4perl->get_logger( 'App::Cpan' );
}
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
- # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _default
{
my( $args, $options ) = @_;
-
+
my $switch = '';
# choose the option that we're going to use
if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } }
else { sub { CPAN::Shell->$method( @_ ) } }
};
-
+
# How do I handle exit codes for multiple arguments?
my $errors = 0;
-
- foreach my $arg ( @$args )
- {
+
+ foreach my $arg ( @$args )
+ {
_clear_cpanpm_output();
$action->( $arg );
$errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED;
}
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
=for comment
sub _hook_into_CPANpm_report
{
no warnings 'redefine';
-
+
*CPAN::Shell::myprint = sub {
my($self,$what) = @_;
$scalar .= $what if defined $what;
*CPAN::Shell::mywarn = sub {
my($self,$what) = @_;
$scalar .= $what if defined $what;
- $self->print_ornamented($what,
+ $self->print_ornamented($what,
$CPAN::Config->{colorize_warn}||'bold red on_white'
);
};
}
-
+
sub _clear_cpanpm_output { $scalar = '' }
-
+
sub _get_cpanpm_output { $scalar }
BEGIN {
sub _get_cpanpm_last_line
{
open my($fh), "<", \ $scalar;
-
+
my @lines = <$fh>;
-
+
# This is a bit ugly. Once we examine a line, we have to
# examine the line before it and go through all of the same
# regexes. I could do something fancy, but this works.
}
}
}
-
+
$logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
-
+
$lines[-1];
}
}
BEGIN {
my $epic_fail_words = join '|',
qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? );
-
+
sub _cpanpm_output_indicates_failure
{
my $last_line = _get_cpanpm_last_line();
-
+
my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
$result || ();
}
}
-
+
sub _cpanpm_output_indicates_success
{
my $last_line = _get_cpanpm_last_line();
-
+
my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
$result || ();
}
-
+
sub _cpanpm_output_is_vague
{
- return FALSE if
- _cpanpm_output_indicates_failure() ||
+ return FALSE if
+ _cpanpm_output_indicates_failure() ||
_cpanpm_output_indicates_success();
return TRUE;
}
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _print_help
{
$logger->info( "Use perldoc to read the documentation" );
exec "perldoc $0";
}
-
+
sub _print_version
{
- $logger->info(
+ $logger->info(
"$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
return HEY_IT_WORKED;
}
-
+
sub _create_autobundle
{
- $logger->info(
+ $logger->info(
"Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
CPAN::Shell->autobundle;
}
sub _load_config # -j
- {
+ {
my $file = shift || '';
-
+
# should I clear out any existing config here?
$CPAN::Config = {};
delete $INC{'CPAN/Config.pm'};
croak( "Config file [$file] does not exist!\n" ) unless -e $file;
-
+
my $rc = eval "require '$file'";
# CPAN::HandleConfig::require_myconfig_or_config looks for this
$INC{'CPAN/MyConfig.pm'} = 'fake out!';
-
+
# CPAN::HandleConfig::load looks for this
$CPAN::Config_loaded = 'fake out';
-
+
croak( "Could not load [$file]: $@\n") unless $rc;
-
+
return HEY_IT_WORKED;
}
{
my $args = shift;
require Data::Dumper;
-
+
my $fh = $args->[0] || \*STDOUT;
-
- my $dd = Data::Dumper->new(
- [$CPAN::Config],
- ['$CPAN::Config']
+
+ my $dd = Data::Dumper->new(
+ [$CPAN::Config],
+ ['$CPAN::Config']
);
-
+
print $fh $dd->Dump, "\n1;\n__END__\n";
-
+
return HEY_IT_WORKED;
}
sub _lock_lobotomy
{
no warnings 'redefine';
-
+
*CPAN::_flock = sub { 1 };
*CPAN::checklock = sub { 1 };
return HEY_IT_WORKED;
}
-
+
sub _download
- {
+ {
my $args = shift;
-
+
local $CPAN::DEBUG = 1;
-
+
my %paths;
-
+
foreach my $module ( @$args )
{
$logger->info( "Checking $module" );
my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
-
+
$logger->debug( "Inst file would be $path\n" );
-
+
$paths{$module} = _get_file( _make_path( $path ) );
}
-
+
return \%paths;
}
sub _make_path { join "/", qw(authors id), $_[0] }
-
+
sub _get_file
{
my $path = shift;
-
+
my $loaded = eval "require LWP::Simple; 1;";
croak "You need LWP::Simple to use features that fetch files from CPAN\n"
unless $loaded;
-
+
my $file = substr $path, rindex( $path, '/' ) + 1;
my $store_path = catfile( cwd(), $file );
$logger->debug( "Store path is $store_path" );
sub _gitify
{
my $args = shift;
-
+
my $loaded = eval "require Archive::Extract; 1;";
croak "You need Archive::Extract to use features that gitify distributions\n"
unless $loaded;
-
+
my $starting_dir = cwd();
-
+
foreach my $module ( @$args )
{
$logger->info( "Checking $module" );
my $store_paths = _download( [ $module ] );
$logger->debug( "gitify Store path is $store_paths->{$module}" );
- my $dirname = dirname( $store_paths->{$module} );
-
+ my $dirname = dirname( $store_paths->{$module} );
+
my $ae = Archive::Extract->new( archive => $store_paths->{$module} );
$ae->extract( to => $dirname );
-
+
chdir $ae->extract_path;
-
+
my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
croak "Could not find $git" unless -e $git;
croak "$git is not executable" unless -x $git;
-
+
# can we do this in Pure Perl?
system( $git, 'init' );
system( $git, qw( add . ) );
system( $git, qw( commit -a -m ), 'initial import' );
}
-
+
chdir $starting_dir;
return HEY_IT_WORKED;
sub _show_Changes
{
my $args = shift;
-
+
foreach my $arg ( @$args )
{
$logger->info( "Checking $arg\n" );
-
+
my $module = eval { CPAN::Shell->expand( "Module", $arg ) };
my $out = _get_cpanpm_output();
-
+
next unless eval { $module->inst_file };
#next if $module->uptodate;
-
+
( my $id = $module->id() ) =~ s/::/\-/;
-
+
my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
$id . "-" . $module->cpan_version() . "/";
-
+
#print "URL: $url\n";
_get_changes_file($url);
}
return HEY_IT_WORKED;
- }
-
+ }
+
sub _get_changes_file
{
croak "Reading Changes files requires LWP::Simple and URI\n"
unless eval "require LWP::Simple; require URI; 1";
-
+
my $url = shift;
my $content = LWP::Simple::get( $url );
$logger->info( "Got $url ..." ) if defined $content;
#print $content;
-
+
my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;
-
+
my $changes_url = URI->new_abs( $change_link, $url );
$logger->debug( "Change link is: $changes_url" );
return HEY_IT_WORKED;
}
-
+
sub _show_Author
- {
+ {
my $args = shift;
-
+
foreach my $arg ( @$args )
{
my $module = CPAN::Shell->expand( "Module", $arg );
$logger->info( "Didn't find a $arg module, so no author!" );
next;
}
-
+
my $author = CPAN::Shell->expand( "Author", $module->userid );
-
+
next unless $module->userid;
-
- printf "%-25s %-8s %-25s %s\n",
+
+ printf "%-25s %-8s %-25s %s\n",
$arg, $module->userid, $author->email, $author->fullname;
}
return HEY_IT_WORKED;
- }
+ }
sub _show_Details
{
my $args = shift;
-
+
foreach my $arg ( @$args )
{
my $module = CPAN::Shell->expand( "Module", $arg );
my $author = CPAN::Shell->expand( "Author", $module->userid );
-
+
next unless $module->userid;
-
+
print "$arg\n", "-" x 73, "\n\t";
print join "\n\t",
$module->description ? $module->description : "(no description)",
$author->fullname . " (" . $module->userid . ")",
$author->email;
print "\n\n";
-
+
}
-
+
return HEY_IT_WORKED;
- }
+ }
sub _show_out_of_date
{
my @modules = CPAN::Shell->expand( "Module", "/./" );
-
+
printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
print "-" x 73, "\n";
-
+
foreach my $module ( @modules )
{
next unless $module->inst_file;
next if $module->uptodate;
printf "%-40s %.4f %.4f\n",
- $module->id,
- $module->inst_version ? $module->inst_version : '',
+ $module->id,
+ $module->inst_version ? $module->inst_version : '',
$module->cpan_version;
}
my $args = shift;
my %hash = map { lc $_, 1 } @$args;
-
+
my @modules = CPAN::Shell->expand( "Module", "/./" );
-
+
foreach my $module ( @modules )
{
next unless exists $hash{ lc $module->userid };
print $module->id, "\n";
}
-
+
return HEY_IT_WORKED;
}
-
+
sub _list_all_mods
{
require File::Find;
-
+
my $args = shift;
-
-
+
+
my $fh = \*STDOUT;
-
+
INC: foreach my $inc ( @INC )
- {
+ {
my( $wanted, $reporter ) = _generator();
File::Find::find( { wanted => $wanted }, $inc );
-
+
my $count = 0;
FILE: foreach my $file ( @{ $reporter->() } )
{
my $version = _parse_version_safely( $file );
-
+
my $module_name = _path_to_module( $inc, $file );
next FILE unless defined $module_name;
-
+
print $fh "$module_name\t$version\n";
-
+
#last if $count++ > 5;
}
}
return HEY_IT_WORKED;
}
-
+
sub _generator
- {
+ {
my @files = ();
-
- sub { push @files,
- File::Spec->canonpath( $File::Find::name )
+
+ sub { push @files,
+ File::Spec->canonpath( $File::Find::name )
if m/\A\w+\.pm\z/ },
sub { \@files },
}
-
+
sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
{
my( $file ) = @_;
-
+
local $/ = "\n";
local $_; # don't mess with the $_ in the map calling this
-
+
return unless open FILE, "<$file";
my $in_pod = 0;
my $version;
- while( <FILE> )
+ while( <FILE> )
{
chomp;
$in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
my( $sigil, $var ) = ( $1, $2 );
-
+
$version = _eval_version( $_, $sigil, $var );
last;
}
close FILE;
return 'undef' unless defined $version;
-
+
return $version;
}
sub _eval_version
{
my( $line, $sigil, $var ) = @_;
-
- my $eval = qq{
+
+ my $eval = qq{
package ExtUtils::MakeMaker::_version;
local $sigil$var;
$line
}; \$$var
};
-
+
my $version = do {
local $^W = 0;
no strict;
{
my( $inc, $path ) = @_;
return if length $path< length $inc;
-
+
my $module_path = substr( $path, length $inc );
$module_path =~ s/\.pm\z//;
-
+
# XXX: this is cheating and doesn't handle everything right
my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
shift @dirs;
-
+
my $module_name = join "::", @dirs;
-
+
return $module_name;
}
=head1 EXIT VALUES
-The script exits with zero if it thinks that everything worked, or a
+The script exits with zero if it thinks that everything worked, or a
positive number if it thinks that something failed. Note, however, that
in some cases it has to divine a failure by the output of things it does
not control. For now, the exit codes are vague:
# vim: ts=4 sts=4 sw=4:
use strict;
package CPAN;
-$CPAN::VERSION = '1.9600';
+$CPAN::VERSION = '1.9800';
$CPAN::VERSION =~ s/_//;
# we need to run chdir all over and we would get at wrong libraries
use CPAN::LWP::UserAgent;
use CPAN::Exception::RecursiveDependency;
use CPAN::Exception::yaml_not_installed;
+use CPAN::Exception::yaml_process_error;
use Carp ();
use Config ();
# don't die, because we may need
# Archive::Tar to upgrade
}
-
+
}
},
],
with slightly differing methods for displaying an object.
Arguments to these commands are either strings exactly matching
-the identification string of an object, or regular expressions
+the identification string of an object, or regular expressions
matched case-insensitively against various attributes of the
objects. The parser only recognizes a regular expression when you
enclose it with slashes.
The principle is that the number of objects found influences how an
item is displayed. If the search finds one item, the result is
-displayed with the rather verbose method C<as_string>, but if
+displayed with the rather verbose method C<as_string>, but if
more than one is found, each object is displayed with the terse method
C<as_glimpse>.
C<readme> displays the README file of the associated distribution.
C<Look> gets and untars (if not yet done) the distribution file,
changes to the appropriate directory and opens a subshell process in
-that directory. C<perldoc> displays the module's pod documentation
+that directory. C<perldoc> displays the module's pod documentation
in html or plain text format.
=item C<ls> author
C<autobundle> writes a bundle file into the
C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
a list of all modules that are both available from CPAN and currently
-installed within @INC. The name of the bundle file is based on the
-current date and a counter.
+installed within @INC. Duplicates of each distribution are suppressed.
+The name of the bundle file is based on the current date and a
+counter.
+
+Return value: path to the written file.
=head2 hosts
directory so that you can save your own preferences instead of the
system-wide ones.
+=head2 r [Module|/Regexp/]...
+
+scans current perl installation for modules that have a newer version
+available on CPAN and provides a list of them. If called without
+argument, all potential upgrades are listed; if called with arguments
+the list is filtered to the modules and regexps given as arguments.
+
+The listing looks something like this:
+
+ Package namespace installed latest in CPAN file
+ CPAN 1.94_64 1.9600 ANDK/CPAN-1.9600.tar.gz
+ CPAN::Reporter 1.1801 1.1902 DAGOLDEN/CPAN-Reporter-1.1902.tar.gz
+ YAML 0.70 0.73 INGY/YAML-0.73.tar.gz
+ YAML::Syck 1.14 1.17 AVAR/YAML-Syck-1.17.tar.gz
+ YAML::Tiny 1.44 1.50 ADAMK/YAML-Tiny-1.50.tar.gz
+ CGI 3.43 3.55 MARKSTOS/CGI.pm-3.55.tar.gz
+ Module::Build::YAML 1.40 1.41 DAGOLDEN/Module-Build-0.3800.tar.gz
+ TAP::Parser::Result::YAML 3.22 3.23 ANDYA/Test-Harness-3.23.tar.gz
+ YAML::XS 0.34 0.35 INGY/YAML-LibYAML-0.35.tar.gz
+
+It suppresses duplicates in the column C<in CPAN file> such that
+distributions with many upgradeable modules are listed only once.
+
+Note that the list is not sorted.
+
=head2 recent ***EXPERIMENTAL COMMAND***
The C<recent> command downloads a list of recent uploads to CPAN and
-displays them I<slowly>. While the command is running, a $SIG{INT}
+displays them I<slowly>. While the command is running, a $SIG{INT}
exits the loop after displaying the current item.
B<Note>: This command requires XML::LibXML installed.
B<Note>: See also L<recent>
-=head2 upgrade [Module|/Regex/]...
+=head2 upgrade [Module|/Regexp/]...
The C<upgrade> command first runs an C<r> command with the given
arguments and then installs the newest versions of all modules that
o conf shell
If KEY starts and ends with a slash, the string in between is
-treated as a regular expression and only keys matching this regex
+treated as a regular expression and only keys matching this regexp
are displayed
Example:
inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
after this many seconds inactivity. Set to 0 to
disable timeouts.
- index_expire refetch index files after this many days
+ index_expire refetch index files after this many days
inhibit_startup_message
if true, suppress the startup message
keep_source_where directory in which to keep the source (if we do)
Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
a distribution are treated differently depending on the config
variable C<build_requires_install_policy>. By setting
-C<build_requires_install_policy> to C<no>, such a module is not
+C<build_requires_install_policy> to C<no>, such a module is not
installed. It is only built and tested, and then kept in the list of
tested but uninstalled modules. As such, it is available during the
build of the dependent module by integrating the path to the
=item
-specify dependencies the original maintainer forgot
+specify dependencies the original maintainer forgot
=item
=head1 PROGRAMMER'S INTERFACE
-If you do not enter the shell, shell commands are
+If you do not enter the shell, shell commands are
available both as methods (C<CPAN::Shell-E<gt>install(...)>) and as
functions in the calling package (C<install(...)>). Before calling low-level
commands, it makes sense to initialize components of CPAN you need, e.g.:
There's currently only one class that has a stable interface -
CPAN::Shell. All commands that are available in the CPAN shell are
-methods of the class CPAN::Shell. Each of the commands that produce
-listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
-the IDs of all modules within the list.
+methods of the class CPAN::Shell. The arguments on the commandline are
+passed as arguments to the method.
+
+So if you take for example the shell command
+
+ notest install A B C
+
+the actually executed command is
+
+ CPAN::Shell->notest("install","A","B","C");
+
+Each of the commands that produce listings of modules (C<r>,
+C<autobundle>, C<u>) also return a list of the IDs of all modules
+within the list.
=over 2
If you don't want any output should all modules be
up to date, parse the output of above command for the regular
expression C</modules are up to date/> and decide to mail the output
-only if it doesn't match.
+only if it doesn't match.
If you prefer to do it more in a programmerish style in one single
process, something like this may better suit you:
you.
This install method only has the power to install the distribution if
-there are no dependencies in the way. To install an object along with all
+there are no dependencies in the way. To install an object along with all
its dependencies, use CPAN::Shell->install.
Note that install() gives no meaningful return value. See uptodate().
packaging, configuration, synchronicity, and even (gasp!) due to bugs
within the CPAN.pm module itself.
-For debugging the code of CPAN.pm itself in interactive mode, some
+For debugging the code of CPAN.pm itself in interactive mode, some
debugging aid can be turned on for most packages within
CPAN.pm with one of
things: dependencies and interactivity. CPAN.pm sometimes fails on
calculating dependencies because not all modules define all MakeMaker
attributes correctly, so a bundle definition file should specify
-prerequisites as early as possible. On the other hand, it's
+prerequisites as early as possible. On the other hand, it's
annoying that so many distributions need some interactive configuring. So
what you can try to accomplish in your private bundle file is to have the
packages that need to be configured early in the file and the gentle
=item One-way visibility
-One-way visibility means these firewalls try to make themselves
+One-way visibility means these firewalls try to make themselves
invisible to users inside the firewall. An FTP data connection is
normally created by sending your IP address to the remote server and then
listening for the return connection. But the remote server will not be able to
$self->_clean_cache($toremove);
return if $CPAN::Signal;
}
+ $self->{FIFO} = [];
}
#-> sub CPAN::CacheMgr::dir ;
||
$self->{install}->failed
)
- );
+ );
}
#-> sub CPAN::Distribution::pick_meta_file ;
sub pick_meta_file {
- my($self, $yaml) = @_;
+ my($self, $filter) = @_;
+ $filter = '.' unless defined $filter;
my $build_dir;
unless ($build_dir = $self->{build_dir}) {
push @choices, 'META.json' if $has_cm;
push @choices, 'META.yml' if $has_cm || $has_pcm;
- for my $file ( @choices ) {
+ for my $file ( grep { /$filter/ } @choices ) {
my $path = File::Spec->catdir( $build_dir, $file );
return $path if -f $path
}
$prefer_installer = CPAN::HandleConfig->prefs_lookup(
$self, q{prefer_installer}
);
- # M::B <= 0.35 left a DATA handle open that
+ # M::B <= 0.35 left a DATA handle open that
# causes problems upgrading M::B on Windows
close *Module::Build::Version::DATA
if fileno *Module::Build::Version::DATA;
sub store_persistent_state {
my($self) = @_;
my $dir = $self->{build_dir};
+ unless (defined $dir && length $dir) {
+ my $id = $self->id;
+ $CPAN::Frontend->mywarnonce("build_dir of $id is not known, ".
+ "will not store persistent state\n");
+ return;
+ }
unless (File::Spec->canonpath(File::Basename::dirname($dir))
eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
}
}
my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
- $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
+ $CPAN::Frontend->myprint("Applying $countedpatches:\n");
my $patches_dir = $CPAN::Config->{patches_dir};
for my $patch (@$patches) {
if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
delete $self->{force_update};
return;
}
- $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
+ $CPAN::Frontend->myprint("\n CPAN.pm: Building ".$self->id."\n\n");
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
}
#-> sub CPAN::Distribution::read_meta
-# read any sort of meta files, return CPAN::Meta object if no errors and
-# dynamic_config = 0
+# read any sort of meta files, return CPAN::Meta object if no errors
sub read_meta {
my($self) = @_;
my $meta_file = $self->pick_meta_file
return if $eummv < 6.2501;
}
- # META/MYMETA is only authoritative if dynamic_config is false
- return if $meta->dynamic_config;
-
return $meta;
}
if $CPAN::DEBUG;
$self->debug($yaml) if $CPAN::DEBUG && $yaml;
# MYMETA.yml is static and authoritative by definition
- if ( $meta_file =~ /MYMETA\.yml/ ) {
- return $yaml;
+ if ( $meta_file =~ /MYMETA\.yml/ ) {
+ return $yaml;
}
# META.yml is authoritative only if dynamic_config is defined and false
if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) {
#-> sub CPAN::Distribution::configure_requires ;
sub configure_requires {
my($self) = @_;
- return unless my $meta_file = $self->pick_meta_file;
+ return unless my $meta_file = $self->pick_meta_file('^META');
if (my $meta_obj = $self->read_meta) {
my $prereqs = $meta_obj->effective_prereqs;
my $cr = $prereqs->requirements_for(qw/configure requires/);
$self->{modulebuild}||"",
) if $CPAN::DEBUG;
my($req,$breq);
- if (my $meta_obj = $self->read_meta) {
+ my $meta_obj = $self->read_meta;
+ # META/MYMETA is only authoritative if dynamic_config is false
+ if ($meta_obj && ! $meta_obj->dynamic_config) {
my $prereqs = $meta_obj->effective_prereqs;
my $requires = $prereqs->requirements_for(qw/runtime requires/);
my $build_requires = $prereqs->requirements_for(qw/build requires/);
# bypass actual tests if "trust_test_report_history" and have a report
my $have_tested_fcn;
if ( $CPAN::Config->{trust_test_report_history}
- && $CPAN::META->has_inst("CPAN::Reporter::History")
+ && $CPAN::META->has_inst("CPAN::Reporter::History")
&& ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
# Do nothing if grade was DISCARD
sub _make_test_illuminate_prereqs {
my($self) = @_;
- my @prereq;
-
- # local $CPAN::DEBUG = 16; # Distribution
- for my $m (keys %{$self->{sponsored_mods}}) {
- next unless $self->{sponsored_mods}{$m} > 0;
- my $m_obj = CPAN::Shell->expand("Module",$m) or next;
- # XXX we need available_version which reflects
- # $ENV{PERL5LIB} so that already tested but not yet
- # installed modules are counted.
- my $available_version = $m_obj->available_version;
- my $available_file = $m_obj->available_file;
- if ($available_version &&
- !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
- ) {
- CPAN->debug("m[$m] good enough available_version[$available_version]")
- if $CPAN::DEBUG;
- } elsif ($available_file
- && (
- !$self->{prereq_pm}{$m}
- ||
- $self->{prereq_pm}{$m} == 0
- )
- ) {
- # lex Class::Accessor::Chained::Fast which has no $VERSION
- CPAN->debug("m[$m] have available_file[$available_file]")
- if $CPAN::DEBUG;
- } else {
- push @prereq, $m;
- }
- }
+ my @prereq;
+
+ # local $CPAN::DEBUG = 16; # Distribution
+ for my $m (keys %{$self->{sponsored_mods}}) {
+ next unless $self->{sponsored_mods}{$m} > 0;
+ my $m_obj = CPAN::Shell->expand("Module",$m) or next;
+ # XXX we need available_version which reflects
+ # $ENV{PERL5LIB} so that already tested but not yet
+ # installed modules are counted.
+ my $available_version = $m_obj->available_version;
+ my $available_file = $m_obj->available_file;
+ if ($available_version &&
+ !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
+ ) {
+ CPAN->debug("m[$m] good enough available_version[$available_version]")
+ if $CPAN::DEBUG;
+ } elsif ($available_file
+ && (
+ !$self->{prereq_pm}{$m}
+ ||
+ $self->{prereq_pm}{$m} == 0
+ )
+ ) {
+ # lex Class::Accessor::Chained::Fast which has no $VERSION
+ CPAN->debug("m[$m] have available_file[$available_file]")
+ if $CPAN::DEBUG;
+ } else {
+ push @prereq, $m;
+ }
+ }
my $but;
- if (@prereq) {
- my $cnt = @prereq;
- my $which = join ",", @prereq;
+ if (@prereq) {
+ my $cnt = @prereq;
+ my $which = join ",", @prereq;
$but = $cnt == 1 ? "one dependency not OK ($which)" :
- "$cnt dependencies missing ($which)";
- }
+ "$cnt dependencies missing ($which)";
+ }
$but;
}
$CPAN::Frontend->myprint(qq{
Function system("@args")
returned status $estatus (wstat $wstatus)
- });
+ });
}
}
else {
file => $_, ext => $ext, dir => $dir
});
# copied from CPAN.pm; is this ever actually possible?
- redo unless -f $result->abs;
+ redo unless -f $result->abs;
my $load_method = $self->_load_method($loader, $result);
my @prefs = eval { $self->$load_method($loader, $result) };
CPAN::Distroprefs -- read and match distroprefs
-=head1 SYNOPSIS
+=head1 SYNOPSIS
use CPAN::Distroprefs;
C<success>, C<warning>, or C<fatal>
-=head3 file
+=head3 file
the file from which these prefs were read, or to which this error refers (relative filename)
an arrayref of CPAN::Distroprefs::Pref objects
-=head1 PREFS
+=head1 PREFS
CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
They are constructed automatically as part of C<success> results from C<find()>.
"'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
}
-package CPAN::Exception::yaml_process_error;
-use strict;
-use overload '""' => "as_string";
-
-use vars qw(
- $VERSION
-);
-$VERSION = "5.5";
-
-
-sub new {
- my($class,$module,$file,$during,$error) = @_;
- # my $at = Carp::longmess(""); # XXX find something more beautiful
- bless { module => $module,
- file => $file,
- during => $during,
- error => $error,
- # at => $at,
- }, $class;
-}
-
-sub as_string {
- my($self) = shift;
- if ($self->{during}) {
- if ($self->{file}) {
- if ($self->{module}) {
- if ($self->{error}) {
- return "Alert: While trying to '$self->{during}' YAML file\n".
- " '$self->{file}'\n".
- "with '$self->{module}' the following error was encountered:\n".
- " $self->{error}\n";
- } else {
- return "Alert: While trying to '$self->{during}' YAML file\n".
- " '$self->{file}'\n".
- "with '$self->{module}' some unknown error was encountered\n";
- }
- } else {
- return "Alert: While trying to '$self->{during}' YAML file\n".
- " '$self->{file}'\n".
- "some unknown error was encountered\n";
- }
- } else {
- return "Alert: While trying to '$self->{during}' some YAML file\n".
- "some unknown error was encountered\n";
- }
- } else {
- return "Alert: unknown error encountered\n";
- }
-}
-
1;
--- /dev/null
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::yaml_process_error;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$module,$file,$during,$error) = @_;
+ # my $at = Carp::longmess(""); # XXX find something more beautiful
+ bless { module => $module,
+ file => $file,
+ during => $during,
+ error => $error,
+ # at => $at,
+ }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($self->{during}) {
+ if ($self->{file}) {
+ if ($self->{module}) {
+ if ($self->{error}) {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' the following error was encountered:\n".
+ " $self->{error}\n";
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' some YAML file\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: unknown error encountered\n";
+ }
+}
+
+1;
sub _ftp_statistics {
my($self,$fh) = @_;
my $locktype = $fh ? LOCK_EX : LOCK_SH;
+ # XXX On Windows flock() implements mandatory locking, so we can
+ # XXX only use shared locking to still allow _yaml_load_file() to
+ # XXX read from the file using a different filehandle.
+ $locktype = LOCK_SH if $^O eq "MSWin32";
+
$fh ||= FileHandle->new;
my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
mkpath dirname $file;
$CPAN::Frontend->mydie($@);
}
}
+ CPAN::_flock($fh, LOCK_UN);
return $stats->[0];
}
$ThesiteURL = $ro_url;
return $l;
}
- # If request is for a compressed file and we can find the
+ # If request is for a compressed file and we can find the
# uncompressed file also, return the path of the uncompressed file
# otherwise, decompress it and return the resulting path
if ($l =~ /(.+)\.gz$/) {
Trying with external ftp to get
'$url'
$netrc_explain
- Going to send the dialog
+ Sending the dialog
$dialog
}
);
$CPAN::Frontend->myprint(qq{
Trying with external ftp to get
$url
- Going to send the dialog
+ Sending the dialog
$dialog
}
);
=item halt_on_failure
Normally, CPAN.pm continues processing the full list of targets and
-dependencies, even if one of them fails. However, you can specify
-that CPAN should halt after the first failure.
+dependencies, even if one of them fails. However, you can specify
+that CPAN should halt after the first failure.
Do you want to halt on failure (yes/no)?
Parameters for the './Build install' command? Typical frequently used
setting:
- --uninst 1 # uninstall conflicting files
+ --uninst 1 # uninstall conflicting files
# (but do NOT use with local::lib or INSTALL_BASE)
Your choice:
if ( $args{autoconfig} ) {
$auto_config = 1;
} elsif ($matcher) {
- $auto_config = 0;
- } else {
+ $auto_config = 0;
+ } else {
my $_conf = prompt($prompts{auto_config}, "yes");
$auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0;
}
my $i_am_mad = 0;
# silent prompting -- just quietly use default
*_real_prompt = sub { return $_[1] };
- }
+ }
#
# bootstrap local::lib or sudo
my_dflt_prompt(makepl_arg => "", $matcher);
my_dflt_prompt(make_arg => "", $matcher);
if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) {
- $CPAN::Frontend->mywarn(
- "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
+ $CPAN::Frontend->mywarn(
+ "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
"that specify their own LIBS or INC options in Makefile.PL.\n"
);
}
);
}
else {
- $CPAN::Frontend->myprint(
- "Autoconfigured everything but 'urllist'.\n"
- );
+ $CPAN::Frontend->myprint(
+ "Autoconfigured everything but 'urllist'.\n"
+ );
_do_pick_mirrors();
}
}
$CPAN::Frontend->myprint(
"Skipping local::lib bootstrap because 'urllist' is not configured.\n"
);
- }
- else {
+ }
+ else {
$CPAN::Frontend->myprint("\nAttempting to bootstrap local::lib...\n");
$CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n");
delete $CPAN::Config->{install_help}; # temporary only
$CPAN::Frontend->myprint("From the CPAN Shell, you might try 'look local::lib' and \n"
. "run 'perl Makefile --bootstrap' and see if that is successful. Then\n"
. "restart your CPAN client\n"
- );
+ );
}
else {
_local_lib_config();
- }
+ }
}
}
Please make sure you have 'make' (or some equivalent) working.
HERE
- if ($^O eq "MSWin32") {
+ if ($^O eq "MSWin32") {
$CPAN::Frontend->mywarn(<<"HERE");
Windows users may want to follow this procedure when back in the CPAN shell:
o conf init make
HERE
- }
+ }
}
sub init_cpan_home {
# (2) We don't have a copy at all
# (2a) If we are allowed to connect, we try to get a new copy. If it succeeds,
# we use it, otherwise, we warn about failure
-# (2b) If we aren't allowed to connect,
+# (2b) If we aren't allowed to connect,
sub conf_sites {
my %args = @_;
}
else {
$CPAN::Frontend->mywarn(<<'HERE');
-You will need to provide CPAN mirror URLs yourself or set
+You will need to provide CPAN mirror URLs yourself or set
'o conf connect_to_internet_ok 1' and try again.
HERE
}
my $local = shift or return;
local $|=1;
$CPAN::Frontend->myprint("Looking for CPAN mirrors near you (please be patient)\n");
- my $mirrors = CPAN::Mirrors->new($local);
+ my $mirrors = CPAN::Mirrors->new;
+ $mirrors->parse_mirrored_by($local);
+
my $cnt = 0;
my @best = $mirrors->best_mirrors(
how_many => 3,
if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); }
},
);
+
my $urllist = [ map { $_->http } @best ];
push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}};
$CPAN::Frontend->myprint(" done!\n\n");
+
return $urllist
}
sub _print_urllist {
my ($which) = @_;
$CPAN::Frontend->myprint("$which urllist\n");
- for ( @{$CPAN::Config->{urllist} || []} ) {
- $CPAN::Frontend->myprint(" $_\n")
+ for ( @{$CPAN::Config->{urllist} || []} ) {
+ $CPAN::Frontend->myprint(" $_\n")
};
}
my($self, $uri, $path) = @_;
my $want_proxy = $self->_want_proxy($uri);
- my $http = HTTP::Tiny->new(
- $want_proxy ? (proxy => $self->{proxy}) : ()
+ my $http = HTTP::Tiny->new(
+ $want_proxy ? (proxy => $self->{proxy}) : ()
);
my ($response, %headers);
my $auth_list = $response->{headers}(lc $auth_header);
return unless defined $auth_list;
$auth_list = [$auth_list] unless ref $auth_list;
-
+
for my $challenge (@$auth_list) {
$challenge =~ tr/,/;/; # "," is used to separate auth-params!!
($challenge) = $self->split_header_words($challenge);
my($self,@args) = @_;
CPAN->debug("args[@args]") if $CPAN::DEBUG;
if ($CPAN::RUN_DEGRADED) {
- $CPAN::Frontend->mydie(
- "'o conf commit' disabled in ".
- "degraded mode. Maybe try\n".
- " !undef \$CPAN::RUN_DEGRADED\n"
- );
+ $CPAN::Frontend->mydie(
+ "'o conf commit' disabled in ".
+ "degraded mode. Maybe try\n".
+ " !undef \$CPAN::RUN_DEGRADED\n"
+ );
}
my ($configpm, $must_reload);
sub require_myconfig_or_config () {
if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
return $INC{"CPAN/MyConfig.pm"};
- }
+ }
elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
return $INC{"CPAN/Config.pm"};
- }
+ }
else {
return q{};
- }
+ }
}
# Load a module, but ignore "can't locate..." errors
if ( -f File::Spec->catfile($dir, $file) ) {
unshift @INC, $dir;
last;
+ }
}
- }
eval { require $file };
my $err_myconfig = $@;
if ($^O ne 'darwin') {
push @dirs, File::HomeDir->my_data;
# my_data is ~/Library/Application Support on darwin,
- # which causes issues in the toolchain.
+ # which causes issues in the toolchain.
}
push @dirs, File::HomeDir->my_home;
}
Old configuration file $configpm
moved to $configpm_bak
END
- }
+ }
}
my $fh = FileHandle->new;
if ($fh->open(">$configpm")) {
return;
}
$CPAN::Frontend->myprint
- (sprintf("Going to read %d yaml file%s from %s/\n",
+ (sprintf("Reading %d yaml file%s from %s/\n",
scalar @candidates,
@candidates==1 ? "" : "s",
$CPAN::Config->{build_dir}
return unless defined $index_target;
return if CPAN::_sqlite_running();
my @lines;
- $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
local(*FH);
tie *FH, 'CPAN::Tarzip', $index_target;
local($/) = "\n";
my($self, $index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
- $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
my($cl,$index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
- $CPAN::Frontend->myprint("Going to read '$index_target'\n");
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
my $slurp = "";
$cache->{last_time} = $LAST_TIME;
$cache->{DATE_OF_02} = $DATE_OF_02;
$cache->{PROTOCOL} = PROTOCOL;
- $CPAN::Frontend->myprint("Going to write $metadata_file\n");
+ $CPAN::Frontend->myprint("Writing $metadata_file\n");
eval { Storable::nstore($cache, $metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}
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;
- $CPAN::Frontend->myprint("Going to read '$metadata_file'\n");
+ $CPAN::Frontend->myprint("Reading '$metadata_file'\n");
my $cache;
eval { $cache = Storable::retrieve($metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
+=head1 NAME
+
+CPAN::Mirrors - Get CPAN miror information and select a fast one
+
+=head1 SYNOPSIS
+
+ use CPAN::Mirrors;
+
+ my $mirrors = CPAN::Mirrors->new;
+ $mirrors->parse_from_file( $mirrored_by_file );
+
+ my $seen = {};
+
+ my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
+ my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
+
+ my $callback = sub {
+ my( $m ) = @_;
+ printf "%s = %s\n", $m->hostname, $m->rtt
+ };
+ $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback );
+
+ @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
+
+ print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
+
+=head1 DESCRIPTION
+
+=over
+
+=cut
+
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
use Fcntl ":flock";
use Net::Ping ();
+=item new( LOCAL_FILE_NAME )
+
+=cut
+
sub new {
my ($class, $file) = @_;
- my $self = bless {
- mirrors => [],
- geography => {},
+ my $self = bless {
+ mirrors => [],
+ geography => {},
}, $class;
+ if( defined $file ) {
+ $self->parse_mirrored_by( $file );
+ }
+
+ return $self
+}
+
+sub parse_mirrored_by {
+ my ($self, $file) = @_;
my $handle = FileHandle->new;
- $handle->open($file)
+ $handle->open($file)
or croak "Couldn't open $file: $!";
flock $handle, LOCK_SH;
$self->_parse($file,$handle);
flock $handle, LOCK_UN;
$handle->close;
+}
- # populate continents & countries
+=item continents()
- return $self
-}
+Return a list of continents based on those defined in F<MIRRORED.BY>.
+
+=cut
sub continents {
my ($self) = @_;
return keys %{$self->{geography}};
}
+=item countries( [CONTINENTS] )
+
+Return a list of countries based on those defined in F<MIRRORED.BY>.
+It only returns countries for the continents you specify (as defined
+in C<continents>). If you don't specify any continents, it returns all
+of the countries listed in F<MIRRORED.BY>.
+
+=cut
+
sub countries {
my ($self, @continents) = @_;
@continents = $self->continents unless @continents;
return @countries;
}
+=item mirrors( [COUNTRIES] )
+
+Return a list of mirrors based on those defined in F<MIRRORED.BY>.
+It only returns mirrors for the countries you specify (as defined
+in C<countries>). If you don't specify any countries, it returns all
+of the mirrors listed in F<MIRRORED.BY>.
+
+=cut
+
sub mirrors {
my ($self, @countries) = @_;
return @{$self->{mirrors}} unless @countries;
return @found;
}
+=item get_mirrors_by_countries( [COUNTRIES] )
+
+A more sensible synonym for mirrors.
+
+=cut
+
+sub get_mirrors_by_countries { &mirrors }
+
+=item get_mirrors_by_continents( [CONTINENTS] )
+
+Return a list of mirrors for all of continents you specify. If you don't
+specify any continents, it returns all of the mirrors.
+
+=cut
+
+sub get_mirrors_by_continents {
+ my ($self, $continents ) = @_;
+
+ $self->mirrors( $self->get_countries_by_continents( @$continents ) );
+ }
+
+=item get_countries_by_continents( [CONTINENTS] )
+
+A more sensible synonym for countries.
+
+=cut
+sub get_countries_by_continents { &countries }
+
+=item best_mirrors
+
+C<best_mirrors> checks for the best mirrors based on the list of
+continents you pass, or, without that, all continents, as defined
+by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
+C<how_many>. In list context, it returns up to C<how_many> mirror.
+In scalar context, it returns the single best mirror.
+
+Arguments
+
+ how_many - the number of mirrors to return. Default: 1
+ callback - a callback for find_best_continents
+ verbose - true or false on all the whining and moaning. Default: false
+ continents - an array ref of the continents to check
+
+If you don't specify the continents, C<best_mirrors> calls
+C<find_best_continents> to get the list of continents to check.
+
+=cut
+
sub best_mirrors {
my ($self, %args) = @_;
- my $how_many = $args{how_many} || 1;
- my $callback = $args{callback};
- my $verbose = $args{verbose};
- my $conts = $args{continents} || [];
- $conts = [$conts] unless ref $conts;
+ my $how_many = $args{how_many} || 1;
+ my $callback = $args{callback};
+ my $verbose = defined $args{verbose} ? $args{verbose} : 0;
+ my $continents = $args{continents} || [];
+ $continents = [$continents] unless ref $continents;
# Old Net::Ping did not do timings at all
return "http://www.cpan.org/" unless Net::Ping->VERSION gt '2.13';
my $seen = {};
- if ( ! @$conts ) {
+ if ( ! @$continents ) {
print "Searching for the best continent ...\n" if $verbose;
- my @best = $self->_find_best_continent($seen, $verbose, $callback);
+ my @best_continents = $self->find_best_continents(
+ seen => $seen,
+ verbose => $verbose,
+ callback => $callback,
+ );
# Only add enough continents to find enough mirrors
my $count = 0;
- for my $c ( @best ) {
- push @$conts, $c;
- $count += $self->mirrors( $self->countries($c) );
+ for my $continent ( @best_continents ) {
+ push @$continents, $continent;
+ $count += $self->mirrors( $self->countries($continent) );
last if $count >= $how_many;
}
}
- print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
+ print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
+
+ my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
+
+ my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback );
+ return [] unless @$timings;
+
+ $how_many = @$timings if $how_many > @$timings;
+
+ return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
+}
+
+=item get_n_random_mirrors_by_continents( N, [CONTINENTS]
+
+Returns up to N random mirrors for the specified continents. Specify the
+continents as an array reference.
+
+=cut
+
+sub get_n_random_mirrors_by_continents {
+ my( $self, $n, $continents ) = @_;
+ $n ||= 3;
+ $continents = [ $continents ] unless ref $continents;
- my @timings;
- my @long_list = $self->mirrors($self->countries(@$conts));
- my $long_list_size = ( $how_many > 10 ? $how_many : 10 );
- if ( @long_list > $long_list_size ) {
- @long_list = map {$_->[0]}
- sort {$a->[1] <=> $b->[1]}
- map {[$_, rand]} @long_list;
- splice @long_list, $long_list_size; # truncate
+ if ( $n <= 0 ) {
+ return wantarray ? () : [];
}
- for my $m ( @long_list ) {
- next unless $m->http;
- my $hostname = $m->hostname;
- if ( $seen->{$hostname} ) {
- push @timings, $seen->{$hostname}
- if defined $seen->{$hostname}[1];
+ my @long_list = $self->get_mirrors_by_continents( $continents );
+
+ if ( $n eq '*' or $n > @long_list ) {
+ return wantarray ? @long_list : \@long_list;
+ }
+
+ @long_list = map {$_->[0]}
+ sort {$a->[1] <=> $b->[1]}
+ map {[$_, rand]} @long_list;
+
+ splice @long_list, $n; # truncate
+
+ \@long_list;
+}
+
+=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK );
+
+Pings the listed mirrors and returns a list of mirrors sorted
+in ascending ping times.
+
+=cut
+
+sub get_mirrors_timings {
+ my( $self, $mirror_list, $seen, $callback ) = @_;
+
+ $seen = {} unless defined $seen;
+ croak "The mirror list argument must be an array reference"
+ unless ref $mirror_list eq ref [];
+ croak "The seen argument must be a hash reference"
+ unless ref $seen eq ref {};
+ croak "callback must be a subroutine"
+ if( defined $callback and ref $callback ne ref sub {} );
+
+ my $timings = [];
+ for my $m ( @$mirror_list ) {
+ $seen->{$m->hostname} = $m;
+ next unless eval{ $m->http };
+
+ if( $self->_try_a_ping( $seen, $m, ) ) {
+ my $ping = $m->ping;
+ next unless defined $ping;
+ push @$timings, $m;
+ $callback->( $m ) if $callback;
}
else {
- my $ping = $m->ping;
- next unless defined $ping;
- push @timings, [$m, $ping];
- $callback->($m,$ping) if $callback;
+ push @$timings, $seen->{$m->hostname}
+ if defined $seen->{$m->hostname}->rtt;
}
}
- return unless @timings;
-
- $how_many = @timings if $how_many > @timings;
- my @best =
- map { $_->[0] }
- sort { $a->[1] <=> $b->[1] } @timings;
- return wantarray ? @best[0 .. $how_many-1] : $best[0];
+ my @best = sort {
+ if( defined $a->rtt and defined $b->rtt ) {
+ $a->rtt <=> $b->rtt
+ }
+ elsif( defined $a->rtt and ! defined $b->rtt ) {
+ return -1;
+ }
+ elsif( ! defined $a->rtt and defined $b->rtt ) {
+ return 1;
+ }
+ elsif( ! defined $a->rtt and ! defined $b->rtt ) {
+ return 0;
+ }
+
+ } @$timings;
+
+ return wantarray ? @best : \@best;
}
-sub _find_best_continent {
- my ($self, $seen, $verbose, $callback) = @_;
+=item find_best_continents( HASH_REF );
+
+C<find_best_continents> goes through each continent and pings C<N> random
+mirrors on that continent. It then orders the continents by ascending
+median ping time. In list context, it returns the ordered list of
+continent. In scalar context, it returns the same list as an anonymous
+array.
+
+Arguments:
+
+ n - the number of hosts to ping for each continent. Default: 3
+ seen - a hashref of cached hostname ping times
+ verbose - true or false for noisy or quiet. Default: false
+ callback - a subroutine to run after each ping.
+ ping_cache_limit - how long, in seconds, to reuse previous ping times.
+ Default: 1 day
+
+The C<seen> hash has hostnames as keys and anonymous arrays as values. The
+anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a ping
+time, and the epoch time for the measurement.
+
+The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
+time, and measurement time (the same things in the C<seen> hashref) as arguments.
+C<find_best_continents> doesn't care what the callback does and ignores the return
+value.
- my %median;
+=cut
+
+sub find_best_continents {
+ my ($self, %args) = @_;
+
+ $args{n} ||= 3;
+ $args{verbose} = 0 unless defined $args{verbose};
+ $args{seen} = {} unless defined $args{seen};
+ croak "The seen argument must be a hash reference"
+ unless ref $args{seen} eq ref {};
+ $args{ping_cache_limit} = 24 * 60 * 60
+ unless defined $args{ping_cache_time};
+ croak "callback must be a subroutine"
+ if( defined $args{callback} and ref $args{callback} ne ref sub {} );
+
+ my %medians;
CONT: for my $c ( $self->continents ) {
+ print "Testing $c\n" if $args{verbose};
my @mirrors = $self->mirrors( $self->countries($c) );
+
next CONT unless @mirrors;
- my $sample = 3;
- my $n = (@mirrors < $sample) ? @mirrors : $sample;
+ my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
+
my @tests;
- RANDOM: while ( @mirrors && @tests < $n ) {
+ my $tries = 0;
+ RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
- my $ping = $m->ping;
- $callback->($m,$ping) if $callback;
- # record undef so we don't try again
- $seen->{$m->hostname} = [$m, $ping];
- next RANDOM unless defined $ping;
- push @tests, $ping;
- }
- next CONT unless @tests;
- @tests = sort { $a <=> $b } @tests;
- if ( @tests == 1 ) {
- $median{$c} = $tests[0];
- }
- elsif ( @tests % 2 ) {
- $median{$c} = $tests[ int(@tests / 2) ];
- }
- else {
- my $mid_high = int(@tests/2);
- $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2;
+ if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) {
+ $self->get_mirrors_timings( [ $m ], @args{qw(seen callback)} );
+ next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
+ }
+ printf "\t%s -> %0.2f ms\n",
+ $m->hostname,
+ join ' ', 1000 * $args{seen}{$m->hostname}->rtt
+ if $args{verbose};
+
+ push @tests, $args{seen}{$m->hostname}->rtt;
}
+
+ my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
+ $medians{$c} = $median if defined $median;
}
- my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
+ my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
- if ( $verbose ) {
+ if ( $args{verbose} ) {
print "Median result by continent:\n";
for my $c ( @best_cont ) {
- printf( " %d ms %s\n", int($median{$c}*1000+.5), $c );
+ printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c );
}
}
return wantarray ? @best_cont : $best_cont[0];
}
+# retry if
+sub _try_a_ping {
+ my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
+
+ ( ! exists $seen->{$mirror->hostname} )
+ or
+ (
+ ! defined $seen->{$mirror->hostname}->rtt
+ or
+ time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit
+ )
+}
+
+sub _get_median_ping_time {
+ my ($self, $tests, $verbose ) = @_;
+
+ my @sorted = sort { $a <=> $b } @$tests;
+
+ my $median = do {
+ if ( @sorted == 0 ) { undef }
+ elsif ( @sorted == 1 ) { $sorted[0] }
+ elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] }
+ else {
+ my $mid_high = int(@sorted/2);
+ ($sorted[$mid_high-1] + $sorted[$mid_high])/2;
+ }
+ };
+
+ printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
+
+ return $median;
+}
+
# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
sub _parse {
my ($self, $file, $handle) = @_;
my $output = $self->{mirrors};
- my $geo = $self->{geography};
+ my $geo = $self->{geography};
local $/ = "\012";
my $line = 0;
$mirror ||= {};
if ( $prop eq 'dst_location' ) {
my (@location,$continent,$country);
- @location = (split /\s*,\s*/, $value)
+ @location = (split /\s*,\s*/, $value)
and ($continent, $country) = @location[-1,-2];
$continent =~ s/\s\(.*//;
$continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
$arg ||= {};
bless $arg, $self;
}
-sub hostname { shift->{hostname} }
-sub continent { shift->{continent} }
-sub country { shift->{country} }
-sub http { shift->{http} || '' }
-sub ftp { shift->{ftp} || '' }
-sub rsync { shift->{rsync} || '' }
-
-sub url {
+sub hostname { shift->{hostname} }
+sub continent { shift->{continent} }
+sub country { shift->{country} }
+sub http { shift->{http} || '' }
+sub ftp { shift->{ftp} || '' }
+sub rsync { shift->{rsync} || '' }
+sub rtt { shift->{rtt} }
+sub ping_time { shift->{ping_time} }
+
+sub url {
my $self = shift;
return $self->{http} || $self->{ftp};
}
sub ping {
my $self = shift;
+
my $ping = Net::Ping->new("tcp",1);
my ($proto) = $self->url =~ m{^([^:]+)};
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
- if ( $ping->can('port_number') ) {
- $ping->port_number($port);
+
+ if ( $ping->can('port_number') ) {
+ $ping->port_number($port);
}
else {
$ping->{'port_num'} = $port;
}
+
$ping->hires(1) if $ping->can('hires');
my ($alive,$rtt) = $ping->ping($self->hostname);
- return $alive ? $rtt : undef;
+
+ $self->{rtt} = $alive ? $rtt : undef;
+ $self->{ping_time} = time;
+
+ $self->rtt;
}
1;
+=back
+
+=head1 AUTHOR
+
+Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
+brian d foy C<< <bdfoy@cpan.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+
+
+=cut
"CPAN::MyConfig already exists as $configpm.\n" .
"Running configuration again...\n"
);
- require CPAN::FirstTime;
+ require CPAN::FirstTime;
CPAN::FirstTime::init($configpm);
}
else {
$fh->close;
$CPAN::Frontend->myprint("\nWrote bundle file
$to\n\n");
+ return $to;
}
#-> sub CPAN::Shell::expandany ;
if ($meth =~ /^($needs_recursion_protection)$/) {
# it would be silly to check for recursion for look or dump
# (we are in CPAN::Shell::rematein)
- CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
+ CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
eval { $obj->color_cmd_tmps(0,1); };
if ($@) {
if (ref $@
my($self) = @_;
if ($CPAN::META->has_inst("XML::LibXML")) {
my $url = $CPAN::Defaultrecent;
- $CPAN::Frontend->myprint("Going to fetch '$url'\n");
+ $CPAN::Frontend->myprint("Fetching '$url'\n");
unless ($CPAN::META->has_usable("LWP")) {
$CPAN::Frontend->mydie("LWP not installed; cannot continue");
}
my $distros = $self->recent;
DISTRO: for my $distro (@$distros) {
next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
- $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
+ $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
{
my $skip = 0;
local $SIG{INT} = sub { $skip = 1 };
=item *
+L<CPAN> has been upgraded from version 1.9600 to version 1.9800
+
+=item *
+
L<CPANPLUS> has been upgraded from version 0.9108 to version 0.9109
Fixed support for v-strings and x.y.z versions with v5.8.4
projects / platform / upstream / perl.git / commitdiff