diff options
author | Jesse Vincent <jesse@bestpractical.com> | 2009-12-18 12:47:08 -0500 |
---|---|---|
committer | Jesse Vincent <jesse@bestpractical.com> | 2009-12-18 12:47:08 -0500 |
commit | 0124e6951248925eb02487d9823d46be100b0e91 (patch) | |
tree | ebbce67360b172514c309e3ce2675124deb621ae /cpan/CPAN/lib | |
parent | 587808146dcf7a2a909b351c4c32085e6fcb74dc (diff) | |
download | perl-0124e6951248925eb02487d9823d46be100b0e91.tar.gz |
Import CPAN.pm 1.94_53 from CPAN
Diffstat (limited to 'cpan/CPAN/lib')
-rw-r--r-- | cpan/CPAN/lib/App/Cpan.pm | 1068 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN.pm | 73 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Author.pm | 22 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Distribution.pm | 45 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/FTP.pm | 96 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/FirstTime.pm | 453 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/HandleConfig.pm | 1 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Mirrors.pm | 259 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Module.pm | 46 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Shell.pm | 38 | ||||
-rw-r--r-- | cpan/CPAN/lib/CPAN/Tarzip.pm | 62 |
11 files changed, 1851 insertions, 312 deletions
diff --git a/cpan/CPAN/lib/App/Cpan.pm b/cpan/CPAN/lib/App/Cpan.pm new file mode 100644 index 0000000000..bfa32e923b --- /dev/null +++ b/cpan/CPAN/lib/App/Cpan.pm @@ -0,0 +1,1068 @@ +package App::Cpan; +use strict; +use warnings; +use vars qw($VERSION); + +$VERSION = '1.57'; + +=head1 NAME + +App::Cpan - easily interact with CPAN from the command line + +=head1 SYNOPSIS + + # with arguments and no switches, installs specified modules + cpan module_name [ module_name ... ] + + # with switches, installs modules with extra behavior + cpan [-cfFimt] module_name [ module_name ... ] + + # 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 + + # without arguments, but some switches + cpan [-ahruvACDLO] + +=head1 DESCRIPTION + +This script provides a command interface (not a shell) to CPAN. At the +moment it uses CPAN.pm to do the work, but it is not a one-shot command +runner for CPAN.pm. + +=head2 Options + +=over 4 + +=item -a + +Creates a CPAN.pm autobundle with CPAN::Shell->autobundle. + +=item -A module [ module ... ] + +Shows the primary maintainers for the specified modules. + +=item -c module + +Runs a `make clean` in the specified module's directories. + +=item -C module [ module ... ] + +Show the F<Changes> files for the specified modules + +=item -D module [ module ... ] + +Show the module details. This prints one line for each out-of-date module +(meaning, modules locally installed but have newer versions on CPAN). +Each line has three columns: module name, local version, and CPAN +version. + +=item -f + +Force the specified action, when it normally would have failed. Use this +to install a module even if its tests fail. When you use this option, +-i is not optional for installing a module when you need to force it: + + % cpan -f -i Module::Foo + +=item -F + +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 -g module [ module ... ] + +Downloads to the current directory the latest distribution of the module. + +=item -G module [ module ... ] + +UNIMPLEMENTED + +Download to the current directory the latest distribution of the +modules, unpack each distribution, and create a git repository for each +distribution. + +If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch> +distribution. + +=item -h + +Print a help message and exit. When you specify C<-h>, it ignores all +of the other options and arguments. + +=item -i + +Install the specified modules. + +=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 +C<$CPAN::Config> as an anonymous hash. + +=item -J + +Dump the configuration in the same format that CPAN.pm uses. This is useful +for checking the configuration as well as using the dump as a starting point +for a new, custom configuration. + +=item -l + +Use C<local::lib>. + +=item -L author [ author ... ] + +List the modules by the specified authors. + +=item -m + +Make the specified modules. + +=item -O + +Show the out-of-date modules. + +=item -t + +Run a `make test` on the specified modules. + +=item -r + +Recompiles dynamically loaded modules with CPAN::Shell->recompile. + +=item -u + +Upgrade all installed modules. Blindly doing this can really break things, +so keep a backup. + +=item -v + +Print the script version and CPAN.pm version then exit. + +=back + +=head2 Examples + + # print a help message + cpan -h + + # print the version numbers + cpan -v + + # create an autobundle + cpan -a + + # recompile modules + cpan -r + + # upgrade all installed modules + cpan -u + + # install modules ( sole -i is optional ) + cpan -i Netscape::Booksmarks Business::ISBN + + # force install modules ( must use -i ) + cpan -fi CGI::Minimal URI + + +=head2 Methods + +=over 4 + +=cut + +use autouse Carp => qw(carp croak cluck); +use CPAN (); +use autouse Cwd => qw(cwd); +use autouse 'Data::Dumper' => qw(Dumper); +use File::Spec::Functions; +use File::Basename; + +use Getopt::Std; + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# Internal constants +use constant TRUE => 1; +use constant FALSE => 0; + + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# The return values +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'; + +%CPAN_METHODS = ( # map switches to method names in CPAN::Shell + $Default => 'install', + 'c' => 'clean', + 'f' => 'force', + 'i' => 'install', + 'm' => 'make', + 't' => 'test', + 'u' => 'upgrade', + ); +@CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS; + +@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 } +sub ARGS () { 1 } +sub GOOD_EXIT () { 0 } + +%Method_table = ( +# key => [ sub ref, takes args?, exit value, description ] + + # options that do their thing first, then exit + h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ], + v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ], + + # options that affect other options + j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ], + J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ], + F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ], + + # 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' ], + O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ], + + l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ], + + L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ], + a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ], + r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ], + u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ], + + c => [ \&_default, ARGS, GOOD_EXIT, 'Running `make clean`' ], + f => [ \&_default, ARGS, GOOD_EXIT, 'Installing with force' ], + i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ], + 'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ], + t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ], + + ); + +%Method_table_index = ( + code => 0, + takes_args => 1, + exit_value => 2, + description => 3, + ); +} + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# 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 ); + \%options; + } + } + +sub _process_setup_options + { + my( $class, $options ) = @_; + + if( $options->{j} ) + { + $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} ); + delete $options->{j}; + } + else + { + # this is what CPAN.pm would do otherwise + CPAN::HandleConfig->load( + be_silent => 1, + write_file => 0, + ); + } + + if( $options->{F} ) + { + $Method_table{F}[ $Method_table_index{code} ]->( $options->{F} ); + delete $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; + } + + +=item run() + +Just do it. + +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 + +my $logger; + +sub run + { + my $class = shift; + + my $return_value = HEY_IT_WORKED; # assume that things will work + + $logger = $class->_init_logger; + $logger->debug( "Using logger from @{[ref $logger]}" ); + + $class->_hook_into_CPANpm_report; + $logger->debug( "Hooked into output" ); + + $class->_stupid_interface_hack_for_non_rtfmers; + $logger->debug( "Patched cargo culting" ); + + my $options = $class->_process_options; + $logger->debug( "Options are @{[Dumper($options)]}" ); + + $class->_process_setup_options( $options ); + + OPTION: foreach my $option ( @option_order ) + { + next unless $options->{$option}; + + my( $sub, $takes_args, $description ) = + map { $Method_table{$option}[ $Method_table_index{$_} ] } + qw( code takes_args ); + + unless( ref $sub eq ref sub {} ) + { + $return_value = THE_PROGRAMMERS_AN_IDIOT; + last OPTION; + } + + $logger->info( "$description -- ignoring other arguments" ) + if( @ARGV && ! $takes_args ); + + $return_value = $sub->( \ @ARGV, $options ); + + last; + } + + return $return_value; + } + +{ +package Local::Null::Logger; + +sub new { bless \ my $x, $_[0] } +sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ } +sub DESTROY { 1 } +} + +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 + # we'll deal with 'f' (force) later, so skip it + foreach my $option ( @CPAN_OPTIONS ) + { + next if $option eq 'f'; + next unless $options->{$option}; + $switch = $option; + last; + } + + # 1. with no switches, but arguments, use the default switch (install) + # 2. with no switches and no args, start the shell + # 3. With a switch but no args, die! These switches need arguments. + if( not $switch and @$args ) { $switch = $Default; } + elsif( not $switch and not @$args ) { return CPAN::shell() } + elsif( $switch and not @$args ) + { die "Nothing to $CPAN_METHODS{$switch}!\n"; } + + # Get and check the method from CPAN::Shell + my $method = $CPAN_METHODS{$switch}; + die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method ); + + # call the CPAN::Shell method, with force if specified + my $action = do { + 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 ) + { + _clear_cpanpm_output(); + $action->( $arg ); + + $errors += defined _cpanpm_output_indicates_failure(); + } + + $errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED; + } + +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + +=for comment + +CPAN.pm sends all the good stuff either to STDOUT, or to a temp +file if $CPAN::Be_Silent is set. I have to intercept that output +so I can find out what happened. + +=cut + +{ +my $scalar = ''; + +sub _hook_into_CPANpm_report + { + no warnings 'redefine'; + + *CPAN::Shell::myprint = sub { + my($self,$what) = @_; + $scalar .= $what; + $self->print_ornamented($what, + $CPAN::Config->{colorize_print}||'bold blue on_white', + ); + }; + + *CPAN::Shell::mywarn = sub { + my($self,$what) = @_; + $scalar .= $what; + $self->print_ornamented($what, + $CPAN::Config->{colorize_warn}||'bold red on_white' + ); + }; + + } + +sub _clear_cpanpm_output { $scalar = '' } + +sub _get_cpanpm_output { $scalar } + +BEGIN { +my @skip_lines = ( + qr/^\QWarning \(usually harmless\)/, + qr/\bwill not store persistent state\b/, + qr(//hint//), + qr/^\s+reports\s+/, + ); + +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. + REGEXES: { + foreach my $regex ( @skip_lines ) + { + if( $lines[-1] =~ m/$regex/ ) + { + pop @lines; + redo REGEXES; # we have to go through all of them for every line! + } + } + } + + $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() || + _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( + "$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION ); + + return HEY_IT_WORKED; + } + +sub _create_autobundle + { + $logger->info( + "Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" ); + + CPAN::Shell->autobundle; + + return HEY_IT_WORKED; + } + +sub _recompile + { + $logger->info( "Recompiling dynamically-loaded extensions" ); + + CPAN::Shell->recompile; + + return HEY_IT_WORKED; + } + +sub _upgrade + { + $logger->info( "Upgrading all modules" ); + + CPAN::Shell->upgrade(); + + return HEY_IT_WORKED; + } + +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; + } + +sub _dump_config + { + my $args = shift; + require Data::Dumper; + + my $fh = $args->[0] || \*STDOUT; + + 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" ); + + foreach my $site ( @{ $CPAN::Config->{urllist} } ) + { + my $fetch_path = join "/", $site, $path; + $logger->debug( "Trying $fetch_path" ); + last if LWP::Simple::getstore( $fetch_path, $store_path ); + } + + return $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 $path = CPAN::Shell->expand( "Module", $module )->cpan_file; + + my $store_paths = _download( [ $module ] ); + $logger->debug( "gitify Store path is $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" ); + + my $changes = LWP::Simple::get( $changes_url ); + + print $changes; + + return HEY_IT_WORKED; + } + +sub _show_Author + { + my $args = shift; + + foreach my $arg ( @$args ) + { + my $module = CPAN::Shell->expand( "Module", $arg ); + unless( $module ) + { + $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", + $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)", + $module->cpan_file, + $module->inst_file, + 'Installed: ' . $module->inst_version, + 'CPAN: ' . $module->cpan_version . ' ' . + ($module->uptodate ? "" : "Not ") . "up to date", + $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->cpan_version; + } + + return HEY_IT_WORKED; + } + +sub _show_author_mods + { + 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 ) + 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> ) + { + chomp; + $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod; + next if $in_pod || /^\s*#/; + + 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{ + package ExtUtils::MakeMaker::_version; + + local $sigil$var; + \$$var=undef; do { + $line + }; \$$var + }; + + my $version = do { + local $^W = 0; + no strict; + eval( $eval ); + }; + + return $version; + } + +sub _path_to_module + { + 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; + } + +1; + +=back + +=head1 EXIT VALUES + +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: + + 1 An unknown error + + 2 The was an external problem + + 4 There was an internal problem with the script + + 8 A module failed to install + +=head1 TO DO + +* There is initial support for Log4perl if it is available, but I +haven't gone through everything to make the NullLogger work out +correctly if Log4perl is not installed. + +* When I capture CPAN.pm output, I need to check for errors and +report them to the user. + +=head1 BUGS + +* none noted + +=head1 SEE ALSO + +Most behaviour, including environment variables and configuration, +comes directly from CPAN.pm. + +=head1 SOURCE AVAILABILITY + +This code is in Github: + + git://github.com/briandfoy/cpan_script.git + +=head1 CREDITS + +Japheth Cleaver added the bits to allow a forced install (-f). + +Jim Brandt suggest and provided the initial implementation for the +up-to-date and Changes features. + +Adam Kennedy pointed out that exit() causes problems on Windows +where this script ends up with a .bat extension + +=head1 AUTHOR + +brian d foy, C<< <bdfoy@cpan.org> >> + +=head1 COPYRIGHT + +Copyright (c) 2001-2009, brian d foy, All Rights Reserved. + +You may redistribute this under the same terms as Perl itself. + +=cut diff --git a/cpan/CPAN/lib/CPAN.pm b/cpan/CPAN/lib/CPAN.pm index 8b06259151..b6ecac7fa5 100644 --- a/cpan/CPAN/lib/CPAN.pm +++ b/cpan/CPAN/lib/CPAN.pm @@ -2,7 +2,7 @@ # vim: ts=4 sts=4 sw=4: use strict; package CPAN; -$CPAN::VERSION = '1.94_51'; +$CPAN::VERSION = '1.94_53'; $CPAN::VERSION =~ s/_//; # we need to run chdir all over and we would get at wrong libraries @@ -342,7 +342,7 @@ Enter 'h' for help. s/^\s+//; next SHELLCOMMAND if /^$/; s/^\s*\?\s*/help /; - if (/^(?:q(?:uit)?|bye|exit)$/i) { + if (/^(?:q(?:uit)?|bye|exit)\s*$/i) { last SHELLCOMMAND; } elsif (s/\\$//s) { chomp; @@ -1024,7 +1024,8 @@ sub has_usable { my $atv = Archive::Tar->VERSION; for ("You have Archive::Tar $atv, but $demand or later is recommended. Please upgrade.\n") { $CPAN::Frontend->mywarn($_); - die $_; + # don't die, because we may need + # Archive::Tar to upgrade } } @@ -1468,12 +1469,29 @@ are printed in one-line format. =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions These commands take any number of arguments and investigate what is -necessary to perform the action. If the argument is a distribution -file name (recognized by embedded slashes), it is processed. If it is -a module, CPAN determines the distribution file in which this module -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<prerequisites_policy>.) +necessary to perform the action. Argument processing is as follows: + + known module name in format Foo/Bar.pm module + other embedded slash distribution + - with trailing slash dot directory + enclosing slashes regexp + known module name in format Foo::Bar module + +If the argument is a distribution file name (recognized by embedded +slashes), it is processed. If it is a module, CPAN determines the +distribution file in which this module 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<prerequisites_policy>). If an argument is enclosed in +slashes it is treated as a regular expression: it is expanded and if +the result is a single object (distribution, bundle or module), this +object is processed. + +Example: + + install Dummy::Perl # installs the module + install AUXXX/Dummy-Perl-3.14.tar.gz # installs that distribution + install /Dummy-Perl-3.14/ # same if the regexp is unambiguous C<get> downloads a distribution file and untars or unzips it, C<make> builds it, C<test> runs the test suite, and C<install> installs it. @@ -1609,7 +1627,8 @@ pressing C<^C> twice. CPAN.pm ignores SIGPIPE. If the user sets C<inactivity_timeout>, a SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl -Build.PL> subprocess. +Build.PL> subprocess. A SIGALRM is also used during module version +parsing, and is controlled by C<version_timeout>. =back @@ -1985,6 +2004,8 @@ currently defined: urllist arrayref to nearby CPAN sites (or equivalent locations) use_sqlite use CPAN::SQLite for metadata storage (fast and lean) username your username if you CPAN server wants one + version_timeout stops version parsing after this many seconds. + Default is 15 secs. Set to 0 to disable. wait_list arrayref to a wait server to try (See CPAN::WAIT) wget path to external prg yaml_load_code enable YAML code deserialisation via CPAN::DeferredCode @@ -2263,7 +2284,7 @@ C<expect>. expect: [] - commendline: "echo SKIPPING make" + commandline: "echo SKIPPING make" test: args: [] @@ -2434,6 +2455,9 @@ C<args> is not used. Extended C<expect>. This is a hash reference with four allowed keys, C<mode>, C<timeout>, C<reuse>, and C<talk>. +You must install the C<Expect> module to use C<eexpect>. CPAN.pm +does not install it for you. + C<mode> may have the values C<deterministic> for the case where all questions come in the order written down and C<anyorder> for the case where the questions may come in any order. The default mode is @@ -2470,12 +2494,15 @@ Environment variables to be set during the command =item expect [array] -C<< expect: <array> >> is a short notation for +You must install the C<Expect> module to use C<expect>. CPAN.pm +does not install it for you. + +C<< expect: <array> >> is a short notation for this C<eexpect>: -eexpect: - mode: deterministic - timeout: 15 - talk: <array> + eexpect: + mode: deterministic + timeout: 15 + talk: <array> =back @@ -2650,7 +2677,7 @@ Recursively runs the C<get> method on all items contained in the bundle =item CPAN::Bundle::inst_file() Returns the highest installed version of the bundle in either @INC or -C<$CPAN::Config->{cpan_home}>. Note that this is different from +C<< $CPAN::Config->{cpan_home} >>. Note that this is different from CPAN::Module::inst_file. =item CPAN::Bundle::inst_version() @@ -2783,10 +2810,10 @@ Makefile.PL> or C<perl Build.PL> and C<make> there. Downloads the pod documentation of the file associated with a distribution (in HTML format) and runs it through the external -command I<lynx> specified in C<$CPAN::Config->{lynx}>. If I<lynx> +command I<lynx> specified in C<< $CPAN::Config->{lynx} >>. If I<lynx> isn't available, it converts it to plain text with the external command I<html2text> and runs it through the pager specified -in C<$CPAN::Config->{pager}> +in C<< $CPAN::Config->{pager} >>. =item CPAN::Distribution::prefs() @@ -2815,7 +2842,7 @@ undef otherwise. =item CPAN::Distribution::readme() Downloads the README file associated with a distribution and runs it -through the pager specified in C<$CPAN::Config->{pager}>. +through the pager specified in C<< $CPAN::Config->{pager} >>. =item CPAN::Distribution::reports() @@ -2847,7 +2874,7 @@ Forces a reload of all indices. =item CPAN::Index::reload() Reloads all indices if they have not been read for more than -C<$CPAN::Config->{index_expire}> days. +C<< $CPAN::Config->{index_expire} >> days. =item CPAN::InfoObj::dump() @@ -3610,9 +3637,7 @@ nice about obeying that variable as well): How do I create a Module::Build based Build.PL derived from an ExtUtils::MakeMaker focused Makefile.PL? -http://search.cpan.org/search?query=Module::Build::Convert - -http://www.refcnt.org/papers/module-build-convert +http://search.cpan.org/dist/Module-Build-Convert/ =item 15) diff --git a/cpan/CPAN/lib/CPAN/Author.pm b/cpan/CPAN/lib/CPAN/Author.pm index 14ef2ef633..e9e9226be5 100644 --- a/cpan/CPAN/lib/CPAN/Author.pm +++ b/cpan/CPAN/lib/CPAN/Author.pm @@ -149,16 +149,24 @@ sub dir_listing { } my $lc_file; if ($may_ftp) { - $lc_file = CPAN::FTP->localize( - "authors/id/@$chksumfile", - $lc_want, - $force, - ); + $lc_file = eval { + CPAN::FTP->localize + ( + "authors/id/@$chksumfile", + $lc_want, + $force, + ); + }; unless ($lc_file) { $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); $chksumfile->[-1] .= ".gz"; - $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", - "$lc_want.gz",1); + $lc_file = eval { + CPAN::FTP->localize + ("authors/id/@$chksumfile", + "$lc_want.gz", + 1, + ); + }; if ($lc_file) { $lc_file =~ s{\.gz(?!\n)\Z}{}; #}; eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; diff --git a/cpan/CPAN/lib/CPAN/Distribution.pm b/cpan/CPAN/lib/CPAN/Distribution.pm index e63002cd72..6887380abc 100644 --- a/cpan/CPAN/lib/CPAN/Distribution.pm +++ b/cpan/CPAN/lib/CPAN/Distribution.pm @@ -663,6 +663,9 @@ sub satisfy_configure_requires { $CPAN::Frontend->mywarn($@); return $self->goodbye("[depend] -- NOT OK"); } + else { + return $self->goodbye("[configure_requires] -- NOT OK"); + } } die "never reached"; } @@ -687,8 +690,13 @@ sub choose_MM_or_MB { if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) { if ($mpl_exists) { # they *can* choose if ($CPAN::META->has_inst("Module::Build")) { - $prefer_installer = CPAN::HandleConfig->prefs_lookup($self, - q{prefer_installer}); + $prefer_installer = CPAN::HandleConfig->prefs_lookup( + $self, q{prefer_installer} + ); + # 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; } } else { $prefer_installer = "mb"; @@ -1258,10 +1266,11 @@ sub readme { "id", split(/\//,"$sans.readme"), ); - $self->debug("Doing localize") if $CPAN::DEBUG; - $local_file = CPAN::FTP->localize("authors/id/$sans.readme", + my $readme = "authors/id/$sans.readme"; + $self->debug("Doing localize for '$readme'") if $CPAN::DEBUG; + $local_file = CPAN::FTP->localize($readme, $local_wanted) - or $CPAN::Frontend->mydie(qq{No $sans.readme found});; + or $CPAN::Frontend->mydie(qq{No $sans.readme found}); if ($^O eq 'MacOS') { Mac::BuildTools::launch_file($local_file); @@ -2084,6 +2093,8 @@ sub _run_via_expect_anyorder { $expo->send($send); # never allow reusing an QA pair unless they told us splice @expectacopy, $i, 2 unless $reuse; + $but =~ s/(?s:^.*?)$regex//; + $timeout_start = time; next EXPECT; } } @@ -2511,7 +2522,7 @@ sub unsat_prereq { my @merged = %merged; CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG; NEED: while (my($need_module, $need_version) = each %merged) { - my($available_version,$available_file,$nmo); + my($available_version,$inst_file,$available_file,$nmo); if ($need_module eq "perl") { $available_version = $]; $available_file = CPAN::find_perl(); @@ -2522,10 +2533,11 @@ sub unsat_prereq { } $nmo = $CPAN::META->instance("CPAN::Module",$need_module); next if $nmo->uptodate; - $available_file = $nmo->available_file; + $inst_file = $nmo->inst_file || ''; + $available_file = $nmo->available_file || ''; # if they have not specified a version, we accept any installed one - if (defined $available_file + if ( $available_file and ( # a few quick shortcurcuits not defined $need_version or $need_version eq '0' # "==" would trigger warning when not numeric @@ -2540,10 +2552,19 @@ sub unsat_prereq { # 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 $available_file) { - my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs - ($need_module,$available_file,$available_version,$need_version); - next NEED if $fulfills_all_version_rqs; + # But we don't want to accept a deprecated module installed as part + # of the Perl core, so we continue if the available file is the installed + # one and is deprecated + + if ( $available_file ) { + if ( $inst_file && $available_file eq $inst_file && $nmo->inst_deprecated ) { + # continue installing as a prereq + } + else { + next NEED if $self->_fulfills_all_version_rqs( + $need_module,$available_file,$available_version,$need_version + ); + } } if ($need_module eq "perl") { diff --git a/cpan/CPAN/lib/CPAN/FTP.pm b/cpan/CPAN/lib/CPAN/FTP.pm index 412f8d7d08..ed327dce86 100644 --- a/cpan/CPAN/lib/CPAN/FTP.pm +++ b/cpan/CPAN/lib/CPAN/FTP.pm @@ -8,12 +8,13 @@ use File::Basename qw(dirname); use File::Path qw(mkpath); use CPAN::FTP::netrc; use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod); + @CPAN::FTP::ISA = qw(CPAN::Debug); use vars qw( $VERSION ); -$VERSION = "5.5002"; +$VERSION = "5.5004"; #-> sub CPAN::FTP::ftp_statistics # if they want to rewrite, they need to pass in a filehandle @@ -42,7 +43,7 @@ sub _ftp_statistics { if ($@) { if (ref $@) { if (ref $@ eq "CPAN::Exception::yaml_not_installed") { - $CPAN::Frontend->myprint("Warning (usually harmless): $@"); + $CPAN::Frontend->myprint("Warning (usually harmless): $@\n"); return; } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") { $CPAN::Frontend->mydie($@); @@ -159,8 +160,7 @@ sub _copy_stat { # checked from, maybe only for young files? #-> sub CPAN::FTP::_recommend_url_for sub _recommend_url_for { - my($self, $file) = @_; - my $urllist = $self->_get_urllist; + my($self, $file, $urllist) = @_; if ($file =~ s|/CHECKSUMS(.gz)?$||) { my $fullstats = $self->_ftp_statistics(); my $history = $fullstats->{history} || []; @@ -183,13 +183,17 @@ sub _recommend_url_for { #-> sub CPAN::FTP::_get_urllist sub _get_urllist { - my($self) = @_; + my($self, $with_defaults) = @_; + $with_defaults ||= 0; + CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG; + $CPAN::Config->{urllist} ||= []; unless (ref $CPAN::Config->{urllist} eq 'ARRAY') { $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n"); $CPAN::Config->{urllist} = []; } my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}}; + push @urllist, @CPAN::Defaultsites if $with_defaults; for my $u (@urllist) { CPAN->debug("u[$u]") if $CPAN::DEBUG; if (UNIVERSAL::can($u,"text")) { @@ -219,19 +223,19 @@ sub ftp_get { $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]); unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) { my $msg = $ftp->message; - $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg"); + $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg\n"); return; } unless ( $ftp->cwd($dir) ) { my $msg = $ftp->message; - $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg"); + $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg\n"); return; } $ftp->binary; $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; unless ( $ftp->get($file,$target) ) { my $msg = $ftp->message; - $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg"); + $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg\n"); return; } $ftp->quit; # it's ok if this fails @@ -268,9 +272,9 @@ sub ftp_get { #-> sub CPAN::FTP::localize ; sub localize { - my($self,$file,$aslocal,$force) = @_; + my($self,$file,$aslocal,$force,$with_defaults) = @_; $force ||= 0; - Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,$force])" ) + Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" ) unless defined $aslocal; if ($CPAN::DEBUG){ require Carp; @@ -346,7 +350,7 @@ sub localize { # Try the list of urls for each single object. We keep a record # where we did get a file from my(@reordered,$last); - my $ccurllist = $self->_get_urllist; + my $ccurllist = $self->_get_urllist($with_defaults); $last = $#$ccurllist; if ($force & 2) { # local cpans probably out of date, don't reorder @reordered = (0..$last); @@ -398,7 +402,7 @@ sub localize { my $level_tuple = $levels[$levelno]; my($level,$scheme,$sitetag) = @$level_tuple; $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme; - my $defaultsites = $sitetag && $sitetag eq "defaultsites"; + my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist; my @urllist; if ($defaultsites) { unless (defined $connect_to_internet_ok) { @@ -427,14 +431,14 @@ I would like to connect to one of the following sites to get '%s': require CPAN::Exception::blocked_urllist; die CPAN::Exception::blocked_urllist->new; } - } else { + } else { # ! $defaultsites my @host_seq = $level =~ /dleasy/ ? @reordered : 0..$last; # reordered has file and $Thesiteurl first @urllist = map { $ccurllist->[$_] } @host_seq; } $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG; my $aslocal_tempfile = $aslocal . ".tmp" . $$; - if (my $recommend = $self->_recommend_url_for($file)) { + if (my $recommend = $self->_recommend_url_for($file,\@urllist)) { @urllist = grep { $_ ne $recommend } @urllist; unshift @urllist, $recommend; } @@ -450,6 +454,10 @@ I would like to connect to one of the following sites to get '%s': "'$ret' to '$aslocal': $!"); $ret = $aslocal; } + elsif (-f $ret && $scheme eq 'file' ) { + # it's a local file, so there's nothing left to do, we + # let them read from where it is + } $Themethod = $level; my $now = time; # utime $now, $now, $aslocal; # too bad, if we do that, we @@ -490,7 +498,7 @@ I would like to connect to one of the following sites to get '%s': if ($maybe_restore) { rename "$aslocal.bak$$", $aslocal; $CPAN::Frontend->myprint("Trying to get away with old file:\n" . - $self->ls($aslocal)); + $self->ls($aslocal) . "\n"); return $aslocal; } return; @@ -536,7 +544,7 @@ sub hostdleasy { #called from hostdlxxx my $l; if ($CPAN::META->has_inst('URI::URL')) { my $u = URI::URL->new($url); - $l = $u->dir; + $l = $u->file; } else { # works only on Unix, is poorly constructed, but # hopefully better than nothing. # RFC 1738 says fileurl BNF is @@ -555,29 +563,53 @@ sub hostdleasy { #called from hostdlxxx $ThesiteURL = $ro_url; return $l; } + # 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$/) { my $ungz = $1; if ( -f $ungz && -r _) { $ThesiteURL = $ro_url; return $ungz; } + else { + eval { CPAN::Tarzip->new($l)->gunzip($aslocal) }; + if ( -f $aslocal) { + $ThesiteURL = $ro_url; + return $aslocal; + } + else { + $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n") + if $@; + return; + } + } } - # Maybe mirror has compressed it? - if (-f "$l.gz") { + # Otherwise, return the local file path if it exists + elsif ( -f $l && -r _) { + $ThesiteURL = $ro_url; + return $l; + } + # If we can't find it, but there is a compressed version + # of it, then decompress it + elsif (-f "$l.gz") { $self->debug("found compressed $l.gz") if $CPAN::DEBUG; eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) }; if ( -f $aslocal) { $ThesiteURL = $ro_url; return $aslocal; } + else { + $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n") + if $@; + return; + } } $CPAN::Frontend->mywarn("Could not find '$l'\n"); } $self->debug("it was not a file URL") if $CPAN::DEBUG; if ($CPAN::META->has_usable('LWP')) { - $CPAN::Frontend->myprint("Fetching with LWP: - $url -"); + $CPAN::Frontend->myprint("Fetching with LWP:\n$url\n"); unless ($Ua) { CPAN::LWP::UserAgent->config; eval { $Ua = CPAN::LWP::UserAgent->new; }; @@ -595,9 +627,7 @@ sub hostdleasy { #called from hostdlxxx return $aslocal; } elsif ($url !~ /\.gz(?!\n)\Z/) { my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint("Fetching with LWP: - $gzurl -"); + $CPAN::Frontend->myprint("Fetching with LWP:\n$gzurl\n"); $res = $Ua->mirror($gzurl, "$aslocal.gz"); if ($res->is_success) { if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) { @@ -625,9 +655,7 @@ sub hostdleasy { #called from hostdlxxx my($host,$dir,$getfile) = ($1,$2,$3); if ($CPAN::META->has_usable('Net::FTP')) { $dir =~ s|/+|/|g; - $CPAN::Frontend->myprint("Fetching with Net::FTP: - $url -"); + $CPAN::Frontend->myprint("Fetching with Net::FTP:\n$url\n"); $self->debug("getfile[$getfile]dir[$dir]host[$host]" . "aslocal[$aslocal]") if $CPAN::DEBUG; if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { @@ -636,9 +664,7 @@ sub hostdleasy { #called from hostdlxxx } if ($aslocal !~ /\.gz(?!\n)\Z/) { my $gz = "$aslocal.gz"; - $CPAN::Frontend->myprint("Fetching with Net::FTP - $url.gz -"); + $CPAN::Frontend->myprint("Fetching with Net::FTP\n$url.gz\n"); if (CPAN::FTP->ftp_get($host, $dir, "$getfile.gz", @@ -682,6 +708,7 @@ sub hostdlhard { my($aslocal_dir) = dirname($aslocal); mkpath($aslocal_dir); my $some_dl_success = 0; + my $any_attempt = 0; HOSTHARD: for $ro_url (@$host_seq) { $self->_set_attempt($stats,"dlhard",$ro_url); my $url = "$ro_url$file"; @@ -699,6 +726,9 @@ sub hostdlhard { next HOSTHARD if $proto eq "file"; # file URLs would have had # success above. Likely a bogus URL + # making at least one attempt against a host + $any_attempt++; + $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; # Try the most capable first and leave ncftp* for last as it only @@ -830,12 +860,12 @@ No success, the file that lynx has downloaded is an empty file. return if $CPAN::Signal; } # download/transfer programs (DLPRG) } # host + return unless $any_attempt; if ($some_dl_success) { - $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed."); + $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n"); } else { - $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it."); + $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n"); } - $CPAN::Frontend->mysleep(5); return; } diff --git a/cpan/CPAN/lib/CPAN/FirstTime.pm b/cpan/CPAN/lib/CPAN/FirstTime.pm index 606455f35e..cf6dbb84fc 100644 --- a/cpan/CPAN/lib/CPAN/FirstTime.pm +++ b/cpan/CPAN/lib/CPAN/FirstTime.pm @@ -1,15 +1,4 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -package CPAN::Mirrored::By; -use strict; - -sub new { - my($self,@arg) = @_; - bless [@arg], $self; -} -sub continent { shift->[0] } -sub country { shift->[1] } -sub url { shift->[2] } - package CPAN::FirstTime; use strict; @@ -18,7 +7,8 @@ use FileHandle (); use File::Basename (); use File::Path (); use File::Spec (); -use vars qw($VERSION $urllist); +use CPAN::Mirrors (); +use vars qw($VERSION $silent); $VERSION = "5.53"; =head1 NAME @@ -540,6 +530,16 @@ memory consumption of CPAN.pm considerably. Use CPAN::SQLite if available? (yes/no)? +=item version_timeout + +This timeout prevents CPAN from hanging when trying to parse a +pathologically coded $VERSION from a module. + +The default is 15 seconds. If you set this value to 0, no timeout +will occur, but this is not recommended. + +Timeout for parsing module versions? + =item yaml_load_code Both YAML.pm and YAML::Syck are capable of deserialising code. As this @@ -576,7 +576,6 @@ use vars qw( %prompts ); my @prompts = ( manual_config => qq[ - CPAN is the world-wide archive of perl resources. It consists of about 300 sites that all replicate the same contents around the globe. Many countries have at least one CPAN site already. The resources found on @@ -589,8 +588,14 @@ If you prefer to enter a dialog instead, you can answer 'no' to this question and I'll let you configure in small steps one thing after the other. (Note: you can revisit this dialog anytime later by typing 'o conf init' at the cpan prompt.) + ], +auto_pick => qq{ +Would you like me to automatically choose the best CPAN mirror +sites for you? (This means connecting to the Internet and could +take a couple minutes)}, + config_intro => qq{ The following questions are intended to help you with the @@ -643,13 +648,12 @@ session. }, urls_intro => qq{ +Now you need to choose your CPAN mirror sites. You can let me +pick mirrors for you, you can select them from a list or you +can enter them by hand. +}, -Now we need to know where your favorite CPAN sites are located. Push -a few sites onto the array (just in case the first on the array won\'t -work). If you are mirroring CPAN to your local workstation, specify a -file: URL. - -First, pick a nearby continent and country by typing in the number(s) +urls_picker_intro => qq{First, pick a nearby continent and country by typing in the number(s) in front of the item(s) you want to select. You can pick several of each, separated by spaces. Then, you will be presented with a list of URLs of CPAN mirrors in the countries you selected, along with @@ -657,6 +661,8 @@ previously selected URLs. Select some of those URLs, or just keep the old list. Finally, you will be prompted for any extra URLs -- file:, ftp:, or http: -- that host a CPAN mirror. +You should select more than one (just in case the first isn't available). + }, password_warn => qq{ @@ -770,6 +776,7 @@ sub init { $fastread = 0; } else { $fastread = 1; + $silent = 1; $CPAN::Config->{urllist} ||= []; $CPAN::Config->{connect_to_internet_ok} ||= 1; @@ -778,31 +785,8 @@ sub init { my $current_second = time; my $current_second_count = 0; my $i_am_mad = 0; - *_real_prompt = sub { - my($q,$a) = @_; - my($ret) = defined $a ? $a : ""; - $CPAN::Frontend->myprint(sprintf qq{%s [%s]\n\n}, $q, $ret); - eval { require Time::HiRes }; - unless ($@) { - if (time == $current_second) { - $current_second_count++; - if ($current_second_count > 20) { - # I don't like more than 20 prompts per second - $i_am_mad++; - } - } else { - $current_second = time; - $current_second_count = 0; - $i_am_mad-- if $i_am_mad>0; - } - if ($i_am_mad>0) { - #require Carp; - #Carp::cluck("SLEEEEEEEEPIIIIIIIIIIINGGGGGGGGGGG"); - Time::HiRes::sleep(0.1); - } - } - $ret; - }; + # silent prompting -- just quietly use default + *_real_prompt = sub { return $_[1] }; } } @@ -813,7 +797,7 @@ sub init { keep_source_where prefs_dir } =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{config_intro}); + $CPAN::Frontend->myprint($prompts{config_intro}) unless $silent; init_cpan_home($matcher); @@ -877,9 +861,14 @@ sub init { $CPAN::META->has_inst("CPAN::Reporter") && CPAN::Reporter->can('configure') ) { - $CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n"); - CPAN::Reporter::configure(); - $CPAN::Frontend->myprint("\nReturning to CPAN configuration.\n"); + local *_real_prompt; + *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt; + my $_conf = prompt("Would you like me configure CPAN::Reporter now?", $silent ? "no" : "yes"); + if ($_conf =~ /^y/i) { + $CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n"); + CPAN::Reporter::configure(); + $CPAN::Frontend->myprint("\nReturning to CPAN configuration.\n"); + } } } @@ -890,11 +879,14 @@ sub init { # if (!$matcher or "yaml_module" =~ /$matcher/) { my_dflt_prompt(yaml_module => "YAML", $matcher); + my $old_v = $CPAN::Config->{load_module_verbosity}; + $CPAN::Config->{load_module_verbosity} = q[none]; unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module})) { $CPAN::Frontend->mywarn ("Warning (maybe harmless): '$CPAN::Config->{yaml_module}' not installed.\n"); $CPAN::Frontend->mysleep(3); } + $CPAN::Config->{load_module_verbosity} = $old_v; } # @@ -939,7 +931,7 @@ sub init { my_prompt_loop(tar_verbosity => 'v', $matcher, 'none|v|vv'); - my_prompt_loop(load_module_verbosity => 'v', $matcher, + my_prompt_loop(load_module_verbosity => 'none', $matcher, 'none|v'); my_prompt_loop(perl5lib_verbosity => 'v', $matcher, 'none|v'); @@ -991,6 +983,7 @@ sub init { # my_dflt_prompt(inactivity_timeout => 0, $matcher); + my_dflt_prompt(version_timeout => 15, $matcher); # #== halt_on_failure @@ -1004,7 +997,7 @@ sub init { my @proxy_vars = qw/ftp_proxy http_proxy no_proxy/; my @proxy_user_vars = qw/proxy_user proxy_pass/; if (!$matcher or "@proxy_vars @proxy_user_vars" =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{proxy_intro}); + $CPAN::Frontend->myprint($prompts{proxy_intro}) unless $silent; for (@proxy_vars) { $prompts{$_} = "Your $_?"; @@ -1016,21 +1009,21 @@ sub init { $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER || ""; - $CPAN::Frontend->myprint($prompts{proxy_user}); + $CPAN::Frontend->myprint($prompts{proxy_user}) unless $silent; if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) { - $CPAN::Frontend->myprint($prompts{proxy_pass}); + $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $silent; if ($CPAN::META->has_inst("Term::ReadKey")) { Term::ReadKey::ReadMode("noecho"); } else { - $CPAN::Frontend->myprint($prompts{password_warn}); + $CPAN::Frontend->myprint($prompts{password_warn}) unless $silent; } $CPAN::Config->{proxy_pass} = prompt_no_strip("Your proxy password?"); if ($CPAN::META->has_inst("Term::ReadKey")) { Term::ReadKey::ReadMode("restore"); } - $CPAN::Frontend->myprint("\n\n"); + $CPAN::Frontend->myprint("\n\n") unless $silent; } } } @@ -1059,25 +1052,25 @@ sub init { 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"; + $CPAN::Frontend->myprint( " on_ on_y ". + " on_ma on_\n") unless $silent; + $CPAN::Frontend->myprint( " on_black on_red green ellow ". + "on_blue genta on_cyan white\n") unless $silent; for my $FG ("", "bold", map {$_,"bold $_"} "black","red","green", "yellow","blue", "magenta", "cyan","white") { - printf "%12s ", $FG; + $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $silent; for my $BG ("",map {"on_$_"} qw(black red green yellow blue magenta cyan white)) { - print $FG||$BG ? - Term::ANSIColor::colored(" $T ","$FG $BG") : " $T "; + $CPAN::Frontend->myprint( $FG||$BG ? + Term::ANSIColor::colored(" $T ","$FG $BG") : " $T ") unless $silent; } - print "\n"; + $CPAN::Frontend->myprint( "\n" ) unless $silent; } - print "\n"; + $CPAN::Frontend->myprint( "\n" ) unless $silent; } for my $tuple ( ["colorize_print", "bold blue on_white"], @@ -1107,7 +1100,7 @@ sub init { # if (!$matcher or 'histfile histsize' =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{histfile_intro}); + $CPAN::Frontend->myprint($prompts{histfile_intro}) unless $silent; defined($default = $CPAN::Config->{histfile}) or $default = File::Spec->catfile($CPAN::Config->{cpan_home},"histfile"); my_dflt_prompt(histfile => $default, $matcher); @@ -1142,13 +1135,31 @@ sub init { # remember, this is only triggered if no urllist is given, so 0 is # fair and protects the default site from being overloaded and # gives the user more chances to select his own urllist. - my_yn_prompt("connect_to_internet_ok" => 0, $matcher); + my_yn_prompt("connect_to_internet_ok" => $fastread ? 1 : 0, $matcher); + $CPAN::Config->{urllist} ||= []; if ($matcher) { if ("urllist" =~ $matcher) { + $CPAN::Frontend->myprint($prompts{urls_intro}); + # conf_sites would go into endless loop with the smash prompt local *_real_prompt; *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt; - conf_sites(); + my $_conf = prompt($prompts{auto_pick}, "yes"); + + if ( $_conf =~ /^y/i ) { + conf_sites( auto_pick => 1 ) or bring_your_own(); + } + else { + my $_conf = prompt( + "Would you like to pick from the CPAN mirror list?", "yes" + ); + + if ( $_conf =~ /^y/i ) { + conf_sites(); + } + bring_your_own(); + } + _print_urllist(); } if ("randomize_urllist" =~ $matcher) { my_dflt_prompt(randomize_urllist => 0, $matcher); @@ -1160,17 +1171,49 @@ sub init { my_dflt_prompt(ftpstats_period => 14, $matcher); } } elsif ($fastread) { - $CPAN::Frontend->myprint("Autoconfigured everything but 'urllist'.\n". - "Please call 'o conf init urllist' to configure ". - "your CPAN server(s) now!\n\n"); - } else { - conf_sites(); + $silent = 0; + local *_real_prompt; + *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt; + if ( @{ $CPAN::Config->{urllist} } ) { + $CPAN::Frontend->myprint( + "\nYour 'urllist' is already configured. Type 'o conf init urllist' to change it.\n" + ); + } + else { + $CPAN::Frontend->myprint( + "Autoconfigured everything but 'urllist'.\n" + ); + + $CPAN::Frontend->myprint($prompts{urls_intro}); + + my $_conf = prompt($prompts{auto_pick}, "yes"); + + if ( $_conf =~ /^y/i ) { + conf_sites( auto_pick => 1 ) or bring_your_own(); + } + else { + my $_conf = prompt( + "Would you like to pick from the CPAN mirror list?", "yes" + ); + + if ( $_conf =~ /^y/i ) { + conf_sites(); + } + bring_your_own(); + } + _print_urllist(); + } + $CPAN::Frontend->myprint( + "\nAutoconfiguration complete.\n" + ); } - $CPAN::Frontend->myprint("\n\n"); + $silent = 0; # reset + + $CPAN::Frontend->myprint("\n"); if ($matcher && !$CPAN::Config->{auto_commit}) { $CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ". - "make the config permanent!\n\n"); + "make the config permanent!\n"); } else { CPAN::HandleConfig->commit($configpm); } @@ -1189,7 +1232,7 @@ sub _init_external_progs { patch applypatch /; if (!$matcher or "@external_progs" =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{external_progs}); + $CPAN::Frontend->myprint($prompts{external_progs}) unless $silent; my $old_warn = $^W; local $^W if $^O eq 'MacOS'; @@ -1230,7 +1273,7 @@ sub _init_external_progs { $path ||= find_exe($progcall,$PATH); unless ($path) { # not -e $path, because find_exe already checked that local $"=";"; - $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n"); + $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n") unless $silent; if ($progname eq "make") { $CPAN::Frontend->mywarn("ALERT: 'make' is an essential tool for ". "building perl Modules. Please make sure you ". @@ -1272,18 +1315,17 @@ I see you already have a directory $cpan_home Shall we use it as the general CPAN build and cache directory? -}); +}) unless $silent; } else { # no cpan-home, must prompt and get one - $CPAN::Frontend->myprint($prompts{cpan_home_where}); + $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $silent; } my $default = $cpan_home; my $loop = 0; my($last_ans,$ans); - $CPAN::Frontend->myprint(" <cpan_home>\n"); + $CPAN::Frontend->myprint(" <cpan_home>\n") unless $silent; PROMPT: while ($ans = prompt("CPAN build and cache directory?",$default)) { - print "\n"; if (File::Spec->file_name_is_absolute($ans)) { my @cpan_home = split /[\/\\]/, $ans; DIR: for my $dir (@cpan_home) { @@ -1330,13 +1372,12 @@ sub my_dflt_prompt { my ($item, $dflt, $m) = @_; my $default = $CPAN::Config->{$item} || $dflt; - if (!$m || $item =~ /$m/) { + if (!$silent && (!$m || $item =~ /$m/)) { if (my $intro = $prompts{$item . "_intro"}) { $CPAN::Frontend->myprint($intro); } $CPAN::Frontend->myprint(" <$item>\n"); $CPAN::Config->{$item} = prompt($prompts{$item}, $default); - print "\n"; } else { $CPAN::Config->{$item} = $default; } @@ -1348,14 +1389,13 @@ sub my_yn_prompt { defined($default = $CPAN::Config->{$item}) or $default = $dflt; # $DB::single = 1; - if (!$m || $item =~ /$m/) { + if (!$silent && (!$m || $item =~ /$m/)) { if (my $intro = $prompts{$item . "_intro"}) { $CPAN::Frontend->myprint($intro); } $CPAN::Frontend->myprint(" <$item>\n"); my $ans = prompt($prompts{$item}, $default ? 'yes' : 'no'); $CPAN::Config->{$item} = ($ans =~ /^[y1]/i ? 1 : 0); - print "\n"; } else { $CPAN::Config->{$item} = $default; } @@ -1366,108 +1406,117 @@ sub my_prompt_loop { my $default = $CPAN::Config->{$item} || $dflt; my $ans; - if (!$m || $item =~ /$m/) { + if (!$silent && (!$m || $item =~ /$m/)) { $CPAN::Frontend->myprint($prompts{$item . "_intro"}); $CPAN::Frontend->myprint(" <$item>\n"); do { $ans = prompt($prompts{$item}, $default); } until $ans =~ /$ok/; $CPAN::Config->{$item} = $ans; - print "\n"; } else { $CPAN::Config->{$item} = $default; } } +# Here's the logic about the MIRRORED.BY file. There are a number of scenarios: +# (1) We have a cached MIRRORED.BY file +# (1a) We're auto-picking +# - Refresh it automatically if it's old +# (1b) Otherwise, ask if using cached is ok. If old, default to no. +# - If cached is not ok, get it from the Internet. If it succeeds we use +# the new file. Otherwise, we use the old file. +# (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, + sub conf_sites { + my %args = @_; + # auto pick implies using the internet + $CPAN::Config->{connect_to_internet_ok} = 1 if $args{auto_pick}; + my $m = 'MIRRORED.BY'; - my $use_mby; my $mby = File::Spec->catfile($CPAN::Config->{keep_source_where},$m); File::Path::mkpath(File::Basename::dirname($mby)); + # Why are we using MIRRORED.BY from the current directory? + # Is this for testing? -- dagolden, 2009-11-05 if (-f $mby && -f $m && -M $m < -M $mby) { - $use_mby = 1; require File::Copy; File::Copy::copy($m,$mby) or die "Could not update $mby: $!"; } local $^T = time; - my $overwrite_local = 0; - if ($mby && -f $mby && -M _ <= 60 && -s _ > 0) { - $use_mby = 1; - my $mtime = localtime((stat _)[9]); - my $prompt = qq{Found $mby as of $mtime - -I'd use that as a database of CPAN sites. If that is OK for you, -please answer 'y', but if you want me to get a new database from the -internet now, please answer 'n' to the following question. - -Shall I use the local database in $mby?}; - my $ans = prompt($prompt,"y"); - if ($ans =~ /^y/i) { - $CPAN::Config->{connect_to_internet_ok} = 1; - } else { - $overwrite_local = 1; + # if we have a cached copy is not older than 60 days, we either + # use it or refresh it or fall back to it if the refresh failed. + if ($mby && -f $mby && -s _ > 0 ) { + my $very_old = (-M $mby > 60); + my $mtime = localtime((stat _)[9]); + # if auto_pick, refresh anything old automatically + if ( $args{auto_pick} ) { + if ( $very_old ) { + $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n}); + eval { CPAN::FTP->localize($m,$mby,3,1) } + or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n}); + $CPAN::Frontend->myprint("\n"); } - } - local $urllist = $CPAN::Config->{urllist}; - my $better_mby; - LOOP: while () { # multiple errors possible - if ($use_mby - or (defined $CPAN::Config->{connect_to_internet_ok} - and $CPAN::Config->{connect_to_internet_ok})){ - if ($overwrite_local) { - $CPAN::Frontend->myprint(qq{Trying to overwrite $mby\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $overwrite_local = 0; - $use_mby=1 if $mby; - } elsif ( ! -f $mby ) { - $CPAN::Frontend->myprint(qq{You have no $mby\n I'm trying to fetch one\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $use_mby=1 if $mby; - } elsif ( -M $mby > 60 ) { - $CPAN::Frontend->myprint(qq{Your $mby is older than 60 days,\n I'm trying }. - qq{to fetch a new one\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $use_mby=1 if $mby; - } elsif (-s $mby == 0) { - $CPAN::Frontend->myprint(qq{You have an empty $mby,\n I'm trying to fetch a better one\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $use_mby=1 if $mby; - } else { - last LOOP; - } - if ($better_mby) { - $mby = $better_mby; - } - } elsif (not @{$urllist||[]} - and (not defined $CPAN::Config->{connect_to_internet_ok} - or not $CPAN::Config->{connect_to_internet_ok})) { - $CPAN::Frontend->myprint(qq{CPAN needs access to at least one CPAN mirror. - -As you did not allow me to connect to the internet you need to supply -a valid CPAN URL now.\n\n}); - - my @default = map {"file://$_"} grep {-e} "/home/ftp/pub/CPAN", "/home/ftp/pub/PAUSE"; - my $ans = prompt("Please enter the URL of your CPAN mirror",shift @default); - if ($ans) { - push @$urllist, $ans; - next LOOP; - } - } else { - last LOOP; + } + else { + my $prompt = qq{Found a cached mirror list as of $mtime + +If you'd like to just use the cached copy, answer 'yes', below. +If you'd like an updated copy of the mirror list, answer 'no' and +I'll get a fresh one from the Internet. + +Shall I use the cached mirror list?}; + my $ans = prompt($prompt, $very_old ? "no" : "yes"); + if ($ans =~ /^n/i) { + $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n}); + # you asked for it from the Internet + $CPAN::Config->{connect_to_internet_ok} = 1; + eval { CPAN::FTP->localize($m,$mby,3,1) } + or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n}); + $CPAN::Frontend->myprint("\n"); } + } } - if ($use_mby){ - read_mirrored_by($mby); - } else { - if (not defined $CPAN::Config->{connect_to_internet_ok} - or not $CPAN::Config->{connect_to_internet_ok}) { - $CPAN::Frontend->myprint("Configuration does not allow connecting to the internet.\n"); + # else there is no cached copy and we must fetch or fail + else { + # If they haven't agree to connect to the internet, ask again + if ( ! $CPAN::Config->{connect_to_internet_ok} ) { + my $prompt = q{You are missing a copy of the CPAN mirror list. + +May I connect to the Internet to get it?}; + my $ans = prompt($prompt, "yes"); + if ($ans =~ /^y/i) { + $CPAN::Config->{connect_to_internet_ok} = 1; } - $CPAN::Frontend->myprint("Current set of CPAN URLs:\n"); - map { $CPAN::Frontend->myprint(" $_\n") } @$urllist; + } + + # Now get it from the Internet or complain + if ( $CPAN::Config->{connect_to_internet_ok} ) { + $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n}); + eval { CPAN::FTP->localize($m,$mby,3,1) } + or $CPAN::Frontend->mywarn(<<'HERE'); +We failed to get a copy of the mirror list from the Internet. +You will need to provide CPAN mirror URLs yourself. +HERE + $CPAN::Frontend->myprint("\n"); + } + else { + $CPAN::Frontend->mywarn(<<'HERE'); +You will need to provide CPAN mirror URLs yourself or set +'o conf connect_to_internet_ok 1' and try again. +HERE + } } - bring_your_own(); - $CPAN::Config->{urllist} = $urllist; + + # if we finally have a good local MIRRORED.BY, get on with picking + if (-f $mby && -s _ > 0){ + $CPAN::Config->{urllist} = + $args{auto_pick} ? auto_mirrored_by($mby) : choose_mirrored_by($mby); + return 1; + } + + return; } sub find_exe { @@ -1523,7 +1572,6 @@ sub picklist { if ($require_nonempty && !@nums) { $CPAN::Frontend->mywarn("$empty_warning\n"); } - $CPAN::Frontend->myprint("\n"); # a blank line continues... unless (@nums){ @@ -1569,38 +1617,35 @@ sub display_some { return $pos; } -sub read_mirrored_by { +sub auto_mirrored_by { my $local = shift or return; - my(%all,$url,$expected_size,$default,$ans,$host, - $dst,$country,$continent,@location); - my $fh = FileHandle->new; - $fh->open($local) or die "Couldn't open $local: $!"; - local $/ = "\012"; - while (<$fh>) { - ($host) = /^([\w\.\-]+)/ unless defined $host; - next unless defined $host; - next unless /\s+dst_(dst|location)/; - /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and - ($continent, $country) = @location[-1,-2]; - $continent =~ s/\s\(.*//; - $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude - /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1; - next unless $host && $dst && $continent && $country; - $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst); - undef $host; - $dst=$continent=$country=""; - } - $fh->close; - $CPAN::Config->{urllist} ||= []; + local $|=1; + $CPAN::Frontend->myprint("Searching for the best CPAN mirrors (please be patient) ..."); + my $mirrors = CPAN::Mirrors->new($local); + my $cnt = 0; + my @best = $mirrors->best_mirrors( + how_many => 5, + callback => sub { $CPAN::Frontend->myprint(".") }, + ); + my $urllist = [ map { $_->url } @best ]; + push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}}; + $CPAN::Frontend->myprint(" done!\n\n"); + return $urllist; +} + +sub choose_mirrored_by { + my $local = shift or return; + my ($default); + my $mirrors = CPAN::Mirrors->new($local); my @previous_urls = @{$CPAN::Config->{urllist}}; - $CPAN::Frontend->myprint($prompts{urls_intro}); + $CPAN::Frontend->myprint($prompts{urls_picker_intro}); my (@cont, $cont, %cont, @countries, @urls, %seen); my $no_previous_warn = "Sorry! since you don't have any existing picks, you must make a\n" . "geographic selection."; - my $offer_cont = [sort keys %all]; + my $offer_cont = [sort $mirrors->continents]; if (@previous_urls) { push @$offer_cont, "(edit previous picks)"; $default = @$offer_cont; @@ -1617,7 +1662,7 @@ sub read_mirrored_by { # return unless @cont; foreach $cont (@cont) { - my @c = sort keys %{$all{$cont}}; + my @c = sort $mirrors->countries($cont); @cont{@c} = map ($cont, 0..$#c); @c = map ("$_ ($cont)", @c) if @cont > 1; push (@countries, @c); @@ -1635,14 +1680,18 @@ sub read_mirrored_by { $no_previous_warn); %seen = map (($_ => 1), @previous_urls); # hmmm, should take list of defaults from CPAN::Config->{'urllist'}... - foreach $country (@countries) { + foreach my $country (@countries) { next if $country =~ /edit previous picks/; (my $bare_country = $country) =~ s/ \(.*\)//; - my @u = sort keys %{$all{$cont{$bare_country}}{$bare_country}}; + my @u; + for my $m ( $mirrors->mirrors($bare_country) ) { + push @u, $m->ftp if $m->ftp; + push @u, $m->http if $m->http; + } @u = grep (! $seen{$_}, @u); @u = map ("$_ ($bare_country)", @u) if @countries > 1; - push (@urls, @u); + push (@urls, sort @u); } } push (@urls, map ("$_ (previous pick)", @previous_urls)); @@ -1657,17 +1706,20 @@ put them on one line, separated by blanks, hyphenated ranges allowed @urls = picklist (\@urls, $prompt, $default); foreach (@urls) { s/ \(.*\)//; } - if (@urls) { - $urllist = \@urls; - } else { - push @$urllist, @urls; - } + return [ @urls ]; } sub bring_your_own { + my $urllist = [ @{$CPAN::Config->{urllist}} ]; my %seen = map (($_ => 1), @$urllist); my($ans,@urls); my $eacnt = 0; # empty answers + $CPAN::Frontend->myprint(<<'HERE'); + +Now you can enter your own CPAN URLs by hand. A local CPAN mirror can be +listed using a 'file:' URL like 'file:///path/to/cpan/' + +HERE do { my $prompt = "Enter another URL or RETURN to quit:"; unless (%seen) { @@ -1679,6 +1731,9 @@ Please enter your CPAN site:}; if ($ans) { $ans =~ s|/?\z|/|; # has to end with one slash + # XXX This manipulation is odd. Shouldn't we check that $ans is + # a directory before converting to file:///? And we need /// below, + # too, don't we? -- dagolden, 2009-11-05 $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: if ($ans =~ /^\w+:\/./) { push @urls, $ans unless $seen{$ans}++; @@ -1706,11 +1761,14 @@ 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 urllist\n"); - for ( @$urllist ) { $CPAN::Frontend->myprint(" $_\n") }; } +sub _print_urllist { + $CPAN::Frontend->myprint("New urllist\n"); + for ( @{$CPAN::Config->{urllist} || []} ) { + $CPAN::Frontend->myprint(" $_\n") + }; +} sub _strip_spaces { $_[0] =~ s/^\s+//; # no leading spaces @@ -1724,6 +1782,7 @@ sub prompt ($;$) { my $ans = _real_prompt(@_); _strip_spaces($ans); + $CPAN::Frontend->myprint("\n"); return $ans; } diff --git a/cpan/CPAN/lib/CPAN/HandleConfig.pm b/cpan/CPAN/lib/CPAN/HandleConfig.pm index 87461913ac..6a134bd755 100644 --- a/cpan/CPAN/lib/CPAN/HandleConfig.pm +++ b/cpan/CPAN/lib/CPAN/HandleConfig.pm @@ -99,6 +99,7 @@ $VERSION = "5.5"; "urllist", "use_sqlite", "username", + "version_timeout", "wait_list", "wget", "yaml_load_code", diff --git a/cpan/CPAN/lib/CPAN/Mirrors.pm b/cpan/CPAN/lib/CPAN/Mirrors.pm new file mode 100644 index 0000000000..2a2de35ce0 --- /dev/null +++ b/cpan/CPAN/lib/CPAN/Mirrors.pm @@ -0,0 +1,259 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- +# vim: ts=4 sts=4 sw=4: +package CPAN::Mirrors; +use strict; +use vars qw($VERSION $urllist $silent); +$VERSION = "1.77"; + +use Carp; +use FileHandle; +use Fcntl ":flock"; + +sub new { + my ($class, $file) = @_; + my $self = bless { + mirrors => [], + geography => {}, + }, $class; + + my $handle = FileHandle->new; + $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 + + return $self +} + +sub continents { + my ($self) = @_; + return keys %{$self->{geography}}; +} + +sub countries { + my ($self, @continents) = @_; + @continents = $self->continents unless @continents; + my @countries; + for my $c (@continents) { + push @countries, keys %{ $self->{geography}{$c} }; + } + return @countries; +} + +sub mirrors { + my ($self, @countries) = @_; + return @{$self->{mirrors}} unless @countries; + my %wanted = map { $_ => 1 } @countries; + my @found; + for my $m (@{$self->{mirrors}}) { + push @found, $m if exists $wanted{$m->country}; + } + return @found; +} + +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 $seen = {}; + + if ( ! @$conts ) { + print "Searching for the best continent ...\n" if $verbose; + my @best = $self->_find_best_continent($seen, $verbose, $callback); + + # how many continents to find enough mirrors? We should scan + # more than we need -- arbitrarily, we'll say x2 + my $count = 0; + for my $c ( @best ) { + push @$conts, $c; + $count += $self->mirrors( $self->countries($c) ); + last if $count >= 2 * $how_many; + } + } + + print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose; + + my @timings; + for my $m ($self->mirrors($self->countries(@$conts))) { + my $hostname = $m->hostname; + if ( $seen->{$hostname} ) { + push @timings, $seen->{$hostname} + if defined $seen->{$hostname}[1]; + } + else { + my $ping = $m->ping; + next unless defined $ping; + push @timings, [$m, $ping]; + $callback->($m,$ping) if $callback; + } + } + 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]; +} + +sub _find_best_continent { + my ($self, $seen, $verbose, $callback) = @_; + + my %median; + CONT: for my $c ( $self->continents ) { + my @mirrors = $self->mirrors( $self->countries($c) ); + next CONT unless @mirrors; + my $sample = 9; + my $n = (@mirrors < $sample) ? @mirrors : $sample; + my @tests; + RANDOM: while ( @mirrors && @tests < $n ) { + 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; + } + } + + my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ; + + if ( $verbose ) { + print "Median result by continent:\n"; + for my $c ( @best_cont ) { + printf( " %d ms %s\n", int($median{$c}*1000+.5), $c ); + } + } + + return wantarray ? @best_cont : $best_cont[0]; +} + +# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy +sub _parse { + my ($self, $file, $handle) = @_; + my $output = $self->{mirrors}; + my $geo = $self->{geography}; + + local $/ = "\012"; + my $line = 0; + my $mirror = undef; + while ( 1 ) { + # Next line + my $string = <$handle>; + last if ! defined $string; + $line = $line + 1; + + # Remove the useless lines + chomp( $string ); + next if $string =~ /^\s*$/; + next if $string =~ /^\s*#/; + + # Hostname or property? + if ( $string =~ /^\s/ ) { + # Property + unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) { + croak("Invalid property on line $line"); + } + my ($prop, $value) = ($1,$2); + $mirror ||= {}; + if ( $prop eq 'dst_location' ) { + my (@location,$continent,$country); + @location = (split /\s*,\s*/, $value) + and ($continent, $country) = @location[-1,-2]; + $continent =~ s/\s\(.*//; + $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude + $geo->{$continent}{$country} = 1 if $continent && $country; + $mirror->{continent} = $continent || "unknown"; + $mirror->{country} = $country || "unknown"; + } + elsif ( $prop eq 'dst_http' ) { + $mirror->{http} = $value; + } + elsif ( $prop eq 'dst_ftp' ) { + $mirror->{ftp} = $value; + } + elsif ( $prop eq 'dst_rsync' ) { + $mirror->{rsync} = $value; + } + else { + $prop =~ s/^dst_//; + $mirror->{$prop} = $value; + } + } else { + # Hostname + unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) { + croak("Invalid host name on line $line"); + } + my $current = $mirror; + $mirror = { hostname => "$1" }; + if ( $current ) { + push @$output, CPAN::Mirrored::By->new($current); + } + } + } + if ( $mirror ) { + push @$output, CPAN::Mirrored::By->new($mirror); + } + + return; +} + +#--------------------------------------------------------------------------# + +package CPAN::Mirrored::By; +use strict; +use Net::Ping (); + +sub new { + my($self,$arg) = @_; + $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 { + 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; + $ping->port_number($port); + $ping->hires(1); + my ($alive,$rtt) = $ping->ping($self->hostname); + return $alive ? $rtt : undef; +} + + +1; + diff --git a/cpan/CPAN/lib/CPAN/Module.pm b/cpan/CPAN/lib/CPAN/Module.pm index 56e477f64f..43c42bf104 100644 --- a/cpan/CPAN/lib/CPAN/Module.pm +++ b/cpan/CPAN/lib/CPAN/Module.pm @@ -508,37 +508,34 @@ sub test { $self->rematein('test',@_); } +#-> sub CPAN::Module::deprecated_in_core ; +sub deprecated_in_core { + my ($self) = @_; + return unless $CPAN::META->has_inst('Module::CoreList') && Module::CoreList->can('is_deprecated'); + return Module::CoreList::is_deprecated($self->{ID}); +} + +#-> sub CPAN::Module::inst_deprecated; +# Indicates whether the *installed* version of the module is a deprecated *and* +# installed as part of the Perl core library path +sub inst_deprecated { + my ($self) = @_; + my $inst_file = $self->inst_file or return; + return $self->deprecated_in_core && $self->_in_priv_or_arch($inst_file); +} + #-> sub CPAN::Module::uptodate ; sub uptodate { my ($self) = @_; local ($_); - my $inst = $self->inst_version or return undef; + my $inst = $self->inst_version or return 0; my $cpan = $self->cpan_version; - local ($^W) = 0; - CPAN::Version->vgt($cpan,$inst) and return 0; - my $inst_file = $self->inst_file; - # trying to support deprecated.pm by Nicholas 2009-02 - my $in_priv_or_arch = ""; - my $isa_perl = ""; - if ($] >= 5.011) { # probably harmful when distros say INSTALLDIRS=perl? - if (0 == CPAN::Version->vcmp($cpan,$inst)) { - if ($in_priv_or_arch = $self->_in_priv_or_arch($inst_file)) { - if (my $distribution = $self->distribution) { - unless ($isa_perl = $distribution->isa_perl) { - return 0; - } - } - } - } - } + return 0 if CPAN::Version->vgt($cpan,$inst) || $self->inst_deprecated; CPAN->debug (join ("", "returning uptodate. ", - "inst_file[$inst_file]", "cpan[$cpan]inst[$inst]", - "in_priv_or_arch[$in_priv_or_arch]", - "isa_perl[$isa_perl]", )) if $CPAN::DEBUG; return 1; } @@ -657,7 +654,12 @@ sub available_version { #-> sub CPAN::Module::parse_version ; sub parse_version { my($self,$parsefile) = @_; - alarm(10) if ALARM_IMPLEMENTED; + if (ALARM_IMPLEMENTED) { + my $timeout = (exists($CPAN::Config{'version_timeout'})) + ? $CPAN::Config{'version_timeout'} + : 15; + alarm($timeout); + } my $have = eval { local $SIG{ALRM} = sub { die "alarm\n" }; MM->parse_version($parsefile); diff --git a/cpan/CPAN/lib/CPAN/Shell.pm b/cpan/CPAN/lib/CPAN/Shell.pm index 6d6599c114..8efea420fc 100644 --- a/cpan/CPAN/lib/CPAN/Shell.pm +++ b/cpan/CPAN/lib/CPAN/Shell.pm @@ -1229,7 +1229,21 @@ sub autobundle { sub expandany { my($self,$s) = @_; CPAN->debug("s[$s]") if $CPAN::DEBUG; - if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory + my $module_as_path = ""; + if ($s =~ m|(?:\w+/)*\w+\.pm$|) { + $module_as_path = $s; + $module_as_path =~ s/.pm$//; + $module_as_path =~ s|/|::|g; + } + if ($module_as_path) { + if ($module_as_path =~ m|^Bundle::|) { + $self->local_bundles; + return $self->expand('Bundle',$module_as_path); + } else { + return $self->expand('Module',$module_as_path) + if $CPAN::META->exists('CPAN::Module',$module_as_path); + } + } elsif ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory $s = CPAN::Distribution->normalize($s); return $CPAN::META->instance('CPAN::Distribution',$s); # Distributions spring into existence, not expand @@ -1585,6 +1599,8 @@ sub setup_output { # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here sub rematein { my $self = shift; + # this variable was global and disturbed programmers, so localize: + local $CPAN::Distrostatus::something_has_failed_at; my($meth,@some) = @_; my @pragma; while($meth =~ /^(ff?orce|notest)$/) { @@ -1626,10 +1642,22 @@ sub rematein { if (substr($s,-1,1) eq ".") { $obj = CPAN::Shell->expandany($s); } else { - $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". - "not supported.\nRejecting argument '$s'\n"); - $CPAN::Frontend->mysleep(2); - next; + my @obj; + CLASS: for my $class (qw(Distribution Bundle Module)) { + if (@obj = $self->expand($class,$s)) { + last CLASS; + } + } + if (@obj) { + if (1==@obj) { + $obj = $obj[0]; + } else { + $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". + "only supported when unambiguous.\nRejecting argument '$s'\n"); + $CPAN::Frontend->mysleep(2); + next STHING; + } + } } } elsif ($meth eq "ls") { $self->globls($s,\@pragma); diff --git a/cpan/CPAN/lib/CPAN/Tarzip.pm b/cpan/CPAN/lib/CPAN/Tarzip.pm index 17b3cd748d..b97bd20016 100644 --- a/cpan/CPAN/lib/CPAN/Tarzip.pm +++ b/cpan/CPAN/lib/CPAN/Tarzip.pm @@ -14,14 +14,14 @@ $BUGHUNTING ||= 0; # released code must have turned off sub new { my($class,$file) = @_; $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file; - if (0) { - # nonono, we get e.g. 01mailrc.txt uncompressed if only wget is available - $CPAN::Frontend->mydie("file[$file] doesn't match /\\.(bz2|gz|zip|tgz)\$/") - unless $file =~ /\.(bz2|gz|zip|tgz)$/i; - } my $me = { FILE => $file }; + if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) { + $me->{ISCOMPRESSED} = 1; + } else { + $me->{ISCOMPRESSED} = 0; + } if (0) { - } elsif ($file =~ /\.bz2$/i) { + } elsif ($file =~ /\.(?:bz2|tbz)$/i) { unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) { my $bzip2 = _my_which("bzip2"); if ($bzip2) { @@ -114,9 +114,28 @@ sub gtest { defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified"); my $read = $self->{FILE}; my $success; - # After I had reread the documentation in zlib.h, I discovered that - # uncompressed files do not lead to an gzerror (anymore?). - if ( $CPAN::META->has_inst("Compress::Zlib") ) { + if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) { + my($buffer,$len); + $len = 0; + my $gz = Compress::Bzip2::bzopen($read, "rb") + or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n", + $read, + $Compress::Bzip2::bzerrno)); + while ($gz->bzread($buffer) > 0 ) { + $len += length($buffer); + $buffer = ""; + } + my $err = $gz->bzerror; + $success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END(); + if ($len == -s $read) { + $success = 0; + CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG; + } + $gz->gzclose(); + CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG; + } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) { + # After I had reread the documentation in zlib.h, I discovered that + # uncompressed files do not lead to an gzerror (anymore?). my($buffer,$len); $len = 0; my $gz = Compress::Zlib::gzopen($read, "rb") @@ -135,6 +154,8 @@ sub gtest { } $gz->gzclose(); CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG; + } elsif (!$self->{ISCOMPRESSED}) { + $success = 0; } else { my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); $success = 0==system(qq{$command -qdt "$read"}); @@ -155,7 +176,12 @@ sub TIEHANDLE { binmode $fh; $self->{FH} = $fh; $class->debug("via uncompressed FH"); - } elsif ($CPAN::META->has_inst("Compress::Zlib")) { + } elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) { + my $gz = Compress::Bzip2::bzopen($file,"rb") or + $CPAN::Frontend->mydie("Could not bzopen $file"); + $self->{GZ} = $gz; + $class->debug("via Compress::Bzip2"); + } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) { my $gz = Compress::Zlib::gzopen($file,"rb") or $CPAN::Frontend->mydie("Could not gzopen $file"); $self->{GZ} = $gz; @@ -166,7 +192,7 @@ sub TIEHANDLE { my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!"); binmode $fh; $self->{FH} = $fh; - $class->debug("via external gzip"); + $class->debug("via external $gzip"); } $self; } @@ -223,10 +249,11 @@ sub untar { $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it my $extgzip = $self->{UNGZIPPRG} || ""; $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it + if (0) { # makes changing order easier } elsif ($BUGHUNTING) { $prefer=2; - } elsif ($exttar && $extgzip && $file =~ /\.bz2$/i) { + } elsif ($exttar && $extgzip && $file =~ /\.(?:bz2|tbz)$/i) { # until Archive::Tar handles bzip2 $prefer = 1; } elsif ( @@ -237,6 +264,17 @@ sub untar { } elsif ($exttar && $extgzip) { # no modules and not bz2 $prefer = 1; + # but solaris binary tar is a problem + if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) { + $CPAN::Frontend->mywarn(<< 'END_WARN'); + +WARNING: Many CPAN distributions were archived with GNU tar and some of +them may be incompatible with Solaris tar. We respectfully suggest you +configure CPAN to use a GNU tar instead ("o conf init tar") or install +a recent Archive::Tar instead; + +END_WARN + } } else { my $foundtar = $exttar ? "'$exttar'" : "nothing"; my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing"; |