'CPAN' =>
{
'MAINTAINER' => 'andk',
- 'DISTRIBUTION' => 'ANDK/CPAN-1.94_51.tar.gz',
+ 'DISTRIBUTION' => 'ANDK/CPAN-1.94_53.tar.gz',
'FILES' => q[cpan/CPAN],
'EXCLUDED' => [ qr{^distroprefs/},
qr{^inc/Test/},
+2009-12-18 Andreas J. Koenig <andk@cpan.org>
+
+ * release 1.94_53
+
+ * bzip2 support should now be on par with gzip
+
+ * allow Foo/Bar.pm on the commandline to mean Foo::Bar (suggested by
+ c9s)
+
+ * bugfix: quit, exit, and bye did not allow a trailing space
+
+ * address #51018: do not switch to default sites when we have a
+ user-configured urllist (reported by Marc Lehmann)
+
+ * bugfix for programming interface (shell did not suffer from this):
+ localize $CPAN::Distrostatus::something_has_failed_at properly so it
+ gets reset after each command (bug inspection by brian d foy)
+
+ * added lib/App/Cpan.pm from brian d foy and update cpan script to his
+ current version
+
+ * major rewrite of the FirstTime experience for new users (including
+ auto-pick of download sites) (by David Golden)
+
+ * improved support for Perl core module deprecation (by David Golden)
+
+2009-10-15 Andreas J. Koenig <andk@cpan.org>
+
+ * release 1.94_52
+
+ * address #48803: avoid 'unreached' if not following
+ configure_requires (David Golden)
+
+ * solaris tar gets more handholding to avoid solaris tar errors (David
+ Golden)
+
+ * allow calling make/test/install with regexp if unambiguous (Andreas
+ Koenig)
+
+ * new config variable version_timeout used in
+ CPAN::Module::parse_version() (Jerry D. Hedden)
+
+ * streamline first time configuration to be more intuitive and less
+ noisy (David Golden)
+
+ * bugfix: eexpect in mode=anyorder with reuse=1 did not consume the
+ output (Andreas Koenig)
+
+ * now with 355 distroprefs files
+
2009-09-14 Andreas J. Koenig <andk@cpan.org>
* release 1.94_51
require Config;
my $HAVE_MAKE = basename($Config::Config{make}) eq "make"; # file-scoped!
+# storable pref files
@ST_PREFS = qw(
);
# Scalar::Util;
# PathTools-3.16.tar.gz
'File::Temp' => 0, # TJENNESS; requires Test::More;
+ 'Net::Ping' => 0, # SMPETERS;
'Scalar::Util' => 0, # GBARR;
# Scalar-List-Utils-1.18.tar.gz;
'Test::Harness' => 2.62,
$prereq_pm->{'File::HomeDir'} = 0.69;
}
+# if they have one of these we declare it as prereq for better reporting
+for my $interesting_module (qw(
+ Archive::Tar
+ Archive::Zip
+ CPAN::Checksums
+ Compress::Zlib
+ Data::Dumper
+ Digest::SHA
+ ExtUtils::CBuilder
+ File::Copy
+ File::HomeDir
+ File::Spec
+ File::Temp
+ File::Which
+ IO::Compress::Base
+ IO::Zlib
+ Module::Build
+ Net::FTP
+ Parse::CPAN::Meta
+ Scalar::Util
+ Term::ReadKey
+ Term::ReadLine::Perl
+ Test::More
+ Text::Glob
+ Text::ParseWords
+ Text::Wrap
+ YAML
+ YAML::Syck
+ YAML::XS
+ )) {
+ eval "require $interesting_module";
+ if (!$@) {
+ $prereq_pm->{$interesting_module} ||= 0;
+ }
+}
if ($HAVE_FILE_SPEC) {
# import PAUSE public key to user's keychain
require Config;
}
if ($HAVE_FILE_SPEC) {
- unless (-f File::Spec->catdir("t","CPAN","authors","id","A","AN","ANDK","NotInChecksums-0.000.tar.gz")) {
+ my $have_distroprefs = -d "distroprefs";
+ my $have_notinchecksums = -f File::Spec->catdir("t","CPAN","authors","id","A","AN","ANDK","NotInChecksums-0.000.tar.gz");
+ if ($have_distroprefs && !$have_notinchecksums) {
warn <<EOW;
####-Note-for-repository-users-####
$(NOECHO) $(ECHO) 'version ' $(VERSION)
$(NOECHO) $(ECHO) 'release-name ' $(DISTVNAME).tar$(SUFFIX)
-release ::
- /usr/bin/perl -Irelease-lib -S release $(DISTVNAME).tar$(SUFFIX)
- rm -rf $(DISTVNAME)
+release :: disttest
git tag -m 'This is $(VERSION)' "$(VERSION)"
+ ls -l $(DISTVNAME).tar$(SUFFIX)
+ rm -rf $(DISTVNAME)
+ $(NOECHO) $(ECHO) '% lftp pause.perl.org'
+ $(NOECHO) $(ECHO) '> cd incoming'
+ $(NOECHO) $(ECHO) '> put $(DISTVNAME).tar$(SUFFIX)'
+ $(NOECHO) $(ECHO) '> quit'
+ $(NOECHO) $(ECHO) '% git push --tags master'
+
+snapshot : Makefile no_CR META.yml README testdistros all tardist
# 16=Distribution; 32=Bundle; 32768=Queue
depefails:
--- /dev/null
+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
# 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
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;
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
}
}
=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.
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
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
expect: []
- commendline: "echo SKIPPING make"
+ commandline: "echo SKIPPING make"
test:
args: []
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
=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
=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()
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()
=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()
=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()
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)
}
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)};
$CPAN::Frontend->mywarn($@);
return $self->goodbye("[depend] -- NOT OK");
}
+ else {
+ return $self->goodbye("[configure_requires] -- NOT OK");
+ }
}
die "never reached";
}
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";
"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);
$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;
}
}
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();
}
$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
# 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") {
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
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($@);
# 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} || [];
#-> 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")) {
$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
#-> 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;
# 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);
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) {
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;
}
"'$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
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;
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
$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; };
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)}) {
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)) {
}
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",
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";
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
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;
}
# -*- 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;
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
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
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
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
},
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
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{
$fastread = 0;
} else {
$fastread = 1;
+ $silent = 1;
$CPAN::Config->{urllist} ||= [];
$CPAN::Config->{connect_to_internet_ok} ||= 1;
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] };
}
}
keep_source_where
prefs_dir
} =~ /$matcher/) {
- $CPAN::Frontend->myprint($prompts{config_intro});
+ $CPAN::Frontend->myprint($prompts{config_intro}) unless $silent;
init_cpan_home($matcher);
$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");
+ }
}
}
#
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;
}
#
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');
#
my_dflt_prompt(inactivity_timeout => 0, $matcher);
+ my_dflt_prompt(version_timeout => 15, $matcher);
#
#== halt_on_failure
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 $_?";
$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;
}
}
}
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"],
#
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);
# 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);
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);
}
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';
$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 ".
$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) {
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;
}
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;
}
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 {
if ($require_nonempty && !@nums) {
$CPAN::Frontend->mywarn("$empty_warning\n");
}
- $CPAN::Frontend->myprint("\n");
# a blank line continues...
unless (@nums){
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;
# 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);
$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));
@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) {
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}++;
@$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
my $ans = _real_prompt(@_);
_strip_spaces($ans);
+ $CPAN::Frontend->myprint("\n");
return $ans;
}
"urllist",
"use_sqlite",
"username",
+ "version_timeout",
"wait_list",
"wget",
"yaml_load_code",
--- /dev/null
+# -*- 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;
+
$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;
}
#-> 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);
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
# 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)$/) {
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);
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) {
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")
}
$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"});
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;
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;
}
$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 (
} 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";
-#!/usr/bin/perl
-# $Id: cpan,v 1.9 2006/11/01 21:49:31 comdog Exp $
+#!/usr/local/bin/perl
use strict;
+use vars qw($VERSION);
+
+use App::Cpan;
+$VERSION = '1.57';
+
+my $rc = App::Cpan->run( @ARGV );
+
+# will this work under Strawberry Perl?
+exit( $rc || 0 );
=head1 NAME
cpan module_name [ module_name ... ]
# with switches, installs modules with extra behavior
- cpan [-cfimt] module_name [ module_name ... ]
+ cpan [-cfgimt] module_name [ module_name ... ]
+ # with just the dot, install from the distribution in the
+ # current directory
+ cpan .
+
# without arguments, starts CPAN.pm shell
cpan
+ # dump the configuration
+ cpan -J
+
+ # load a different configuration to install Module::Foo
+ cpan -j some/other/file Module::Foo
+
# without arguments, but some switches
- cpan [-ahrvACDLO]
+ cpan [-ahrvACDlLO]
=head1 DESCRIPTION
moment it uses CPAN.pm to do the work, but it is not a one-shot command
runner for CPAN.pm.
-=head2 Meta Options
-
-These options are mutually exclusive, and the script processes them in
-this order: [hvCAar]. Once the script finds one, it ignores the others,
-and then exits after it finishes the task. The script ignores any other
-command line options.
+=head2 Options
=over 4
=item -a
-Creates the CPAN.pm autobundle with CPAN::Shell->autobundle.
+Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
=item -A module [ module ... ]
-Shows the primary maintainers for the specified modules
+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 C<Changes> files for the specified modules
+Show the F<Changes> files for the specified modules
=item -D module [ module ... ]
Each line has three columns: module name, local version, and CPAN
version.
-=item -L author [ author ... ]
+=item -f
-List the modules by the specified authors.
+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:
-=item -h
+ % cpan -f -i Module::Foo
-Prints a help message.
+=item -F
-=item -O
+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.
-Show the out-of-date modules.
+=item -g module [ module ... ]
-=item -r
+Downloads to the current directory the latest distribution of the module.
-Recompiles dynamically loaded modules with CPAN::Shell->recompile.
+=item -G module [ module ... ]
-=item -v
+UNIMPLEMENTED
-Print the script version and CPAN.pm version.
+Download to the current directory the latest distribution of the
+modules, unpack each distribution, and create a git repository for each
+distribution.
-=back
+If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
+distribution.
-=head2 Module options
+=item -h
-These options are mutually exclusive, and the script processes them in
-alphabetical order. It only processes the first one it finds.
+Print a help message and exit. When you specify C<-h>, it ignores all
+of the other options and arguments.
-=over 4
+=item -i
-=item c
+Install the specified modules.
-Runs a `make clean` in the specified module's 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
+C<$CPAN::Config> as an anonymous hash.
-=item f
+=item -J
-Forces the specified action, when it normally would have failed.
+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 i
+=item -L author [ author ... ]
-Installed the specified modules.
+List the modules by the specified authors.
-=item m
+=item -m
-Makes the specified modules.
+Make the specified modules.
-=item t
+=item -O
-Runs a `make test` on the specified modules.
+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 -v
+
+Print the script version and CPAN.pm version then exit.
=back
# force install modules ( must use -i )
cpan -fi CGI::Minimal URI
+=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
+* one shot configuration values from the command line
+
+
=head1 BUGS
=head1 SOURCE AVAILABILITY
-This source is part of a SourceForge project which always has the
-latest sources in CVS, as well as all of the previous releases.
-
- http://sourceforge.net/projects/brian-d-foy/
+This code is in Github:
-If, for some reason, I disappear from the world, one of the other
-members of the project can shepherd this module appropriately.
+ git://github.com/briandfoy/cpan_script.git
=head1 CREDITS
=head1 COPYRIGHT
-Copyright (c) 2001-2006, brian d foy, All Rights Reserved.
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.
=cut
-use CPAN ();
-use Getopt::Std;
-
-my $VERSION =
- sprintf "%d.%d", q$Revision: 1.9 $ =~ m/ (\d+) \. (\d+) /xg;
-
-if( $ARGV[0] eq 'install' )
- {
- my @args = @ARGV;
- shift @args;
-
- die <<"HERE";
-It looks like you specified 'install' as an argument to cpan(1). This
-script is not the CPAN.pm prompt and doesn't understand the same commands.
-In fact, doesn't require the extra typing. You probably just want to
-list the modules you want to install:
-
- cpan @args
-
-See the documentation for more details on using this script.
-HERE
- }
-
-if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# set up the order of options that we layer over CPAN::Shell
-my @META_OPTIONS = qw( h v C A D O L a r );
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# map switches to method names in CPAN::Shell
-my $Default = 'default';
-
-my %CPAN_METHODS = (
- $Default => 'install',
- 'c' => 'clean',
- 'f' => 'force',
- 'i' => 'install',
- 'm' => 'make',
- 't' => 'test',
- );
-my @CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# map switches to the subroutines in this script, along with other information.
-# use this stuff instead of hard-coded indices and values
-my %Method_table = (
-# key => [ sub ref, takes args?, exit value, description ]
- h => [ \&_print_help, 0, 0, 'Printing help' ],
- v => [ \&_print_version, 0, 0, 'Printing version' ],
- C => [ \&_show_Changes, 1, 0, 'Showing Changes file' ],
- A => [ \&_show_Author, 1, 0, 'Showing Author' ],
- D => [ \&_show_Details, 1, 0, 'Showing Details' ],
- O => [ \&_show_out_of_date, 0, 0, 'Showing Out of date' ],
- L => [ \&_show_author_mods, 1, 0, 'Showing author mods' ],
- a => [ \&_create_autobundle, 0, 0, 'Creating autobundle' ],
- r => [ \&_recompiling, 0, 0, 'Recompiling' ],
-
- c => [ \&_default, 1, 0, 'Running `make clean`' ],
- f => [ \&_default, 1, 0, 'Installing with force' ],
- i => [ \&_default, 1, 0, 'Running `make install`' ],
- 'm' => [ \&_default, 1, 0, 'Running `make`' ],
- t => [ \&_default, 1, 0, 'Running `make test`' ],
-
- );
-
-my %Method_table_index = (
- code => 0,
- takes_args => 1,
- exit_value => 2,
- description => 3,
- );
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# finally, do some argument processing
-my @option_order = ( @META_OPTIONS, @CPAN_OPTIONS );
-
-my %options;
-Getopt::Std::getopts(
- join( '', @option_order ), \%options );
-
-my $option_count = grep { $options{$_} } @option_order;
-$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;
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# try each of the possible switches until we find one to handle
-# print an error message if there are too many switches
-# print an error message if there are arguments when there shouldn't be any
-foreach my $option ( @option_order )
- {
- next unless $options{$option};
- die unless
- ref $Method_table{$option}[ $Method_table_index{code} ] eq ref sub {};
-
- print "$Method_table{$option}[ $Method_table_index{description} ] " .
- "-- ignoring other opitions\n" if $option_count > 1;
- print "$Method_table{$option}[ $Method_table_index{description} ] " .
- "-- ignoring other arguments\n"
- if( @ARGV && ! $Method_table{$option}[ $Method_table_index{takes_args} ] );
-
- $Method_table{$option}[ $Method_table_index{code} ]->( \@ARGV );
-
- last;
- }
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
- # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-
-sub _default
- {
- my $args = shift;
-
- 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 ) { CPAN::shell(); return }
- elsif( $switch and not @$args )
- { die "Nothing to $CPAN_METHODS{$switch}!\n"; }
-
- # Get and cheeck 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
- foreach my $arg ( @$args )
- {
- if( $options{f} ) { CPAN::Shell->force( $method, $arg ) }
- else { CPAN::Shell->$method( $arg ) }
- }
- }
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-sub _print_help
- {
- print STDERR "Use perldoc to read the documentation\n";
- exec "perldoc $0";
- }
-
-sub _print_version
- {
- print STDERR "$0 script version $VERSION, CPAN.pm version " .
- CPAN->VERSION . "\n";
- }
-
-sub _create_autobundle
- {
- print "Creating autobundle in ", $CPAN::Config->{cpan_home},
- "/Bundle\n";
-
- CPAN::Shell->autobundle;
- }
-
-sub _recompiling
- {
- print "Recompiling dynamically-loaded extensions\n";
-
- CPAN::Shell->recompile;
- }
-
-sub _show_Changes
- {
- my $args = shift;
-
- foreach my $arg ( @$args )
- {
- print "Checking $arg\n";
- my $module = CPAN::Shell->expand( "Module", $arg );
-
- next unless $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);
- }
- }
-
-sub _get_changes_file
- {
- die "Reading Changes files requires LWP::Simple and URI\n"
- unless eval { require LWP::Simple; require URI; };
-
- my $url = shift;
-
- my $content = LWP::Simple::get( $url );
- print "Got $url ...\n" if defined $content;
- #print $content;
-
- my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;
-
- my $changes_url = URI->new_abs( $change_link, $url );
- #print "change link is: $changes_url\n";
- my $changes = LWP::Simple::get( $changes_url );
- #print "change text is: " . $change_link->text() . "\n";
- print $changes;
- }
-
-sub _show_Author
- {
- 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;
-
- printf "%-25s %-8s %-25s %s\n",
- $arg, $module->userid, $author->email, $author->fullname;
- }
- }
-
-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";
-
- }
- }
-
-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;
- }
-
- }
-
-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";
- }
-
- }
-
1;
use_ok( 'CPAN::FirstTime' );
can_ok( 'CPAN::Mirrored::By', 'new', 'continent', 'country', 'url' );
-my $cmb = CPAN::Mirrored::By->new();
+my $cmb = CPAN::Mirrored::By->new(
+ {
+ continent => "continent",
+ country => "country",
+ http => "http",
+ ftp => "ftp",
+ }
+);
isa_ok( $cmb, 'CPAN::Mirrored::By' );
-@$cmb = qw( continent country url );
is( $cmb->continent(), 'continent',
'continent() should return continent entry' );
is( $cmb->country(), 'country', 'country() should return country entry' );
-is( $cmb->url(), 'url', 'url() should return url entry' );
+is( $cmb->url(), 'http', 'url() should return best url entry' );
__END__
# Local Variables:
projects / p5sagit/p5-mst-13.2.git / commitdiff