1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $CPAN::VERSION = '1.88_62';
5 $CPAN::VERSION = eval $CPAN::VERSION;
7 use CPAN::HandleConfig;
17 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
18 # 5.005_04 does not work without
20 use File::Basename ();
28 use Sys::Hostname qw(hostname);
29 use Text::ParseWords ();
32 # we need to run chdir all over and we would get at wrong libraries
35 if (File::Spec->can("rel2abs")) {
37 $inc = File::Spec->rel2abs($inc);
43 require Mac::BuildTools if $^O eq 'MacOS';
45 END { $CPAN::End++; &cleanup; }
48 $CPAN::Frontend ||= "CPAN::Shell";
49 unless (@CPAN::Defaultsites){
50 @CPAN::Defaultsites = map {
51 CPAN::URL->new(TEXT => $_, FROM => "DEF")
53 "http://www.perl.org/CPAN/",
54 "ftp://ftp.perl.org/pub/CPAN/";
56 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
57 $CPAN::Perl ||= CPAN::find_perl();
58 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
59 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
61 # our globals are getting a mess
84 @CPAN::ISA = qw(CPAN::Debug Exporter);
86 # note that these functions live in CPAN::Shell and get executed via
87 # AUTOLOAD when called directly
111 sub soft_chdir_with_alternatives ($);
114 $autoload_recursion ||= 0;
116 #-> sub CPAN::AUTOLOAD ;
118 $autoload_recursion++;
122 warn "Refusing to autoload '$l' while signal pending";
123 $autoload_recursion--;
126 if ($autoload_recursion > 1) {
127 my $fullcommand = join " ", map { "'$_'" } $l, @_;
128 warn "Refusing to autoload $fullcommand in recursion\n";
129 $autoload_recursion--;
133 @export{@EXPORT} = '';
134 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
135 if (exists $export{$l}){
138 die(qq{Unknown CPAN command "$AUTOLOAD". }.
139 qq{Type ? for help.\n});
141 $autoload_recursion--;
145 #-> sub CPAN::shell ;
148 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
149 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
151 my $oprompt = shift || CPAN::Prompt->new;
152 my $prompt = $oprompt;
153 my $commandline = shift || "";
154 $CPAN::CurrentCommandId ||= 1;
157 unless ($Suppress_readline) {
158 require Term::ReadLine;
161 $term->ReadLine eq "Term::ReadLine::Stub"
163 $term = Term::ReadLine->new('CPAN Monitor');
165 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
166 my $attribs = $term->Attribs;
167 $attribs->{attempted_completion_function} = sub {
168 &CPAN::Complete::gnu_cpl;
171 $readline::rl_completion_function =
172 $readline::rl_completion_function = 'CPAN::Complete::cpl';
174 if (my $histfile = $CPAN::Config->{'histfile'}) {{
175 unless ($term->can("AddHistory")) {
176 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
179 my($fh) = FileHandle->new;
180 open $fh, "<$histfile" or last;
184 $term->AddHistory($_);
188 for ($CPAN::Config->{term_ornaments}) { # alias
189 local $Term::ReadLine::termcap_nowarn = 1;
190 $term->ornaments($_) if defined;
192 # $term->OUT is autoflushed anyway
193 my $odef = select STDERR;
200 # no strict; # I do not recall why no strict was here (2000-09-03)
202 my @cwd = grep { defined $_ and length $_ }
204 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
205 File::Spec->rootdir();
206 my $try_detect_readline;
207 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
208 my $rl_avail = $Suppress_readline ? "suppressed" :
209 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
210 "available (try 'install Bundle::CPAN')";
212 unless ($CPAN::Config->{'inhibit_startup_message'}){
213 $CPAN::Frontend->myprint(
215 cpan shell -- CPAN exploration and modules installation (v%s)
223 my($continuation) = "";
224 my $last_term_ornaments;
225 SHELLCOMMAND: while () {
226 if ($Suppress_readline) {
228 last SHELLCOMMAND unless defined ($_ = <> );
231 last SHELLCOMMAND unless
232 defined ($_ = $term->readline($prompt, $commandline));
234 $_ = "$continuation$_" if $continuation;
236 next SHELLCOMMAND if /^$/;
237 $_ = 'h' if /^\s*\?/;
238 if (/^(?:q(?:uit)?|bye|exit)$/i) {
249 use vars qw($import_done);
250 CPAN->import(':DEFAULT') unless $import_done++;
251 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
258 eval { @line = Text::ParseWords::shellwords($_) };
259 warn($@), next SHELLCOMMAND if $@;
260 warn("Text::Parsewords could not parse the line [$_]"),
261 next SHELLCOMMAND unless @line;
262 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
263 my $command = shift @line;
264 eval { CPAN::Shell->$command(@line) };
269 if ($command =~ /^(make|test|install|force|notest|clean|report|upgrade)$/) {
270 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
272 soft_chdir_with_alternatives(\@cwd);
273 $CPAN::Frontend->myprint("\n");
275 $CPAN::CurrentCommandId++;
279 $commandline = ""; # I do want to be able to pass a default to
280 # shell, but on the second command I see no
283 CPAN::Queue->nullify_queue;
284 if ($try_detect_readline) {
285 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
287 $CPAN::META->has_inst("Term::ReadLine::Perl")
289 delete $INC{"Term/ReadLine.pm"};
291 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
292 require Term::ReadLine;
293 $CPAN::Frontend->myprint("\n$redef subroutines in ".
294 "Term::ReadLine redefined\n");
298 if ($term and $term->can("ornaments")) {
299 for ($CPAN::Config->{term_ornaments}) { # alias
301 if (not defined $last_term_ornaments
302 or $_ != $last_term_ornaments
304 local $Term::ReadLine::termcap_nowarn = 1;
305 $term->ornaments($_);
306 $last_term_ornaments = $_;
309 undef $last_term_ornaments;
313 for my $class (qw(Module Distribution)) {
314 # again unsafe meta access?
315 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
316 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
317 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
318 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
322 $GOTOSHELL = 0; # not too often
323 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
328 soft_chdir_with_alternatives(\@cwd);
331 sub soft_chdir_with_alternatives ($) {
334 my $root = File::Spec->rootdir();
335 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
336 Trying '$root' as temporary haven.
341 if (chdir $cwd->[0]) {
345 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
346 Trying to chdir to "$cwd->[1]" instead.
350 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
357 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
359 $yaml_module ne "YAML"
361 !$CPAN::META->has_inst($yaml_module)
363 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
364 $yaml_module = "YAML";
369 # CPAN::_yaml_loadfile
371 my($self,$local_file) = @_;
372 return +[] unless -s $local_file;
373 my $yaml_module = $self->_yaml_module;
374 if ($CPAN::META->has_inst($yaml_module)) {
375 my $code = UNIVERSAL::can($yaml_module, "LoadFile");
377 eval { @yaml = $code->($local_file); };
379 $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
381 "with $yaml_module the following error was encountered:\n".
387 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
392 # CPAN::_yaml_dumpfile
394 my($self,$to_local_file,@what) = @_;
395 my $yaml_module = $self->_yaml_module;
396 if ($CPAN::META->has_inst($yaml_module)) {
397 if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
398 my $code = UNIVERSAL::can($yaml_module, "Dump");
399 eval { print $to_local_file $code->(@what) };
401 my $code = UNIVERSAL::can($yaml_module, "DumpFile");
402 eval { $code->($to_local_file,@what); };
405 $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n".
407 "with $yaml_module the following error was encountered:\n".
412 $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' not installed, not dumping to '$to_local_file'\n");
416 package CPAN::CacheMgr;
418 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
423 use Fcntl qw(:flock);
424 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
425 @CPAN::FTP::ISA = qw(CPAN::Debug);
427 package CPAN::LWP::UserAgent;
429 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
430 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
432 package CPAN::Complete;
434 @CPAN::Complete::ISA = qw(CPAN::Debug);
435 # Q: where is the "How do I add a new command" HOWTO?
436 # A: svn diff -r 1048:1049 where andk added the report command
437 @CPAN::Complete::COMMANDS = sort qw(
438 ! a b d h i m o q r u
465 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
466 @CPAN::Index::ISA = qw(CPAN::Debug);
469 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
472 package CPAN::InfoObj;
474 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
476 package CPAN::Author;
478 @CPAN::Author::ISA = qw(CPAN::InfoObj);
480 package CPAN::Distribution;
482 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
484 package CPAN::Bundle;
486 @CPAN::Bundle::ISA = qw(CPAN::Module);
488 package CPAN::Module;
490 @CPAN::Module::ISA = qw(CPAN::InfoObj);
492 package CPAN::Exception::RecursiveDependency;
494 use overload '""' => "as_string";
501 for my $dep (@$deps) {
503 last if $seen{$dep}++;
505 bless { deps => \@deps }, $class;
510 "\nRecursive dependency detected:\n " .
511 join("\n => ", @{$self->{deps}}) .
512 ".\nCannot continue.\n";
515 package CPAN::Prompt; use overload '""' => "as_string";
516 use vars qw($prompt);
518 $CPAN::CurrentCommandId ||= 0;
524 unless ($CPAN::META->{LOCK}) {
525 $word = "nolock_cpan";
527 if ($CPAN::Config->{commandnumber_in_prompt}) {
528 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
534 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
535 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
536 # planned are things like age or quality
538 my($class,%args) = @_;
550 $self->{TEXT} = $set;
555 package CPAN::Distrostatus;
556 use overload '""' => "as_string",
559 my($class,$arg) = @_;
562 FAILED => substr($arg,0,2) eq "NO",
563 COMMANDID => $CPAN::CurrentCommandId,
566 sub commandid { shift->{COMMANDID} }
567 sub failed { shift->{FAILED} }
571 $self->{TEXT} = $set;
590 @CPAN::Shell::ISA = qw(CPAN::Debug);
591 $COLOR_REGISTERED ||= 0;
594 $autoload_recursion ||= 0;
596 #-> sub CPAN::Shell::AUTOLOAD ;
598 $autoload_recursion++;
600 my $class = shift(@_);
601 # warn "autoload[$l] class[$class]";
604 warn "Refusing to autoload '$l' while signal pending";
605 $autoload_recursion--;
608 if ($autoload_recursion > 1) {
609 my $fullcommand = join " ", map { "'$_'" } $l, @_;
610 warn "Refusing to autoload $fullcommand in recursion\n";
611 $autoload_recursion--;
615 # XXX needs to be reconsidered
616 if ($CPAN::META->has_inst('CPAN::WAIT')) {
619 $CPAN::Frontend->mywarn(qq{
620 Commands starting with "w" require CPAN::WAIT to be installed.
621 Please consider installing CPAN::WAIT to use the fulltext index.
622 For this you just need to type
627 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
631 $autoload_recursion--;
638 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
640 # from here on only subs.
641 ################################################################################
643 sub _perl_fingerprint {
644 my($self,$other_fingerprint) = @_;
645 my $dll = eval {OS2::DLLname()};
648 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
650 my $this_fingerprint = {
652 sitearchexp => $Config::Config{sitearchexp},
653 'mtime_$^X' => (stat $^X)[9],
654 'mtime_dll' => $mtime_dll,
656 if ($other_fingerprint) {
657 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
658 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
660 # mandatory keys since 1.88_57
661 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
662 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
666 return $this_fingerprint;
670 sub suggest_myconfig () {
671 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
672 $CPAN::Frontend->myprint("You don't seem to have a user ".
673 "configuration (MyConfig.pm) yet.\n");
674 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
675 "user configuration now? (Y/n)",
678 CPAN::Shell->mkmyconfig();
681 $CPAN::Frontend->mydie("OK, giving up.");
686 #-> sub CPAN::all_objects ;
688 my($mgr,$class) = @_;
689 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
690 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
692 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
695 # Called by shell, not in batch mode. In batch mode I see no risk in
696 # having many processes updating something as installations are
697 # continually checked at runtime. In shell mode I suspect it is
698 # unintentional to open more than one shell at a time
700 #-> sub CPAN::checklock ;
703 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
704 if (-f $lockfile && -M _ > 0) {
705 my $fh = FileHandle->new($lockfile) or
706 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
707 my $otherpid = <$fh>;
708 my $otherhost = <$fh>;
710 if (defined $otherpid && $otherpid) {
713 if (defined $otherhost && $otherhost) {
716 my $thishost = hostname();
717 if (defined $otherhost && defined $thishost &&
718 $otherhost ne '' && $thishost ne '' &&
719 $otherhost ne $thishost) {
720 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
721 "reports other host $otherhost and other ".
722 "process $otherpid.\n".
723 "Cannot proceed.\n"));
724 } elsif ($RUN_DEGRADED) {
725 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
726 } elsif (defined $otherpid && $otherpid) {
727 return if $$ == $otherpid; # should never happen
728 $CPAN::Frontend->mywarn(
730 There seems to be running another CPAN process (pid $otherpid). Contacting...
732 if (kill 0, $otherpid) {
733 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
735 CPAN::Shell::colorable_makemaker_prompt
736 (qq{Shall I try to run in degraded }.
737 qq{mode? (Y/n)},"y");
739 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
740 Please report if something unexpected happens\n");
742 for ($CPAN::Config) {
743 $_->{build_dir_reuse} = 0;
744 $_->{commandnumber_in_prompt} = 0;
746 $_->{cache_metadata} = 0;
749 $CPAN::Frontend->mydie("
750 You may want to kill the other job and delete the lockfile. On UNIX try:
755 } elsif (-w $lockfile) {
757 CPAN::Shell::colorable_makemaker_prompt
758 (qq{Other job not responding. Shall I overwrite }.
759 qq{the lockfile '$lockfile'? (Y/n)},"y");
760 $CPAN::Frontend->myexit("Ok, bye\n")
761 unless $ans =~ /^y/i;
764 qq{Lockfile '$lockfile' not writeable by you. }.
765 qq{Cannot proceed.\n}.
767 qq{ rm '$lockfile'\n}.
768 qq{ and then rerun us.\n}
772 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
773 "'$lockfile', please remove. Cannot proceed.\n"));
776 my $dotcpan = $CPAN::Config->{cpan_home};
777 eval { File::Path::mkpath($dotcpan);};
779 # A special case at least for Jarkko.
784 $symlinkcpan = readlink $dotcpan;
785 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
786 eval { File::Path::mkpath($symlinkcpan); };
790 $CPAN::Frontend->mywarn(qq{
791 Working directory $symlinkcpan created.
795 unless (-d $dotcpan) {
797 Your configuration suggests "$dotcpan" as your
798 CPAN.pm working directory. I could not create this directory due
799 to this error: $firsterror\n};
801 As "$dotcpan" is a symlink to "$symlinkcpan",
802 I tried to create that, but I failed with this error: $seconderror
805 Please make sure the directory exists and is writable.
807 $CPAN::Frontend->myprint($mess);
808 return suggest_myconfig;
810 } # $@ after eval mkpath $dotcpan
811 if (0) { # to test what happens when a race condition occurs
812 for (reverse 1..10) {
818 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
820 unless ($fh = FileHandle->new("+>>$lockfile")) {
821 if ($! =~ /Permission/) {
822 $CPAN::Frontend->myprint(qq{
824 Your configuration suggests that CPAN.pm should use a working
826 $CPAN::Config->{cpan_home}
827 Unfortunately we could not create the lock file
829 due to permission problems.
831 Please make sure that the configuration variable
832 \$CPAN::Config->{cpan_home}
833 points to a directory where you can write a .lock file. You can set
834 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
837 return suggest_myconfig;
841 while (!flock $fh, LOCK_EX|LOCK_NB) {
843 $CPAN::Frontend->mydie("Giving up\n");
845 $CPAN::Frontend->mysleep($sleep++);
846 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
851 $fh->print($$, "\n");
852 $fh->print(hostname(), "\n");
853 $self->{LOCK} = $lockfile;
854 $self->{LOCKFH} = $fh;
859 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
865 die "Got yet another signal" if $Signal > 1;
866 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
867 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
871 # From: Larry Wall <larry@wall.org>
872 # Subject: Re: deprecating SIGDIE
873 # To: perl5-porters@perl.org
874 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
876 # The original intent of __DIE__ was only to allow you to substitute one
877 # kind of death for another on an application-wide basis without respect
878 # to whether you were in an eval or not. As a global backstop, it should
879 # not be used any more lightly (or any more heavily :-) than class
880 # UNIVERSAL. Any attempt to build a general exception model on it should
881 # be politely squashed. Any bug that causes every eval {} to have to be
882 # modified should be not so politely squashed.
884 # Those are my current opinions. It is also my optinion that polite
885 # arguments degenerate to personal arguments far too frequently, and that
886 # when they do, it's because both people wanted it to, or at least didn't
887 # sufficiently want it not to.
891 # global backstop to cleanup if we should really die
892 $SIG{__DIE__} = \&cleanup;
893 $self->debug("Signal handler set.") if $CPAN::DEBUG;
896 #-> sub CPAN::DESTROY ;
898 &cleanup; # need an eval?
901 #-> sub CPAN::anycwd ;
904 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
909 sub cwd {Cwd::cwd();}
911 #-> sub CPAN::getcwd ;
912 sub getcwd {Cwd::getcwd();}
914 #-> sub CPAN::fastcwd ;
915 sub fastcwd {Cwd::fastcwd();}
917 #-> sub CPAN::backtickcwd ;
918 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
920 #-> sub CPAN::find_perl ;
922 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
923 my $pwd = $CPAN::iCwd = CPAN::anycwd();
924 my $candidate = File::Spec->catfile($pwd,$^X);
925 $perl ||= $candidate if MM->maybe_command($candidate);
928 my ($component,$perl_name);
929 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
930 PATH_COMPONENT: foreach $component (File::Spec->path(),
931 $Config::Config{'binexp'}) {
932 next unless defined($component) && $component;
933 my($abs) = File::Spec->catfile($component,$perl_name);
934 if (MM->maybe_command($abs)) {
946 #-> sub CPAN::exists ;
948 my($mgr,$class,$id) = @_;
949 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
951 ### Carp::croak "exists called without class argument" unless $class;
953 $id =~ s/:+/::/g if $class eq "CPAN::Module";
954 exists $META->{readonly}{$class}{$id} or
955 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
958 #-> sub CPAN::delete ;
960 my($mgr,$class,$id) = @_;
961 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
962 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
965 #-> sub CPAN::has_usable
966 # has_inst is sometimes too optimistic, we should replace it with this
967 # has_usable whenever a case is given
969 my($self,$mod,$message) = @_;
970 return 1 if $HAS_USABLE->{$mod};
971 my $has_inst = $self->has_inst($mod,$message);
972 return unless $has_inst;
975 LWP => [ # we frequently had "Can't locate object
976 # method "new" via package "LWP::UserAgent" at
977 # (eval 69) line 2006
979 sub {require LWP::UserAgent},
980 sub {require HTTP::Request},
981 sub {require URI::URL},
984 sub {require Net::FTP},
985 sub {require Net::Config},
988 sub {require File::HomeDir;
989 unless (File::HomeDir::->VERSION >= 0.52){
990 for ("Will not use File::HomeDir, need 0.52\n") {
991 $CPAN::Frontend->mywarn($_);
998 if ($usable->{$mod}) {
999 for my $c (0..$#{$usable->{$mod}}) {
1000 my $code = $usable->{$mod}[$c];
1001 my $ret = eval { &$code() };
1002 $ret = "" unless defined $ret;
1004 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1009 return $HAS_USABLE->{$mod} = 1;
1012 #-> sub CPAN::has_inst
1014 my($self,$mod,$message) = @_;
1015 Carp::croak("CPAN->has_inst() called without an argument")
1016 unless defined $mod;
1017 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1018 keys %{$CPAN::Config->{dontload_hash}||{}},
1019 @{$CPAN::Config->{dontload_list}||[]};
1020 if (defined $message && $message eq "no" # afair only used by Nox
1024 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1032 # checking %INC is wrong, because $INC{LWP} may be true
1033 # although $INC{"URI/URL.pm"} may have failed. But as
1034 # I really want to say "bla loaded OK", I have to somehow
1036 ### warn "$file in %INC"; #debug
1038 } elsif (eval { require $file }) {
1039 # eval is good: if we haven't yet read the database it's
1040 # perfect and if we have installed the module in the meantime,
1041 # it tries again. The second require is only a NOOP returning
1042 # 1 if we had success, otherwise it's retrying
1044 my $v = eval "\$$mod\::VERSION";
1045 $v = $v ? " (v$v)" : "";
1046 $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1047 if ($mod eq "CPAN::WAIT") {
1048 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1051 } elsif ($mod eq "Net::FTP") {
1052 $CPAN::Frontend->mywarn(qq{
1053 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1055 install Bundle::libnet
1057 }) unless $Have_warned->{"Net::FTP"}++;
1058 $CPAN::Frontend->mysleep(3);
1059 } elsif ($mod eq "Digest::SHA"){
1060 if ($Have_warned->{"Digest::SHA"}++) {
1061 $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1062 qq{because Digest::SHA not installed.\n});
1064 $CPAN::Frontend->mywarn(qq{
1065 CPAN: checksum security checks disabled because Digest::SHA not installed.
1066 Please consider installing the Digest::SHA module.
1069 $CPAN::Frontend->mysleep(2);
1071 } elsif ($mod eq "Module::Signature"){
1072 if (not $CPAN::Config->{check_sigs}) {
1073 # they do not want us:-(
1074 } elsif (not $Have_warned->{"Module::Signature"}++) {
1075 # No point in complaining unless the user can
1076 # reasonably install and use it.
1077 if (eval { require Crypt::OpenPGP; 1 } ||
1079 defined $CPAN::Config->{'gpg'}
1081 $CPAN::Config->{'gpg'} =~ /\S/
1084 $CPAN::Frontend->mywarn(qq{
1085 CPAN: Module::Signature security checks disabled because Module::Signature
1086 not installed. Please consider installing the Module::Signature module.
1087 You may also need to be able to connect over the Internet to the public
1088 keyservers like pgp.mit.edu (port 11371).
1091 $CPAN::Frontend->mysleep(2);
1095 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1100 #-> sub CPAN::instance ;
1102 my($mgr,$class,$id) = @_;
1103 CPAN::Index->reload;
1105 # unsafe meta access, ok?
1106 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1107 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1115 #-> sub CPAN::cleanup ;
1117 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1118 local $SIG{__DIE__} = '';
1123 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1124 $ineval = 1, last if
1125 $subroutine eq '(eval)';
1127 return if $ineval && !$CPAN::End;
1128 return unless defined $META->{LOCK};
1129 return unless -f $META->{LOCK};
1131 unlink $META->{LOCK};
1133 # Carp::cluck("DEBUGGING");
1134 if ( $CPAN::CONFIG_DIRTY ) {
1135 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1137 $CPAN::Frontend->myprint("Lockfile removed.\n");
1140 #-> sub CPAN::savehist
1143 my($histfile,$histsize);
1144 unless ($histfile = $CPAN::Config->{'histfile'}){
1145 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1148 $histsize = $CPAN::Config->{'histsize'} || 100;
1150 unless ($CPAN::term->can("GetHistory")) {
1151 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1157 my @h = $CPAN::term->GetHistory;
1158 splice @h, 0, @h-$histsize if @h>$histsize;
1159 my($fh) = FileHandle->new;
1160 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1161 local $\ = local $, = "\n";
1166 #-> sub CPAN::is_tested
1168 my($self,$what) = @_;
1169 $self->{is_tested}{$what} = 1;
1172 #-> sub CPAN::is_installed
1173 # unsets the is_tested flag: as soon as the thing is installed, it is
1174 # not needed in set_perl5lib anymore
1176 my($self,$what) = @_;
1177 delete $self->{is_tested}{$what};
1180 #-> sub CPAN::set_perl5lib
1182 my($self,$for) = @_;
1184 (undef,undef,undef,$for) = caller(1);
1187 $self->{is_tested} ||= {};
1188 return unless %{$self->{is_tested}};
1189 my $env = $ENV{PERL5LIB};
1190 $env = $ENV{PERLLIB} unless defined $env;
1192 push @env, $env if defined $env and length $env;
1193 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1194 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1195 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}};
1197 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\n");
1199 my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
1200 sort keys %{$self->{is_tested}};
1201 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ".
1203 "%BUILDDIR%=$CPAN::Config->{'build_dir'} ".
1208 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1211 package CPAN::CacheMgr;
1214 #-> sub CPAN::CacheMgr::as_string ;
1216 eval { require Data::Dumper };
1218 return shift->SUPER::as_string;
1220 return Data::Dumper::Dumper(shift);
1224 #-> sub CPAN::CacheMgr::cachesize ;
1229 #-> sub CPAN::CacheMgr::tidyup ;
1232 return unless -d $self->{ID};
1233 while ($self->{DU} > $self->{'MAX'} ) {
1234 my($toremove) = shift @{$self->{FIFO}};
1235 $CPAN::Frontend->myprint(sprintf(
1236 "Deleting from cache".
1237 ": $toremove (%.1f>%.1f MB)\n",
1238 $self->{DU}, $self->{'MAX'})
1240 return if $CPAN::Signal;
1241 $self->force_clean_cache($toremove);
1242 return if $CPAN::Signal;
1246 #-> sub CPAN::CacheMgr::dir ;
1251 #-> sub CPAN::CacheMgr::entries ;
1253 my($self,$dir) = @_;
1254 return unless defined $dir;
1255 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1256 $dir ||= $self->{ID};
1257 my($cwd) = CPAN::anycwd();
1258 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1259 my $dh = DirHandle->new(File::Spec->curdir)
1260 or Carp::croak("Couldn't opendir $dir: $!");
1263 next if $_ eq "." || $_ eq "..";
1265 push @entries, File::Spec->catfile($dir,$_);
1267 push @entries, File::Spec->catdir($dir,$_);
1269 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1272 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1273 sort { -M $b <=> -M $a} @entries;
1276 #-> sub CPAN::CacheMgr::disk_usage ;
1278 my($self,$dir) = @_;
1279 return if exists $self->{SIZE}{$dir};
1280 return if $CPAN::Signal;
1284 unless (chmod 0755, $dir) {
1285 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1286 "permission to change the permission; cannot ".
1287 "estimate disk usage of '$dir'\n");
1288 $CPAN::Frontend->mysleep(5);
1293 $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1298 $File::Find::prune++ if $CPAN::Signal;
1300 if ($^O eq 'MacOS') {
1302 my $cat = Mac::Files::FSpGetCatInfo($_);
1303 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1307 unless (chmod 0755, $_) {
1308 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1309 "the permission to change the permission; ".
1310 "can only partially estimate disk usage ".
1312 $CPAN::Frontend->mysleep(5);
1323 return if $CPAN::Signal;
1324 $self->{SIZE}{$dir} = $Du/1024/1024;
1325 push @{$self->{FIFO}}, $dir;
1326 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1327 $self->{DU} += $Du/1024/1024;
1331 #-> sub CPAN::CacheMgr::force_clean_cache ;
1332 sub force_clean_cache {
1333 my($self,$dir) = @_;
1334 return unless -e $dir;
1335 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1337 File::Path::rmtree($dir);
1338 unlink "$dir.yml"; # may fail
1339 $self->{DU} -= $self->{SIZE}{$dir};
1340 delete $self->{SIZE}{$dir};
1343 #-> sub CPAN::CacheMgr::new ;
1350 ID => $CPAN::Config->{'build_dir'},
1351 MAX => $CPAN::Config->{'build_cache'},
1352 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1355 File::Path::mkpath($self->{ID});
1356 my $dh = DirHandle->new($self->{ID});
1357 bless $self, $class;
1360 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1362 CPAN->debug($debug) if $CPAN::DEBUG;
1366 #-> sub CPAN::CacheMgr::scan_cache ;
1369 return if $self->{SCAN} eq 'never';
1370 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1371 unless $self->{SCAN} eq 'atstart';
1372 $CPAN::Frontend->myprint(
1373 sprintf("Scanning cache %s for sizes\n",
1376 for $e ($self->entries($self->{ID})) {
1377 next if $e eq ".." || $e eq ".";
1378 $self->disk_usage($e);
1379 return if $CPAN::Signal;
1384 package CPAN::Shell;
1387 #-> sub CPAN::Shell::h ;
1389 my($class,$about) = @_;
1390 if (defined $about) {
1391 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1393 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1394 $CPAN::Frontend->myprint(qq{
1395 Display Information $filler (ver $CPAN::VERSION)
1396 command argument description
1397 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1398 i WORD or /REGEXP/ about any of the above
1399 ls AUTHOR or GLOB about files in the author's directory
1400 (with WORD being a module, bundle or author name or a distribution
1401 name of the form AUTHOR/DISTRIBUTION)
1403 Download, Test, Make, Install...
1404 get download clean make clean
1405 make make (implies get) look open subshell in dist directory
1406 test make test (implies make) readme display these README files
1407 install make install (implies test) perldoc display POD documentation
1410 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1411 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1414 force COMMAND unconditionally do command
1415 notest COMMAND skip testing
1418 h,? display this menu ! perl-code eval a perl command
1419 o conf [opt] set and query options q quit the cpan shell
1420 reload cpan load CPAN.pm again reload index load newer indices
1421 autobundle Snapshot recent latest CPAN uploads});
1427 #-> sub CPAN::Shell::a ;
1429 my($self,@arg) = @_;
1430 # authors are always UPPERCASE
1432 $_ = uc $_ unless /=/;
1434 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1437 #-> sub CPAN::Shell::globls ;
1439 my($self,$s,$pragmas) = @_;
1440 # ls is really very different, but we had it once as an ordinary
1441 # command in the Shell (upto rev. 321) and we could not handle
1443 my(@accept,@preexpand);
1444 if ($s =~ /[\*\?\/]/) {
1445 if ($CPAN::META->has_inst("Text::Glob")) {
1446 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1447 my $rau = Text::Glob::glob_to_regex(uc $au);
1448 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1450 push @preexpand, map { $_->id . "/" . $pathglob }
1451 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1453 my $rau = Text::Glob::glob_to_regex(uc $s);
1454 push @preexpand, map { $_->id }
1455 CPAN::Shell->expand_by_method('CPAN::Author',
1460 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1463 push @preexpand, uc $s;
1466 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1467 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1472 my $silent = @accept>1;
1473 my $last_alpha = "";
1475 for my $a (@accept){
1476 my($author,$pathglob);
1477 if ($a =~ m|(.*?)/(.*)|) {
1480 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1482 $a2) or die "No author found for $a2";
1484 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1486 $a) or die "No author found for $a";
1489 my $alpha = substr $author->id, 0, 1;
1491 if ($alpha eq $last_alpha) {
1495 $last_alpha = $alpha;
1497 $CPAN::Frontend->myprint($ad);
1499 for my $pragma (@$pragmas) {
1500 if ($author->can($pragma)) {
1504 push @results, $author->ls($pathglob,$silent); # silent if
1507 for my $pragma (@$pragmas) {
1508 my $unpragma = "un$pragma";
1509 if ($author->can($unpragma)) {
1510 $author->$unpragma();
1517 #-> sub CPAN::Shell::local_bundles ;
1519 my($self,@which) = @_;
1520 my($incdir,$bdir,$dh);
1521 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1522 my @bbase = "Bundle";
1523 while (my $bbase = shift @bbase) {
1524 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1525 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1526 if ($dh = DirHandle->new($bdir)) { # may fail
1528 for $entry ($dh->read) {
1529 next if $entry =~ /^\./;
1530 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1531 if (-d File::Spec->catdir($bdir,$entry)){
1532 push @bbase, "$bbase\::$entry";
1534 next unless $entry =~ s/\.pm(?!\n)\Z//;
1535 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1543 #-> sub CPAN::Shell::b ;
1545 my($self,@which) = @_;
1546 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1547 $self->local_bundles;
1548 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1551 #-> sub CPAN::Shell::d ;
1552 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1554 #-> sub CPAN::Shell::m ;
1555 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1557 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1560 #-> sub CPAN::Shell::i ;
1564 @args = '/./' unless @args;
1566 for my $type (qw/Bundle Distribution Module/) {
1567 push @result, $self->expand($type,@args);
1569 # Authors are always uppercase.
1570 push @result, $self->expand("Author", map { uc $_ } @args);
1572 my $result = @result == 1 ?
1573 $result[0]->as_string :
1575 "No objects found of any type for argument @args\n" :
1577 (map {$_->as_glimpse} @result),
1578 scalar @result, " items found\n",
1580 $CPAN::Frontend->myprint($result);
1583 #-> sub CPAN::Shell::o ;
1585 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1586 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1587 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1588 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1590 my($self,$o_type,@o_what) = @_;
1592 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1593 if ($o_type eq 'conf') {
1594 if (!@o_what) { # print all things, "o conf"
1596 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1598 if (exists $INC{'CPAN/Config.pm'}) {
1599 push @from, $INC{'CPAN/Config.pm'};
1601 if (exists $INC{'CPAN/MyConfig.pm'}) {
1602 push @from, $INC{'CPAN/MyConfig.pm'};
1604 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1605 $CPAN::Frontend->myprint(":\n");
1606 for $k (sort keys %CPAN::HandleConfig::can) {
1607 $v = $CPAN::HandleConfig::can{$k};
1608 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1610 $CPAN::Frontend->myprint("\n");
1611 for $k (sort keys %$CPAN::Config) {
1612 CPAN::HandleConfig->prettyprint($k);
1614 $CPAN::Frontend->myprint("\n");
1616 if (CPAN::HandleConfig->edit(@o_what)) {
1617 unless ($o_what[0] eq "init") {
1618 $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
1619 "make the config permanent!\n\n");
1622 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1626 } elsif ($o_type eq 'debug') {
1628 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1631 my($what) = shift @o_what;
1632 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1633 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1636 if ( exists $CPAN::DEBUG{$what} ) {
1637 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1638 } elsif ($what =~ /^\d/) {
1639 $CPAN::DEBUG = $what;
1640 } elsif (lc $what eq 'all') {
1642 for (values %CPAN::DEBUG) {
1645 $CPAN::DEBUG = $max;
1648 for (keys %CPAN::DEBUG) {
1649 next unless lc($_) eq lc($what);
1650 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1653 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1658 my $raw = "Valid options for debug are ".
1659 join(", ",sort(keys %CPAN::DEBUG), 'all').
1660 qq{ or a number. Completion works on the options. }.
1661 qq{Case is ignored.};
1663 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1664 $CPAN::Frontend->myprint("\n\n");
1667 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1669 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1670 $v = $CPAN::DEBUG{$k};
1671 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1672 if $v & $CPAN::DEBUG;
1675 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1678 $CPAN::Frontend->myprint(qq{
1680 conf set or get configuration variables
1681 debug set or get debugging options
1686 # CPAN::Shell::paintdots_onreload
1687 sub paintdots_onreload {
1690 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1694 # $CPAN::Frontend->myprint(".($subr)");
1695 $CPAN::Frontend->myprint(".");
1696 if ($subr =~ /\bshell\b/i) {
1697 # warn "debug[$_[0]]";
1699 # It would be nice if we could detect that a
1700 # subroutine has actually changed, but for now we
1701 # practically always set the GOTOSHELL global
1711 #-> sub CPAN::Shell::hosts ;
1714 my $fullstats = CPAN::FTP->_ftp_statistics();
1715 my $history = $fullstats->{history} || [];
1717 while (my $last = pop @$history) {
1718 my $attempts = $last->{attempts} or next;
1721 $start = $attempts->[-1]{start};
1722 if ($#$attempts > 0) {
1723 for my $i (0..$#$attempts-1) {
1724 my $url = $attempts->[$i]{url} or next;
1729 $start = $last->{start};
1731 next unless $last->{thesiteurl}; # C-C? bad filenames?
1733 $S{end} ||= $last->{end};
1734 my $dltime = $last->{end} - $start;
1735 my $dlsize = $last->{filesize} || 0;
1736 my $url = $last->{thesiteurl}->text;
1737 my $s = $S{ok}{$url} ||= {};
1740 $s->{dlsize} += $dlsize/1024;
1742 $s->{dltime} += $dltime;
1745 for my $url (keys %{$S{ok}}) {
1746 next if $S{ok}{$url}{dltime} == 0; # div by zero
1747 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1748 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1752 for my $url (keys %{$S{no}}) {
1753 push @{$res->{no}}, [$S{no}{$url},
1757 my $R = ""; # report
1758 $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown";
1759 $R .= sprintf "Log ends : %s\n", scalar(localtime $S{end}) || "unknown";
1760 if ($res->{ok} && @{$res->{ok}}) {
1761 $R .= sprintf "\nSuccessful downloads:
1762 N kB secs kB/s url\n";
1763 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1764 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1767 if ($res->{no} && @{$res->{no}}) {
1768 $R .= sprintf "\nUnsuccessful downloads:\n";
1769 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1770 $R .= sprintf "%4d %s\n", @$_;
1773 $CPAN::Frontend->myprint($R);
1776 #-> sub CPAN::Shell::reload ;
1778 my($self,$command,@arg) = @_;
1780 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1781 if ($command =~ /^cpan$/i) {
1783 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1787 "CPAN/HandleConfig.pm",
1788 "CPAN/FirstTime.pm",
1795 MFILE: for my $f (@relo) {
1796 next unless exists $INC{$f};
1800 $CPAN::Frontend->myprint("($p");
1801 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1802 $self->reload_this($f) or $failed++;
1803 my $v = eval "$p\::->VERSION";
1804 $CPAN::Frontend->myprint("v$v)");
1806 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1808 my $errors = $failed == 1 ? "error" : "errors";
1809 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1812 } elsif ($command =~ /^index$/i) {
1813 CPAN::Index->force_reload;
1815 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
1816 index re-reads the index files\n});
1820 # reload means only load again what we have loaded before
1821 #-> sub CPAN::Shell::reload_this ;
1823 my($self,$f,$args) = @_;
1824 CPAN->debug("f[$f]") if $CPAN::DEBUG;
1825 return 1 unless $INC{$f}; # we never loaded this, so we do not
1827 my $pwd = CPAN::anycwd();
1828 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1830 for my $inc (@INC) {
1831 $file = File::Spec->catfile($inc,split /\//, $f);
1835 CPAN->debug("file[$file]") if $CPAN::DEBUG;
1837 unless ($file && -f $file) {
1838 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1840 unless (CPAN->has_inst("File::Basename")) {
1841 @inc = File::Basename::dirname($file);
1843 # do we ever need this?
1844 @inc = substr($file,0,-length($f)-1); # bring in back to me!
1847 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1849 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1852 my $mtime = (stat $file)[9];
1853 $reload->{$f} ||= $^T;
1854 my $must_reload = $mtime > $reload->{$f};
1856 $must_reload ||= $args->{force};
1858 my $fh = FileHandle->new($file) or
1859 $CPAN::Frontend->mydie("Could not open $file: $!");
1862 my $content = <$fh>;
1863 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1867 eval "require '$f'";
1872 $reload->{$f} = time;
1874 $CPAN::Frontend->myprint("__unchanged__");
1879 #-> sub CPAN::Shell::mkmyconfig ;
1881 my($self, $cpanpm, %args) = @_;
1882 require CPAN::FirstTime;
1883 my $home = CPAN::HandleConfig::home;
1884 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1885 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1886 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1887 CPAN::HandleConfig::require_myconfig_or_config;
1888 $CPAN::Config ||= {};
1893 keep_source_where => undef,
1896 CPAN::FirstTime::init($cpanpm, %args);
1899 #-> sub CPAN::Shell::_binary_extensions ;
1900 sub _binary_extensions {
1901 my($self) = shift @_;
1902 my(@result,$module,%seen,%need,$headerdone);
1903 for $module ($self->expand('Module','/./')) {
1904 my $file = $module->cpan_file;
1905 next if $file eq "N/A";
1906 next if $file =~ /^Contact Author/;
1907 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1908 next if $dist->isa_perl;
1909 next unless $module->xs_file;
1911 $CPAN::Frontend->myprint(".");
1912 push @result, $module;
1914 # print join " | ", @result;
1915 $CPAN::Frontend->myprint("\n");
1919 #-> sub CPAN::Shell::recompile ;
1921 my($self) = shift @_;
1922 my($module,@module,$cpan_file,%dist);
1923 @module = $self->_binary_extensions();
1924 for $module (@module){ # we force now and compile later, so we
1926 $cpan_file = $module->cpan_file;
1927 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1929 $dist{$cpan_file}++;
1931 for $cpan_file (sort keys %dist) {
1932 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1933 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1935 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1936 # stop a package from recompiling,
1937 # e.g. IO-1.12 when we have perl5.003_10
1941 #-> sub CPAN::Shell::scripts ;
1943 my($self, $arg) = @_;
1944 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1946 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1947 unless ($CPAN::META->has_inst($req)) {
1948 $CPAN::Frontend->mywarn(" $req not available\n");
1951 my $p = HTML::LinkExtor->new();
1952 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1953 unless (-f $indexfile) {
1954 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1956 $p->parse_file($indexfile);
1959 if ($arg =~ s|^/(.+)/$|$1|) {
1960 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1962 for my $l ($p->links) {
1963 my $tag = shift @$l;
1964 next unless $tag eq "a";
1966 my $href = $att{href};
1967 next unless $href =~ s|^\.\./authors/id/./../||;
1970 if ($href =~ $qrarg) {
1974 if ($href =~ /\Q$arg\E/) {
1982 # now filter for the latest version if there is more than one of a name
1988 $stems{$stem} ||= [];
1989 push @{$stems{$stem}}, $href;
1991 for (sort keys %stems) {
1993 if (@{$stems{$_}} > 1) {
1994 $highest = List::Util::reduce {
1995 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1998 $highest = $stems{$_}[0];
2000 $CPAN::Frontend->myprint("$highest\n");
2004 #-> sub CPAN::Shell::report ;
2006 my($self,@args) = @_;
2007 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2008 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2010 local $CPAN::Config->{test_report} = 1;
2011 $self->force("test",@args); # force is there so that the test be
2012 # re-run (as documented)
2015 #-> sub CPAN::Shell::install_tested
2016 sub install_tested {
2017 my($self,@some) = @_;
2018 $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
2020 CPAN::Index->reload;
2022 for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) {
2023 my $do = CPAN::Shell->expandany($d);
2024 next unless $do->{build_dir};
2028 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2029 return unless @some;
2031 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2032 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2033 return unless @some;
2035 @some = grep { not $_->uptodate } @some;
2036 $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2037 return unless @some;
2039 CPAN->debug("some[@some]");
2041 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2042 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2043 $CPAN::Frontend->sleep(1);
2048 #-> sub CPAN::Shell::upgrade ;
2050 my($self,@args) = @_;
2051 $self->install($self->r(@args));
2054 #-> sub CPAN::Shell::_u_r_common ;
2056 my($self) = shift @_;
2057 my($what) = shift @_;
2058 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2059 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2060 $what && $what =~ /^[aru]$/;
2062 @args = '/./' unless @args;
2063 my(@result,$module,%seen,%need,$headerdone,
2064 $version_undefs,$version_zeroes);
2065 $version_undefs = $version_zeroes = 0;
2066 my $sprintf = "%s%-25s%s %9s %9s %s\n";
2067 my @expand = $self->expand('Module',@args);
2068 my $expand = scalar @expand;
2069 if (0) { # Looks like noise to me, was very useful for debugging
2070 # for metadata cache
2071 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2073 MODULE: for $module (@expand) {
2074 my $file = $module->cpan_file;
2075 next MODULE unless defined $file; # ??
2076 $file =~ s|^./../||;
2077 my($latest) = $module->cpan_version;
2078 my($inst_file) = $module->inst_file;
2080 return if $CPAN::Signal;
2083 $have = $module->inst_version;
2084 } elsif ($what eq "r") {
2085 $have = $module->inst_version;
2087 if ($have eq "undef"){
2089 } elsif ($have == 0){
2092 next MODULE unless CPAN::Version->vgt($latest, $have);
2093 # to be pedantic we should probably say:
2094 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2095 # to catch the case where CPAN has a version 0 and we have a version undef
2096 } elsif ($what eq "u") {
2102 } elsif ($what eq "r") {
2104 } elsif ($what eq "u") {
2108 return if $CPAN::Signal; # this is sometimes lengthy
2111 push @result, sprintf "%s %s\n", $module->id, $have;
2112 } elsif ($what eq "r") {
2113 push @result, $module->id;
2114 next MODULE if $seen{$file}++;
2115 } elsif ($what eq "u") {
2116 push @result, $module->id;
2117 next MODULE if $seen{$file}++;
2118 next MODULE if $file =~ /^Contact/;
2120 unless ($headerdone++){
2121 $CPAN::Frontend->myprint("\n");
2122 $CPAN::Frontend->myprint(sprintf(
2125 "Package namespace",
2137 $CPAN::META->has_inst("Term::ANSIColor")
2139 $module->description
2141 $color_on = Term::ANSIColor::color("green");
2142 $color_off = Term::ANSIColor::color("reset");
2144 $CPAN::Frontend->myprint(sprintf $sprintf,
2151 $need{$module->id}++;
2155 $CPAN::Frontend->myprint("No modules found for @args\n");
2156 } elsif ($what eq "r") {
2157 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2161 if ($version_zeroes) {
2162 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2163 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2164 qq{a version number of 0\n});
2166 if ($version_undefs) {
2167 my $s_has = $version_undefs > 1 ? "s have" : " has";
2168 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2169 qq{parseable version number\n});
2175 #-> sub CPAN::Shell::r ;
2177 shift->_u_r_common("r",@_);
2180 #-> sub CPAN::Shell::u ;
2182 shift->_u_r_common("u",@_);
2185 #-> sub CPAN::Shell::failed ;
2187 my($self,$only_id,$silent) = @_;
2189 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2191 NAY: for my $nosayer (
2200 next unless exists $d->{$nosayer};
2202 $d->{$nosayer}->can("failed") ?
2203 $d->{$nosayer}->failed :
2204 $d->{$nosayer} =~ /^NO/
2206 next NAY if $only_id && $only_id != (
2207 $d->{$nosayer}->can("commandid")
2209 $d->{$nosayer}->commandid
2211 $CPAN::CurrentCommandId
2216 next DIST unless $failed;
2220 # " %-45s: %s %s\n",
2223 $d->{$failed}->can("failed") ?
2225 $d->{$failed}->commandid,
2228 $d->{$failed}->text,
2238 my $scope = $only_id ? "command" : "session";
2240 my $print = join "",
2241 map { sprintf " %-45s: %s %s\n", @$_[1,2,3] }
2242 sort { $a->[0] <=> $b->[0] } @failed;
2243 $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
2244 } elsif (!$only_id || !$silent) {
2245 $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
2249 # XXX intentionally undocumented because completely bogus, unportable,
2252 #-> sub CPAN::Shell::status ;
2255 require Devel::Size;
2256 my $ps = FileHandle->new;
2257 open $ps, "/proc/$$/status";
2260 next unless /VmSize:\s+(\d+)/;
2264 $CPAN::Frontend->mywarn(sprintf(
2265 "%-27s %6d\n%-27s %6d\n",
2269 Devel::Size::total_size($CPAN::META)/1024,
2271 for my $k (sort keys %$CPAN::META) {
2272 next unless substr($k,0,4) eq "read";
2273 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2274 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2275 warn sprintf " %-25s %6d (keys: %6d)\n",
2277 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2278 scalar keys %{$CPAN::META->{$k}{$k2}};
2283 #-> sub CPAN::Shell::autobundle ;
2286 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2287 my(@bundle) = $self->_u_r_common("a",@_);
2288 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2289 File::Path::mkpath($todir);
2290 unless (-d $todir) {
2291 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2294 my($y,$m,$d) = (localtime)[5,4,3];
2298 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2299 my($to) = File::Spec->catfile($todir,"$me.pm");
2301 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2302 $to = File::Spec->catfile($todir,"$me.pm");
2304 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2306 "package Bundle::$me;\n\n",
2307 "\$VERSION = '0.01';\n\n",
2311 "Bundle::$me - Snapshot of installation on ",
2312 $Config::Config{'myhostname'},
2315 "\n\n=head1 SYNOPSIS\n\n",
2316 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2317 "=head1 CONTENTS\n\n",
2318 join("\n", @bundle),
2319 "\n\n=head1 CONFIGURATION\n\n",
2321 "\n\n=head1 AUTHOR\n\n",
2322 "This Bundle has been generated automatically ",
2323 "by the autobundle routine in CPAN.pm.\n",
2326 $CPAN::Frontend->myprint("\nWrote bundle file
2330 #-> sub CPAN::Shell::expandany ;
2333 CPAN->debug("s[$s]") if $CPAN::DEBUG;
2334 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2335 $s = CPAN::Distribution->normalize($s);
2336 return $CPAN::META->instance('CPAN::Distribution',$s);
2337 # Distributions spring into existence, not expand
2338 } elsif ($s =~ m|^Bundle::|) {
2339 $self->local_bundles; # scanning so late for bundles seems
2340 # both attractive and crumpy: always
2341 # current state but easy to forget
2343 return $self->expand('Bundle',$s);
2345 return $self->expand('Module',$s)
2346 if $CPAN::META->exists('CPAN::Module',$s);
2351 #-> sub CPAN::Shell::expand ;
2354 my($type,@args) = @_;
2355 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2356 my $class = "CPAN::$type";
2357 my $methods = ['id'];
2358 for my $meth (qw(name)) {
2359 next if $] < 5.00303; # no "can"
2360 next unless $class->can($meth);
2361 push @$methods, $meth;
2363 $self->expand_by_method($class,$methods,@args);
2366 #-> sub CPAN::Shell::expand_by_method ;
2367 sub expand_by_method {
2369 my($class,$methods,@args) = @_;
2372 my($regex,$command);
2373 if ($arg =~ m|^/(.*)/$|) {
2375 } elsif ($arg =~ m/=/) {
2379 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2381 defined $regex ? $regex : "UNDEFINED",
2382 defined $command ? $command : "UNDEFINED",
2384 if (defined $regex) {
2386 $CPAN::META->all_objects($class)
2389 # BUG, we got an empty object somewhere
2390 require Data::Dumper;
2391 CPAN->debug(sprintf(
2392 "Bug in CPAN: Empty id on obj[%s][%s]",
2394 Data::Dumper::Dumper($obj)
2398 for my $method (@$methods) {
2399 my $match = eval {$obj->$method() =~ /$regex/i};
2401 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2402 $err ||= $@; # if we were too restrictive above
2403 $CPAN::Frontend->mydie("$err\n");
2410 } elsif ($command) {
2411 die "equal sign in command disabled (immature interface), ".
2413 ! \$CPAN::Shell::ADVANCED_QUERY=1
2414 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2415 that may go away anytime.\n"
2416 unless $ADVANCED_QUERY;
2417 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2418 my($matchcrit) = $criterion =~ m/^~(.+)/;
2422 $CPAN::META->all_objects($class)
2424 my $lhs = $self->$method() or next; # () for 5.00503
2426 push @m, $self if $lhs =~ m/$matchcrit/;
2428 push @m, $self if $lhs eq $criterion;
2433 if ( $class eq 'CPAN::Bundle' ) {
2434 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2435 } elsif ($class eq "CPAN::Distribution") {
2436 $xarg = CPAN::Distribution->normalize($arg);
2440 if ($CPAN::META->exists($class,$xarg)) {
2441 $obj = $CPAN::META->instance($class,$xarg);
2442 } elsif ($CPAN::META->exists($class,$arg)) {
2443 $obj = $CPAN::META->instance($class,$arg);
2450 @m = sort {$a->id cmp $b->id} @m;
2451 if ( $CPAN::DEBUG ) {
2452 my $wantarray = wantarray;
2453 my $join_m = join ",", map {$_->id} @m;
2454 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2456 return wantarray ? @m : $m[0];
2459 #-> sub CPAN::Shell::format_result ;
2462 my($type,@args) = @_;
2463 @args = '/./' unless @args;
2464 my(@result) = $self->expand($type,@args);
2465 my $result = @result == 1 ?
2466 $result[0]->as_string :
2468 "No objects of type $type found for argument @args\n" :
2470 (map {$_->as_glimpse} @result),
2471 scalar @result, " items found\n",
2476 #-> sub CPAN::Shell::report_fh ;
2478 my $installation_report_fh;
2479 my $previously_noticed = 0;
2482 return $installation_report_fh if $installation_report_fh;
2483 if ($CPAN::META->has_inst("File::Temp")) {
2484 $installation_report_fh
2486 template => 'cpan_install_XXXX',
2491 unless ( $installation_report_fh ) {
2492 warn("Couldn't open installation report file; " .
2493 "no report file will be generated."
2494 ) unless $previously_noticed++;
2500 # The only reason for this method is currently to have a reliable
2501 # debugging utility that reveals which output is going through which
2502 # channel. No, I don't like the colors ;-)
2504 # to turn colordebugging on, write
2505 # cpan> o conf colorize_output 1
2507 #-> sub CPAN::Shell::print_ornamented ;
2509 my $print_ornamented_have_warned = 0;
2510 sub colorize_output {
2511 my $colorize_output = $CPAN::Config->{colorize_output};
2512 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2513 unless ($print_ornamented_have_warned++) {
2514 # no myprint/mywarn within myprint/mywarn!
2515 warn "Colorize_output is set to true but Term::ANSIColor is not
2516 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2518 $colorize_output = 0;
2520 return $colorize_output;
2525 #-> sub CPAN::Shell::print_ornamented ;
2526 sub print_ornamented {
2527 my($self,$what,$ornament) = @_;
2528 return unless defined $what;
2530 local $| = 1; # Flush immediately
2531 if ( $CPAN::Be_Silent ) {
2532 print {report_fh()} $what;
2535 my $swhat = "$what"; # stringify if it is an object
2536 if ($CPAN::Config->{term_is_latin}){
2539 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2541 if ($self->colorize_output) {
2542 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2543 # if you want to have this configurable, please file a bugreport
2544 $ornament = "black on_cyan";
2546 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2548 print "Term::ANSIColor rejects color[$ornament]: $@\n
2549 Please choose a different color (Hint: try 'o conf init color.*')\n";
2553 Term::ANSIColor::color("reset");
2559 #-> sub CPAN::Shell::myprint ;
2561 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2562 # where to use what! I think, we send everything to STDOUT and use
2563 # print for normal/good news and warn for news that need more
2564 # attention. Yes, this is our working contract for now.
2566 my($self,$what) = @_;
2568 $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2571 #-> sub CPAN::Shell::myexit ;
2573 my($self,$what) = @_;
2574 $self->myprint($what);
2578 #-> sub CPAN::Shell::mywarn ;
2580 my($self,$what) = @_;
2581 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2584 # only to be used for shell commands
2585 #-> sub CPAN::Shell::mydie ;
2587 my($self,$what) = @_;
2588 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2590 # If it is the shell, we want that the following die to be silent,
2591 # but if it is not the shell, we would need a 'die $what'. We need
2592 # to take care that only shell commands use mydie. Is this
2598 # sub CPAN::Shell::colorable_makemaker_prompt ;
2599 sub colorable_makemaker_prompt {
2601 if (CPAN::Shell->colorize_output) {
2602 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2603 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2606 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2607 if (CPAN::Shell->colorize_output) {
2608 print Term::ANSIColor::color('reset');
2613 # use this only for unrecoverable errors!
2614 #-> sub CPAN::Shell::unrecoverable_error ;
2615 sub unrecoverable_error {
2616 my($self,$what) = @_;
2617 my @lines = split /\n/, $what;
2619 for my $l (@lines) {
2620 $longest = length $l if length $l > $longest;
2622 $longest = 62 if $longest > 62;
2623 for my $l (@lines) {
2629 if (length $l < 66) {
2630 $l = pack "A66 A*", $l, "<==";
2634 unshift @lines, "\n";
2635 $self->mydie(join "", @lines);
2638 #-> sub CPAN::Shell::mysleep ;
2640 my($self, $sleep) = @_;
2644 #-> sub CPAN::Shell::setup_output ;
2646 return if -t STDOUT;
2647 my $odef = select STDERR;
2654 #-> sub CPAN::Shell::rematein ;
2655 # RE-adme||MA-ke||TE-st||IN-stall
2658 my($meth,@some) = @_;
2660 while($meth =~ /^(force|notest)$/) {
2661 push @pragma, $meth;
2662 $meth = shift @some or
2663 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2667 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2669 # Here is the place to set "test_count" on all involved parties to
2670 # 0. We then can pass this counter on to the involved
2671 # distributions and those can refuse to test if test_count > X. In
2672 # the first stab at it we could use a 1 for "X".
2674 # But when do I reset the distributions to start with 0 again?
2675 # Jost suggested to have a random or cycling interaction ID that
2676 # we pass through. But the ID is something that is just left lying
2677 # around in addition to the counter, so I'd prefer to set the
2678 # counter to 0 now, and repeat at the end of the loop. But what
2679 # about dependencies? They appear later and are not reset, they
2680 # enter the queue but not its copy. How do they get a sensible
2683 # construct the queue
2685 STHING: foreach $s (@some) {
2688 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2690 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2691 } elsif ($s =~ m|^/|) { # looks like a regexp
2692 if (substr($s,-1,1) eq ".") {
2693 $obj = CPAN::Shell->expandany($s);
2695 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2696 "not supported.\nRejecting argument '$s'\n");
2697 $CPAN::Frontend->mysleep(2);
2700 } elsif ($meth eq "ls") {
2701 $self->globls($s,\@pragma);
2704 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2705 $obj = CPAN::Shell->expandany($s);
2708 } elsif (ref $obj) {
2709 $obj->color_cmd_tmps(0,1);
2710 CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2712 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2713 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2714 if ($meth =~ /^(dump|ls)$/) {
2717 $CPAN::Frontend->mywarn(
2719 "Don't be silly, you can't $meth ",
2723 $CPAN::Frontend->mysleep(2);
2725 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2726 CPAN::InfoObj->dump($s);
2729 ->mywarn(qq{Warning: Cannot $meth $s, }.
2730 qq{don't know what it is.
2735 to find objects with matching identifiers.
2737 $CPAN::Frontend->mysleep(2);
2741 # queuerunner (please be warned: when I started to change the
2742 # queue to hold objects instead of names, I made one or two
2743 # mistakes and never found which. I reverted back instead)
2744 while (my $q = CPAN::Queue->first) {
2746 my $s = $q->as_string;
2747 my $reqtype = $q->reqtype || "";
2748 $obj = CPAN::Shell->expandany($s);
2749 $obj->{reqtype} ||= "";
2750 CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2751 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2752 if ($obj->{reqtype}) {
2753 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2754 $obj->{reqtype} = $reqtype;
2756 exists $obj->{install}
2759 $obj->{install}->can("failed") ?
2760 $obj->{install}->failed :
2761 $obj->{install} =~ /^NO/
2764 delete $obj->{install};
2765 $CPAN::Frontend->mywarn
2766 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2770 $obj->{reqtype} = $reqtype;
2773 for my $pragma (@pragma) {
2776 $obj->can($pragma)){
2777 $obj->$pragma($meth);
2780 if ($obj->can('called_for')) {
2781 $obj->called_for($s);
2783 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2784 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2788 CPAN::Queue->delete($s);
2790 CPAN->debug("failed");
2794 for my $pragma (@pragma) {
2795 my $unpragma = "un$pragma";
2796 if ($obj->can($unpragma)) {
2800 CPAN::Queue->delete_first($s);
2802 for my $obj (@qcopy) {
2803 $obj->color_cmd_tmps(0,0);
2807 #-> sub CPAN::Shell::recent ;
2811 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2816 # set up the dispatching methods
2818 for my $command (qw(
2833 *$command = sub { shift->rematein($command, @_); };
2837 package CPAN::LWP::UserAgent;
2841 return if $SETUPDONE;
2842 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2843 require LWP::UserAgent;
2844 @ISA = qw(Exporter LWP::UserAgent);
2847 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
2851 sub get_basic_credentials {
2852 my($self, $realm, $uri, $proxy) = @_;
2853 if ($USER && $PASSWD) {
2854 return ($USER, $PASSWD);
2857 ($USER,$PASSWD) = $self->get_proxy_credentials();
2859 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2861 return($USER,$PASSWD);
2864 sub get_proxy_credentials {
2866 my ($user, $password);
2867 if ( defined $CPAN::Config->{proxy_user} &&
2868 defined $CPAN::Config->{proxy_pass}) {
2869 $user = $CPAN::Config->{proxy_user};
2870 $password = $CPAN::Config->{proxy_pass};
2871 return ($user, $password);
2873 my $username_prompt = "\nProxy authentication needed!
2874 (Note: to permanently configure username and password run
2875 o conf proxy_user your_username
2876 o conf proxy_pass your_password
2878 ($user, $password) =
2879 _get_username_and_password_from_user($username_prompt);
2880 return ($user,$password);
2883 sub get_non_proxy_credentials {
2885 my ($user,$password);
2886 if ( defined $CPAN::Config->{username} &&
2887 defined $CPAN::Config->{password}) {
2888 $user = $CPAN::Config->{username};
2889 $password = $CPAN::Config->{password};
2890 return ($user, $password);
2892 my $username_prompt = "\nAuthentication needed!
2893 (Note: to permanently configure username and password run
2894 o conf username your_username
2895 o conf password your_password
2898 ($user, $password) =
2899 _get_username_and_password_from_user($username_prompt);
2900 return ($user,$password);
2903 sub _get_username_and_password_from_user {
2904 my $username_message = shift;
2905 my ($username,$password);
2907 ExtUtils::MakeMaker->import(qw(prompt));
2908 $username = prompt($username_message);
2909 if ($CPAN::META->has_inst("Term::ReadKey")) {
2910 Term::ReadKey::ReadMode("noecho");
2913 $CPAN::Frontend->mywarn(
2914 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2917 $password = prompt("Password:");
2919 if ($CPAN::META->has_inst("Term::ReadKey")) {
2920 Term::ReadKey::ReadMode("restore");
2922 $CPAN::Frontend->myprint("\n\n");
2923 return ($username,$password);
2926 # mirror(): Its purpose is to deal with proxy authentication. When we
2927 # call SUPER::mirror, we relly call the mirror method in
2928 # LWP::UserAgent. LWP::UserAgent will then call
2929 # $self->get_basic_credentials or some equivalent and this will be
2930 # $self->dispatched to our own get_basic_credentials method.
2932 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2934 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2935 # although we have gone through our get_basic_credentials, the proxy
2936 # server refuses to connect. This could be a case where the username or
2937 # password has changed in the meantime, so I'm trying once again without
2938 # $USER and $PASSWD to give the get_basic_credentials routine another
2939 # chance to set $USER and $PASSWD.
2941 # mirror(): Its purpose is to deal with proxy authentication. When we
2942 # call SUPER::mirror, we relly call the mirror method in
2943 # LWP::UserAgent. LWP::UserAgent will then call
2944 # $self->get_basic_credentials or some equivalent and this will be
2945 # $self->dispatched to our own get_basic_credentials method.
2947 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2949 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2950 # although we have gone through our get_basic_credentials, the proxy
2951 # server refuses to connect. This could be a case where the username or
2952 # password has changed in the meantime, so I'm trying once again without
2953 # $USER and $PASSWD to give the get_basic_credentials routine another
2954 # chance to set $USER and $PASSWD.
2957 my($self,$url,$aslocal) = @_;
2958 my $result = $self->SUPER::mirror($url,$aslocal);
2959 if ($result->code == 407) {
2962 $result = $self->SUPER::mirror($url,$aslocal);
2970 #-> sub CPAN::FTP::ftp_statistics
2971 # if they want to rewrite, they need to pass in a filehandle
2972 sub _ftp_statistics {
2974 my $locktype = $fh ? LOCK_EX : LOCK_SH;
2975 $fh ||= FileHandle->new;
2976 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
2977 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
2979 while (!flock $fh, $locktype|LOCK_NB) {
2983 $CPAN::Frontend->mysleep($sleep++);
2985 my $stats = CPAN->_yaml_loadfile($file);
2986 if ($locktype == LOCK_SH) {
2989 if (@$stats){ # no yaml no write
2997 if (CPAN->has_inst("Time::HiRes")) {
2998 return Time::HiRes::time();
3005 my($self,$file) = @_;
3014 sub _add_to_statistics {
3015 my($self,$stats) = @_;
3016 $stats->{thesiteurl} = $ThesiteURL;
3017 if (CPAN->has_inst("Time::HiRes")) {
3018 $stats->{end} = Time::HiRes::time();
3020 $stats->{end} = time;
3022 my $fh = FileHandle->new;
3023 my $fullstats = $self->_ftp_statistics($fh);
3024 push @{$fullstats->{history}}, $stats;
3026 shift @{$fullstats->{history}}
3027 while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
3028 CPAN->_yaml_dumpfile($fh,$fullstats);
3031 # if file is CHECKSUMS, suggest the place where we got the file to be
3032 # checked from, maybe only for young files?
3033 sub _recommend_url_for {
3034 my($self, $file) = @_;
3035 my $urllist = $self->_get_urllist;
3036 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3037 my $fullstats = $self->_ftp_statistics();
3038 my $history = $fullstats->{history} || [];
3039 while (my $last = pop @$history) {
3040 last if $last->{end} - time > 3600; # only young results are interesting
3041 next unless $file eq File::Basename::dirname($last->{file});
3042 return $last->{thesiteurl};
3045 if ($CPAN::Config->{randomize_urllist}
3047 rand(1) < $CPAN::Config->{randomize_urllist}
3049 $urllist->[int rand scalar @$urllist];
3057 $CPAN::Config->{urllist} ||= [];
3058 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3059 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
3060 $CPAN::Config->{urllist} = [];
3062 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3063 for my $u (@urllist) {
3064 CPAN->debug("u[$u]") if $CPAN::DEBUG;
3065 if (UNIVERSAL::can($u,"text")) {
3066 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3068 $u .= "/" unless substr($u,-1) eq "/";
3069 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3075 #-> sub CPAN::FTP::ftp_get ;
3077 my($class,$host,$dir,$file,$target) = @_;
3079 qq[Going to fetch file [$file] from dir [$dir]
3080 on host [$host] as local [$target]\n]
3082 my $ftp = Net::FTP->new($host);
3084 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
3087 return 0 unless defined $ftp;
3088 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3089 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3090 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3091 my $msg = $ftp->message;
3092 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
3095 unless ( $ftp->cwd($dir) ){
3096 my $msg = $ftp->message;
3097 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
3101 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3102 unless ( $ftp->get($file,$target) ){
3103 my $msg = $ftp->message;
3104 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
3107 $ftp->quit; # it's ok if this fails
3111 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3113 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
3114 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
3116 # > *** 1562,1567 ****
3117 # > --- 1562,1580 ----
3118 # > return 1 if substr($url,0,4) eq "file";
3119 # > return 1 unless $url =~ m|://([^/]+)|;
3121 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3123 # > + $proxy =~ m|://([^/:]+)|;
3125 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3126 # > + if ($noproxy) {
3127 # > + if ($host !~ /$noproxy$/) {
3128 # > + $host = $proxy;
3131 # > + $host = $proxy;
3134 # > require Net::Ping;
3135 # > return 1 unless $Net::Ping::VERSION >= 2;
3139 #-> sub CPAN::FTP::localize ;
3141 my($self,$file,$aslocal,$force) = @_;
3143 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3144 unless defined $aslocal;
3145 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3148 if ($^O eq 'MacOS') {
3149 # Comment by AK on 2000-09-03: Uniq short filenames would be
3150 # available in CHECKSUMS file
3151 my($name, $path) = File::Basename::fileparse($aslocal, '');
3152 if (length($name) > 31) {
3163 my $size = 31 - length($suf);
3164 while (length($name) > $size) {
3168 $aslocal = File::Spec->catfile($path, $name);
3172 if (-f $aslocal && -r _ && !($force & 1)){
3174 if ($size = -s $aslocal) {
3175 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3178 # empty file from a previous unsuccessful attempt to download it
3180 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3181 "could not remove.");
3184 my($maybe_restore) = 0;
3186 rename $aslocal, "$aslocal.bak$$";
3190 my($aslocal_dir) = File::Basename::dirname($aslocal);
3191 File::Path::mkpath($aslocal_dir);
3192 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3193 qq{directory "$aslocal_dir".
3194 I\'ll continue, but if you encounter problems, they may be due
3195 to insufficient permissions.\n}) unless -w $aslocal_dir;
3197 # Inheritance is not easier to manage than a few if/else branches
3198 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3200 CPAN::LWP::UserAgent->config;
3201 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3203 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3207 $Ua->proxy('ftp', $var)
3208 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3209 $Ua->proxy('http', $var)
3210 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3213 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3215 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3216 # > use ones that require basic autorization.
3218 # > Example of when I use it manually in my own stuff:
3220 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3221 # > $req->proxy_authorization_basic("username","password");
3222 # > $res = $ua->request($req);
3226 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3230 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3231 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3234 # Try the list of urls for each single object. We keep a record
3235 # where we did get a file from
3236 my(@reordered,$last);
3237 my $ccurllist = $self->_get_urllist;
3238 $last = $#$ccurllist;
3239 if ($force & 2) { # local cpans probably out of date, don't reorder
3240 @reordered = (0..$last);
3244 (substr($ccurllist->[$b],0,4) eq "file")
3246 (substr($ccurllist->[$a],0,4) eq "file")
3248 defined($ThesiteURL)
3250 ($ccurllist->[$b] eq $ThesiteURL)
3252 ($ccurllist->[$a] eq $ThesiteURL)
3257 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3259 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3261 @levels = qw/easy hard hardest/;
3263 @levels = qw/easy/ if $^O eq 'MacOS';
3265 local $ENV{FTP_PASSIVE} =
3266 exists $CPAN::Config->{ftp_passive} ?
3267 $CPAN::Config->{ftp_passive} : 1;
3269 my $stats = $self->_new_stats($file);
3270 LEVEL: for $levelno (0..$#levels) {
3271 my $level = $levels[$levelno];
3272 my $method = "host$level";
3273 my @host_seq = $level eq "easy" ?
3274 @reordered : 0..$last; # reordered has CDROM up front
3275 my @urllist = map { $ccurllist->[$_] } @host_seq;
3276 for my $u (@CPAN::Defaultsites) {
3277 push @urllist, $u unless grep { $_ eq $u } @urllist;
3279 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3280 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3281 if (my $recommend = $self->_recommend_url_for($file)) {
3282 @urllist = grep { $_ ne $recommend } @urllist;
3283 unshift @urllist, $recommend;
3285 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3286 $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3288 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3289 if ($ret eq $aslocal_tempfile) {
3290 # if we got it exactly as we asked for, only then we
3292 rename $aslocal_tempfile, $aslocal
3293 or $CPAN::Frontend->mydie("Error while trying to rename ".
3294 "'$ret' to '$aslocal': $!");
3297 $Themethod = $level;
3299 # utime $now, $now, $aslocal; # too bad, if we do that, we
3300 # might alter a local mirror
3301 $self->debug("level[$level]") if $CPAN::DEBUG;
3304 unlink $aslocal_tempfile;
3305 last if $CPAN::Signal; # need to cleanup
3309 $stats->{filesize} = -s $ret;
3311 $self->_add_to_statistics($stats);
3315 unless ($CPAN::Signal) {
3318 if (@{$CPAN::Config->{urllist}}) {
3320 qq{Please check, if the URLs I found in your configuration file \(}.
3321 join(", ", @{$CPAN::Config->{urllist}}).
3324 push @mess, qq{Your urllist is empty!};
3326 push @mess, qq{The urllist can be edited.},
3327 qq{E.g. with 'o conf urllist push ftp://myurl/'};
3328 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3329 $CPAN::Frontend->mywarn("Could not fetch $file\n");
3330 $CPAN::Frontend->mysleep(2);
3332 if ($maybe_restore) {
3333 rename "$aslocal.bak$$", $aslocal;
3334 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3335 $self->ls($aslocal));
3342 my($self,$stats,$method,$url) = @_;
3343 push @{$stats->{attempts}}, {
3350 # package CPAN::FTP;
3352 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3354 HOSTEASY: for $ro_url (@$host_seq) {
3355 $self->_set_attempt($stats,"easy",$ro_url);
3356 my $url .= "$ro_url$file";
3357 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3358 if ($url =~ /^file:/) {
3360 if ($CPAN::META->has_inst('URI::URL')) {
3361 my $u = URI::URL->new($url);
3363 } else { # works only on Unix, is poorly constructed, but
3364 # hopefully better than nothing.
3365 # RFC 1738 says fileurl BNF is
3366 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3367 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3369 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3370 $l =~ s|^file:||; # assume they
3374 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
3376 $self->debug("local file[$l]") if $CPAN::DEBUG;
3377 if ( -f $l && -r _) {
3378 $ThesiteURL = $ro_url;
3381 if ($l =~ /(.+)\.gz$/) {
3383 if ( -f $ungz && -r _) {
3384 $ThesiteURL = $ro_url;
3388 # Maybe mirror has compressed it?
3390 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3391 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
3393 $ThesiteURL = $ro_url;
3398 $self->debug("it was not a file URL") if $CPAN::DEBUG;
3399 if ($CPAN::META->has_usable('LWP')) {
3400 $CPAN::Frontend->myprint("Fetching with LWP:
3404 CPAN::LWP::UserAgent->config;
3405 eval { $Ua = CPAN::LWP::UserAgent->new; };
3407 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3410 my $res = $Ua->mirror($url, $aslocal);
3411 if ($res->is_success) {
3412 $ThesiteURL = $ro_url;
3414 utime $now, $now, $aslocal; # download time is more
3415 # important than upload
3418 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3419 my $gzurl = "$url.gz";
3420 $CPAN::Frontend->myprint("Fetching with LWP:
3423 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3424 if ($res->is_success &&
3425 CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
3427 $ThesiteURL = $ro_url;
3431 $CPAN::Frontend->myprint(sprintf(
3432 "LWP failed with code[%s] message[%s]\n",
3436 # Alan Burlison informed me that in firewall environments
3437 # Net::FTP can still succeed where LWP fails. So we do not
3438 # skip Net::FTP anymore when LWP is available.
3441 $CPAN::Frontend->mywarn(" LWP not available\n");
3443 return if $CPAN::Signal;
3444 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3445 # that's the nice and easy way thanks to Graham
3446 $self->debug("recognized ftp") if $CPAN::DEBUG;
3447 my($host,$dir,$getfile) = ($1,$2,$3);
3448 if ($CPAN::META->has_usable('Net::FTP')) {
3450 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3453 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3454 "aslocal[$aslocal]") if $CPAN::DEBUG;
3455 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3456 $ThesiteURL = $ro_url;
3459 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3460 my $gz = "$aslocal.gz";
3461 $CPAN::Frontend->myprint("Fetching with Net::FTP
3464 if (CPAN::FTP->ftp_get($host,
3468 CPAN::Tarzip->new($gz)->gunzip($aslocal)
3470 $ThesiteURL = $ro_url;
3476 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3480 UNIVERSAL::can($ro_url,"text")
3482 $ro_url->{FROM} eq "USER"
3484 ##address #17973: default URLs should not try to override
3485 ##user-defined URLs just because LWP is not available
3486 my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3487 return $ret if $ret;
3489 return if $CPAN::Signal;
3493 # package CPAN::FTP;
3495 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3497 # Came back if Net::FTP couldn't establish connection (or
3498 # failed otherwise) Maybe they are behind a firewall, but they
3499 # gave us a socksified (or other) ftp program...
3502 my($devnull) = $CPAN::Config->{devnull} || "";
3504 my($aslocal_dir) = File::Basename::dirname($aslocal);
3505 File::Path::mkpath($aslocal_dir);
3506 HOSTHARD: for $ro_url (@$host_seq) {
3507 $self->_set_attempt($stats,"hard",$ro_url);
3508 my $url = "$ro_url$file";
3509 my($proto,$host,$dir,$getfile);
3511 # Courtesy Mark Conty mark_conty@cargill.com change from
3512 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3514 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3515 # proto not yet used
3516 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3518 next HOSTHARD; # who said, we could ftp anything except ftp?
3520 next HOSTHARD if $proto eq "file"; # file URLs would have had
3521 # success above. Likely a bogus URL
3523 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3525 # Try the most capable first and leave ncftp* for last as it only
3527 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3528 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3529 next unless defined $funkyftp;
3530 next if $funkyftp =~ /^\s*$/;
3532 my($asl_ungz, $asl_gz);
3533 ($asl_ungz = $aslocal) =~ s/\.gz//;
3534 $asl_gz = "$asl_ungz.gz";
3536 my($src_switch) = "";
3538 my($stdout_redir) = " > $asl_ungz";
3540 $src_switch = " -source";
3541 } elsif ($f eq "ncftp"){
3542 $src_switch = " -c";
3543 } elsif ($f eq "wget"){
3544 $src_switch = " -O $asl_ungz";
3546 } elsif ($f eq 'curl'){
3547 $src_switch = ' -L -f -s -S --netrc-optional';
3550 if ($f eq "ncftpget"){
3551 $chdir = "cd $aslocal_dir && ";
3554 $CPAN::Frontend->myprint(
3556 Trying with "$funkyftp$src_switch" to get
3560 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3561 $self->debug("system[$system]") if $CPAN::DEBUG;
3562 my($wstatus) = system($system);
3564 # lynx returns 0 when it fails somewhere
3566 my $content = do { local *FH;
3567 open FH, $asl_ungz or die;
3570 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3571 $CPAN::Frontend->mywarn(qq{
3572 No success, the file that lynx has has downloaded looks like an error message:
3575 $CPAN::Frontend->mysleep(1);
3579 $CPAN::Frontend->myprint(qq{
3580 No success, the file that lynx has has downloaded is an empty file.
3585 if ($wstatus == 0) {
3588 } elsif ($asl_ungz ne $aslocal) {
3589 # test gzip integrity
3590 if (CPAN::Tarzip->new($asl_ungz)->gtest) {
3591 # e.g. foo.tar is gzipped --> foo.tar.gz
3592 rename $asl_ungz, $aslocal;
3594 CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
3597 $ThesiteURL = $ro_url;
3599 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3601 -f $asl_ungz && -s _ == 0;
3602 my $gz = "$aslocal.gz";
3603 my $gzurl = "$url.gz";
3604 $CPAN::Frontend->myprint(
3606 Trying with "$funkyftp$src_switch" to get
3609 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3610 $self->debug("system[$system]") if $CPAN::DEBUG;
3612 if (($wstatus = system($system)) == 0
3616 # test gzip integrity
3617 my $ct = CPAN::Tarzip->new($asl_gz);
3619 $ct->gunzip($aslocal);
3621 # somebody uncompressed file for us?
3622 rename $asl_ungz, $aslocal;
3624 $ThesiteURL = $ro_url;
3627 unlink $asl_gz if -f $asl_gz;
3630 my $estatus = $wstatus >> 8;
3631 my $size = -f $aslocal ?
3632 ", left\n$aslocal with size ".-s _ :
3633 "\nWarning: expected file [$aslocal] doesn't exist";
3634 $CPAN::Frontend->myprint(qq{
3635 System call "$system"
3636 returned status $estatus (wstat $wstatus)$size
3639 return if $CPAN::Signal;
3640 } # transfer programs
3644 # package CPAN::FTP;
3646 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3649 my($aslocal_dir) = File::Basename::dirname($aslocal);
3650 File::Path::mkpath($aslocal_dir);
3651 my $ftpbin = $CPAN::Config->{ftp};
3652 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3653 $CPAN::Frontend->myprint("No external ftp command available\n\n");
3656 $CPAN::Frontend->mywarn(qq{
3657 As a last ressort we now switch to the external ftp command '$ftpbin'
3660 Doing so often leads to problems that are hard to diagnose.
3662 If you're victim of such problems, please consider unsetting the ftp
3663 config variable with
3669 $CPAN::Frontend->mysleep(2);
3670 HOSTHARDEST: for $ro_url (@$host_seq) {
3671 $self->_set_attempt($stats,"hardest",$ro_url);
3672 my $url = "$ro_url$file";
3673 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3674 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3677 my($host,$dir,$getfile) = ($1,$2,$3);
3679 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3680 $ctime,$blksize,$blocks) = stat($aslocal);
3681 $timestamp = $mtime ||= 0;
3682 my($netrc) = CPAN::FTP::netrc->new;
3683 my($netrcfile) = $netrc->netrc;
3684 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3685 my $targetfile = File::Basename::basename($aslocal);
3691 map("cd $_", split /\//, $dir), # RFC 1738
3693 "get $getfile $targetfile",
3697 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3698 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3699 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3701 $netrc->contains($host))) if $CPAN::DEBUG;
3702 if ($netrc->protected) {
3703 my $dialog = join "", map { " $_\n" } @dialog;
3705 if ($netrc->contains($host)) {
3706 $netrc_explain = "Relying that your .netrc entry for '$host' ".
3707 "manages the login";
3709 $netrc_explain = "Relying that your default .netrc entry ".
3710 "manages the login";
3712 $CPAN::Frontend->myprint(qq{
3713 Trying with external ftp to get
3716 Going to send the dialog
3720 $self->talk_ftp("$ftpbin$verbose $host",
3722 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3723 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3725 if ($mtime > $timestamp) {
3726 $CPAN::Frontend->myprint("GOT $aslocal\n");
3727 $ThesiteURL = $ro_url;
3730 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3732 return if $CPAN::Signal;
3734 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3735 qq{correctly protected.\n});
3738 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3739 nor does it have a default entry\n");
3742 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3743 # then and login manually to host, using e-mail as
3745 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3749 "user anonymous $Config::Config{'cf_email'}"
3751 my $dialog = join "", map { " $_\n" } @dialog;
3752 $CPAN::Frontend->myprint(qq{
3753 Trying with external ftp to get
3755 Going to send the dialog
3759 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3760 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3761 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3763 if ($mtime > $timestamp) {
3764 $CPAN::Frontend->myprint("GOT $aslocal\n");
3765 $ThesiteURL = $ro_url;
3768 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3770 return if $CPAN::Signal;
3771 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3772 $CPAN::Frontend->mysleep(2);
3776 # package CPAN::FTP;
3778 my($self,$command,@dialog) = @_;
3779 my $fh = FileHandle->new;
3780 $fh->open("|$command") or die "Couldn't open ftp: $!";
3781 foreach (@dialog) { $fh->print("$_\n") }
3782 $fh->close; # Wait for process to complete
3784 my $estatus = $wstatus >> 8;
3785 $CPAN::Frontend->myprint(qq{
3786 Subprocess "|$command"
3787 returned status $estatus (wstat $wstatus)
3791 # find2perl needs modularization, too, all the following is stolen
3795 my($self,$name) = @_;
3796 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3797 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3799 my($perms,%user,%group);
3803 $blocks = int(($blocks + 1) / 2);
3806 $blocks = int(($sizemm + 1023) / 1024);
3809 if (-f _) { $perms = '-'; }
3810 elsif (-d _) { $perms = 'd'; }
3811 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3812 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3813 elsif (-p _) { $perms = 'p'; }
3814 elsif (-S _) { $perms = 's'; }
3815 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3817 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3818 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3819 my $tmpmode = $mode;
3820 my $tmp = $rwx[$tmpmode & 7];
3822 $tmp = $rwx[$tmpmode & 7] . $tmp;
3824 $tmp = $rwx[$tmpmode & 7] . $tmp;
3825 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3826 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3827 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3830 my $user = $user{$uid} || $uid; # too lazy to implement lookup
3831 my $group = $group{$gid} || $gid;
3833 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3835 my($moname) = $moname[$mon];
3836 if (-M _ > 365.25 / 2) {
3837 $timeyear = $year + 1900;
3840 $timeyear = sprintf("%02d:%02d", $hour, $min);
3843 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3857 package CPAN::FTP::netrc;
3860 # package CPAN::FTP::netrc;
3863 my $home = CPAN::HandleConfig::home;
3864 my $file = File::Spec->catfile($home,".netrc");
3866 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3867 $atime,$mtime,$ctime,$blksize,$blocks)
3872 my($fh,@machines,$hasdefault);
3874 $fh = FileHandle->new or die "Could not create a filehandle";
3876 if($fh->open($file)){
3877 $protected = ($mode & 077) == 0;
3879 NETRC: while (<$fh>) {
3880 my(@tokens) = split " ", $_;
3881 TOKEN: while (@tokens) {
3882 my($t) = shift @tokens;
3883 if ($t eq "default"){
3887 last TOKEN if $t eq "macdef";
3888 if ($t eq "machine") {
3889 push @machines, shift @tokens;
3894 $file = $hasdefault = $protected = "";
3898 'mach' => [@machines],
3900 'hasdefault' => $hasdefault,
3901 'protected' => $protected,
3905 # CPAN::FTP::netrc::hasdefault;
3906 sub hasdefault { shift->{'hasdefault'} }
3907 sub netrc { shift->{'netrc'} }
3908 sub protected { shift->{'protected'} }
3910 my($self,$mach) = @_;
3911 for ( @{$self->{'mach'}} ) {
3912 return 1 if $_ eq $mach;
3917 package CPAN::Complete;
3921 my($text, $line, $start, $end) = @_;
3922 my(@perlret) = cpl($text, $line, $start);
3923 # find longest common match. Can anybody show me how to peruse
3924 # T::R::Gnu to have this done automatically? Seems expensive.
3925 return () unless @perlret;
3926 my($newtext) = $text;
3927 for (my $i = length($text)+1;;$i++) {
3928 last unless length($perlret[0]) && length($perlret[0]) >= $i;
3929 my $try = substr($perlret[0],0,$i);
3930 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3931 # warn "try[$try]tries[@tries]";
3932 if (@tries == @perlret) {
3938 ($newtext,@perlret);
3941 #-> sub CPAN::Complete::cpl ;
3943 my($word,$line,$pos) = @_;
3947 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3949 if ($line =~ s/^(force\s*)//) {
3954 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3955 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3957 } elsif ($line =~ /^(a|ls)\s/) {
3958 @return = cplx('CPAN::Author',uc($word));
3959 } elsif ($line =~ /^b\s/) {
3960 CPAN::Shell->local_bundles;
3961 @return = cplx('CPAN::Bundle',$word);
3962 } elsif ($line =~ /^d\s/) {
3963 @return = cplx('CPAN::Distribution',$word);
3964 } elsif ($line =~ m/^(
3965 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3967 if ($word =~ /^Bundle::/) {
3968 CPAN::Shell->local_bundles;
3970 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3971 } elsif ($line =~ /^i\s/) {
3972 @return = cpl_any($word);
3973 } elsif ($line =~ /^reload\s/) {
3974 @return = cpl_reload($word,$line,$pos);
3975 } elsif ($line =~ /^o\s/) {
3976 @return = cpl_option($word,$line,$pos);
3977 } elsif ($line =~ m/^\S+\s/ ) {
3978 # fallback for future commands and what we have forgotten above
3979 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3986 #-> sub CPAN::Complete::cplx ;
3988 my($class, $word) = @_;
3989 # I believed for many years that this was sorted, today I
3990 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3991 # make it sorted again. Maybe sort was dropped when GNU-readline
3992 # support came in? The RCS file is difficult to read on that:-(
3993 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3996 #-> sub CPAN::Complete::cpl_any ;
4000 cplx('CPAN::Author',$word),
4001 cplx('CPAN::Bundle',$word),
4002 cplx('CPAN::Distribution',$word),
4003 cplx('CPAN::Module',$word),
4007 #-> sub CPAN::Complete::cpl_reload ;
4009 my($word,$line,$pos) = @_;
4011 my(@words) = split " ", $line;
4012 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4013 my(@ok) = qw(cpan index);
4014 return @ok if @words == 1;
4015 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4018 #-> sub CPAN::Complete::cpl_option ;
4020 my($word,$line,$pos) = @_;
4022 my(@words) = split " ", $line;
4023 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4024 my(@ok) = qw(conf debug);
4025 return @ok if @words == 1;
4026 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4028 } elsif ($words[1] eq 'index') {
4030 } elsif ($words[1] eq 'conf') {
4031 return CPAN::HandleConfig::cpl(@_);
4032 } elsif ($words[1] eq 'debug') {
4033 return sort grep /^\Q$word\E/i,
4034 sort keys %CPAN::DEBUG, 'all';
4038 package CPAN::Index;
4041 #-> sub CPAN::Index::force_reload ;
4044 $CPAN::Index::LAST_TIME = 0;
4048 #-> sub CPAN::Index::reload ;
4050 my($self,$force) = @_;
4053 # XXX check if a newer one is available. (We currently read it
4054 # from time to time)
4055 for ($CPAN::Config->{index_expire}) {
4056 $_ = 0.001 unless $_ && $_ > 0.001;
4058 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4059 # debug here when CPAN doesn't seem to read the Metadata
4061 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4063 unless ($CPAN::META->{PROTOCOL}) {
4064 $self->read_metadata_cache;
4065 $CPAN::META->{PROTOCOL} ||= "1.0";
4067 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
4068 # warn "Setting last_time to 0";
4069 $LAST_TIME = 0; # No warning necessary
4071 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4074 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4076 # IFF we are developing, it helps to wipe out the memory
4077 # between reloads, otherwise it is not what a user expects.
4078 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4079 $CPAN::META = CPAN->new;
4082 local $LAST_TIME = $time;
4083 local $CPAN::META->{PROTOCOL} = PROTOCOL;
4085 my $needshort = $^O eq "dos";
4087 $self->rd_authindex($self
4089 "authors/01mailrc.txt.gz",
4091 File::Spec->catfile('authors', '01mailrc.gz') :
4092 File::Spec->catfile('authors', '01mailrc.txt.gz'),
4095 $debug = "timing reading 01[".($t2 - $time)."]";
4097 return if $CPAN::Signal; # this is sometimes lengthy
4098 $self->rd_modpacks($self
4100 "modules/02packages.details.txt.gz",
4102 File::Spec->catfile('modules', '02packag.gz') :
4103 File::Spec->catfile('modules', '02packages.details.txt.gz'),
4106 $debug .= "02[".($t2 - $time)."]";
4108 return if $CPAN::Signal; # this is sometimes lengthy
4109 $self->rd_modlist($self
4111 "modules/03modlist.data.gz",
4113 File::Spec->catfile('modules', '03mlist.gz') :
4114 File::Spec->catfile('modules', '03modlist.data.gz'),
4116 $self->write_metadata_cache;
4118 $debug .= "03[".($t2 - $time)."]";
4120 CPAN->debug($debug) if $CPAN::DEBUG;
4122 if ($CPAN::Config->{build_dir_reuse}) {
4123 $self->reanimate_build_dir;
4126 $CPAN::META->{PROTOCOL} = PROTOCOL;
4129 #-> sub CPAN::Index::reanimate_build_dir ;
4130 sub reanimate_build_dir {
4132 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4135 return if $HAVE_REANIMATED++;
4136 my $d = $CPAN::Config->{build_dir};
4137 my $dh = DirHandle->new;
4138 opendir $dh, $d or return; # does not exist
4143 $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4144 my @candidates = grep {/\.yml$/} readdir $dh;
4145 DISTRO: for $dirent (@candidates) {
4146 my $c = CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))->[0];
4147 if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4148 my $key = $c->{distribution}{ID};
4149 for my $k (keys %{$c->{distribution}}) {
4150 if ($c->{distribution}{$k}
4151 && ref $c->{distribution}{$k}
4152 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4153 # the correct algorithm would be a
4154 # two-pass and we would subtract the
4155 # maximum of all old commands minus 2
4156 $c->{distribution}{$k}{COMMANDID} -= scalar @candidates - 2 ;
4160 #we tried to restore only if element already
4161 #exists; but then we do not work with metadata
4163 $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} = $c->{distribution};
4167 while (($painted/76) < ($i/@candidates)) {
4168 $CPAN::Frontend->myprint(".");
4172 $CPAN::Frontend->myprint(sprintf(
4173 "DONE\nFound %s old builds, restored the state of %s\n",
4174 @candidates ? sprintf("%d",scalar @candidates) : "no",
4175 $restored || "none",
4180 #-> sub CPAN::Index::reload_x ;
4182 my($cl,$wanted,$localname,$force) = @_;
4183 $force |= 2; # means we're dealing with an index here
4184 CPAN::HandleConfig->load; # we should guarantee loading wherever
4185 # we rely on Config XXX
4186 $localname ||= $wanted;
4187 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4191 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4194 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4195 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4196 qq{day$s. I\'ll use that.});
4199 $force |= 1; # means we're quite serious about it.
4201 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4204 #-> sub CPAN::Index::rd_authindex ;
4206 my($cl, $index_target) = @_;
4208 return unless defined $index_target;
4209 $CPAN::Frontend->myprint("Going to read $index_target\n");
4211 tie *FH, 'CPAN::Tarzip', $index_target;
4214 push @lines, split /\012/ while <FH>;
4216 my $modulus = int($#lines/75) || 1;
4217 CPAN->debug(sprintf "modulus[%d]lines[%s]", $modulus, scalar @lines) if $CPAN::DEBUG;
4219 my($userid,$fullname,$email) =
4220 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4221 $fullname ||= $email;
4222 if ($userid && $fullname && $email){
4223 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4224 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4226 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4228 $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
4229 return if $CPAN::Signal;
4231 $CPAN::Frontend->myprint("DONE\n");
4235 my($self,$dist) = @_;
4236 $dist = $self->{'id'} unless defined $dist;
4237 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4241 #-> sub CPAN::Index::rd_modpacks ;
4243 my($self, $index_target) = @_;
4244 return unless defined $index_target;
4245 $CPAN::Frontend->myprint("Going to read $index_target\n");
4246 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4248 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4251 while (my $bytes = $fh->READ(\$chunk,8192)) {
4254 my @lines = split /\012/, $slurp;
4255 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4258 my($line_count,$last_updated);
4260 my $shift = shift(@lines);
4261 last if $shift =~ /^\s*$/;
4262 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4263 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4265 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4266 if (not defined $line_count) {
4268 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4269 Please check the validity of the index file by comparing it to more
4270 than one CPAN mirror. I'll continue but problems seem likely to
4274 $CPAN::Frontend->mysleep(5);
4275 } elsif ($line_count != scalar @lines) {
4277 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4278 contains a Line-Count header of %d but I see %d lines there. Please
4279 check the validity of the index file by comparing it to more than one
4280 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4281 $index_target, $line_count, scalar(@lines));
4284 if (not defined $last_updated) {
4286 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4287 Please check the validity of the index file by comparing it to more
4288 than one CPAN mirror. I'll continue but problems seem likely to
4292 $CPAN::Frontend->mysleep(5);
4296 ->myprint(sprintf qq{ Database was generated on %s\n},
4298 $DATE_OF_02 = $last_updated;
4301 if ($CPAN::META->has_inst('HTTP::Date')) {
4303 $age -= HTTP::Date::str2time($last_updated);
4305 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
4306 require Time::Local;
4307 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4308 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4309 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4316 qq{Warning: This index file is %d days old.
4317 Please check the host you chose as your CPAN mirror for staleness.
4318 I'll continue but problems seem likely to happen.\a\n},
4321 } elsif ($age < -1) {
4325 qq{Warning: Your system date is %d days behind this index file!
4327 Timestamp index file: %s
4328 Please fix your system time, problems with the make command expected.\n},
4338 # A necessity since we have metadata_cache: delete what isn't
4340 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4341 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4344 my $modulus = int($#lines/75) || 1;
4346 # before 1.56 we split into 3 and discarded the rest. From
4347 # 1.57 we assign remaining text to $comment thus allowing to
4348 # influence isa_perl
4349 my($mod,$version,$dist,$comment) = split " ", $_, 4;
4350 my($bundle,$id,$userid);
4352 if ($mod eq 'CPAN' &&
4354 CPAN::Queue->exists('Bundle::CPAN') ||
4355 CPAN::Queue->exists('CPAN')
4359 if ($version > $CPAN::VERSION){
4360 $CPAN::Frontend->mywarn(qq{
4361 New CPAN.pm version (v$version) available.
4362 [Currently running version is v$CPAN::VERSION]
4363 You might want to try
4366 to both upgrade CPAN.pm and run the new version without leaving
4367 the current session.
4370 $CPAN::Frontend->mysleep(2);
4371 $CPAN::Frontend->myprint(qq{\n});
4373 last if $CPAN::Signal;
4374 } elsif ($mod =~ /^Bundle::(.*)/) {
4379 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
4380 # Let's make it a module too, because bundles have so much
4381 # in common with modules.
4383 # Changed in 1.57_63: seems like memory bloat now without
4384 # any value, so commented out
4386 # $CPAN::META->instance('CPAN::Module',$mod);
4390 # instantiate a module object
4391 $id = $CPAN::META->instance('CPAN::Module',$mod);
4395 # Although CPAN prohibits same name with different version the
4396 # indexer may have changed the version for the same distro
4397 # since the last time ("Force Reindexing" feature)
4398 if ($id->cpan_file ne $dist
4400 $id->cpan_version ne $version
4402 $userid = $id->userid || $self->userid($dist);
4404 'CPAN_USERID' => $userid,
4405 'CPAN_VERSION' => $version,
4406 'CPAN_FILE' => $dist,
4410 # instantiate a distribution object
4411 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4412 # we do not need CONTAINSMODS unless we do something with
4413 # this dist, so we better produce it on demand.
4415 ## my $obj = $CPAN::META->instance(
4416 ## 'CPAN::Distribution' => $dist
4418 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4420 $CPAN::META->instance(
4421 'CPAN::Distribution' => $dist
4423 'CPAN_USERID' => $userid,
4424 'CPAN_COMMENT' => $comment,
4428 for my $name ($mod,$dist) {
4429 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4430 $exists{$name} = undef;
4433 $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
4434 return if $CPAN::Signal;
4436 $CPAN::Frontend->myprint("DONE\n");