1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $CPAN::VERSION = '1.88_63';
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';
44 $ENV{PERL5_CPAN_IS_RUNNING}=1;
46 END { $CPAN::End++; &cleanup; }
49 $CPAN::Frontend ||= "CPAN::Shell";
50 unless (@CPAN::Defaultsites){
51 @CPAN::Defaultsites = map {
52 CPAN::URL->new(TEXT => $_, FROM => "DEF")
54 "http://www.perl.org/CPAN/",
55 "ftp://ftp.perl.org/pub/CPAN/";
57 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
58 $CPAN::Perl ||= CPAN::find_perl();
59 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
60 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
62 # our globals are getting a mess
86 @CPAN::ISA = qw(CPAN::Debug Exporter);
88 # note that these functions live in CPAN::Shell and get executed via
89 # AUTOLOAD when called directly
113 sub soft_chdir_with_alternatives ($);
116 $autoload_recursion ||= 0;
118 #-> sub CPAN::AUTOLOAD ;
120 $autoload_recursion++;
124 warn "Refusing to autoload '$l' while signal pending";
125 $autoload_recursion--;
128 if ($autoload_recursion > 1) {
129 my $fullcommand = join " ", map { "'$_'" } $l, @_;
130 warn "Refusing to autoload $fullcommand in recursion\n";
131 $autoload_recursion--;
135 @export{@EXPORT} = '';
136 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
137 if (exists $export{$l}){
140 die(qq{Unknown CPAN command "$AUTOLOAD". }.
141 qq{Type ? for help.\n});
143 $autoload_recursion--;
147 #-> sub CPAN::shell ;
150 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
151 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
153 my $oprompt = shift || CPAN::Prompt->new;
154 my $prompt = $oprompt;
155 my $commandline = shift || "";
156 $CPAN::CurrentCommandId ||= 1;
159 unless ($Suppress_readline) {
160 require Term::ReadLine;
163 $term->ReadLine eq "Term::ReadLine::Stub"
165 $term = Term::ReadLine->new('CPAN Monitor');
167 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
168 my $attribs = $term->Attribs;
169 $attribs->{attempted_completion_function} = sub {
170 &CPAN::Complete::gnu_cpl;
173 $readline::rl_completion_function =
174 $readline::rl_completion_function = 'CPAN::Complete::cpl';
176 if (my $histfile = $CPAN::Config->{'histfile'}) {{
177 unless ($term->can("AddHistory")) {
178 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
181 my($fh) = FileHandle->new;
182 open $fh, "<$histfile" or last;
186 $term->AddHistory($_);
190 for ($CPAN::Config->{term_ornaments}) { # alias
191 local $Term::ReadLine::termcap_nowarn = 1;
192 $term->ornaments($_) if defined;
194 # $term->OUT is autoflushed anyway
195 my $odef = select STDERR;
202 # no strict; # I do not recall why no strict was here (2000-09-03)
204 my @cwd = grep { defined $_ and length $_ }
206 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
207 File::Spec->rootdir();
208 my $try_detect_readline;
209 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
210 my $rl_avail = $Suppress_readline ? "suppressed" :
211 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
212 "available (try 'install Bundle::CPAN')";
214 unless ($CPAN::Config->{'inhibit_startup_message'}){
215 $CPAN::Frontend->myprint(
217 cpan shell -- CPAN exploration and modules installation (v%s)
225 my($continuation) = "";
226 my $last_term_ornaments;
227 SHELLCOMMAND: while () {
228 if ($Suppress_readline) {
230 last SHELLCOMMAND unless defined ($_ = <> );
233 last SHELLCOMMAND unless
234 defined ($_ = $term->readline($prompt, $commandline));
236 $_ = "$continuation$_" if $continuation;
238 next SHELLCOMMAND if /^$/;
239 $_ = 'h' if /^\s*\?/;
240 if (/^(?:q(?:uit)?|bye|exit)$/i) {
251 use vars qw($import_done);
252 CPAN->import(':DEFAULT') unless $import_done++;
253 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
260 eval { @line = Text::ParseWords::shellwords($_) };
261 warn($@), next SHELLCOMMAND if $@;
262 warn("Text::Parsewords could not parse the line [$_]"),
263 next SHELLCOMMAND unless @line;
264 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
265 my $command = shift @line;
266 eval { CPAN::Shell->$command(@line) };
271 if ($command =~ /^(make|test|install|force|notest|clean|report|upgrade)$/) {
272 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
274 soft_chdir_with_alternatives(\@cwd);
275 $CPAN::Frontend->myprint("\n");
277 $CPAN::CurrentCommandId++;
281 $commandline = ""; # I do want to be able to pass a default to
282 # shell, but on the second command I see no
285 CPAN::Queue->nullify_queue;
286 if ($try_detect_readline) {
287 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
289 $CPAN::META->has_inst("Term::ReadLine::Perl")
291 delete $INC{"Term/ReadLine.pm"};
293 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
294 require Term::ReadLine;
295 $CPAN::Frontend->myprint("\n$redef subroutines in ".
296 "Term::ReadLine redefined\n");
300 if ($term and $term->can("ornaments")) {
301 for ($CPAN::Config->{term_ornaments}) { # alias
303 if (not defined $last_term_ornaments
304 or $_ != $last_term_ornaments
306 local $Term::ReadLine::termcap_nowarn = 1;
307 $term->ornaments($_);
308 $last_term_ornaments = $_;
311 undef $last_term_ornaments;
315 for my $class (qw(Module Distribution)) {
316 # again unsafe meta access?
317 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
318 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
319 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
320 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
324 $GOTOSHELL = 0; # not too often
325 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
330 soft_chdir_with_alternatives(\@cwd);
333 sub soft_chdir_with_alternatives ($) {
336 my $root = File::Spec->rootdir();
337 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
338 Trying '$root' as temporary haven.
343 if (chdir $cwd->[0]) {
347 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
348 Trying to chdir to "$cwd->[1]" instead.
352 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
359 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
361 $yaml_module ne "YAML"
363 !$CPAN::META->has_inst($yaml_module)
365 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
366 $yaml_module = "YAML";
371 # CPAN::_yaml_loadfile
373 my($self,$local_file) = @_;
374 return +[] unless -s $local_file;
375 my $yaml_module = $self->_yaml_module;
376 if ($CPAN::META->has_inst($yaml_module)) {
377 my $code = UNIVERSAL::can($yaml_module, "LoadFile");
379 eval { @yaml = $code->($local_file); };
381 $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
383 "with $yaml_module the following error was encountered:\n".
389 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
394 # CPAN::_yaml_dumpfile
396 my($self,$to_local_file,@what) = @_;
397 my $yaml_module = $self->_yaml_module;
398 if ($CPAN::META->has_inst($yaml_module)) {
399 if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
400 my $code = UNIVERSAL::can($yaml_module, "Dump");
401 eval { print $to_local_file $code->(@what) };
403 my $code = UNIVERSAL::can($yaml_module, "DumpFile");
404 eval { $code->($to_local_file,@what); };
407 $CPAN::Frontend->mydie("Alert: While trying to dump YAML file\n".
409 "with $yaml_module the following error was encountered:\n".
414 if (UNIVERSAL::isa($to_local_file, "FileHandle")) {
415 # I think this case does not justify a warning at all
417 $CPAN::Frontend->myprint("Note (usually harmless): '$yaml_module' ".
418 "not installed, not dumping to '$to_local_file'\n");
423 sub _init_sqlite () {
424 unless ($CPAN::META->has_inst("CPAN::SQLite")
426 $CPAN::META->has_inst("CPAN::SQLite::META")
428 $CPAN::Frontend->mywarn(qq{SQLite not installed, cannot work with CPAN::SQLite});
431 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
434 package CPAN::CacheMgr;
436 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
441 use Fcntl qw(:flock);
442 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
443 @CPAN::FTP::ISA = qw(CPAN::Debug);
445 package CPAN::LWP::UserAgent;
447 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
448 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
450 package CPAN::Complete;
452 @CPAN::Complete::ISA = qw(CPAN::Debug);
453 # Q: where is the "How do I add a new command" HOWTO?
454 # A: svn diff -r 1048:1049 where andk added the report command
455 @CPAN::Complete::COMMANDS = sort qw(
456 ! a b d h i m o q r u
483 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
484 @CPAN::Index::ISA = qw(CPAN::Debug);
487 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
490 package CPAN::InfoObj;
492 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
494 package CPAN::Author;
496 @CPAN::Author::ISA = qw(CPAN::InfoObj);
498 package CPAN::Distribution;
500 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
502 package CPAN::Bundle;
504 @CPAN::Bundle::ISA = qw(CPAN::Module);
506 package CPAN::Module;
508 @CPAN::Module::ISA = qw(CPAN::InfoObj);
510 package CPAN::Exception::RecursiveDependency;
512 use overload '""' => "as_string";
519 for my $dep (@$deps) {
521 last if $seen{$dep}++;
523 bless { deps => \@deps }, $class;
528 "\nRecursive dependency detected:\n " .
529 join("\n => ", @{$self->{deps}}) .
530 ".\nCannot continue.\n";
533 package CPAN::Prompt; use overload '""' => "as_string";
534 use vars qw($prompt);
536 $CPAN::CurrentCommandId ||= 0;
542 unless ($CPAN::META->{LOCK}) {
543 $word = "nolock_cpan";
545 if ($CPAN::Config->{commandnumber_in_prompt}) {
546 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
552 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
553 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
554 # planned are things like age or quality
556 my($class,%args) = @_;
568 $self->{TEXT} = $set;
573 package CPAN::Distrostatus;
574 use overload '""' => "as_string",
577 my($class,$arg) = @_;
580 FAILED => substr($arg,0,2) eq "NO",
581 COMMANDID => $CPAN::CurrentCommandId,
585 sub commandid { shift->{COMMANDID} }
586 sub failed { shift->{FAILED} }
590 $self->{TEXT} = $set;
609 @CPAN::Shell::ISA = qw(CPAN::Debug);
610 $COLOR_REGISTERED ||= 0;
613 $autoload_recursion ||= 0;
615 #-> sub CPAN::Shell::AUTOLOAD ;
617 $autoload_recursion++;
619 my $class = shift(@_);
620 # warn "autoload[$l] class[$class]";
623 warn "Refusing to autoload '$l' while signal pending";
624 $autoload_recursion--;
627 if ($autoload_recursion > 1) {
628 my $fullcommand = join " ", map { "'$_'" } $l, @_;
629 warn "Refusing to autoload $fullcommand in recursion\n";
630 $autoload_recursion--;
634 # XXX needs to be reconsidered
635 if ($CPAN::META->has_inst('CPAN::WAIT')) {
638 $CPAN::Frontend->mywarn(qq{
639 Commands starting with "w" require CPAN::WAIT to be installed.
640 Please consider installing CPAN::WAIT to use the fulltext index.
641 For this you just need to type
646 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
650 $autoload_recursion--;
657 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
659 # from here on only subs.
660 ################################################################################
662 sub _perl_fingerprint {
663 my($self,$other_fingerprint) = @_;
664 my $dll = eval {OS2::DLLname()};
667 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
669 my $this_fingerprint = {
671 sitearchexp => $Config::Config{sitearchexp},
672 'mtime_$^X' => (stat $^X)[9],
673 'mtime_dll' => $mtime_dll,
675 if ($other_fingerprint) {
676 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
677 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
679 # mandatory keys since 1.88_57
680 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
681 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
685 return $this_fingerprint;
689 sub suggest_myconfig () {
690 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
691 $CPAN::Frontend->myprint("You don't seem to have a user ".
692 "configuration (MyConfig.pm) yet.\n");
693 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
694 "user configuration now? (Y/n)",
697 CPAN::Shell->mkmyconfig();
700 $CPAN::Frontend->mydie("OK, giving up.");
705 #-> sub CPAN::all_objects ;
707 my($mgr,$class) = @_;
708 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
709 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
711 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
714 # Called by shell, not in batch mode. In batch mode I see no risk in
715 # having many processes updating something as installations are
716 # continually checked at runtime. In shell mode I suspect it is
717 # unintentional to open more than one shell at a time
719 #-> sub CPAN::checklock ;
722 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
723 if (-f $lockfile && -M _ > 0) {
724 my $fh = FileHandle->new($lockfile) or
725 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
726 my $otherpid = <$fh>;
727 my $otherhost = <$fh>;
729 if (defined $otherpid && $otherpid) {
732 if (defined $otherhost && $otherhost) {
735 my $thishost = hostname();
736 if (defined $otherhost && defined $thishost &&
737 $otherhost ne '' && $thishost ne '' &&
738 $otherhost ne $thishost) {
739 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
740 "reports other host $otherhost and other ".
741 "process $otherpid.\n".
742 "Cannot proceed.\n"));
743 } elsif ($RUN_DEGRADED) {
744 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
745 } elsif (defined $otherpid && $otherpid) {
746 return if $$ == $otherpid; # should never happen
747 $CPAN::Frontend->mywarn(
749 There seems to be running another CPAN process (pid $otherpid). Contacting...
751 if (kill 0, $otherpid) {
752 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
754 CPAN::Shell::colorable_makemaker_prompt
755 (qq{Shall I try to run in degraded }.
756 qq{mode? (Y/n)},"y");
758 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
759 Please report if something unexpected happens\n");
761 for ($CPAN::Config) {
763 # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
764 $_->{commandnumber_in_prompt} = 0; # visibility
765 $_->{histfile} = ""; # who should win otherwise?
766 $_->{cache_metadata} = 0; # better would be a lock?
769 $CPAN::Frontend->mydie("
770 You may want to kill the other job and delete the lockfile. On UNIX try:
775 } elsif (-w $lockfile) {
777 CPAN::Shell::colorable_makemaker_prompt
778 (qq{Other job not responding. Shall I overwrite }.
779 qq{the lockfile '$lockfile'? (Y/n)},"y");
780 $CPAN::Frontend->myexit("Ok, bye\n")
781 unless $ans =~ /^y/i;
784 qq{Lockfile '$lockfile' not writeable by you. }.
785 qq{Cannot proceed.\n}.
787 qq{ rm '$lockfile'\n}.
788 qq{ and then rerun us.\n}
792 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
793 "'$lockfile', please remove. Cannot proceed.\n"));
796 my $dotcpan = $CPAN::Config->{cpan_home};
797 eval { File::Path::mkpath($dotcpan);};
799 # A special case at least for Jarkko.
804 $symlinkcpan = readlink $dotcpan;
805 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
806 eval { File::Path::mkpath($symlinkcpan); };
810 $CPAN::Frontend->mywarn(qq{
811 Working directory $symlinkcpan created.
815 unless (-d $dotcpan) {
817 Your configuration suggests "$dotcpan" as your
818 CPAN.pm working directory. I could not create this directory due
819 to this error: $firsterror\n};
821 As "$dotcpan" is a symlink to "$symlinkcpan",
822 I tried to create that, but I failed with this error: $seconderror
825 Please make sure the directory exists and is writable.
827 $CPAN::Frontend->myprint($mess);
828 return suggest_myconfig;
830 } # $@ after eval mkpath $dotcpan
831 if (0) { # to test what happens when a race condition occurs
832 for (reverse 1..10) {
838 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
840 unless ($fh = FileHandle->new("+>>$lockfile")) {
841 if ($! =~ /Permission/) {
842 $CPAN::Frontend->myprint(qq{
844 Your configuration suggests that CPAN.pm should use a working
846 $CPAN::Config->{cpan_home}
847 Unfortunately we could not create the lock file
849 due to permission problems.
851 Please make sure that the configuration variable
852 \$CPAN::Config->{cpan_home}
853 points to a directory where you can write a .lock file. You can set
854 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
857 return suggest_myconfig;
861 while (!flock $fh, LOCK_EX|LOCK_NB) {
863 $CPAN::Frontend->mydie("Giving up\n");
865 $CPAN::Frontend->mysleep($sleep++);
866 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
871 $fh->print($$, "\n");
872 $fh->print(hostname(), "\n");
873 $self->{LOCK} = $lockfile;
874 $self->{LOCKFH} = $fh;
879 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
885 die "Got yet another signal" if $Signal > 1;
886 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
887 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
891 # From: Larry Wall <larry@wall.org>
892 # Subject: Re: deprecating SIGDIE
893 # To: perl5-porters@perl.org
894 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
896 # The original intent of __DIE__ was only to allow you to substitute one
897 # kind of death for another on an application-wide basis without respect
898 # to whether you were in an eval or not. As a global backstop, it should
899 # not be used any more lightly (or any more heavily :-) than class
900 # UNIVERSAL. Any attempt to build a general exception model on it should
901 # be politely squashed. Any bug that causes every eval {} to have to be
902 # modified should be not so politely squashed.
904 # Those are my current opinions. It is also my optinion that polite
905 # arguments degenerate to personal arguments far too frequently, and that
906 # when they do, it's because both people wanted it to, or at least didn't
907 # sufficiently want it not to.
911 # global backstop to cleanup if we should really die
912 $SIG{__DIE__} = \&cleanup;
913 $self->debug("Signal handler set.") if $CPAN::DEBUG;
916 #-> sub CPAN::DESTROY ;
918 &cleanup; # need an eval?
921 #-> sub CPAN::anycwd ;
924 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
929 sub cwd {Cwd::cwd();}
931 #-> sub CPAN::getcwd ;
932 sub getcwd {Cwd::getcwd();}
934 #-> sub CPAN::fastcwd ;
935 sub fastcwd {Cwd::fastcwd();}
937 #-> sub CPAN::backtickcwd ;
938 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
940 #-> sub CPAN::find_perl ;
942 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
943 my $pwd = $CPAN::iCwd = CPAN::anycwd();
944 my $candidate = File::Spec->catfile($pwd,$^X);
945 $perl ||= $candidate if MM->maybe_command($candidate);
948 my ($component,$perl_name);
949 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
950 PATH_COMPONENT: foreach $component (File::Spec->path(),
951 $Config::Config{'binexp'}) {
952 next unless defined($component) && $component;
953 my($abs) = File::Spec->catfile($component,$perl_name);
954 if (MM->maybe_command($abs)) {
966 #-> sub CPAN::exists ;
968 my($mgr,$class,$id) = @_;
969 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
971 ### Carp::croak "exists called without class argument" unless $class;
973 $id =~ s/:+/::/g if $class eq "CPAN::Module";
974 if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
975 return (exists $META->{readonly}{$class}{$id} or
976 $CPAN::SQLite->set($class, $id));
978 return (exists $META->{readonly}{$class}{$id} or
979 exists $META->{readwrite}{$class}{$id}); # unsafe meta access, ok
983 #-> sub CPAN::delete ;
985 my($mgr,$class,$id) = @_;
986 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
987 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
990 #-> sub CPAN::has_usable
991 # has_inst is sometimes too optimistic, we should replace it with this
992 # has_usable whenever a case is given
994 my($self,$mod,$message) = @_;
995 return 1 if $HAS_USABLE->{$mod};
996 my $has_inst = $self->has_inst($mod,$message);
997 return unless $has_inst;
1000 LWP => [ # we frequently had "Can't locate object
1001 # method "new" via package "LWP::UserAgent" at
1002 # (eval 69) line 2006
1004 sub {require LWP::UserAgent},
1005 sub {require HTTP::Request},
1006 sub {require URI::URL},
1009 sub {require Net::FTP},
1010 sub {require Net::Config},
1012 'File::HomeDir' => [
1013 sub {require File::HomeDir;
1014 unless (File::HomeDir::->VERSION >= 0.52){
1015 for ("Will not use File::HomeDir, need 0.52\n") {
1016 $CPAN::Frontend->mywarn($_);
1023 if ($usable->{$mod}) {
1024 for my $c (0..$#{$usable->{$mod}}) {
1025 my $code = $usable->{$mod}[$c];
1026 my $ret = eval { &$code() };
1027 $ret = "" unless defined $ret;
1029 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1034 return $HAS_USABLE->{$mod} = 1;
1037 #-> sub CPAN::has_inst
1039 my($self,$mod,$message) = @_;
1040 Carp::croak("CPAN->has_inst() called without an argument")
1041 unless defined $mod;
1042 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1043 keys %{$CPAN::Config->{dontload_hash}||{}},
1044 @{$CPAN::Config->{dontload_list}||[]};
1045 if (defined $message && $message eq "no" # afair only used by Nox
1049 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1057 # checking %INC is wrong, because $INC{LWP} may be true
1058 # although $INC{"URI/URL.pm"} may have failed. But as
1059 # I really want to say "bla loaded OK", I have to somehow
1061 ### warn "$file in %INC"; #debug
1063 } elsif (eval { require $file }) {
1064 # eval is good: if we haven't yet read the database it's
1065 # perfect and if we have installed the module in the meantime,
1066 # it tries again. The second require is only a NOOP returning
1067 # 1 if we had success, otherwise it's retrying
1069 my $v = eval "\$$mod\::VERSION";
1070 $v = $v ? " (v$v)" : "";
1071 $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1072 if ($mod eq "CPAN::WAIT") {
1073 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1076 } elsif ($mod eq "Net::FTP") {
1077 $CPAN::Frontend->mywarn(qq{
1078 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1080 install Bundle::libnet
1082 }) unless $Have_warned->{"Net::FTP"}++;
1083 $CPAN::Frontend->mysleep(3);
1084 } elsif ($mod eq "Digest::SHA"){
1085 if ($Have_warned->{"Digest::SHA"}++) {
1086 $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1087 qq{because Digest::SHA not installed.\n});
1089 $CPAN::Frontend->mywarn(qq{
1090 CPAN: checksum security checks disabled because Digest::SHA not installed.
1091 Please consider installing the Digest::SHA module.
1094 $CPAN::Frontend->mysleep(2);
1096 } elsif ($mod eq "Module::Signature"){
1097 # NOT prefs_lookup, we are not a distro
1098 my $check_sigs = $CPAN::Config->{check_sigs};
1099 if (not $check_sigs) {
1100 # they do not want us:-(
1101 } elsif (not $Have_warned->{"Module::Signature"}++) {
1102 # No point in complaining unless the user can
1103 # reasonably install and use it.
1104 if (eval { require Crypt::OpenPGP; 1 } ||
1106 defined $CPAN::Config->{'gpg'}
1108 $CPAN::Config->{'gpg'} =~ /\S/
1111 $CPAN::Frontend->mywarn(qq{
1112 CPAN: Module::Signature security checks disabled because Module::Signature
1113 not installed. Please consider installing the Module::Signature module.
1114 You may also need to be able to connect over the Internet to the public
1115 keyservers like pgp.mit.edu (port 11371).
1118 $CPAN::Frontend->mysleep(2);
1122 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1127 #-> sub CPAN::instance ;
1129 my($mgr,$class,$id) = @_;
1130 CPAN::Index->reload;
1132 # unsafe meta access, ok?
1133 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1134 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1142 #-> sub CPAN::cleanup ;
1144 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1145 local $SIG{__DIE__} = '';
1150 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1151 $ineval = 1, last if
1152 $subroutine eq '(eval)';
1154 return if $ineval && !$CPAN::End;
1155 return unless defined $META->{LOCK};
1156 return unless -f $META->{LOCK};
1158 unlink $META->{LOCK};
1160 # Carp::cluck("DEBUGGING");
1161 if ( $CPAN::CONFIG_DIRTY ) {
1162 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1164 $CPAN::Frontend->myprint("Lockfile removed.\n");
1167 #-> sub CPAN::savehist
1170 my($histfile,$histsize);
1171 unless ($histfile = $CPAN::Config->{'histfile'}){
1172 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1175 $histsize = $CPAN::Config->{'histsize'} || 100;
1177 unless ($CPAN::term->can("GetHistory")) {
1178 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1184 my @h = $CPAN::term->GetHistory;
1185 splice @h, 0, @h-$histsize if @h>$histsize;
1186 my($fh) = FileHandle->new;
1187 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1188 local $\ = local $, = "\n";
1193 #-> sub CPAN::is_tested
1195 my($self,$what) = @_;
1196 $self->{is_tested}{$what} = 1;
1199 #-> sub CPAN::is_installed
1200 # unsets the is_tested flag: as soon as the thing is installed, it is
1201 # not needed in set_perl5lib anymore
1203 my($self,$what) = @_;
1204 delete $self->{is_tested}{$what};
1207 #-> sub CPAN::set_perl5lib
1209 my($self,$for) = @_;
1211 (undef,undef,undef,$for) = caller(1);
1214 $self->{is_tested} ||= {};
1215 return unless %{$self->{is_tested}};
1216 my $env = $ENV{PERL5LIB};
1217 $env = $ENV{PERLLIB} unless defined $env;
1219 push @env, $env if defined $env and length $env;
1220 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1221 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1222 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}};
1224 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for $for\n");
1226 my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
1227 sort keys %{$self->{is_tested}};
1228 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of ".
1230 "%BUILDDIR%=$CPAN::Config->{'build_dir'} ".
1235 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1238 package CPAN::CacheMgr;
1241 #-> sub CPAN::CacheMgr::as_string ;
1243 eval { require Data::Dumper };
1245 return shift->SUPER::as_string;
1247 return Data::Dumper::Dumper(shift);
1251 #-> sub CPAN::CacheMgr::cachesize ;
1256 #-> sub CPAN::CacheMgr::tidyup ;
1259 return unless $CPAN::META->{LOCK};
1260 return unless -d $self->{ID};
1261 while ($self->{DU} > $self->{'MAX'} ) {
1262 my($toremove) = shift @{$self->{FIFO}};
1263 $CPAN::Frontend->myprint(sprintf(
1264 "Deleting from cache".
1265 ": $toremove (%.1f>%.1f MB)\n",
1266 $self->{DU}, $self->{'MAX'})
1268 return if $CPAN::Signal;
1269 $self->force_clean_cache($toremove);
1270 return if $CPAN::Signal;
1274 #-> sub CPAN::CacheMgr::dir ;
1279 #-> sub CPAN::CacheMgr::entries ;
1281 my($self,$dir) = @_;
1282 return unless defined $dir;
1283 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1284 $dir ||= $self->{ID};
1285 my($cwd) = CPAN::anycwd();
1286 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1287 my $dh = DirHandle->new(File::Spec->curdir)
1288 or Carp::croak("Couldn't opendir $dir: $!");
1291 next if $_ eq "." || $_ eq "..";
1293 push @entries, File::Spec->catfile($dir,$_);
1295 push @entries, File::Spec->catdir($dir,$_);
1297 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1300 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1301 sort { -M $b <=> -M $a} @entries;
1304 #-> sub CPAN::CacheMgr::disk_usage ;
1306 my($self,$dir) = @_;
1307 return if exists $self->{SIZE}{$dir};
1308 return if $CPAN::Signal;
1312 unless (chmod 0755, $dir) {
1313 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1314 "permission to change the permission; cannot ".
1315 "estimate disk usage of '$dir'\n");
1316 $CPAN::Frontend->mysleep(5);
1321 $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1326 $File::Find::prune++ if $CPAN::Signal;
1328 if ($^O eq 'MacOS') {
1330 my $cat = Mac::Files::FSpGetCatInfo($_);
1331 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1335 unless (chmod 0755, $_) {
1336 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1337 "the permission to change the permission; ".
1338 "can only partially estimate disk usage ".
1340 $CPAN::Frontend->mysleep(5);
1351 return if $CPAN::Signal;
1352 $self->{SIZE}{$dir} = $Du/1024/1024;
1353 push @{$self->{FIFO}}, $dir;
1354 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1355 $self->{DU} += $Du/1024/1024;
1359 #-> sub CPAN::CacheMgr::force_clean_cache ;
1360 sub force_clean_cache {
1361 my($self,$dir) = @_;
1362 return unless -e $dir;
1363 unless (File::Basename::dirname($dir) eq $CPAN::Config->{build_dir}) {
1364 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1365 "will not remove\n");
1366 $CPAN::Frontend->mysleep(5);
1369 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1371 File::Path::rmtree($dir);
1372 unlink "$dir.yml"; # may fail
1373 $self->{DU} -= $self->{SIZE}{$dir};
1374 delete $self->{SIZE}{$dir};
1377 #-> sub CPAN::CacheMgr::new ;
1384 ID => $CPAN::Config->{'build_dir'},
1385 MAX => $CPAN::Config->{'build_cache'},
1386 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1389 File::Path::mkpath($self->{ID});
1390 my $dh = DirHandle->new($self->{ID});
1391 bless $self, $class;
1394 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1396 CPAN->debug($debug) if $CPAN::DEBUG;
1400 #-> sub CPAN::CacheMgr::scan_cache ;
1403 return if $self->{SCAN} eq 'never';
1404 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1405 unless $self->{SCAN} eq 'atstart';
1406 $CPAN::Frontend->myprint(
1407 sprintf("Scanning cache %s for sizes\n",
1410 for $e ($self->entries($self->{ID})) {
1411 next if $e eq ".." || $e eq ".";
1412 $self->disk_usage($e);
1413 return if $CPAN::Signal;
1418 package CPAN::Shell;
1421 #-> sub CPAN::Shell::h ;
1423 my($class,$about) = @_;
1424 if (defined $about) {
1425 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1427 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1428 $CPAN::Frontend->myprint(qq{
1429 Display Information $filler (ver $CPAN::VERSION)
1430 command argument description
1431 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1432 i WORD or /REGEXP/ about any of the above
1433 ls AUTHOR or GLOB about files in the author's directory
1434 (with WORD being a module, bundle or author name or a distribution
1435 name of the form AUTHOR/DISTRIBUTION)
1437 Download, Test, Make, Install...
1438 get download clean make clean
1439 make make (implies get) look open subshell in dist directory
1440 test make test (implies make) readme display these README files
1441 install make install (implies test) perldoc display POD documentation
1444 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1445 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1448 force COMMAND unconditionally do command
1449 notest COMMAND skip testing
1452 h,? display this menu ! perl-code eval a perl command
1453 o conf [opt] set and query options q quit the cpan shell
1454 reload cpan load CPAN.pm again reload index load newer indices
1455 autobundle Snapshot recent latest CPAN uploads});
1461 #-> sub CPAN::Shell::a ;
1463 my($self,@arg) = @_;
1464 # authors are always UPPERCASE
1466 $_ = uc $_ unless /=/;
1468 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1471 #-> sub CPAN::Shell::globls ;
1473 my($self,$s,$pragmas) = @_;
1474 # ls is really very different, but we had it once as an ordinary
1475 # command in the Shell (upto rev. 321) and we could not handle
1477 my(@accept,@preexpand);
1478 if ($s =~ /[\*\?\/]/) {
1479 if ($CPAN::META->has_inst("Text::Glob")) {
1480 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1481 my $rau = Text::Glob::glob_to_regex(uc $au);
1482 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1484 push @preexpand, map { $_->id . "/" . $pathglob }
1485 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1487 my $rau = Text::Glob::glob_to_regex(uc $s);
1488 push @preexpand, map { $_->id }
1489 CPAN::Shell->expand_by_method('CPAN::Author',
1494 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1497 push @preexpand, uc $s;
1500 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1501 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1506 my $silent = @accept>1;
1507 my $last_alpha = "";
1509 for my $a (@accept){
1510 my($author,$pathglob);
1511 if ($a =~ m|(.*?)/(.*)|) {
1514 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1516 $a2) or die "No author found for $a2";
1518 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1520 $a) or die "No author found for $a";
1523 my $alpha = substr $author->id, 0, 1;
1525 if ($alpha eq $last_alpha) {
1529 $last_alpha = $alpha;
1531 $CPAN::Frontend->myprint($ad);
1533 for my $pragma (@$pragmas) {
1534 if ($author->can($pragma)) {
1538 push @results, $author->ls($pathglob,$silent); # silent if
1541 for my $pragma (@$pragmas) {
1542 my $unpragma = "un$pragma";
1543 if ($author->can($unpragma)) {
1544 $author->$unpragma();
1551 #-> sub CPAN::Shell::local_bundles ;
1553 my($self,@which) = @_;
1554 my($incdir,$bdir,$dh);
1555 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1556 my @bbase = "Bundle";
1557 while (my $bbase = shift @bbase) {
1558 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1559 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1560 if ($dh = DirHandle->new($bdir)) { # may fail
1562 for $entry ($dh->read) {
1563 next if $entry =~ /^\./;
1564 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1565 if (-d File::Spec->catdir($bdir,$entry)){
1566 push @bbase, "$bbase\::$entry";
1568 next unless $entry =~ s/\.pm(?!\n)\Z//;
1569 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1577 #-> sub CPAN::Shell::b ;
1579 my($self,@which) = @_;
1580 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1581 $self->local_bundles;
1582 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1585 #-> sub CPAN::Shell::d ;
1586 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1588 #-> sub CPAN::Shell::m ;
1589 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1591 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1594 #-> sub CPAN::Shell::i ;
1598 @args = '/./' unless @args;
1600 for my $type (qw/Bundle Distribution Module/) {
1601 push @result, $self->expand($type,@args);
1603 # Authors are always uppercase.
1604 push @result, $self->expand("Author", map { uc $_ } @args);
1606 my $result = @result == 1 ?
1607 $result[0]->as_string :
1609 "No objects found of any type for argument @args\n" :
1611 (map {$_->as_glimpse} @result),
1612 scalar @result, " items found\n",
1614 $CPAN::Frontend->myprint($result);
1617 #-> sub CPAN::Shell::o ;
1619 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1620 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1621 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1622 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1624 my($self,$o_type,@o_what) = @_;
1626 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1627 if ($o_type eq 'conf') {
1628 if (!@o_what) { # print all things, "o conf"
1630 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1632 if (exists $INC{'CPAN/Config.pm'}) {
1633 push @from, $INC{'CPAN/Config.pm'};
1635 if (exists $INC{'CPAN/MyConfig.pm'}) {
1636 push @from, $INC{'CPAN/MyConfig.pm'};
1638 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1639 $CPAN::Frontend->myprint(":\n");
1640 for $k (sort keys %CPAN::HandleConfig::can) {
1641 $v = $CPAN::HandleConfig::can{$k};
1642 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1644 $CPAN::Frontend->myprint("\n");
1645 for $k (sort keys %$CPAN::Config) {
1646 CPAN::HandleConfig->prettyprint($k);
1648 $CPAN::Frontend->myprint("\n");
1650 if (CPAN::HandleConfig->edit(@o_what)) {
1651 unless ($o_what[0] =~ /^(init|commit|defaults)$/) {
1652 $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
1653 "make the config permanent!\n\n");
1656 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1660 } elsif ($o_type eq 'debug') {
1662 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1665 my($what) = shift @o_what;
1666 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1667 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1670 if ( exists $CPAN::DEBUG{$what} ) {
1671 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1672 } elsif ($what =~ /^\d/) {
1673 $CPAN::DEBUG = $what;
1674 } elsif (lc $what eq 'all') {
1676 for (values %CPAN::DEBUG) {
1679 $CPAN::DEBUG = $max;
1682 for (keys %CPAN::DEBUG) {
1683 next unless lc($_) eq lc($what);
1684 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1687 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1692 my $raw = "Valid options for debug are ".
1693 join(", ",sort(keys %CPAN::DEBUG), 'all').
1694 qq{ or a number. Completion works on the options. }.
1695 qq{Case is ignored.};
1697 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1698 $CPAN::Frontend->myprint("\n\n");
1701 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1703 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1704 $v = $CPAN::DEBUG{$k};
1705 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1706 if $v & $CPAN::DEBUG;
1709 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1712 $CPAN::Frontend->myprint(qq{
1714 conf set or get configuration variables
1715 debug set or get debugging options
1720 # CPAN::Shell::paintdots_onreload
1721 sub paintdots_onreload {
1724 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1728 # $CPAN::Frontend->myprint(".($subr)");
1729 $CPAN::Frontend->myprint(".");
1730 if ($subr =~ /\bshell\b/i) {
1731 # warn "debug[$_[0]]";
1733 # It would be nice if we could detect that a
1734 # subroutine has actually changed, but for now we
1735 # practically always set the GOTOSHELL global
1745 #-> sub CPAN::Shell::hosts ;
1748 my $fullstats = CPAN::FTP->_ftp_statistics();
1749 my $history = $fullstats->{history} || [];
1751 while (my $last = pop @$history) {
1752 my $attempts = $last->{attempts} or next;
1755 $start = $attempts->[-1]{start};
1756 if ($#$attempts > 0) {
1757 for my $i (0..$#$attempts-1) {
1758 my $url = $attempts->[$i]{url} or next;
1763 $start = $last->{start};
1765 next unless $last->{thesiteurl}; # C-C? bad filenames?
1767 $S{end} ||= $last->{end};
1768 my $dltime = $last->{end} - $start;
1769 my $dlsize = $last->{filesize} || 0;
1770 my $url = $last->{thesiteurl}->text;
1771 my $s = $S{ok}{$url} ||= {};
1774 $s->{dlsize} += $dlsize/1024;
1776 $s->{dltime} += $dltime;
1779 for my $url (keys %{$S{ok}}) {
1780 next if $S{ok}{$url}{dltime} == 0; # div by zero
1781 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1782 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1786 for my $url (keys %{$S{no}}) {
1787 push @{$res->{no}}, [$S{no}{$url},
1791 my $R = ""; # report
1792 $R .= sprintf "Log starts: %s\n", scalar(localtime $S{start}) || "unknown";
1793 $R .= sprintf "Log ends : %s\n", scalar(localtime $S{end}) || "unknown";
1794 if ($res->{ok} && @{$res->{ok}}) {
1795 $R .= sprintf "\nSuccessful downloads:
1796 N kB secs kB/s url\n";
1798 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1799 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1803 if ($res->{no} && @{$res->{no}}) {
1804 $R .= sprintf "\nUnsuccessful downloads:\n";
1806 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1807 $R .= sprintf "%4d %s\n", @$_;
1811 $CPAN::Frontend->myprint($R);
1814 #-> sub CPAN::Shell::reload ;
1816 my($self,$command,@arg) = @_;
1818 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1819 if ($command =~ /^cpan$/i) {
1821 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1825 "CPAN/HandleConfig.pm",
1826 "CPAN/FirstTime.pm",
1833 MFILE: for my $f (@relo) {
1834 next unless exists $INC{$f};
1838 $CPAN::Frontend->myprint("($p");
1839 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1840 $self->reload_this($f) or $failed++;
1841 my $v = eval "$p\::->VERSION";
1842 $CPAN::Frontend->myprint("v$v)");
1844 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1846 my $errors = $failed == 1 ? "error" : "errors";
1847 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1850 } elsif ($command =~ /^index$/i) {
1851 CPAN::Index->force_reload;
1853 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
1854 index re-reads the index files\n});
1858 # reload means only load again what we have loaded before
1859 #-> sub CPAN::Shell::reload_this ;
1861 my($self,$f,$args) = @_;
1862 CPAN->debug("f[$f]") if $CPAN::DEBUG;
1863 return 1 unless $INC{$f}; # we never loaded this, so we do not
1865 my $pwd = CPAN::anycwd();
1866 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1868 for my $inc (@INC) {
1869 $file = File::Spec->catfile($inc,split /\//, $f);
1873 CPAN->debug("file[$file]") if $CPAN::DEBUG;
1875 unless ($file && -f $file) {
1876 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1878 unless (CPAN->has_inst("File::Basename")) {
1879 @inc = File::Basename::dirname($file);
1881 # do we ever need this?
1882 @inc = substr($file,0,-length($f)-1); # bring in back to me!
1885 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1887 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1890 my $mtime = (stat $file)[9];
1891 $reload->{$f} ||= $^T;
1892 my $must_reload = $mtime > $reload->{$f};
1894 $must_reload ||= $args->{force};
1896 my $fh = FileHandle->new($file) or
1897 $CPAN::Frontend->mydie("Could not open $file: $!");
1900 my $content = <$fh>;
1901 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1905 eval "require '$f'";
1910 $reload->{$f} = time;
1912 $CPAN::Frontend->myprint("__unchanged__");
1917 #-> sub CPAN::Shell::mkmyconfig ;
1919 my($self, $cpanpm, %args) = @_;
1920 require CPAN::FirstTime;
1921 my $home = CPAN::HandleConfig::home;
1922 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1923 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1924 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1925 CPAN::HandleConfig::require_myconfig_or_config;
1926 $CPAN::Config ||= {};
1931 keep_source_where => undef,
1934 CPAN::FirstTime::init($cpanpm, %args);
1937 #-> sub CPAN::Shell::_binary_extensions ;
1938 sub _binary_extensions {
1939 my($self) = shift @_;
1940 my(@result,$module,%seen,%need,$headerdone);
1941 for $module ($self->expand('Module','/./')) {
1942 my $file = $module->cpan_file;
1943 next if $file eq "N/A";
1944 next if $file =~ /^Contact Author/;
1945 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1946 next if $dist->isa_perl;
1947 next unless $module->xs_file;
1949 $CPAN::Frontend->myprint(".");
1950 push @result, $module;
1952 # print join " | ", @result;
1953 $CPAN::Frontend->myprint("\n");
1957 #-> sub CPAN::Shell::recompile ;
1959 my($self) = shift @_;
1960 my($module,@module,$cpan_file,%dist);
1961 @module = $self->_binary_extensions();
1962 for $module (@module){ # we force now and compile later, so we
1964 $cpan_file = $module->cpan_file;
1965 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1967 $dist{$cpan_file}++;
1969 for $cpan_file (sort keys %dist) {
1970 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1971 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1973 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1974 # stop a package from recompiling,
1975 # e.g. IO-1.12 when we have perl5.003_10
1979 #-> sub CPAN::Shell::scripts ;
1981 my($self, $arg) = @_;
1982 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1984 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1985 unless ($CPAN::META->has_inst($req)) {
1986 $CPAN::Frontend->mywarn(" $req not available\n");
1989 my $p = HTML::LinkExtor->new();
1990 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1991 unless (-f $indexfile) {
1992 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1994 $p->parse_file($indexfile);
1997 if ($arg =~ s|^/(.+)/$|$1|) {
1998 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2000 for my $l ($p->links) {
2001 my $tag = shift @$l;
2002 next unless $tag eq "a";
2004 my $href = $att{href};
2005 next unless $href =~ s|^\.\./authors/id/./../||;
2008 if ($href =~ $qrarg) {
2012 if ($href =~ /\Q$arg\E/) {
2020 # now filter for the latest version if there is more than one of a name
2026 $stems{$stem} ||= [];
2027 push @{$stems{$stem}}, $href;
2029 for (sort keys %stems) {
2031 if (@{$stems{$_}} > 1) {
2032 $highest = List::Util::reduce {
2033 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2036 $highest = $stems{$_}[0];
2038 $CPAN::Frontend->myprint("$highest\n");
2042 #-> sub CPAN::Shell::report ;
2044 my($self,@args) = @_;
2045 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2046 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2048 local $CPAN::Config->{test_report} = 1;
2049 $self->force("test",@args); # force is there so that the test be
2050 # re-run (as documented)
2053 #-> sub CPAN::Shell::install_tested
2054 sub install_tested {
2055 my($self,@some) = @_;
2056 $CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
2058 CPAN::Index->reload;
2060 for my $d (%{$CPAN::META->{readwrite}{'CPAN::Distribution'}}) {
2061 my $do = CPAN::Shell->expandany($d);
2062 next unless $do->{build_dir};
2066 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2067 return unless @some;
2069 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2070 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2071 return unless @some;
2073 @some = grep { not $_->uptodate } @some;
2074 $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2075 return unless @some;
2077 CPAN->debug("some[@some]");
2079 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2080 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2081 $CPAN::Frontend->sleep(1);
2086 #-> sub CPAN::Shell::upgrade ;
2088 my($self,@args) = @_;
2089 $self->install($self->r(@args));
2092 #-> sub CPAN::Shell::_u_r_common ;
2094 my($self) = shift @_;
2095 my($what) = shift @_;
2096 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2097 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2098 $what && $what =~ /^[aru]$/;
2100 @args = '/./' unless @args;
2101 my(@result,$module,%seen,%need,$headerdone,
2102 $version_undefs,$version_zeroes);
2103 $version_undefs = $version_zeroes = 0;
2104 my $sprintf = "%s%-25s%s %9s %9s %s\n";
2105 my @expand = $self->expand('Module',@args);
2106 my $expand = scalar @expand;
2107 if (0) { # Looks like noise to me, was very useful for debugging
2108 # for metadata cache
2109 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2111 MODULE: for $module (@expand) {
2112 my $file = $module->cpan_file;
2113 next MODULE unless defined $file; # ??
2114 $file =~ s|^./../||;
2115 my($latest) = $module->cpan_version;
2116 my($inst_file) = $module->inst_file;
2118 return if $CPAN::Signal;
2121 $have = $module->inst_version;
2122 } elsif ($what eq "r") {
2123 $have = $module->inst_version;
2125 if ($have eq "undef"){
2127 } elsif ($have == 0){
2130 next MODULE unless CPAN::Version->vgt($latest, $have);
2131 # to be pedantic we should probably say:
2132 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2133 # to catch the case where CPAN has a version 0 and we have a version undef
2134 } elsif ($what eq "u") {
2140 } elsif ($what eq "r") {
2142 } elsif ($what eq "u") {
2146 return if $CPAN::Signal; # this is sometimes lengthy
2149 push @result, sprintf "%s %s\n", $module->id, $have;
2150 } elsif ($what eq "r") {
2151 push @result, $module->id;
2152 next MODULE if $seen{$file}++;
2153 } elsif ($what eq "u") {
2154 push @result, $module->id;
2155 next MODULE if $seen{$file}++;
2156 next MODULE if $file =~ /^Contact/;
2158 unless ($headerdone++){
2159 $CPAN::Frontend->myprint("\n");
2160 $CPAN::Frontend->myprint(sprintf(
2163 "Package namespace",
2175 $CPAN::META->has_inst("Term::ANSIColor")
2177 $module->description
2179 $color_on = Term::ANSIColor::color("green");
2180 $color_off = Term::ANSIColor::color("reset");
2182 $CPAN::Frontend->myprint(sprintf $sprintf,
2189 $need{$module->id}++;
2193 $CPAN::Frontend->myprint("No modules found for @args\n");
2194 } elsif ($what eq "r") {
2195 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2199 if ($version_zeroes) {
2200 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2201 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2202 qq{a version number of 0\n});
2204 if ($version_undefs) {
2205 my $s_has = $version_undefs > 1 ? "s have" : " has";
2206 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2207 qq{parseable version number\n});
2213 #-> sub CPAN::Shell::r ;
2215 shift->_u_r_common("r",@_);
2218 #-> sub CPAN::Shell::u ;
2220 shift->_u_r_common("u",@_);
2223 #-> sub CPAN::Shell::failed ;
2225 my($self,$only_id,$silent) = @_;
2227 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2229 NAY: for my $nosayer (
2238 next unless exists $d->{$nosayer};
2239 next unless defined $d->{$nosayer};
2241 UNIVERSAL::can($d->{$nosayer},"failed") ?
2242 $d->{$nosayer}->failed :
2243 $d->{$nosayer} =~ /^NO/
2245 next NAY if $only_id && $only_id != (
2246 UNIVERSAL::can($d->{$nosayer},"commandid")
2248 $d->{$nosayer}->commandid
2250 $CPAN::CurrentCommandId
2255 next DIST unless $failed;
2259 # " %-45s: %s %s\n",
2262 UNIVERSAL::can($d->{$failed},"failed") ?
2264 $d->{$failed}->commandid,
2267 $d->{$failed}->text,
2268 $d->{$failed}{TIME}||0,
2281 $scope = "this command";
2282 } elsif ($CPAN::Index::HAVE_REANIMATED) {
2283 $scope = "this or a previous session";
2284 # it might be nice to have a section for previous session and
2287 $scope = "this session";
2294 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2295 sort { $a->[0] <=> $b->[0] } @failed;
2298 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2305 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2306 } elsif (!$only_id || !$silent) {
2307 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2311 # XXX intentionally undocumented because completely bogus, unportable,
2314 #-> sub CPAN::Shell::status ;
2317 require Devel::Size;
2318 my $ps = FileHandle->new;
2319 open $ps, "/proc/$$/status";
2322 next unless /VmSize:\s+(\d+)/;
2326 $CPAN::Frontend->mywarn(sprintf(
2327 "%-27s %6d\n%-27s %6d\n",
2331 Devel::Size::total_size($CPAN::META)/1024,
2333 for my $k (sort keys %$CPAN::META) {
2334 next unless substr($k,0,4) eq "read";
2335 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2336 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2337 warn sprintf " %-25s %6d (keys: %6d)\n",
2339 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2340 scalar keys %{$CPAN::META->{$k}{$k2}};
2345 #-> sub CPAN::Shell::autobundle ;
2348 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2349 my(@bundle) = $self->_u_r_common("a",@_);
2350 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2351 File::Path::mkpath($todir);
2352 unless (-d $todir) {
2353 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2356 my($y,$m,$d) = (localtime)[5,4,3];
2360 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2361 my($to) = File::Spec->catfile($todir,"$me.pm");
2363 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2364 $to = File::Spec->catfile($todir,"$me.pm");
2366 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2368 "package Bundle::$me;\n\n",
2369 "\$VERSION = '0.01';\n\n",
2373 "Bundle::$me - Snapshot of installation on ",
2374 $Config::Config{'myhostname'},
2377 "\n\n=head1 SYNOPSIS\n\n",
2378 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2379 "=head1 CONTENTS\n\n",
2380 join("\n", @bundle),
2381 "\n\n=head1 CONFIGURATION\n\n",
2383 "\n\n=head1 AUTHOR\n\n",
2384 "This Bundle has been generated automatically ",
2385 "by the autobundle routine in CPAN.pm.\n",
2388 $CPAN::Frontend->myprint("\nWrote bundle file
2392 #-> sub CPAN::Shell::expandany ;
2395 CPAN->debug("s[$s]") if $CPAN::DEBUG;
2396 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2397 $s = CPAN::Distribution->normalize($s);
2398 return $CPAN::META->instance('CPAN::Distribution',$s);
2399 # Distributions spring into existence, not expand
2400 } elsif ($s =~ m|^Bundle::|) {
2401 $self->local_bundles; # scanning so late for bundles seems
2402 # both attractive and crumpy: always
2403 # current state but easy to forget
2405 return $self->expand('Bundle',$s);
2407 return $self->expand('Module',$s)
2408 if $CPAN::META->exists('CPAN::Module',$s);
2413 #-> sub CPAN::Shell::expand ;
2416 my($type,@args) = @_;
2417 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2418 my $class = "CPAN::$type";
2419 my $methods = ['id'];
2420 for my $meth (qw(name)) {
2421 next unless $class->can($meth);
2422 push @$methods, $meth;
2424 $self->expand_by_method($class,$methods,@args);
2427 #-> sub CPAN::Shell::expand_by_method ;
2428 sub expand_by_method {
2430 my($class,$methods,@args) = @_;
2433 my($regex,$command);
2434 if ($arg =~ m|^/(.*)/$|) {
2436 } elsif ($arg =~ m/=/) {
2440 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2442 defined $regex ? $regex : "UNDEFINED",
2443 defined $command ? $command : "UNDEFINED",
2445 if (defined $regex) {
2446 if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
2447 $CPAN::SQLite->search($class, $regex);
2450 $CPAN::META->all_objects($class)
2453 # BUG, we got an empty object somewhere
2454 require Data::Dumper;
2455 CPAN->debug(sprintf(
2456 "Bug in CPAN: Empty id on obj[%s][%s]",
2458 Data::Dumper::Dumper($obj)
2462 for my $method (@$methods) {
2463 my $match = eval {$obj->$method() =~ /$regex/i};
2465 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2466 $err ||= $@; # if we were too restrictive above
2467 $CPAN::Frontend->mydie("$err\n");
2474 } elsif ($command) {
2475 die "equal sign in command disabled (immature interface), ".
2477 ! \$CPAN::Shell::ADVANCED_QUERY=1
2478 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2479 that may go away anytime.\n"
2480 unless $ADVANCED_QUERY;
2481 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2482 my($matchcrit) = $criterion =~ m/^~(.+)/;
2486 $CPAN::META->all_objects($class)
2488 my $lhs = $self->$method() or next; # () for 5.00503
2490 push @m, $self if $lhs =~ m/$matchcrit/;
2492 push @m, $self if $lhs eq $criterion;
2497 if ( $class eq 'CPAN::Bundle' ) {
2498 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2499 } elsif ($class eq "CPAN::Distribution") {
2500 $xarg = CPAN::Distribution->normalize($arg);
2504 if ($CPAN::META->exists($class,$xarg)) {
2505 $obj = $CPAN::META->instance($class,$xarg);
2506 } elsif ($CPAN::META->exists($class,$arg)) {
2507 $obj = $CPAN::META->instance($class,$arg);
2514 @m = sort {$a->id cmp $b->id} @m;
2515 if ( $CPAN::DEBUG ) {
2516 my $wantarray = wantarray;
2517 my $join_m = join ",", map {$_->id} @m;
2518 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2520 return wantarray ? @m : $m[0];
2523 #-> sub CPAN::Shell::format_result ;
2526 my($type,@args) = @_;
2527 @args = '/./' unless @args;
2528 my(@result) = $self->expand($type,@args);
2529 my $result = @result == 1 ?
2530 $result[0]->as_string :
2532 "No objects of type $type found for argument @args\n" :
2534 (map {$_->as_glimpse} @result),
2535 scalar @result, " items found\n",
2540 #-> sub CPAN::Shell::report_fh ;
2542 my $installation_report_fh;
2543 my $previously_noticed = 0;
2546 return $installation_report_fh if $installation_report_fh;
2547 if ($CPAN::META->has_inst("File::Temp")) {
2548 $installation_report_fh
2550 template => 'cpan_install_XXXX',
2555 unless ( $installation_report_fh ) {
2556 warn("Couldn't open installation report file; " .
2557 "no report file will be generated."
2558 ) unless $previously_noticed++;
2564 # The only reason for this method is currently to have a reliable
2565 # debugging utility that reveals which output is going through which
2566 # channel. No, I don't like the colors ;-)
2568 # to turn colordebugging on, write
2569 # cpan> o conf colorize_output 1
2571 #-> sub CPAN::Shell::print_ornamented ;
2573 my $print_ornamented_have_warned = 0;
2574 sub colorize_output {
2575 my $colorize_output = $CPAN::Config->{colorize_output};
2576 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2577 unless ($print_ornamented_have_warned++) {
2578 # no myprint/mywarn within myprint/mywarn!
2579 warn "Colorize_output is set to true but Term::ANSIColor is not
2580 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2582 $colorize_output = 0;
2584 return $colorize_output;
2589 #-> sub CPAN::Shell::print_ornamented ;
2590 sub print_ornamented {
2591 my($self,$what,$ornament) = @_;
2592 return unless defined $what;
2594 local $| = 1; # Flush immediately
2595 if ( $CPAN::Be_Silent ) {
2596 print {report_fh()} $what;
2599 my $swhat = "$what"; # stringify if it is an object
2600 if ($CPAN::Config->{term_is_latin}){
2603 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2605 if ($self->colorize_output) {
2606 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2607 # if you want to have this configurable, please file a bugreport
2608 $ornament = "black on_cyan";
2610 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2612 print "Term::ANSIColor rejects color[$ornament]: $@\n
2613 Please choose a different color (Hint: try 'o conf init color.*')\n";
2617 Term::ANSIColor::color("reset");
2623 #-> sub CPAN::Shell::myprint ;
2625 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2626 # where to use what! I think, we send everything to STDOUT and use
2627 # print for normal/good news and warn for news that need more
2628 # attention. Yes, this is our working contract for now.
2630 my($self,$what) = @_;
2632 $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2635 #-> sub CPAN::Shell::myexit ;
2637 my($self,$what) = @_;
2638 $self->myprint($what);
2642 #-> sub CPAN::Shell::mywarn ;
2644 my($self,$what) = @_;
2645 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2648 # only to be used for shell commands
2649 #-> sub CPAN::Shell::mydie ;
2651 my($self,$what) = @_;
2652 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2654 # If it is the shell, we want that the following die to be silent,
2655 # but if it is not the shell, we would need a 'die $what'. We need
2656 # to take care that only shell commands use mydie. Is this
2662 # sub CPAN::Shell::colorable_makemaker_prompt ;
2663 sub colorable_makemaker_prompt {
2665 if (CPAN::Shell->colorize_output) {
2666 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2667 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2670 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2671 if (CPAN::Shell->colorize_output) {
2672 print Term::ANSIColor::color('reset');
2677 # use this only for unrecoverable errors!
2678 #-> sub CPAN::Shell::unrecoverable_error ;
2679 sub unrecoverable_error {
2680 my($self,$what) = @_;
2681 my @lines = split /\n/, $what;
2683 for my $l (@lines) {
2684 $longest = length $l if length $l > $longest;
2686 $longest = 62 if $longest > 62;
2687 for my $l (@lines) {
2693 if (length $l < 66) {
2694 $l = pack "A66 A*", $l, "<==";
2698 unshift @lines, "\n";
2699 $self->mydie(join "", @lines);
2702 #-> sub CPAN::Shell::mysleep ;
2704 my($self, $sleep) = @_;
2708 #-> sub CPAN::Shell::setup_output ;
2710 return if -t STDOUT;
2711 my $odef = select STDERR;
2718 #-> sub CPAN::Shell::rematein ;
2719 # RE-adme||MA-ke||TE-st||IN-stall
2722 my($meth,@some) = @_;
2724 while($meth =~ /^(force|notest)$/) {
2725 push @pragma, $meth;
2726 $meth = shift @some or
2727 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2731 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2733 # Here is the place to set "test_count" on all involved parties to
2734 # 0. We then can pass this counter on to the involved
2735 # distributions and those can refuse to test if test_count > X. In
2736 # the first stab at it we could use a 1 for "X".
2738 # But when do I reset the distributions to start with 0 again?
2739 # Jost suggested to have a random or cycling interaction ID that
2740 # we pass through. But the ID is something that is just left lying
2741 # around in addition to the counter, so I'd prefer to set the
2742 # counter to 0 now, and repeat at the end of the loop. But what
2743 # about dependencies? They appear later and are not reset, they
2744 # enter the queue but not its copy. How do they get a sensible
2747 # construct the queue
2749 STHING: foreach $s (@some) {
2752 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2754 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2755 } elsif ($s =~ m|^/|) { # looks like a regexp
2756 if (substr($s,-1,1) eq ".") {
2757 $obj = CPAN::Shell->expandany($s);
2759 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2760 "not supported.\nRejecting argument '$s'\n");
2761 $CPAN::Frontend->mysleep(2);
2764 } elsif ($meth eq "ls") {
2765 $self->globls($s,\@pragma);
2768 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2769 $obj = CPAN::Shell->expandany($s);
2772 } elsif (ref $obj) {
2773 $obj->color_cmd_tmps(0,1);
2774 CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2776 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2777 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2778 if ($meth =~ /^(dump|ls)$/) {
2781 $CPAN::Frontend->mywarn(
2783 "Don't be silly, you can't $meth ",
2787 $CPAN::Frontend->mysleep(2);
2789 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2790 CPAN::InfoObj->dump($s);
2793 ->mywarn(qq{Warning: Cannot $meth $s, }.
2794 qq{don't know what it is.
2799 to find objects with matching identifiers.
2801 $CPAN::Frontend->mysleep(2);
2805 # queuerunner (please be warned: when I started to change the
2806 # queue to hold objects instead of names, I made one or two
2807 # mistakes and never found which. I reverted back instead)
2808 while (my $q = CPAN::Queue->first) {
2810 my $s = $q->as_string;
2811 my $reqtype = $q->reqtype || "";
2812 $obj = CPAN::Shell->expandany($s);
2813 $obj->{reqtype} ||= "";
2814 CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2815 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2816 if ($obj->{reqtype}) {
2817 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2818 $obj->{reqtype} = $reqtype;
2820 exists $obj->{install}
2823 UNIVERSAL::can($obj->{install},"failed") ?
2824 $obj->{install}->failed :
2825 $obj->{install} =~ /^NO/
2828 delete $obj->{install};
2829 $CPAN::Frontend->mywarn
2830 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2834 $obj->{reqtype} = $reqtype;
2837 for my $pragma (@pragma) {
2840 $obj->can($pragma)){
2841 $obj->$pragma($meth);
2844 if ($obj->can('called_for')) {
2845 $obj->called_for($s);
2847 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2848 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2852 CPAN::Queue->delete($s);
2854 CPAN->debug("failed");
2858 for my $pragma (@pragma) {
2859 my $unpragma = "un$pragma";
2860 if ($obj->can($unpragma)) {
2864 CPAN::Queue->delete_first($s);
2866 for my $obj (@qcopy) {
2867 $obj->color_cmd_tmps(0,0);
2871 #-> sub CPAN::Shell::recent ;
2875 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2880 # set up the dispatching methods
2882 for my $command (qw(
2897 *$command = sub { shift->rematein($command, @_); };
2901 package CPAN::LWP::UserAgent;
2905 return if $SETUPDONE;
2906 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2907 require LWP::UserAgent;
2908 @ISA = qw(Exporter LWP::UserAgent);
2911 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
2915 sub get_basic_credentials {
2916 my($self, $realm, $uri, $proxy) = @_;
2917 if ($USER && $PASSWD) {
2918 return ($USER, $PASSWD);
2921 ($USER,$PASSWD) = $self->get_proxy_credentials();
2923 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2925 return($USER,$PASSWD);
2928 sub get_proxy_credentials {
2930 my ($user, $password);
2931 if ( defined $CPAN::Config->{proxy_user} &&
2932 defined $CPAN::Config->{proxy_pass}) {
2933 $user = $CPAN::Config->{proxy_user};
2934 $password = $CPAN::Config->{proxy_pass};
2935 return ($user, $password);
2937 my $username_prompt = "\nProxy authentication needed!
2938 (Note: to permanently configure username and password run
2939 o conf proxy_user your_username
2940 o conf proxy_pass your_password
2942 ($user, $password) =
2943 _get_username_and_password_from_user($username_prompt);
2944 return ($user,$password);
2947 sub get_non_proxy_credentials {
2949 my ($user,$password);
2950 if ( defined $CPAN::Config->{username} &&
2951 defined $CPAN::Config->{password}) {
2952 $user = $CPAN::Config->{username};
2953 $password = $CPAN::Config->{password};
2954 return ($user, $password);
2956 my $username_prompt = "\nAuthentication needed!
2957 (Note: to permanently configure username and password run
2958 o conf username your_username
2959 o conf password your_password
2962 ($user, $password) =
2963 _get_username_and_password_from_user($username_prompt);
2964 return ($user,$password);
2967 sub _get_username_and_password_from_user {
2968 my $username_message = shift;
2969 my ($username,$password);
2971 ExtUtils::MakeMaker->import(qw(prompt));
2972 $username = prompt($username_message);
2973 if ($CPAN::META->has_inst("Term::ReadKey")) {
2974 Term::ReadKey::ReadMode("noecho");
2977 $CPAN::Frontend->mywarn(
2978 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2981 $password = prompt("Password:");
2983 if ($CPAN::META->has_inst("Term::ReadKey")) {
2984 Term::ReadKey::ReadMode("restore");
2986 $CPAN::Frontend->myprint("\n\n");
2987 return ($username,$password);
2990 # mirror(): Its purpose is to deal with proxy authentication. When we
2991 # call SUPER::mirror, we relly call the mirror method in
2992 # LWP::UserAgent. LWP::UserAgent will then call
2993 # $self->get_basic_credentials or some equivalent and this will be
2994 # $self->dispatched to our own get_basic_credentials method.
2996 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2998 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2999 # although we have gone through our get_basic_credentials, the proxy
3000 # server refuses to connect. This could be a case where the username or
3001 # password has changed in the meantime, so I'm trying once again without
3002 # $USER and $PASSWD to give the get_basic_credentials routine another
3003 # chance to set $USER and $PASSWD.
3005 # mirror(): Its purpose is to deal with proxy authentication. When we
3006 # call SUPER::mirror, we relly call the mirror method in
3007 # LWP::UserAgent. LWP::UserAgent will then call
3008 # $self->get_basic_credentials or some equivalent and this will be
3009 # $self->dispatched to our own get_basic_credentials method.
3011 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3013 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3014 # although we have gone through our get_basic_credentials, the proxy
3015 # server refuses to connect. This could be a case where the username or
3016 # password has changed in the meantime, so I'm trying once again without
3017 # $USER and $PASSWD to give the get_basic_credentials routine another
3018 # chance to set $USER and $PASSWD.
3021 my($self,$url,$aslocal) = @_;
3022 my $result = $self->SUPER::mirror($url,$aslocal);
3023 if ($result->code == 407) {
3026 $result = $self->SUPER::mirror($url,$aslocal);
3034 #-> sub CPAN::FTP::ftp_statistics
3035 # if they want to rewrite, they need to pass in a filehandle
3036 sub _ftp_statistics {
3038 my $locktype = $fh ? LOCK_EX : LOCK_SH;
3039 $fh ||= FileHandle->new;
3040 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3041 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3043 while (!flock $fh, $locktype|LOCK_NB) {
3045 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file'\n");
3047 $CPAN::Frontend->mysleep($sleep);
3052 my $stats = CPAN->_yaml_loadfile($file);
3053 if ($locktype == LOCK_SH) {
3056 if (@$stats){ # no yaml no write
3064 if (CPAN->has_inst("Time::HiRes")) {
3065 return Time::HiRes::time();
3072 my($self,$file) = @_;
3081 sub _add_to_statistics {
3082 my($self,$stats) = @_;
3083 $stats->{thesiteurl} = $ThesiteURL;
3084 if (CPAN->has_inst("Time::HiRes")) {
3085 $stats->{end} = Time::HiRes::time();
3087 $stats->{end} = time;
3089 my $fh = FileHandle->new;
3090 my $fullstats = $self->_ftp_statistics($fh);
3091 push @{$fullstats->{history}}, $stats;
3093 shift @{$fullstats->{history}}
3094 while $time - $fullstats->{history}[0]{start} > 30*86400; # one month too much?
3095 CPAN->_yaml_dumpfile($fh,$fullstats);
3098 # if file is CHECKSUMS, suggest the place where we got the file to be
3099 # checked from, maybe only for young files?
3100 sub _recommend_url_for {
3101 my($self, $file) = @_;
3102 my $urllist = $self->_get_urllist;
3103 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3104 my $fullstats = $self->_ftp_statistics();
3105 my $history = $fullstats->{history} || [];
3106 while (my $last = pop @$history) {
3107 last if $last->{end} - time > 3600; # only young results are interesting
3108 next unless $last->{file}; # dirname of nothing dies!
3109 next unless $file eq File::Basename::dirname($last->{file});
3110 return $last->{thesiteurl};
3113 if ($CPAN::Config->{randomize_urllist}
3115 rand(1) < $CPAN::Config->{randomize_urllist}
3117 $urllist->[int rand scalar @$urllist];
3125 $CPAN::Config->{urllist} ||= [];
3126 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3127 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
3128 $CPAN::Config->{urllist} = [];
3130 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3131 for my $u (@urllist) {
3132 CPAN->debug("u[$u]") if $CPAN::DEBUG;
3133 if (UNIVERSAL::can($u,"text")) {
3134 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3136 $u .= "/" unless substr($u,-1) eq "/";
3137 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3143 #-> sub CPAN::FTP::ftp_get ;
3145 my($class,$host,$dir,$file,$target) = @_;
3147 qq[Going to fetch file [$file] from dir [$dir]
3148 on host [$host] as local [$target]\n]
3150 my $ftp = Net::FTP->new($host);
3152 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
3155 return 0 unless defined $ftp;
3156 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3157 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3158 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3159 my $msg = $ftp->message;
3160 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
3163 unless ( $ftp->cwd($dir) ){
3164 my $msg = $ftp->message;
3165 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
3169 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3170 unless ( $ftp->get($file,$target) ){
3171 my $msg = $ftp->message;
3172 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
3175 $ftp->quit; # it's ok if this fails
3179 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3181 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
3182 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
3184 # > *** 1562,1567 ****
3185 # > --- 1562,1580 ----
3186 # > return 1 if substr($url,0,4) eq "file";
3187 # > return 1 unless $url =~ m|://([^/]+)|;
3189 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3191 # > + $proxy =~ m|://([^/:]+)|;
3193 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3194 # > + if ($noproxy) {
3195 # > + if ($host !~ /$noproxy$/) {
3196 # > + $host = $proxy;
3199 # > + $host = $proxy;
3202 # > require Net::Ping;
3203 # > return 1 unless $Net::Ping::VERSION >= 2;
3207 #-> sub CPAN::FTP::localize ;
3209 my($self,$file,$aslocal,$force) = @_;
3211 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3212 unless defined $aslocal;
3213 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3216 if ($^O eq 'MacOS') {
3217 # Comment by AK on 2000-09-03: Uniq short filenames would be
3218 # available in CHECKSUMS file
3219 my($name, $path) = File::Basename::fileparse($aslocal, '');
3220 if (length($name) > 31) {
3231 my $size = 31 - length($suf);
3232 while (length($name) > $size) {
3236 $aslocal = File::Spec->catfile($path, $name);
3240 if (-f $aslocal && -r _ && !($force & 1)){
3242 if ($size = -s $aslocal) {
3243 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3246 # empty file from a previous unsuccessful attempt to download it
3248 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3249 "could not remove.");
3252 my($maybe_restore) = 0;
3254 rename $aslocal, "$aslocal.bak$$";
3258 my($aslocal_dir) = File::Basename::dirname($aslocal);
3259 File::Path::mkpath($aslocal_dir);
3260 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3261 qq{directory "$aslocal_dir".
3262 I\'ll continue, but if you encounter problems, they may be due
3263 to insufficient permissions.\n}) unless -w $aslocal_dir;
3265 # Inheritance is not easier to manage than a few if/else branches
3266 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3268 CPAN::LWP::UserAgent->config;
3269 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3271 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3275 $Ua->proxy('ftp', $var)
3276 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3277 $Ua->proxy('http', $var)
3278 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3281 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3283 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3284 # > use ones that require basic autorization.
3286 # > Example of when I use it manually in my own stuff:
3288 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3289 # > $req->proxy_authorization_basic("username","password");
3290 # > $res = $ua->request($req);
3294 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3298 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3299 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3302 # Try the list of urls for each single object. We keep a record
3303 # where we did get a file from
3304 my(@reordered,$last);
3305 my $ccurllist = $self->_get_urllist;
3306 $last = $#$ccurllist;
3307 if ($force & 2) { # local cpans probably out of date, don't reorder
3308 @reordered = (0..$last);
3312 (substr($ccurllist->[$b],0,4) eq "file")
3314 (substr($ccurllist->[$a],0,4) eq "file")
3316 defined($ThesiteURL)
3318 ($ccurllist->[$b] eq $ThesiteURL)
3320 ($ccurllist->[$a] eq $ThesiteURL)
3325 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3327 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3329 @levels = qw/easy hard hardest/;
3331 @levels = qw/easy/ if $^O eq 'MacOS';
3333 local $ENV{FTP_PASSIVE} =
3334 exists $CPAN::Config->{ftp_passive} ?
3335 $CPAN::Config->{ftp_passive} : 1;
3337 my $stats = $self->_new_stats($file);
3338 LEVEL: for $levelno (0..$#levels) {
3339 my $level = $levels[$levelno];
3340 my $method = "host$level";
3341 my @host_seq = $level eq "easy" ?
3342 @reordered : 0..$last; # reordered has CDROM up front
3343 my @urllist = map { $ccurllist->[$_] } @host_seq;
3344 for my $u (@CPAN::Defaultsites) {
3345 push @urllist, $u unless grep { $_ eq $u } @urllist;
3347 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3348 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3349 if (my $recommend = $self->_recommend_url_for($file)) {
3350 @urllist = grep { $_ ne $recommend } @urllist;
3351 unshift @urllist, $recommend;
3353 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3354 $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3356 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3357 if ($ret eq $aslocal_tempfile) {
3358 # if we got it exactly as we asked for, only then we
3360 rename $aslocal_tempfile, $aslocal
3361 or $CPAN::Frontend->mydie("Error while trying to rename ".
3362 "'$ret' to '$aslocal': $!");
3365 $Themethod = $level;
3367 # utime $now, $now, $aslocal; # too bad, if we do that, we
3368 # might alter a local mirror
3369 $self->debug("level[$level]") if $CPAN::DEBUG;
3372 unlink $aslocal_tempfile;
3373 last if $CPAN::Signal; # need to cleanup
3377 $stats->{filesize} = -s $ret;
3379 $self->_add_to_statistics($stats);
3381 unlink "$aslocal.bak$$";
3384 unless ($CPAN::Signal) {
3387 if (@{$CPAN::Config->{urllist}}) {
3389 qq{Please check, if the URLs I found in your configuration file \(}.
3390 join(", ", @{$CPAN::Config->{urllist}}).
3393 push @mess, qq{Your urllist is empty!};
3395 push @mess, qq{The urllist can be edited.},
3396 qq{E.g. with 'o conf urllist push ftp://myurl/'};
3397 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3398 $CPAN::Frontend->mywarn("Could not fetch $file\n");
3399 $CPAN::Frontend->mysleep(2);
3401 if ($maybe_restore) {
3402 rename "$aslocal.bak$$", $aslocal;
3403 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3404 $self->ls($aslocal));
3411 my($self,$stats,$method,$url) = @_;
3412 push @{$stats->{attempts}}, {
3419 # package CPAN::FTP;
3421 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3423 HOSTEASY: for $ro_url (@$host_seq) {
3424 $self->_set_attempt($stats,"easy",$ro_url);
3425 my $url .= "$ro_url$file";
3426 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3427 if ($url =~ /^file:/) {
3429 if ($CPAN::META->has_inst('URI::URL')) {
3430 my $u = URI::URL->new($url);
3432 } else { # works only on Unix, is poorly constructed, but
3433 # hopefully better than nothing.
3434 # RFC 1738 says fileurl BNF is
3435 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3436 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3438 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3439 $l =~ s|^file:||; # assume they
3443 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
3445 $self->debug("local file[$l]") if $CPAN::DEBUG;
3446 if ( -f $l && -r _) {
3447 $ThesiteURL = $ro_url;
3450 if ($l =~ /(.+)\.gz$/) {
3452 if ( -f $ungz && -r _) {
3453 $ThesiteURL = $ro_url;
3457 # Maybe mirror has compressed it?
3459 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3460 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3462 $ThesiteURL = $ro_url;
3467 $self->debug("it was not a file URL") if $CPAN::DEBUG;
3468 if ($CPAN::META->has_usable('LWP')) {
3469 $CPAN::Frontend->myprint("Fetching with LWP:
3473 CPAN::LWP::UserAgent->config;
3474 eval { $Ua = CPAN::LWP::UserAgent->new; };
3476 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3479 my $res = $Ua->mirror($url, $aslocal);
3480 if ($res->is_success) {
3481 $ThesiteURL = $ro_url;
3483 utime $now, $now, $aslocal; # download time is more
3484 # important than upload
3487 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3488 my $gzurl = "$url.gz";
3489 $CPAN::Frontend->myprint("Fetching with LWP:
3492 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3493 if ($res->is_success) {
3494 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3495 $ThesiteURL = $ro_url;
3500 $CPAN::Frontend->myprint(sprintf(
3501 "LWP failed with code[%s] message[%s]\n",
3505 # Alan Burlison informed me that in firewall environments
3506 # Net::FTP can still succeed where LWP fails. So we do not
3507 # skip Net::FTP anymore when LWP is available.
3510 $CPAN::Frontend->mywarn(" LWP not available\n");
3512 return if $CPAN::Signal;
3513 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3514 # that's the nice and easy way thanks to Graham
3515 $self->debug("recognized ftp") if $CPAN::DEBUG;
3516 my($host,$dir,$getfile) = ($1,$2,$3);
3517 if ($CPAN::META->has_usable('Net::FTP')) {
3519 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3522 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3523 "aslocal[$aslocal]") if $CPAN::DEBUG;
3524 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3525 $ThesiteURL = $ro_url;
3528 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3529 my $gz = "$aslocal.gz";
3530 $CPAN::Frontend->myprint("Fetching with Net::FTP
3533 if (CPAN::FTP->ftp_get($host,
3537 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3539 $ThesiteURL = $ro_url;
3545 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3549 UNIVERSAL::can($ro_url,"text")
3551 $ro_url->{FROM} eq "USER"
3553 ##address #17973: default URLs should not try to override
3554 ##user-defined URLs just because LWP is not available
3555 my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3556 return $ret if $ret;
3558 return if $CPAN::Signal;
3562 # package CPAN::FTP;
3564 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3566 # Came back if Net::FTP couldn't establish connection (or
3567 # failed otherwise) Maybe they are behind a firewall, but they
3568 # gave us a socksified (or other) ftp program...
3571 my($devnull) = $CPAN::Config->{devnull} || "";
3573 my($aslocal_dir) = File::Basename::dirname($aslocal);
3574 File::Path::mkpath($aslocal_dir);
3575 HOSTHARD: for $ro_url (@$host_seq) {
3576 $self->_set_attempt($stats,"hard",$ro_url);
3577 my $url = "$ro_url$file";
3578 my($proto,$host,$dir,$getfile);
3580 # Courtesy Mark Conty mark_conty@cargill.com change from
3581 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3583 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3584 # proto not yet used
3585 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3587 next HOSTHARD; # who said, we could ftp anything except ftp?
3589 next HOSTHARD if $proto eq "file"; # file URLs would have had
3590 # success above. Likely a bogus URL
3592 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3594 # Try the most capable first and leave ncftp* for last as it only
3596 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3597 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3598 next unless defined $funkyftp;
3599 next if $funkyftp =~ /^\s*$/;
3601 my($asl_ungz, $asl_gz);
3602 ($asl_ungz = $aslocal) =~ s/\.gz//;
3603 $asl_gz = "$asl_ungz.gz";
3605 my($src_switch) = "";
3607 my($stdout_redir) = " > $asl_ungz";
3609 $src_switch = " -source";
3610 } elsif ($f eq "ncftp"){
3611 $src_switch = " -c";
3612 } elsif ($f eq "wget"){
3613 $src_switch = " -O $asl_ungz";
3615 } elsif ($f eq 'curl'){
3616 $src_switch = ' -L -f -s -S --netrc-optional';
3619 if ($f eq "ncftpget"){
3620 $chdir = "cd $aslocal_dir && ";
3623 $CPAN::Frontend->myprint(
3625 Trying with "$funkyftp$src_switch" to get
3629 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3630 $self->debug("system[$system]") if $CPAN::DEBUG;
3631 my($wstatus) = system($system);
3633 # lynx returns 0 when it fails somewhere
3635 my $content = do { local *FH;
3636 open FH, $asl_ungz or die;
3639 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3640 $CPAN::Frontend->mywarn(qq{
3641 No success, the file that lynx has has downloaded looks like an error message:
3644 $CPAN::Frontend->mysleep(1);
3648 $CPAN::Frontend->myprint(qq{
3649 No success, the file that lynx has has downloaded is an empty file.
3654 if ($wstatus == 0) {
3657 } elsif ($asl_ungz ne $aslocal) {
3658 # test gzip integrity
3659 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3660 # e.g. foo.tar is gzipped --> foo.tar.gz
3661 rename $asl_ungz, $aslocal;
3663 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3666 $ThesiteURL = $ro_url;
3668 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3670 -f $asl_ungz && -s _ == 0;
3671 my $gz = "$aslocal.gz";
3672 my $gzurl = "$url.gz";
3673 $CPAN::Frontend->myprint(
3675 Trying with "$funkyftp$src_switch" to get
3678 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3679 $self->debug("system[$system]") if $CPAN::DEBUG;
3681 if (($wstatus = system($system)) == 0
3685 # test gzip integrity
3686 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3687 if ($ct && $ct->gtest) {
3688 $ct->gunzip($aslocal);
3690 # somebody uncompressed file for us?
3691 rename $asl_ungz, $aslocal;
3693 $ThesiteURL = $ro_url;
3696 unlink $asl_gz if -f $asl_gz;
3699 my $estatus = $wstatus >> 8;
3700 my $size = -f $aslocal ?
3701 ", left\n$aslocal with size ".-s _ :
3702 "\nWarning: expected file [$aslocal] doesn't exist";
3703 $CPAN::Frontend->myprint(qq{
3704 System call "$system"
3705 returned status $estatus (wstat $wstatus)$size
3708 return if $CPAN::Signal;
3709 } # transfer programs
3713 # package CPAN::FTP;
3715 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3718 my($aslocal_dir) = File::Basename::dirname($aslocal);
3719 File::Path::mkpath($aslocal_dir);
3720 my $ftpbin = $CPAN::Config->{ftp};
3721 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3722 $CPAN::Frontend->myprint("No external ftp command available\n\n");
3725 $CPAN::Frontend->mywarn(qq{
3726 As a last ressort we now switch to the external ftp command '$ftpbin'
3729 Doing so often leads to problems that are hard to diagnose.
3731 If you're victim of such problems, please consider unsetting the ftp
3732 config variable with
3738 $CPAN::Frontend->mysleep(2);
3739 HOSTHARDEST: for $ro_url (@$host_seq) {
3740 $self->_set_attempt($stats,"hardest",$ro_url);
3741 my $url = "$ro_url$file";
3742 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3743 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3746 my($host,$dir,$getfile) = ($1,$2,$3);
3748 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3749 $ctime,$blksize,$blocks) = stat($aslocal);
3750 $timestamp = $mtime ||= 0;
3751 my($netrc) = CPAN::FTP::netrc->new;
3752 my($netrcfile) = $netrc->netrc;
3753 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3754 my $targetfile = File::Basename::basename($aslocal);
3760 map("cd $_", split /\//, $dir), # RFC 1738
3762 "get $getfile $targetfile",
3766 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3767 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3768 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3770 $netrc->contains($host))) if $CPAN::DEBUG;
3771 if ($netrc->protected) {
3772 my $dialog = join "", map { " $_\n" } @dialog;
3774 if ($netrc->contains($host)) {
3775 $netrc_explain = "Relying that your .netrc entry for '$host' ".
3776 "manages the login";
3778 $netrc_explain = "Relying that your default .netrc entry ".
3779 "manages the login";
3781 $CPAN::Frontend->myprint(qq{
3782 Trying with external ftp to get
3785 Going to send the dialog
3789 $self->talk_ftp("$ftpbin$verbose $host",
3791 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3792 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3794 if ($mtime > $timestamp) {
3795 $CPAN::Frontend->myprint("GOT $aslocal\n");
3796 $ThesiteURL = $ro_url;
3799 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3801 return if $CPAN::Signal;
3803 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3804 qq{correctly protected.\n});
3807 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3808 nor does it have a default entry\n");
3811 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3812 # then and login manually to host, using e-mail as
3814 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3818 "user anonymous $Config::Config{'cf_email'}"
3820 my $dialog = join "", map { " $_\n" } @dialog;
3821 $CPAN::Frontend->myprint(qq{
3822 Trying with external ftp to get
3824 Going to send the dialog
3828 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3829 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3830 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3832 if ($mtime > $timestamp) {
3833 $CPAN::Frontend->myprint("GOT $aslocal\n");
3834 $ThesiteURL = $ro_url;
3837 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3839 return if $CPAN::Signal;
3840 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3841 $CPAN::Frontend->mysleep(2);
3845 # package CPAN::FTP;
3847 my($self,$command,@dialog) = @_;
3848 my $fh = FileHandle->new;
3849 $fh->open("|$command") or die "Couldn't open ftp: $!";
3850 foreach (@dialog) { $fh->print("$_\n") }
3851 $fh->close; # Wait for process to complete
3853 my $estatus = $wstatus >> 8;
3854 $CPAN::Frontend->myprint(qq{
3855 Subprocess "|$command"
3856 returned status $estatus (wstat $wstatus)
3860 # find2perl needs modularization, too, all the following is stolen
3864 my($self,$name) = @_;
3865 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3866 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3868 my($perms,%user,%group);
3872 $blocks = int(($blocks + 1) / 2);
3875 $blocks = int(($sizemm + 1023) / 1024);
3878 if (-f _) { $perms = '-'; }
3879 elsif (-d _) { $perms = 'd'; }
3880 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3881 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3882 elsif (-p _) { $perms = 'p'; }
3883 elsif (-S _) { $perms = 's'; }
3884 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3886 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3887 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3888 my $tmpmode = $mode;
3889 my $tmp = $rwx[$tmpmode & 7];
3891 $tmp = $rwx[$tmpmode & 7] . $tmp;
3893 $tmp = $rwx[$tmpmode & 7] . $tmp;
3894 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3895 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3896 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3899 my $user = $user{$uid} || $uid; # too lazy to implement lookup
3900 my $group = $group{$gid} || $gid;
3902 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3904 my($moname) = $moname[$mon];
3905 if (-M _ > 365.25 / 2) {
3906 $timeyear = $year + 1900;
3909 $timeyear = sprintf("%02d:%02d", $hour, $min);
3912 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3926 package CPAN::FTP::netrc;
3929 # package CPAN::FTP::netrc;
3932 my $home = CPAN::HandleConfig::home;
3933 my $file = File::Spec->catfile($home,".netrc");
3935 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3936 $atime,$mtime,$ctime,$blksize,$blocks)
3941 my($fh,@machines,$hasdefault);
3943 $fh = FileHandle->new or die "Could not create a filehandle";
3945 if($fh->open($file)){
3946 $protected = ($mode & 077) == 0;
3948 NETRC: while (<$fh>) {
3949 my(@tokens) = split " ", $_;
3950 TOKEN: while (@tokens) {
3951 my($t) = shift @tokens;
3952 if ($t eq "default"){
3956 last TOKEN if $t eq "macdef";
3957 if ($t eq "machine") {
3958 push @machines, shift @tokens;
3963 $file = $hasdefault = $protected = "";
3967 'mach' => [@machines],
3969 'hasdefault' => $hasdefault,
3970 'protected' => $protected,
3974 # CPAN::FTP::netrc::hasdefault;
3975 sub hasdefault { shift->{'hasdefault'} }
3976 sub netrc { shift->{'netrc'} }
3977 sub protected { shift->{'protected'} }
3979 my($self,$mach) = @_;
3980 for ( @{$self->{'mach'}} ) {
3981 return 1 if $_ eq $mach;
3986 package CPAN::Complete;
3990 my($text, $line, $start, $end) = @_;
3991 my(@perlret) = cpl($text, $line, $start);
3992 # find longest common match. Can anybody show me how to peruse
3993 # T::R::Gnu to have this done automatically? Seems expensive.
3994 return () unless @perlret;
3995 my($newtext) = $text;
3996 for (my $i = length($text)+1;;$i++) {
3997 last unless length($perlret[0]) && length($perlret[0]) >= $i;
3998 my $try = substr($perlret[0],0,$i);
3999 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4000 # warn "try[$try]tries[@tries]";
4001 if (@tries == @perlret) {
4007 ($newtext,@perlret);
4010 #-> sub CPAN::Complete::cpl ;
4012 my($word,$line,$pos) = @_;
4016 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4018 if ($line =~ s/^(force\s*)//) {
4023 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4024 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4026 } elsif ($line =~ /^(a|ls)\s/) {
4027 @return = cplx('CPAN::Author',uc($word));
4028 } elsif ($line =~ /^b\s/) {
4029 CPAN::Shell->local_bundles;
4030 @return = cplx('CPAN::Bundle',$word);
4031 } elsif ($line =~ /^d\s/) {
4032 @return = cplx('CPAN::Distribution',$word);
4033 } elsif ($line =~ m/^(
4034 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4036 if ($word =~ /^Bundle::/) {
4037 CPAN::Shell->local_bundles;
4039 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4040 } elsif ($line =~ /^i\s/) {
4041 @return = cpl_any($word);
4042 } elsif ($line =~ /^reload\s/) {
4043 @return = cpl_reload($word,$line,$pos);
4044 } elsif ($line =~ /^o\s/) {
4045 @return = cpl_option($word,$line,$pos);
4046 } elsif ($line =~ m/^\S+\s/ ) {
4047 # fallback for future commands and what we have forgotten above
4048 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4055 #-> sub CPAN::Complete::cplx ;
4057 my($class, $word) = @_;
4058 # I believed for many years that this was sorted, today I
4059 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
4060 # make it sorted again. Maybe sort was dropped when GNU-readline
4061 # support came in? The RCS file is difficult to read on that:-(
4062 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4065 #-> sub CPAN::Complete::cpl_any ;
4069 cplx('CPAN::Author',$word),
4070 cplx('CPAN::Bundle',$word),
4071 cplx('CPAN::Distribution',$word),
4072 cplx('CPAN::Module',$word),
4076 #-> sub CPAN::Complete::cpl_reload ;
4078 my($word,$line,$pos) = @_;
4080 my(@words) = split " ", $line;
4081 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4082 my(@ok) = qw(cpan index);
4083 return @ok if @words == 1;
4084 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4087 #-> sub CPAN::Complete::cpl_option ;
4089 my($word,$line,$pos) = @_;
4091 my(@words) = split " ", $line;
4092 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4093 my(@ok) = qw(conf debug);
4094 return @ok if @words == 1;
4095 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4097 } elsif ($words[1] eq 'index') {
4099 } elsif ($words[1] eq 'conf') {
4100 return CPAN::HandleConfig::cpl(@_);
4101 } elsif ($words[1] eq 'debug') {
4102 return sort grep /^\Q$word\E/i,
4103 sort keys %CPAN::DEBUG, 'all';
4107 package CPAN::Index;
4110 #-> sub CPAN::Index::force_reload ;
4113 $CPAN::Index::LAST_TIME = 0;
4117 #-> sub CPAN::Index::reload ;
4119 my($self,$force) = @_;
4122 # XXX check if a newer one is available. (We currently read it
4123 # from time to time)
4124 for ($CPAN::Config->{index_expire}) {
4125 $_ = 0.001 unless $_ && $_ > 0.001;
4127 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4128 # debug here when CPAN doesn't seem to read the Metadata
4130 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4132 unless ($CPAN::META->{PROTOCOL}) {
4133 $self->read_metadata_cache;
4134 $CPAN::META->{PROTOCOL} ||= "1.0";
4136 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
4137 # warn "Setting last_time to 0";
4138 $LAST_TIME = 0; # No warning necessary
4140 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4143 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4145 # IFF we are developing, it helps to wipe out the memory
4146 # between reloads, otherwise it is not what a user expects.
4147 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4148 $CPAN::META = CPAN->new;
4151 local $LAST_TIME = $time;
4152 local $CPAN::META->{PROTOCOL} = PROTOCOL;
4154 my $needshort = $^O eq "dos";
4156 $self->rd_authindex($self
4158 "authors/01mailrc.txt.gz",
4160 File::Spec->catfile('authors', '01mailrc.gz') :
4161 File::Spec->catfile('authors', '01mailrc.txt.gz'),
4164 $debug = "timing reading 01[".($t2 - $time)."]";
4166 return if $CPAN::Signal; # this is sometimes lengthy
4167 $self->rd_modpacks($self
4169 "modules/02packages.details.txt.gz",
4171 File::Spec->catfile('modules', '02packag.gz') :
4172 File::Spec->catfile('modules', '02packages.details.txt.gz'),
4175 $debug .= "02[".($t2 - $time)."]";
4177 return if $CPAN::Signal; # this is sometimes lengthy
4178 $self->rd_modlist($self
4180 "modules/03modlist.data.gz",
4182 File::Spec->catfile('modules', '03mlist.gz') :
4183 File::Spec->catfile('modules', '03modlist.data.gz'),
4185 $self->write_metadata_cache;
4187 $debug .= "03[".($t2 - $time)."]";
4189 CPAN->debug($debug) if $CPAN::DEBUG;
4191 if ($CPAN::Config->{build_dir_reuse}) {
4192 $self->reanimate_build_dir;
4194 if ($CPAN::Config->{use_sqlite} && CPAN::_init_sqlite) { # not yet officially supported
4195 $CPAN::SQLite->reload(time => $time, force => $force)
4199 $CPAN::META->{PROTOCOL} = PROTOCOL;
4202 #-> sub CPAN::Index::reanimate_build_dir ;
4203 sub reanimate_build_dir {
4205 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4208 return if $HAVE_REANIMATED++;
4209 my $d = $CPAN::Config->{build_dir};
4210 my $dh = DirHandle->new;
4211 opendir $dh, $d or return; # does not exist
4216 $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4217 my @candidates = map { $_->[0] }
4218 sort { $b->[1] <=> $a->[1] }
4219 map { [ $_, -M File::Spec->catfile($d,$_) ] }
4220 grep {/\.yml$/} readdir $dh;
4221 DISTRO: for $dirent (@candidates) {
4222 my $c = CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))->[0];
4223 if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4224 my $key = $c->{distribution}{ID};
4225 for my $k (keys %{$c->{distribution}}) {
4226 if ($c->{distribution}{$k}
4227 && ref $c->{distribution}{$k}
4228 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4229 $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4233 #we tried to restore only if element already
4234 #exists; but then we do not work with metadata
4236 $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} = $c->{distribution};
4240 while (($painted/76) < ($i/@candidates)) {
4241 $CPAN::Frontend->myprint(".");
4245 $CPAN::Frontend->myprint(sprintf(
4246 "DONE\nFound %s old builds, restored the state of %s\n",
4247 @candidates ? sprintf("%d",scalar @candidates) : "no",
4248 $restored || "none",
4253 #-> sub CPAN::Index::reload_x ;
4255 my($cl,$wanted,$localname,$force) = @_;
4256 $force |= 2; # means we're dealing with an index here
4257 CPAN::HandleConfig->load; # we should guarantee loading wherever
4258 # we rely on Config XXX
4259 $localname ||= $wanted;
4260 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4264 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4267 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4268 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4269 qq{day$s. I\'ll use that.});
4272 $force |= 1; # means we're quite serious about it.
4274 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4277 #-> sub CPAN::Index::rd_authindex ;
4279 my($cl, $index_target) = @_;
4281 return unless defined $index_target;
4282 $CPAN::Frontend->myprint("Going to read $index_target\n");
4284 tie *FH, 'CPAN::Tarzip', $index_target;
4287 push @lines, split /\012/ while <FH>;
4291 my($userid,$fullname,$email) =
4292 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4293 $fullname ||= $email;
4294 if ($userid && $fullname && $email){
4295 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4296 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4298 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4301 while (($painted/76) < ($i/@lines)) {
4302 $CPAN::Frontend->myprint(".");
4305 return if $CPAN::Signal;
4307 $CPAN::Frontend->myprint("DONE\n");
4311 my($self,$dist) = @_;
4312 $dist = $self->{'id'} unless defined $dist;
4313 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4317 #-> sub CPAN::Index::rd_modpacks ;
4319 my($self, $index_target) = @_;
4320 return unless defined $index_target;
4321 $CPAN::Frontend->myprint("Going to read $index_target\n");
4322 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4324 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4327 while (my $bytes = $fh->READ(\$chunk,8192)) {
4330 my @lines = split /\012/, $slurp;
4331 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4334 my($line_count,$last_updated);
4336 my $shift = shift(@lines);
4337 last if $shift =~ /^\s*$/;
4338 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4339 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4341 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4342 if (not defined $line_count) {
4344 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4345 Please check the validity of the index file by comparing it to more
4346 than one CPAN mirror. I'll continue but problems seem likely to
4350 $CPAN::Frontend->mysleep(5);
4351 } elsif ($line_count != scalar @lines) {
4353 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4354 contains a Line-Count header of %d but I see %d lines there. Please
4355 check the validity of the index file by comparing it to more than one
4356 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4357 $index_target, $line_count, scalar(@lines));
4360 if (not defined $last_updated) {
4362 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4363 Please check the validity of the index file by comparing it to more
4364 than one CPAN mirror. I'll continue but problems seem likely to
4368 $CPAN::Frontend->mysleep(5);
4372 ->myprint(sprintf qq{ Database was generated on %s\n},
4374 $DATE_OF_02 = $last_updated;
4377 if ($CPAN::META->has_inst('HTTP::Date')) {
4379 $age -= HTTP::Date::str2time($last_updated);
4381 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
4382 require Time::Local;
4383 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4384 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4385 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4392 qq{Warning: This index file is %d days old.
4393 Please check the host you chose as your CPAN mirror for staleness.
4394 I'll continue but problems seem likely to happen.\a\n},
4397 } elsif ($age < -1) {
4401 qq{Warning: Your system date is %d days behind this index file!
4403 Timestamp index file: %s
4404 Please fix your system time, problems with the make command expected.\n},
4414 # A necessity since we have metadata_cache: delete what isn't
4416 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4417 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4422 # before 1.56 we split into 3 and discarded the rest. From
4423 # 1.57 we assign remaining text to $comment thus allowing to
4424 # influence isa_perl
4425 my($mod,$version,$dist,$comment) = split " ", $_, 4;
4426 my($bundle,$id,$userid);
4428 if ($mod eq 'CPAN' &&
4430 CPAN::Queue->exists('Bundle::CPAN') ||
4431 CPAN::Queue->exists('CPAN')
4435 if ($version > $CPAN::VERSION){
4436 $CPAN::Frontend->mywarn(qq{
4437 New CPAN.pm version (v$version) available.
4438 [Currently running version is v$CPAN::VERSION]
4439 You might want to try
4442 to both upgrade CPAN.pm and run the new version without leaving
4443 the current session.
4446 $CPAN::Frontend->mysleep(2);
4447 $CPAN::Frontend->myprint(qq{\n});
4449 last if $CPAN::Signal;
4450 } elsif ($mod =~ /^Bundle::(.*)/) {
4455 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
4456 # Let's make it a module too, because bundles have so much
4457 # in common with modules.
4459 # Changed in 1.57_63: seems like memory bloat now without
4460 # any value, so commented out
4462 # $CPAN::META->instance('CPAN::Module',$mod);
4466 # instantiate a module object
4467 $id = $CPAN::META->instance('CPAN::Module',$mod);
4471 # Although CPAN prohibits same name with different version the
4472 # indexer may have changed the version for the same distro
4473 # since the last time ("Force Reindexing" feature)
4474 if ($id->cpan_file ne $dist
4476 $id->cpan_version ne $version
4478 $userid = $id->userid || $self->userid($dist);
4480 'CPAN_USERID' => $userid,
4481 'CPAN_VERSION' => $version,
4482 'CPAN_FILE' => $dist,
4486 # instantiate a distribution object
4487 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4488 # we do not need CONTAINSMODS unless we do something with
4489 # this dist, so we better produce it on demand.
4491 ## my $obj = $CPAN::META->instance(
4492 ## 'CPAN::Distribution' => $dist
4494 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4496 $CPAN::META->instance(
4497 'CPAN::Distribution' => $dist
4499 'CPAN_USERID' => $userid,
4500 'CPAN_COMMENT' => $comment,
4504 for my $name ($mod,$dist) {
4505 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4506 $exists{$name} = undef;
4510 while (($painted/76) < ($i/@lines)) {
4511 $CPAN::Frontend->myprint(".");
4514 return if $CPAN::Signal;
4516 $CPAN::Frontend->myprint("DONE\n");
4518 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4519 for my $o ($CPAN::META->all_objects($class)) {
4520 next if exists $exists{$o->{ID}};
4521 $CPAN::META->delete($class,$o->{ID});
4522 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4529 #-> sub CPAN::Index::rd_modlist ;
4531 my($cl,$index_target) = @_;
4532 return unless defined $index_target;
4533 $CPAN::Frontend->myprint("Going to read $index_target\n");
4534 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4538 while (my $bytes = $fh->READ(\$chunk,8192)) {
4541 my @eval2 = split /\012/, $slurp;
4544 my $shift = shift(@eval2);
4545 if ($shift =~ /^Date:\s+(.*)/){
4546 if ($DATE_OF_03 eq $1){
4547 $CPAN::Frontend->myprint("Unchanged.\n");
4552 last if $shift =~ /^\s*$/;
4554 push @eval2, q{CPAN::Modulelist->data;};
4556 my($comp) = Safe->new("CPAN::Safe1");
4557 my($eval2) = join("\n", @eval2);
4558 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4559 my $ret = $comp->reval($eval2);
4560 Carp::confess($@) if $@;
4561 return if $CPAN::Signal;
4563 my $until = keys(%$ret);
4565 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4567 my $obj = $CPAN::META->instance("CPAN::Module",$_);
4568 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4569 $obj->set(%{$ret->{$_}});
4571 while (($painted/76) < ($i/$until)) {
4572 $CPAN::Frontend->myprint(".");
4575 return if $CPAN::Signal;
4577 $CPAN::Frontend->myprint("DONE\n");
4580 #-> sub CPAN::Index::write_metadata_cache ;
4581 sub write_metadata_cache {
4583 return unless $CPAN::Config->{'cache_metadata'};
4584 return unless $CPAN::META->has_usable("Storable");
4586 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4587 CPAN::Distribution)) {
4588 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4590 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4591 $cache->{last_time} = $LAST_TIME;
4592 $cache->{DATE_OF_02} = $DATE_OF_02;
4593 $cache->{PROTOCOL} = PROTOCOL;
4594 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4595 eval { Storable::nstore($cache, $metadata_file) };
4596 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4599 #-> sub CPAN::Index::read_metadata_cache ;
4600 sub read_metadata_cache {
4602 return unless $CPAN::Config->{'cache_metadata'};
4603 return unless $CPAN::META->has_usable("Storable");
4604 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4605 return unless -r $metadata_file and -f $metadata_file;
4606 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4608 eval { $cache = Storable::retrieve($metadata_file) };
4609 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4610 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4614 if (exists $cache->{PROTOCOL}) {
4615 if (PROTOCOL > $cache->{PROTOCOL}) {
4616 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4617 "with protocol v%s, requiring v%s\n",
4624 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4625 "with protocol v1.0\n");
4630 while(my($class,$v) = each %$cache) {
4631 next unless $class =~ /^CPAN::/;
4632 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4633 while (my($id,$ro) = each %$v) {
4634 $CPAN::META->{readwrite}{$class}{$id} ||=
4635 $class->new(ID=>$id, RO=>$ro);
4640 unless ($clcnt) { # sanity check
4641 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4644 if ($idcnt < 1000) {
4645 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4646 "in $metadata_file\n");
4649 $CPAN::META->{PROTOCOL} ||=
4650 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4651 # does initialize to some protocol
4652 $LAST_TIME = $cache->{last_time};
4653 $DATE_OF_02 = $cache->{DATE_OF_02};
4654 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
4655 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4659 package CPAN::InfoObj;
4664 exists $self->{RO} and return $self->{RO};
4667 #-> sub CPAN::InfoObj::cpan_userid
4672 return $ro->{CPAN_USERID} || "N/A";
4674 $self->debug("ID[$self->{ID}]");
4675 # N/A for bundles found locally
4680 sub id { shift->{ID}; }
4682 #-> sub CPAN::InfoObj::new ;
4684 my $this = bless {}, shift;
4689 # The set method may only be used by code that reads index data or
4690 # otherwise "objective" data from the outside world. All session
4691 # related material may do anything else with instance variables but
4692 # must not touch the hash under the RO attribute. The reason is that
4693 # the RO hash gets written to Metadata file and is thus persistent.
4695 #-> sub CPAN::InfoObj::safe_chdir ;
4697 my($self,$todir) = @_;
4698 # we die if we cannot chdir and we are debuggable
4699 Carp::confess("safe_chdir called without todir argument")
4700 unless defined $todir and length $todir;
4702 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4706 unless (-x $todir) {
4707 unless (chmod 0755, $todir) {
4708 my $cwd = CPAN::anycwd();
4709 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4710 "permission to change the permission; cannot ".
4711 "chdir to '$todir'\n");
4712 $CPAN::Frontend->mysleep(5);
4713 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4714 qq{to todir[$todir]: $!});
4718 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4721 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4724 my $cwd = CPAN::anycwd();
4725 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4726 qq{to todir[$todir] (a chmod has been issued): $!});
4731 #-> sub CPAN::InfoObj::set ;
4733 my($self,%att) = @_;
4734 my $class = ref $self;
4736 # This must be ||=, not ||, because only if we write an empty
4737 # reference, only then the set method will write into the readonly
4738 # area. But for Distributions that spring into existence, maybe
4739 # because of a typo, we do not like it that they are written into
4740 # the readonly area and made permanent (at least for a while) and
4741 # that is why we do not "allow" other places to call ->set.
4742 unless ($self->id) {
4743 CPAN->debug("Bug? Empty ID, rejecting");
4746 my $ro = $self->{RO} =
4747 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4749 while (my($k,$v) = each %att) {
4754 #-> sub CPAN::InfoObj::as_glimpse ;
4758 my $class = ref($self);
4759 $class =~ s/^CPAN:://;
4760 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4761 push @m, sprintf "%-15s %s\n", $class, $id;
4765 #-> sub CPAN::InfoObj::as_string ;
4769 my $class = ref($self);
4770 $class =~ s/^CPAN:://;
4771 push @m, $class, " id = $self->{ID}\n";
4773 unless ($ro = $self->ro) {
4774 if (substr($self->{ID},-1,1) eq ".") { # directory
4777 $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4780 for (sort keys %$ro) {
4781 # next if m/^(ID|RO)$/;
4783 if ($_ eq "CPAN_USERID") {
4785 $extra .= $self->fullname;
4786 my $email; # old perls!
4787 if ($email = $CPAN::META->instance("CPAN::Author",
4790 $extra .= " <$email>";
4792 $extra .= " <no email>";
4795 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4796 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
4799 next unless defined $ro->{$_};
4800 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
4802 KEY: for (sort keys %$self) {
4803 next if m/^(ID|RO)$/;
4804 unless (defined $self->{$_}) {
4808 if (ref($self->{$_}) eq "ARRAY") {
4809 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
4810 } elsif (ref($self->{$_}) eq "HASH") {
4812 if (/^CONTAINSMODS$/) {
4813 $value = join(" ",sort keys %{$self->{$_}});
4814 } elsif (/^prereq_pm$/) {
4816 my $v = $self->{$_};
4817 for my $x (sort keys %$v) {
4819 for my $y (sort keys %{$v->{$x}}) {
4820 push @svalue, "$y=>$v->{$x}{$y}";
4822 push @value, "$x\:" . join ",", @svalue if @svalue;
4824 $value = join ";", @value;
4826 $value = $self->{$_};
4834 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
4840 #-> sub CPAN::InfoObj::fullname ;
4843 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4846 #-> sub CPAN::InfoObj::dump ;
4848 my($self, $what) = @_;
4849 unless ($CPAN::META->has_inst("Data::Dumper")) {
4850 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4852 local $Data::Dumper::Sortkeys;
4853 $Data::Dumper::Sortkeys = 1;
4854 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4855 if (length $out > 100000) {
4856 my $fh_pager = FileHandle->new;
4857 local($SIG{PIPE}) = "IGNORE";
4858 my $pager = $CPAN::Config->{'pager'} || "cat";
4859 $fh_pager->open("|$pager")
4860 or die "Could not open pager $pager\: $!";
4861 $fh_pager->print($out);
4864 $CPAN::Frontend->myprint($out);
4868 package CPAN::Author;
4871 #-> sub CPAN::Author::force
4877 #-> sub CPAN::Author::force
4880 delete $self->{force};
4883 #-> sub CPAN::Author::id
4886 my $id = $self->{ID};
4887 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4891 #-> sub CPAN::Author::as_glimpse ;
4895 my $class = ref($self);
4896 $class =~ s/^CPAN:://;
4897 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4905 #-> sub CPAN::Author::fullname ;
4907 shift->ro->{FULLNAME};
4911 #-> sub CPAN::Author::email ;
4912 sub email { shift->ro->{EMAIL}; }
4914 #-> sub CPAN::Author::ls ;
4917 my $glob = shift || "";
4918 my $silent = shift || 0;
4921 # adapted from CPAN::Distribution::verifyCHECKSUM ;
4922 my(@csf); # chksumfile
4923 @csf = $self->id =~ /(.)(.)(.*)/;
4924 $csf[1] = join "", @csf[0,1];
4925 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4927 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4928 unless (grep {$_->[2] eq $csf[1]} @dl) {
4929 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4932 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4933 unless (grep {$_->[2] eq $csf[2]} @dl) {
4934 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4937 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4939 if ($CPAN::META->has_inst("Text::Glob")) {
4940 my $rglob = Text::Glob::glob_to_regex($glob);
4941 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4943 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4946 $CPAN::Frontend->myprint(join "", map {
4947 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4948 } sort { $a->[2] cmp $b->[2] } @dl);
4952 # returns an array of arrays, the latter contain (size,mtime,filename)
4953 #-> sub CPAN::Author::dir_listing ;
4956 my $chksumfile = shift;
4957 my $recursive = shift;
4958 my $may_ftp = shift;
4961 File::Spec->catfile($CPAN::Config->{keep_source_where},
4962 "authors", "id", @$chksumfile);
4966 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4967 # hazard. (Without GPG installed they are not that much better,
4969 $fh = FileHandle->new;
4970 if (open($fh, $lc_want)) {
4971 my $line = <$fh>; close $fh;
4972 unlink($lc_want) unless $line =~ /PGP/;
4976 # connect "force" argument with "index_expire".
4977 my $force = $self->{force};
4978 if (my @stat = stat $lc_want) {
4979 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4983 $lc_file = CPAN::FTP->localize(
4984 "authors/id/@$chksumfile",
4989 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4990 $chksumfile->[-1] .= ".gz";
4991 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4994 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4995 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5001 $lc_file = $lc_want;
5002 # we *could* second-guess and if the user has a file: URL,
5003 # then we could look there. But on the other hand, if they do
5004 # have a file: URL, wy did they choose to set
5005 # $CPAN::Config->{show_upload_date} to false?
5008 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5009 $fh = FileHandle->new;
5011 if (open $fh, $lc_file){
5014 $eval =~ s/\015?\012/\n/g;
5016 my($comp) = Safe->new();
5017 $cksum = $comp->reval($eval);
5019 rename $lc_file, "$lc_file.bad";
5020 Carp::confess($@) if $@;
5022 } elsif ($may_ftp) {
5023 Carp::carp "Could not open '$lc_file' for reading.";
5025 # Maybe should warn: "You may want to set show_upload_date to a true value"
5029 for $f (sort keys %$cksum) {
5030 if (exists $cksum->{$f}{isdir}) {
5032 my(@dir) = @$chksumfile;
5034 push @dir, $f, "CHECKSUMS";
5036 [$_->[0], $_->[1], "$f/$_->[2]"]
5037 } $self->dir_listing(\@dir,1,$may_ftp);
5039 push @result, [ 0, "-", $f ];
5043 ($cksum->{$f}{"size"}||0),
5044 $cksum->{$f}{"mtime"}||"---",
5052 package CPAN::Distribution;
5058 my $ro = $self->ro or return;
5062 # CPAN::Distribution::undelay
5065 delete $self->{later};
5068 # add the A/AN/ stuff
5069 # CPAN::Distribution::normalize
5072 $s = $self->id unless defined $s;
5073 if (substr($s,-1,1) eq ".") {
5074 # using a global because we are sometimes called as static method
5075 if (!$CPAN::META->{LOCK}
5076 && !$CPAN::Have_warned->{"$s is unlocked"}++
5078 $CPAN::Frontend->mywarn("You are visiting the local directory
5080 without lock, take care that concurrent processes do not do likewise.\n");
5081 $CPAN::Frontend->mysleep(1);
5084 $s = "$CPAN::iCwd/.";
5085 } elsif (File::Spec->file_name_is_absolute($s)) {
5086 } elsif (File::Spec->can("rel2abs")) {
5087 $s = File::Spec->rel2abs($s);
5089 $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5091 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5092 unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5093 for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5094 $_->{build_dir} = $s;
5095 $_->{archived} = "local_directory";
5096 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5102 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5104 return $s if $s =~ m:^N/A|^Contact Author: ;
5105 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5106 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5107 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5112 #-> sub CPAN::Distribution::author ;
5116 if (substr($self->id,-1,1) eq ".") {
5117 $authorid = "LOCAL";
5119 ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5121 CPAN::Shell->expand("Author",$authorid);
5124 # tries to get the yaml from CPAN instead of the distro itself:
5125 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5128 my $meta = $self->pretty_id;
5129 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5130 my(@ls) = CPAN::Shell->globls($meta);
5131 my $norm = $self->normalize($meta);
5135 File::Spec->catfile(
5136 $CPAN::Config->{keep_source_where},
5141 $self->debug("Doing localize") if $CPAN::DEBUG;
5142 unless ($local_file =
5143 CPAN::FTP->localize("authors/id/$norm",
5145 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5147 my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5150 #-> sub CPAN::Distribution::cpan_userid
5153 if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5156 return $self->SUPER::cpan_userid;
5159 #-> sub CPAN::Distribution::pretty_id
5163 return $id unless $id =~ m|^./../|;
5167 # mark as dirty/clean
5168 #-> sub CPAN::Distribution::color_cmd_tmps ;
5169 sub color_cmd_tmps {
5171 my($depth) = shift || 0;
5172 my($color) = shift || 0;
5173 my($ancestors) = shift || [];
5174 # a distribution needs to recurse into its prereq_pms
5176 return if exists $self->{incommandcolor}
5177 && $self->{incommandcolor}==$color;
5179 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5181 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5182 my $prereq_pm = $self->prereq_pm;
5183 if (defined $prereq_pm) {
5184 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5185 keys %{$prereq_pm->{build_requires}||{}}) {
5186 next PREREQ if $pre eq "perl";
5188 unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5189 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5190 $CPAN::Frontend->mysleep(2);
5193 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5197 delete $self->{sponsored_mods};
5198 delete $self->{badtestcnt};
5200 $self->{incommandcolor} = $color;
5203 #-> sub CPAN::Distribution::as_string ;
5206 $self->containsmods;
5208 $self->SUPER::as_string(@_);
5211 #-> sub CPAN::Distribution::containsmods ;
5214 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5215 my $dist_id = $self->{ID};
5216 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5217 my $mod_file = $mod->cpan_file or next;
5218 my $mod_id = $mod->{ID} or next;
5219 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5221 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5223 keys %{$self->{CONTAINSMODS}};
5226 #-> sub CPAN::Distribution::upload_date ;
5229 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5230 my(@local_wanted) = split(/\//,$self->id);
5231 my $filename = pop @local_wanted;
5232 push @local_wanted, "CHECKSUMS";
5233 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5234 return unless $author;
5235 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5237 my($dirent) = grep { $_->[2] eq $filename } @dl;
5238 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5239 return unless $dirent->[1];
5240 return $self->{UPLOAD_DATE} = $dirent->[1];
5243 #-> sub CPAN::Distribution::uptodate ;
5247 foreach $c ($self->containsmods) {
5248 my $obj = CPAN::Shell->expandany($c);
5249 unless ($obj->uptodate){
5250 my $id = $self->pretty_id;
5251 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5258 #-> sub CPAN::Distribution::called_for ;
5261 $self->{CALLED_FOR} = $id if defined $id;
5262 return $self->{CALLED_FOR};
5265 #-> sub CPAN::Distribution::get ;
5268 if (my $goto = $self->prefs->{goto}) {
5269 $CPAN::Frontend->mywarn
5271 "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5273 $self->{prefs_file},
5274 $self->{prefs_file_doc},
5276 return $self->goto($goto);
5278 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5280 : ($ENV{PERLLIB} || "");
5282 $CPAN::META->set_perl5lib;
5283 local $ENV{MAKEFLAGS}; # protect us from outer make calls
5287 if ($self->prefs->{disabled}) {
5289 "disabled via prefs file '%s' doc %d",
5290 $self->{prefs_file},
5291 $self->{prefs_file_doc},
5294 exists $self->{build_dir} and push @e,
5295 "Is already unwrapped into directory $self->{build_dir}";
5297 exists $self->{unwrapped} and (
5298 UNIVERSAL::can($self->{unwrapped},"failed") ?
5299 $self->{unwrapped}->failed :
5300 $self->{unwrapped} =~ /^NO/
5302 and push @e, "Unwrapping had some problem, won't try again without force";
5304 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
5306 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5309 # Get the file on local disk
5314 File::Spec->catfile(
5315 $CPAN::Config->{keep_source_where},
5318 split(/\//,$self->id)
5321 $self->debug("Doing localize") if $CPAN::DEBUG;
5322 unless ($local_file =
5323 CPAN::FTP->localize("authors/id/$self->{ID}",
5326 if ($CPAN::Index::DATE_OF_02) {
5327 $note = "Note: Current database in memory was generated ".
5328 "on $CPAN::Index::DATE_OF_02\n";
5330 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5333 $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5334 $self->{localfile} = $local_file;
5335 return if $CPAN::Signal;
5340 if ($CPAN::META->has_inst("Digest::SHA")) {
5341 $self->debug("Digest::SHA is installed, verifying");
5342 $self->verifyCHECKSUM;
5344 $self->debug("Digest::SHA is NOT installed");
5346 return if $CPAN::Signal;
5349 # Create a clean room and go there
5351 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5352 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5353 $self->safe_chdir($builddir);
5354 $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5355 File::Path::rmtree("tmp-$$");
5356 unless (mkdir "tmp-$$", 0755) {
5357 $CPAN::Frontend->unrecoverable_error(<<EOF);
5358 Couldn't mkdir '$builddir/tmp-$$': $!
5360 Cannot continue: Please find the reason why I cannot make the
5363 and fix the problem, then retry.
5368 $self->safe_chdir($sub_wd);
5371 $self->safe_chdir("tmp-$$");
5376 my $ct = eval{CPAN::Tarzip->new($local_file)};
5378 $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5379 delete $self->{build_dir};
5382 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5383 $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5384 $self->untar_me($ct);
5385 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5386 $self->unzip_me($ct);
5388 $self->{was_uncompressed}++ unless $ct->gtest();
5389 $local_file = $self->handle_singlefile($local_file);
5391 # $self->{archived} = "NO";
5392 # $self->safe_chdir($sub_wd);
5396 # we are still in the tmp directory!
5397 # Let's check if the package has its own directory.
5398 my $dh = DirHandle->new(File::Spec->curdir)
5399 or Carp::croak("Couldn't opendir .: $!");
5400 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5403 # XXX here we want in each branch File::Temp to protect all build_dir directories
5404 if (CPAN->has_inst("File::Temp")) {
5408 if (@readdir == 1 && -d $readdir[0]) {
5409 $tdir_base = $readdir[0];
5410 $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5411 my $dh2 = DirHandle->new($from_dir)
5412 or Carp::croak("Couldn't opendir $from_dir: $!");
5413 @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5415 my $userid = $self->cpan_userid;
5416 CPAN->debug("userid[$userid]");
5417 if (!$userid or $userid eq "N/A") {
5420 $tdir_base = $userid;
5421 $from_dir = File::Spec->curdir;
5422 @dirents = @readdir;
5424 $packagedir = File::Temp::tempdir(
5425 "$tdir_base-XXXXXX",
5430 for $f (@dirents) { # is already without "." and ".."
5431 my $from = File::Spec->catdir($from_dir,$f);
5432 my $to = File::Spec->catdir($packagedir,$f);
5433 File::Copy::move($from,$to) or Carp::confess("Couldn't move $from to $to: $!");
5435 } else { # older code below, still better than nothing when there is no File::Temp
5437 if (@readdir == 1 && -d $readdir[0]) {
5438 $distdir = $readdir[0];
5439 $packagedir = File::Spec->catdir($builddir,$distdir);
5440 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5442 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5444 File::Path::rmtree($packagedir);
5445 unless (File::Copy::move($distdir,$packagedir)) {
5446 $CPAN::Frontend->unrecoverable_error(<<EOF);
5447 Couldn't move '$distdir' to '$packagedir': $!
5449 Cannot continue: Please find the reason why I cannot move
5450 $builddir/tmp-$$/$distdir
5453 and fix the problem, then retry
5457 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5464 my $userid = $self->cpan_userid;
5465 CPAN->debug("userid[$userid]");
5466 if (!$userid or $userid eq "N/A") {
5469 my $pragmatic_dir = $userid . '000';
5470 $pragmatic_dir =~ s/\W_//g;
5471 $pragmatic_dir++ while -d "../$pragmatic_dir";
5472 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5473 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5474 File::Path::mkpath($packagedir);
5476 for $f (@readdir) { # is already without "." and ".."
5477 my $to = File::Spec->catdir($packagedir,$f);
5478 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5483 $self->safe_chdir($sub_wd);
5487 $self->{'build_dir'} = $packagedir;
5488 $self->safe_chdir($builddir);
5489 File::Path::rmtree("tmp-$$");
5491 $self->safe_chdir($packagedir);
5492 $self->_signature_business();
5493 $self->safe_chdir($builddir);
5494 return if $CPAN::Signal;
5497 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5498 my($mpl_exists) = -f $mpl;
5499 unless ($mpl_exists) {
5500 # NFS has been reported to have racing problems after the
5501 # renaming of a directory in some environments.
5503 $CPAN::Frontend->mysleep(1);
5504 my $mpldh = DirHandle->new($packagedir)
5505 or Carp::croak("Couldn't opendir $packagedir: $!");
5506 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5509 my $prefer_installer = "eumm"; # eumm|mb
5510 if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5511 if ($mpl_exists) { # they *can* choose
5512 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5513 q{prefer_installer});
5515 $prefer_installer = "mb";
5518 return unless $self->patch;
5519 if (lc($prefer_installer) eq "mb") {
5520 $self->{modulebuild} = 1;
5521 } elsif (! $mpl_exists) {
5522 $self->_edge_cases($mpl,$packagedir,$local_file);
5524 if ($self->{build_dir}
5526 $CPAN::Config->{build_dir_reuse}
5528 $self->store_persistent_state;
5534 #-> CPAN::Distribution::store_persistent_state
5535 sub store_persistent_state {
5537 my $dir = $self->{build_dir};
5538 unless (File::Basename::dirname($dir) eq $CPAN::Config->{build_dir}) {
5539 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5540 "will not store persistent state\n");
5543 my $file = sprintf "%s.yml", $dir;
5544 CPAN->_yaml_dumpfile(
5548 perl => CPAN::_perl_fingerprint,
5549 distribution => $self,
5554 #-> CPAN::Distribution::patch
5556 my($self,$patch) = @_;
5557 my $norm = $self->normalize($patch);
5559 File::Spec->catfile(
5560 $CPAN::Config->{keep_source_where},
5565 $self->debug("Doing localize") if $CPAN::DEBUG;
5566 return CPAN::FTP->localize("authors/id/$norm",
5570 #-> CPAN::Distribution::patch
5573 if (my $patches = $self->prefs->{patches}) {
5574 return unless @$patches;
5575 $self->safe_chdir($self->{build_dir});
5576 CPAN->debug("patches[$patches]");
5577 my $patchbin = $CPAN::Config->{patch};
5578 unless ($patchbin && length $patchbin) {
5579 $CPAN::Frontend->mydie("No external patch command configured\n\n".
5580 "Please run 'o conf init /patch/'\n\n");
5582 unless (MM->maybe_command($patchbin)) {
5583 $CPAN::Frontend->mydie("No external patch command available\n\n".
5584 "Please run 'o conf init /patch/'\n\n");
5586 $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5587 local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5588 # supported everywhere (and then,
5589 # not ever necessary there)
5590 my $stdpatchargs = "-N --fuzz=3";
5591 my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5592 $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5593 for my $patch (@$patches) {
5594 unless (-f $patch) {
5595 if (my $trydl = $self->try_download($patch)) {
5598 my $fail = "Could not find patch '$patch'";
5599 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5600 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5601 delete $self->{build_dir};
5605 $CPAN::Frontend->myprint(" $patch\n");
5606 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5607 my $thispatchargs = join " ", $stdpatchargs, $self->_patch_p_parameter($readfh);
5608 CPAN->debug("thispatchargs[$thispatchargs]") if $CPAN::DEBUG;
5609 $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5610 my $writefh = FileHandle->new;
5611 unless (open $writefh, "|$patchbin $thispatchargs") {
5612 my $fail = "Could not fork '$patchbin $thispatchargs'";
5613 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5614 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5615 delete $self->{build_dir};
5618 while (my $x = $readfh->READLINE) {
5621 unless (close $writefh) {
5622 my $fail = "Could not apply patch '$patch'";
5623 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5624 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5625 delete $self->{build_dir};
5634 sub _patch_p_parameter {
5637 my $cnt_p0files = 0;
5639 while ($_ = $fh->READLINE) {
5640 next unless /^[\*\+]{3}\s(\S+)/;
5643 $cnt_p0files++ if -f $file;
5644 CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") if $CPAN::DEBUG;
5646 return "-p1" unless $cnt_files;
5647 return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
5650 #-> sub CPAN::Distribution::_edge_cases
5651 # with "configure" or "Makefile" or single file scripts
5653 my($self,$mpl,$packagedir,$local_file) = @_;
5654 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
5658 my($configure) = File::Spec->catfile($packagedir,"Configure");
5659 if (-f $configure) {
5660 # do we have anything to do?
5661 $self->{configure} = $configure;
5662 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
5663 $CPAN::Frontend->mywarn(qq{
5664 Package comes with a Makefile and without a Makefile.PL.
5665 We\'ll try to build it with that Makefile then.
5667 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5668 $CPAN::Frontend->mysleep(2);
5670 my $cf = $self->called_for || "unknown";
5675 $cf =~ s|[/\\:]||g; # risk of filesystem damage
5676 $cf = "unknown" unless length($cf);
5677 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
5678 (The test -f "$mpl" returned false.)
5679 Writing one on our own (setting NAME to $cf)\a\n});
5680 $self->{had_no_makefile_pl}++;
5681 $CPAN::Frontend->mysleep(3);
5683 # Writing our own Makefile.PL
5686 if ($self->{archived} eq "maybe_pl") {
5687 my $fh = FileHandle->new;
5688 my $script_file = File::Spec->catfile($packagedir,$local_file);
5689 $fh->open($script_file)
5690 or Carp::croak("Could not open $script_file: $!");
5692 # name parsen und prereq
5693 my($state) = "poddir";
5694 my($name, $prereq) = ("", "");
5696 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
5699 } elsif ($1 eq 'PREREQUISITES') {
5702 } elsif ($state =~ m{^(name|prereq)$}) {
5707 } elsif ($state eq "name") {
5712 } elsif ($state eq "prereq") {
5715 } elsif (/^=cut\b/) {
5722 s{.*<}{}; # strip X<...>
5726 $prereq = join " ", split /\s+/, $prereq;
5727 my($PREREQ_PM) = join("\n", map {
5728 s{.*<}{}; # strip X<...>
5730 if (/[\s\'\"]/) { # prose?
5732 s/[^\w:]$//; # period?
5733 " "x28 . "'$_' => 0,";
5735 } split /\s*,\s*/, $prereq);
5738 EXE_FILES => ['$name'],
5744 my $to_file = File::Spec->catfile($packagedir, $name);
5745 rename $script_file, $to_file
5746 or die "Can't rename $script_file to $to_file: $!";
5750 my $fh = FileHandle->new;
5752 or Carp::croak("Could not open >$mpl: $!");
5754 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
5755 # because there was no Makefile.PL supplied.
5756 # Autogenerated on: }.scalar localtime().qq{
5758 use ExtUtils::MakeMaker;
5760 NAME => q[$cf],$script
5767 #-> CPAN::Distribution::_signature_business
5768 sub _signature_business {
5770 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
5773 if ($CPAN::META->has_inst("Module::Signature")) {
5774 if (-f "SIGNATURE") {
5775 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
5776 my $rv = Module::Signature::verify();
5777 if ($rv != Module::Signature::SIGNATURE_OK() and
5778 $rv != Module::Signature::SIGNATURE_MISSING()) {
5779 $CPAN::Frontend->mywarn(
5780 qq{\nSignature invalid for }.
5781 qq{distribution file. }.
5782 qq{Please investigate.\n\n}
5786 sprintf(qq{I'd recommend removing %s. Its signature
5787 is invalid. Maybe you have configured your 'urllist' with
5788 a bad URL. Please check this array with 'o conf urllist', and
5789 retry. For more information, try opening a subshell with
5797 $self->{signature_verify} = CPAN::Distrostatus->new("NO");
5798 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
5799 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
5801 $self->{signature_verify} = CPAN::Distrostatus->new("YES");
5802 $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
5805 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
5808 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
5813 #-> CPAN::Distribution::untar_me ;
5816 $self->{archived} = "tar";
5818 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5820 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
5824 # CPAN::Distribution::unzip_me ;
5827 $self->{archived} = "zip";
5829 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5831 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
5836 sub handle_singlefile {
5837 my($self,$local_file) = @_;
5839 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
5840 $self->{archived} = "pm";
5842 $self->{archived} = "maybe_pl";
5845 my $to = File::Basename::basename($local_file);
5846 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
5847 if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
5848 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
5850 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
5853 File::Copy::cp($local_file,".");
5854 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
5859 #-> sub CPAN::Distribution::new ;
5861 my($class,%att) = @_;
5863 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5865 my $this = { %att };
5866 return bless $this, $class;
5869 #-> sub CPAN::Distribution::look ;
5873 if ($^O eq 'MacOS') {
5874 $self->Mac::BuildTools::look;
5878 if ( $CPAN::Config->{'shell'} ) {
5879 $CPAN::Frontend->myprint(qq{
5880 Trying to open a subshell in the build directory...
5883 $CPAN::Frontend->myprint(qq{
5884 Your configuration does not define a value for subshells.
5885 Please define it with "o conf shell <your shell>"
5889 my $dist = $self->id;
5891 unless ($dir = $self->dir) {
5894 unless ($dir ||= $self->dir) {
5895 $CPAN::Frontend->mywarn(qq{
5896 Could not determine which directory to use for looking at $dist.
5900 my $pwd = CPAN::anycwd();
5901 $self->safe_chdir($dir);
5902 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5904 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
5905 $ENV{CPAN_SHELL_LEVEL} += 1;
5906 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5907 unless (system($shell) == 0) {
5909 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
5912 $self->safe_chdir($pwd);
5915 # CPAN::Distribution::cvs_import ;
5919 my $dir = $self->dir;
5921 my $package = $self->called_for;
5922 my $module = $CPAN::META->instance('CPAN::Module', $package);
5923 my $version = $module->cpan_version;
5925 my $userid = $self->cpan_userid;
5927 my $cvs_dir = (split /\//, $dir)[-1];
5928 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
5930 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
5932 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
5933 if ($cvs_site_perl) {
5934 $cvs_dir = "$cvs_site_perl/$cvs_dir";
5936 my $cvs_log = qq{"imported $package $version sources"};
5937 $version =~ s/\./_/g;
5938 # XXX cvs: undocumented and unclear how it was meant to work
5939 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
5940 "$cvs_dir", $userid, "v$version");
5942 my $pwd = CPAN::anycwd();
5943 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
5945 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5947 $CPAN::Frontend->myprint(qq{@cmd\n});
5948 system(@cmd) == 0 or
5950 $CPAN::Frontend->mydie("cvs import failed");
5951 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5954 #-> sub CPAN::Distribution::readme ;
5957 my($dist) = $self->id;
5958 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
5959 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
5962 File::Spec->catfile(
5963 $CPAN::Config->{keep_source_where},
5966 split(/\//,"$sans.readme"),
5968 $self->debug("Doing localize") if $CPAN::DEBUG;
5969 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
5971 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
5973 if ($^O eq 'MacOS') {
5974 Mac::BuildTools::launch_file($local_file);
5978 my $fh_pager = FileHandle->new;
5979 local($SIG{PIPE}) = "IGNORE";
5980 my $pager = $CPAN::Config->{'pager'} || "cat";
5981 $fh_pager->open("|$pager")
5982 or die "Could not open pager $pager\: $!";
5983 my $fh_readme = FileHandle->new;
5984 $fh_readme->open($local_file)
5985 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
5986 $CPAN::Frontend->myprint(qq{
5991 $fh_pager->print(<$fh_readme>);
5995 #-> sub CPAN::Distribution::verifyCHECKSUM ;
5996 sub verifyCHECKSUM {
6000 $self->{CHECKSUM_STATUS} ||= "";
6001 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6002 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6004 my($lc_want,$lc_file,@local,$basename);
6005 @local = split(/\//,$self->id);
6007 push @local, "CHECKSUMS";
6009 File::Spec->catfile($CPAN::Config->{keep_source_where},
6010 "authors", "id", @local);
6012 if (my $size = -s $lc_want) {
6013 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6014 if ($self->CHECKSUM_check_file($lc_want,1)) {
6015 return $self->{CHECKSUM_STATUS} = "OK";
6018 $lc_file = CPAN::FTP->localize("authors/id/@local",
6021 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6022 $local[-1] .= ".gz";
6023 $lc_file = CPAN::FTP->localize("authors/id/@local",
6026 $lc_file =~ s/\.gz(?!\n)\Z//;
6027 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6032 if ($self->CHECKSUM_check_file($lc_file)) {
6033 return $self->{CHECKSUM_STATUS} = "OK";
6037 #-> sub CPAN::Distribution::SIG_check_file ;
6038 sub SIG_check_file {
6039 my($self,$chk_file) = @_;
6040 my $rv = eval { Module::Signature::_verify($chk_file) };
6042 if ($rv == Module::Signature::SIGNATURE_OK()) {
6043 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6044 return $self->{SIG_STATUS} = "OK";
6046 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6047 qq{distribution file. }.
6048 qq{Please investigate.\n\n}.
6050 $CPAN::META->instance(
6055 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6056 is invalid. Maybe you have configured your 'urllist' with
6057 a bad URL. Please check this array with 'o conf urllist', and
6060 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6064 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6066 # sloppy is 1 when we have an old checksums file that maybe is good
6069 sub CHECKSUM_check_file {
6070 my($self,$chk_file,$sloppy) = @_;
6071 my($cksum,$file,$basename);
6074 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6075 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6078 if ($CPAN::META->has_inst("Module::Signature")) {
6079 $self->debug("Module::Signature is installed, verifying");
6080 $self->SIG_check_file($chk_file);
6082 $self->debug("Module::Signature is NOT installed");
6086 $file = $self->{localfile};
6087 $basename = File::Basename::basename($file);
6088 my $fh = FileHandle->new;
6089 if (open $fh, $chk_file){
6092 $eval =~ s/\015?\012/\n/g;
6094 my($comp) = Safe->new();
6095 $cksum = $comp->reval($eval);
6097 rename $chk_file, "$chk_file.bad";
6098 Carp::confess($@) if $@;
6101 Carp::carp "Could not open $chk_file for reading";
6104 if (! ref $cksum or ref $cksum ne "HASH") {
6105 $CPAN::Frontend->mywarn(qq{
6106 Warning: checksum file '$chk_file' broken.
6108 When trying to read that file I expected to get a hash reference
6109 for further processing, but got garbage instead.
6111 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6112 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6113 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6115 } elsif (exists $cksum->{$basename}{sha256}) {
6116 $self->debug("Found checksum for $basename:" .
6117 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6121 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6123 $fh = CPAN::Tarzip->TIEHANDLE($file);
6126 my $dg = Digest::SHA->new(256);
6129 while ($fh->READ($ref, 4096) > 0){
6132 my $hexdigest = $dg->hexdigest;
6133 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6137 $CPAN::Frontend->myprint("Checksum for $file ok\n");
6138 return $self->{CHECKSUM_STATUS} = "OK";
6140 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6141 qq{distribution file. }.
6142 qq{Please investigate.\n\n}.
6144 $CPAN::META->instance(
6149 my $wrap = qq{I\'d recommend removing $file. Its
6150 checksum is incorrect. Maybe you have configured your 'urllist' with
6151 a bad URL. Please check this array with 'o conf urllist', and
6154 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6156 # former versions just returned here but this seems a
6157 # serious threat that deserves a die
6159 # $CPAN::Frontend->myprint("\n\n");
6163 # close $fh if fileno($fh);
6166 unless ($self->{CHECKSUM_STATUS}) {
6167 $CPAN::Frontend->mywarn(qq{
6168 Warning: No checksum for $basename in $chk_file.
6170 The cause for this may be that the file is very new and the checksum
6171 has not yet been calculated, but it may also be that something is
6172 going awry right now.
6174 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6175 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6177 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6182 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6184 my($self,$fh,$expect) = @_;
6185 if ($CPAN::META->has_inst("Digest::SHA")) {
6186 my $dg = Digest::SHA->new(256);
6188 while (read($fh, $data, 4096)){
6191 my $hexdigest = $dg->hexdigest;
6192 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6193 return $hexdigest eq $expect;
6198 #-> sub CPAN::Distribution::force ;
6200 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6201 # effect by autoinspection, not by inspecting a global variable. One
6202 # of the reason why this was chosen to work that way was the treatment
6203 # of dependencies. They should not automatically inherit the force
6204 # status. But this has the downside that ^C and die() will return to
6205 # the prompt but will not be able to reset the force_update
6206 # attributes. We try to correct for it currently in the read_metadata
6207 # routine, and immediately before we check for a Signal. I hope this
6208 # works out in one of v1.57_53ff
6210 # "Force get forgets previous error conditions"
6212 #-> sub CPAN::Distribution::force ;
6214 my($self, $method) = @_;
6235 delete $self->{$att};
6236 CPAN->debug(sprintf "att[%s]", $att) if $CPAN::DEBUG;
6238 if ($method && $method =~ /make|test|install/) {
6239 $self->{"force_update"}++; # name should probably have been force_install
6243 #-> sub CPAN::Distribution::notest ;
6245 my($self, $method) = @_;
6246 # warn "XDEBUG: set notest for $self $method";
6247 $self->{"notest"}++; # name should probably have been force_install
6250 #-> sub CPAN::Distribution::unnotest ;
6253 # warn "XDEBUG: deleting notest";
6254 delete $self->{'notest'};
6257 #-> sub CPAN::Distribution::unforce ;
6260 delete $self->{'force_update'};
6263 #-> sub CPAN::Distribution::isa_perl ;
6266 my $file = File::Basename::basename($self->id);
6267 if ($file =~ m{ ^ perl
6276 \.tar[._-](?:gz|bz2)
6280 } elsif ($self->cpan_comment
6282 $self->cpan_comment =~ /isa_perl\(.+?\)/){
6288 #-> sub CPAN::Distribution::perl ;
6293 carp __PACKAGE__ . "::perl was called without parameters.";
6295 return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6299 #-> sub CPAN::Distribution::make ;
6302 if (my $goto = $self->prefs->{goto}) {
6303 return $self->goto($goto);
6305 my $make = $self->{modulebuild} ? "Build" : "make";
6306 # Emergency brake if they said install Pippi and get newest perl
6307 if ($self->isa_perl) {
6309 $self->called_for ne $self->id &&
6310 ! $self->{force_update}
6312 # if we die here, we break bundles
6315 qq{The most recent version "%s" of the module "%s"
6316 is part of the perl-%s distribution. To install that, you need to run
6317 force install %s --or--
6320 $CPAN::META->instance(
6329 $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6330 $CPAN::Frontend->mysleep(1);
6334 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6336 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6338 : ($ENV{PERLLIB} || "");
6340 $CPAN::META->set_perl5lib;
6341 local $ENV{MAKEFLAGS}; # protect us from outer make calls
6344 delete $self->{force_update};
6349 if (!$self->{archived} || $self->{archived} eq "NO") {
6350 push @e, "Is neither a tar nor a zip archive.";
6353 if (!$self->{unwrapped}
6355 UNIVERSAL::can($self->{unwrapped},"failed") ?
6356 $self->{unwrapped}->failed :
6357 $self->{unwrapped} =~ /^NO/
6359 push @e, "Had problems unarchiving. Please build manually";
6362 unless ($self->{force_update}) {
6363 exists $self->{signature_verify} and
6365 UNIVERSAL::can($self->{signature_verify},"failed") ?
6366 $self->{signature_verify}->failed :
6367 $self->{signature_verify} =~ /^NO/
6369 and push @e, "Did not pass the signature test.";
6372 if (exists $self->{writemakefile} &&
6374 UNIVERSAL::can($self->{writemakefile},"failed") ?
6375 $self->{writemakefile}->failed :
6376 $self->{writemakefile} =~ /^NO/
6378 # XXX maybe a retry would be in order?
6379 my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6380 $self->{writemakefile}->text :
6381 $self->{writemakefile};
6383 $err ||= "Had some problem writing Makefile";
6384 $err .= ", won't make";
6388 defined $self->{make} and push @e,
6389 "Has already been processed within this session";
6391 if (exists $self->{later} and length($self->{later})) {
6392 if ($self->unsat_prereq) {
6393 push @e, $self->{later};
6394 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6395 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6396 # are not sufficient to be sure if we really must/may do the delete
6397 # here. SO I accept the suggested patch for now. If we trigger a bug
6398 # again, I must go into deep contemplation about the {later} flag.
6401 # delete $self->{later};
6405 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6408 delete $self->{force_update};
6411 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
6412 my $builddir = $self->dir or
6413 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6414 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
6415 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6417 if ($^O eq 'MacOS') {
6418 Mac::BuildTools::make($self);
6423 if ($self->{'configure'}) {
6424 $system = $self->{'configure'};
6425 } elsif ($self->{modulebuild}) {
6426 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6427 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6429 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6431 # This needs a handler that can be turned on or off:
6432 # $switch = "-MExtUtils::MakeMaker ".
6433 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6435 my $makepl_arg = $self->make_x_arg("pl");
6436 $system = sprintf("%s%s Makefile.PL%s",
6438 $switch ? " $switch" : "",
6439 $makepl_arg ? " $makepl_arg" : "",
6443 while (my($k,$v) = each %ENV) {
6444 next unless defined $v;
6448 if (my $env = $self->prefs->{pl}{env}) {
6449 for my $e (keys %$env) {
6450 $ENV{$e} = $env->{$e};
6453 if (exists $self->{writemakefile}) {
6455 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6459 if ($CPAN::Config->{inactivity_timeout}) {
6461 if ($Config::Config{d_alarm}
6463 $Config::Config{d_alarm} eq "define"
6467 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6468 "variable 'inactivity_timeout' to ".
6469 "'$CPAN::Config->{inactivity_timeout}'. But ".
6470 "on this machine the system call 'alarm' ".
6471 "isn't available. This means that we cannot ".
6472 "provide the feature of intercepting long ".
6473 "waiting code and will turn this feature off.\n"
6475 $CPAN::Config->{inactivity_timeout} = 0;
6478 if ($go_via_alarm) {
6480 alarm $CPAN::Config->{inactivity_timeout};
6481 local $SIG{CHLD}; # = sub { wait };
6482 if (defined($pid = fork)) {
6487 # note, this exec isn't necessary if
6488 # inactivity_timeout is 0. On the Mac I'd
6489 # suggest, we set it always to 0.
6493 $CPAN::Frontend->myprint("Cannot fork: $!");
6502 $CPAN::Frontend->myprint($err);
6503 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6508 if (my $expect_model = $self->_prefs_with_expect("pl")) {
6509 $ret = $self->_run_via_expect($system,$expect_model);
6511 && $self->{writemakefile}
6512 && $self->{writemakefile}->failed) {
6517 $ret = system($system);
6520 $self->{writemakefile} = CPAN::Distrostatus
6521 ->new("NO '$system' returned status $ret");
6522 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6523 $self->store_persistent_state;
6524 $self->store_persistent_state;
6528 if (-f "Makefile" || -f "Build") {
6529 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6530 delete $self->{make_clean}; # if cleaned before, enable next
6532 $self->{writemakefile} = CPAN::Distrostatus
6533 ->new(qq{NO -- Unknown reason});
6537 delete $self->{force_update};
6540 if (my @prereq = $self->unsat_prereq){
6541 if ($prereq[0][0] eq "perl") {
6542 my $need = "requires perl '$prereq[0][1]'";
6543 my $id = $self->pretty_id;
6544 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6545 $self->{make} = CPAN::Distrostatus->new("NO $need");
6546 $self->store_persistent_state;
6549 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6553 delete $self->{force_update};
6556 if ($self->{modulebuild}) {
6557 unless (-f "Build") {
6559 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6560 " in cwd[$cwd]. Danger, Will Robinson!");
6561 $CPAN::Frontend->mysleep(5);
6563 $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6565 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
6567 my $make_arg = $self->make_x_arg("make");
6568 $system = sprintf("%s%s",
6570 $make_arg ? " $make_arg" : "",
6572 if (my $env = $self->prefs->{make}{env}) { # overriding the local
6573 # ENV of PL, not the
6575 # unlikely to be a risk
6576 for my $e (keys %$env) {
6577 $ENV{$e} = $env->{$e};
6580 my $expect_model = $self->_prefs_with_expect("make");
6581 my $want_expect = 0;
6582 if ( $expect_model && @{$expect_model->{talk}} ) {
6583 my $can_expect = $CPAN::META->has_inst("Expect");
6587 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
6593 $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
6595 $system_ok = system($system) == 0;
6597 $self->introduce_myself;
6599 $CPAN::Frontend->myprint(" $system -- OK\n");
6600 $self->{make} = CPAN::Distrostatus->new("YES");
6602 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
6603 $self->{make} = CPAN::Distrostatus->new("NO");
6604 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
6606 $self->store_persistent_state;
6609 # CPAN::Distribution::_run_via_expect
6610 sub _run_via_expect {
6611 my($self,$system,$expect_model) = @_;
6612 CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
6613 if ($CPAN::META->has_inst("Expect")) {
6614 my $expo = Expect->new; # expo Expect object;
6615 $expo->spawn($system);
6616 my $expecta = $expect_model->{talk};
6617 if ($expect_model->{mode} eq "expect") {
6618 return $self->_run_via_expect_deterministic($expo,$expecta);
6619 } elsif ($expect_model->{mode} eq "expect-in-any-order") {
6620 return $self->_run_via_expect_anyorder($expo,$expecta);
6622 die "Panic: Illegal expect mode: $expect_model->{mode}";
6625 $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
6626 return system($system);
6630 sub _run_via_expect_anyorder {
6631 my($self,$expo,$expecta) = @_;
6632 my $timeout = 3; # currently unsettable
6633 my @expectacopy = @$expecta; # we trash it!
6636 my($eof,$ran_into_timeout);
6637 my @match = $expo->expect($timeout,
6642 $ran_into_timeout++;
6649 $but .= $expo->clear_accum;
6652 return $expo->exitstatus();
6653 } elsif ($ran_into_timeout) {
6654 # warn "DEBUG: they are asking a question, but[$but]";
6655 for (my $i = 0; $i <= $#expectacopy; $i+=2) {
6656 my($next,$send) = @expectacopy[$i,$i+1];
6657 my $regex = eval "qr{$next}";
6658 # warn "DEBUG: will compare with regex[$regex].";
6659 if ($but =~ /$regex/) {
6660 # warn "DEBUG: will send send[$send]";
6662 splice @expectacopy, $i, 2; # never allow reusing an QA pair
6666 my $why = "could not answer a question during the dialog";
6667 $CPAN::Frontend->mywarn("Failing: $why\n");
6668 $self->{writemakefile} =
6669 CPAN::Distrostatus->new("NO $why");
6675 sub _run_via_expect_deterministic {
6676 my($self,$expo,$expecta) = @_;
6677 my $ran_into_timeout;
6678 EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
6679 my($next,$send) = @$expecta[$i,$i+1];
6682 $timeout = $next->{timeout};
6683 $re = $next->{expect};
6688 CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
6689 my $regex = eval "qr{$re}";
6690 $expo->expect($timeout,
6692 my $but = $expo->clear_accum;
6693 $CPAN::Frontend->mywarn("EOF (maybe harmless)
6694 expected[$regex]\nbut[$but]\n\n");
6698 my $but = $expo->clear_accum;
6699 $CPAN::Frontend->mywarn("TIMEOUT
6700 expected[$regex]\nbut[$but]\n\n");
6701 $ran_into_timeout++;
6704 if ($ran_into_timeout){
6705 # note that the caller expects 0 for success
6706 $self->{writemakefile} =
6707 CPAN::Distrostatus->new("NO timeout during expect dialog");
6713 return $expo->exitstatus();
6716 # CPAN::Distribution::_find_prefs
6719 my $distroid = $self->pretty_id;
6720 CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
6721 my $prefs_dir = $CPAN::Config->{prefs_dir};
6722 eval { File::Path::mkpath($prefs_dir); };
6724 $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
6726 my $yaml_module = CPAN->_yaml_module;
6728 if ($CPAN::META->has_inst($yaml_module)) {
6729 push @extensions, "yml";
6732 if ($CPAN::META->has_inst("Data::Dumper")) {
6733 push @extensions, "dd";
6734 push @fallbacks, "Data::Dumper";
6736 if ($CPAN::META->has_inst("Storable")) {
6737 push @extensions, "st";
6738 push @fallbacks, "Storable";
6742 unless ($self->{have_complained_about_missing_yaml}++) {
6743 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
6744 "to @fallbacks to read prefs '$prefs_dir'\n");
6747 unless ($self->{have_complained_about_missing_yaml}++) {
6748 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
6749 "read prefs '$prefs_dir'\n");
6754 my $dh = DirHandle->new($prefs_dir)
6755 or die Carp::croak("Couldn't open '$prefs_dir': $!");
6756 DIRENT: for (sort $dh->read) {
6757 next if $_ eq "." || $_ eq "..";
6758 my $exte = join "|", @extensions;
6759 next unless /\.($exte)$/;
6761 my $abs = File::Spec->catfile($prefs_dir, $_);
6763 CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
6765 if ($thisexte eq "yml") {
6766 @distropref = @{CPAN->_yaml_loadfile($abs)};
6767 } elsif ($thisexte eq "dd") {
6770 open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
6776 $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
6779 while (${"VAR".$i}) {
6780 push @distropref, ${"VAR".$i};
6783 } elsif ($thisexte eq "st") {
6784 # eval because Storable is never forward compatible
6785 eval { @distropref = @{scalar Storable::retrieve($abs)}; };
6787 $CPAN::Frontend->mywarn("Error reading distroprefs file ".
6788 "$_, skipping\: $@");
6789 $CPAN::Frontend->mysleep(4);
6794 ELEMENT: for my $y (0..$#distropref) {
6795 my $distropref = $distropref[$y];
6796 my $match = $distropref->{match};
6798 CPAN->debug("no 'match' in abs[$abs], skipping");
6802 for my $sub_attribute (keys %$match) {
6803 my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
6804 if ($sub_attribute eq "module") {
6806 CPAN->debug(sprintf "abs[%s]distropref[%d]", $abs, scalar @distropref) if $CPAN::DEBUG;
6807 my @modules = $self->containsmods;
6808 CPAN->debug(sprintf "abs[%s]distropref[%d]modules[%s]", $abs, scalar @distropref, join(",",@modules)) if $CPAN::DEBUG;
6809 MODULE: for my $module (@modules) {
6810 $okm ||= $module =~ /$qr/;
6811 last MODULE if $okm;
6814 } elsif ($sub_attribute eq "distribution") {
6815 my $okd = $distroid =~ /$qr/;
6817 } elsif ($sub_attribute eq "perl") {
6818 my $okp = $^X =~ /$qr/;
6821 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
6822 "unknown sub_attribut '$sub_attribute'. ".
6824 "remove, cannot continue.");
6827 CPAN->debug(sprintf "abs[%s]distropref[%d]ok[%d]", $abs, scalar @distropref, $ok) if $CPAN::DEBUG;
6830 prefs => $distropref,
6832 prefs_file_doc => $y,
6843 # CPAN::Distribution::prefs
6846 if (exists $self->{prefs}) {
6847 return $self->{prefs}; # XXX comment out during debugging
6849 if ($CPAN::Config->{prefs_dir}) {
6850 CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
6851 my $prefs = $self->_find_prefs();
6853 for my $x (qw(prefs prefs_file prefs_file_doc)) {
6854 $self->{$x} = $prefs->{$x};
6858 File::Basename::basename($self->{prefs_file}),
6859 $self->{prefs_file_doc},
6861 my $filler1 = "_" x 22;
6862 my $filler2 = int(66 - length($bs))/2;
6863 $filler2 = 0 if $filler2 < 0;
6864 $filler2 = " " x $filler2;
6865 $CPAN::Frontend->myprint("
6866 $filler1 D i s t r o P r e f s $filler1
6867 $filler2 $bs $filler2
6869 $CPAN::Frontend->mysleep(1);
6870 return $self->{prefs};
6876 # CPAN::Distribution::make_x_arg
6878 my($self, $whixh) = @_;
6880 my $prefs = $self->prefs;
6883 && exists $prefs->{$whixh}
6884 && exists $prefs->{$whixh}{args}
6885 && $prefs->{$whixh}{args}
6887 $make_x_arg = join(" ",
6888 map {CPAN::HandleConfig
6889 ->safe_quote($_)} @{$prefs->{$whixh}{args}},
6892 my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
6893 $make_x_arg ||= $CPAN::Config->{$what};
6897 # CPAN::Distribution::_make_command
6904 CPAN::HandleConfig->prefs_lookup($self,
6906 || $Config::Config{make}
6910 # Old style call, without object. Deprecated
6911 Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
6914 CPAN::HandleConfig->prefs_lookup($self,q{make})
6915 || $CPAN::Config->{make}
6916 || $Config::Config{make}
6921 #-> sub CPAN::Distribution::follow_prereqs ;
6922 sub follow_prereqs {
6924 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
6925 return unless @prereq_tuples;
6926 my @prereq = map { $_->[0] } @prereq_tuples;
6927 my $pretty_id = $self->pretty_id;
6929 b => "build_requires",
6933 my($filler1,$filler2,$filler3,$filler4);
6934 my $unsat = "Unsatisfied dependencies detected during";
6935 my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
6937 my $r = int(($w - length($unsat))/2);
6938 my $l = $w - length($unsat) - $r;
6939 $filler1 = "-"x4 . " "x$l;
6940 $filler2 = " "x$r . "-"x4 . "\n";
6943 my $r = int(($w - length($pretty_id))/2);
6944 my $l = $w - length($pretty_id) - $r;
6945 $filler3 = "-"x4 . " "x$l;
6946 $filler4 = " "x$r . "-"x4 . "\n";
6949 myprint("$filler1 $unsat $filler2".
6950 "$filler3 $pretty_id $filler4".
6951 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
6954 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
6956 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
6957 my $answer = CPAN::Shell::colorable_makemaker_prompt(
6958 "Shall I follow them and prepend them to the queue
6959 of modules we are processing right now?", "yes");
6960 $follow = $answer =~ /^\s*y/i;
6964 myprint(" Ignoring dependencies on modules @prereq\n");
6968 # color them as dirty
6969 for my $p (@prereq) {
6970 # warn "calling color_cmd_tmps(0,1)";
6971 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
6973 # queue them and re-queue yourself
6974 CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
6975 reverse @prereq_tuples);
6976 $self->{later} = "Delayed until after prerequisites";
6977 return 1; # signal success to the queuerunner
6981 #-> sub CPAN::Distribution::unsat_prereq ;
6982 # return ([Foo=>1],[Bar=>1.2]) for normal modules
6983 # return ([perl=>5.008]) if we need a newer perl than we are running under
6986 my $prereq_pm = $self->prereq_pm or return;
6988 my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
6989 NEED: while (my($need_module, $need_version) = each %merged) {
6990 my($have_version,$inst_file);
6991 if ($need_module eq "perl") {
6995 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
6996 next if $nmo->uptodate;
6997 $inst_file = $nmo->inst_file;
6999 # if they have not specified a version, we accept any installed one
7000 if (not defined $need_version or
7001 $need_version eq "0" or
7002 $need_version eq "undef") {
7003 next if defined $inst_file;
7006 $have_version = $nmo->inst_version;
7009 # We only want to install prereqs if either they're not installed
7010 # or if the installed version is too old. We cannot omit this
7011 # check, because if 'force' is in effect, nobody else will check.
7012 if (defined $inst_file) {
7013 my(@all_requirements) = split /\s*,\s*/, $need_version;
7016 RQ: for my $rq (@all_requirements) {
7017 if ($rq =~ s|>=\s*||) {
7018 } elsif ($rq =~ s|>\s*||) {
7020 if (CPAN::Version->vgt($have_version,$rq)){
7024 } elsif ($rq =~ s|!=\s*||) {
7026 if (CPAN::Version->vcmp($have_version,$rq)){
7032 } elsif ($rq =~ m|<=?\s*|) {
7034 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
7038 if (! CPAN::Version->vgt($rq, $have_version)){
7041 CPAN->debug(sprintf("need_module[%s]inst_file[%s]".
7042 "inst_version[%s]rq[%s]ok[%d]",
7046 CPAN::Version->readable($rq),
7050 next NEED if $ok == @all_requirements;
7053 if ($need_module eq "perl") {
7054 return ["perl", $need_version];
7056 if ($self->{sponsored_mods}{$need_module}++){
7057 # We have already sponsored it and for some reason it's still
7058 # not available. So we do nothing. Or what should we do?
7059 # if we push it again, we have a potential infinite loop
7062 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7063 push @need, [$need_module,$needed_as];
7068 #-> sub CPAN::Distribution::read_yaml ;
7071 return $self->{yaml_content} if exists $self->{yaml_content};
7072 my $build_dir = $self->{build_dir};
7073 my $yaml = File::Spec->catfile($build_dir,"META.yml");
7074 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7075 return unless -f $yaml;
7076 eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7078 $CPAN::Frontend->mywarn("Warning (probably harmless): Could not read ".
7079 "'$yaml'. Falling back to other ".
7080 "methods to determine prerequisites\n");
7081 return; # if we die, then we cannot read YAML's own META.yml
7083 if (not exists $self->{yaml_content}{dynamic_config}
7084 or $self->{yaml_content}{dynamic_config}
7086 $self->{yaml_content} = undef;
7088 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7090 return $self->{yaml_content};
7093 #-> sub CPAN::Distribution::prereq_pm ;
7096 $self->{prereq_pm_detected} ||= 0;
7097 CPAN->debug("prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7098 return $self->{prereq_pm} if $self->{prereq_pm_detected};
7099 return unless $self->{writemakefile} # no need to have succeeded
7100 # but we must have run it
7101 || $self->{modulebuild};
7102 CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7103 $self->{writemakefile}||"",
7104 $self->{modulebuild}||"",
7107 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7108 $req = $yaml->{requires} || {};
7109 $breq = $yaml->{build_requires} || {};
7110 undef $req unless ref $req eq "HASH" && %$req;
7112 if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7113 my $eummv = do { local $^W = 0; $1+0; };
7114 if ($eummv < 6.2501) {
7115 # thanks to Slaven for digging that out: MM before
7116 # that could be wrong because it could reflect a
7123 while (my($k,$v) = each %{$req||{}}) {
7126 } elsif ($k =~ /[A-Za-z]/ &&
7128 $CPAN::META->exists("Module",$v)
7130 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7131 "requires hash: $k => $v; I'll take both ".
7132 "key and value as a module name\n");
7133 $CPAN::Frontend->mysleep(1);
7139 $req = $areq if $do_replace;
7142 unless ($req || $breq) {
7143 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7144 my $makefile = File::Spec->catfile($build_dir,"Makefile");
7148 $fh = FileHandle->new("<$makefile\0")) {
7149 CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7152 last if /MakeMaker post_initialize section/;
7154 \s+PREREQ_PM\s+=>\s+(.+)
7157 # warn "Found prereq expr[$p]";
7159 # Regexp modified by A.Speer to remember actual version of file
7160 # PREREQ_PM hash key wants, then add to
7161 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
7162 # In case a prereq is mentioned twice, complain.
7163 if ( defined $req->{$1} ) {
7164 warn "Warning: PREREQ_PM mentions $1 more than once, ".
7165 "last mention wins";
7173 unless ($req || $breq) {
7174 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7175 my $buildfile = File::Spec->catfile($build_dir,"Build");
7176 if (-f $buildfile) {
7177 CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7178 my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7179 if (-f $build_prereqs) {
7180 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7181 my $content = do { local *FH;
7182 open FH, $build_prereqs
7183 or $CPAN::Frontend->mydie("Could not open ".
7184 "'$build_prereqs': $!");
7188 my $bphash = eval $content;
7191 $req = $bphash->{requires} || +{};
7192 $breq = $bphash->{build_requires} || +{};
7198 && ! -f "Makefile.PL"
7199 && ! exists $req->{"Module::Build"}
7200 && ! $CPAN::META->has_inst("Module::Build")) {
7201 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
7202 "undeclared prerequisite.\n".
7203 " Adding it now as such.\n"
7205 $CPAN::Frontend->mysleep(5);
7206 $req->{"Module::Build"} = 0;
7207 delete $self->{writemakefile};
7209 if ($req || $breq) {
7210 $self->{prereq_pm_detected}++;
7211 return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7215 #-> sub CPAN::Distribution::test ;
7218 if (my $goto = $self->prefs->{goto}) {
7219 return $self->goto($goto);
7223 delete $self->{force_update};
7226 # warn "XDEBUG: checking for notest: $self->{notest} $self";
7227 if ($self->{notest}) {
7228 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7232 my $make = $self->{modulebuild} ? "Build" : "make";
7234 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7236 : ($ENV{PERLLIB} || "");
7238 $CPAN::META->set_perl5lib;
7239 local $ENV{MAKEFLAGS}; # protect us from outer make calls
7241 $CPAN::Frontend->myprint("Running $make test\n");
7242 if (my @prereq = $self->unsat_prereq){
7243 unless ($prereq[0][0] eq "perl") {
7244 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7249 unless (exists $self->{make} or exists $self->{later}) {
7251 "Make had some problems, won't test";
7254 exists $self->{make} and
7256 UNIVERSAL::can($self->{make},"failed") ?
7257 $self->{make}->failed :
7258 $self->{make} =~ /^NO/
7259 ) and push @e, "Can't test without successful make";
7261 $self->{badtestcnt} ||= 0;
7262 $self->{badtestcnt} > 0 and
7263 push @e, "Won't repeat unsuccessful test during this command";
7265 exists $self->{later} and length($self->{later}) and
7266 push @e, $self->{later};
7268 if (exists $self->{build_dir}) {
7269 if ($CPAN::META->{is_tested}{$self->{build_dir}}
7271 exists $self->{make_test}
7274 UNIVERSAL::can($self->{make_test},"failed") ?
7275 $self->{make_test}->failed :
7276 $self->{make_test} =~ /^NO/
7279 push @e, "Already tested successfully";
7282 push @e, "Has no own directory";
7285 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7287 chdir $self->{'build_dir'} or
7288 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7289 $self->debug("Changed directory to $self->{'build_dir'}")
7292 if ($^O eq 'MacOS') {
7293 Mac::BuildTools::make_test($self);
7297 if ($self->{modulebuild}) {
7298 my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7299 if (CPAN::Version->vlt($v,2.62)) {
7300 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7301 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7302 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7308 if ($self->{modulebuild}) {
7309 $system = sprintf "%s test", $self->_build_command();
7311 $system = join " ", $self->_make_command(), "test";
7315 while (my($k,$v) = each %ENV) {
7316 next unless defined $v;
7320 if (my $env = $self->prefs->{test}{env}) {
7321 for my $e (keys %$env) {
7322 $ENV{$e} = $env->{$e};
7325 my $expect_model = $self->_prefs_with_expect("test");
7326 my $want_expect = 0;
7327 if ( $expect_model && @{$expect_model->{talk}} ) {
7328 my $can_expect = $CPAN::META->has_inst("Expect");
7332 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7333 "testing without\n");
7336 my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7340 my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7344 $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7345 "testing without\n");
7348 my $ready_to_report = $want_report;
7349 if ($ready_to_report
7351 substr($self->id,-1,1) eq "."
7353 $self->author->id eq "LOCAL"
7356 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7357 "for local directories\n");
7358 $ready_to_report = 0;
7360 if ($ready_to_report
7362 $self->prefs->{patches}
7364 @{$self->prefs->{patches}}
7368 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7369 "when the source has been patched\n");
7370 $ready_to_report = 0;
7373 if ($ready_to_report) {
7374 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7375 "not supported when distroprefs specify ".
7376 "an interactive test\n");
7378 $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7379 } elsif ( $ready_to_report ) {
7380 $tests_ok = CPAN::Reporter::test($self, $system);
7382 $tests_ok = system($system) == 0;
7384 $self->introduce_myself;
7388 for my $m (keys %{$self->{sponsored_mods}}) {
7389 my $m_obj = CPAN::Shell->expand("Module",$m);
7390 my $d_obj = $m_obj->distribution;
7392 if (!$d_obj->{make_test}
7394 $d_obj->{make_test}->failed){
7402 my $which = join ",", @prereq;
7403 my $verb = $cnt == 1 ? "one dependency not OK ($which)" :
7404 "$cnt dependencies missing ($which)";
7405 $CPAN::Frontend->mywarn("Tests succeeded but $verb\n");
7406 $self->{make_test} = CPAN::Distrostatus->new("NO $verb");
7407 $self->store_persistent_state;
7412 $CPAN::Frontend->myprint(" $system -- OK\n");
7413 $CPAN::META->is_tested($self->{'build_dir'});
7414 $self->{make_test} = CPAN::Distrostatus->new("YES");
7416 $self->{make_test} = CPAN::Distrostatus->new("NO");
7417 $self->{badtestcnt}++;
7418 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
7420 $self->store_persistent_state;
7423 sub _prefs_with_expect {
7424 my($self,$where) = @_;
7425 return unless my $prefs = $self->prefs;
7426 return unless my $where_prefs = $prefs->{$where};
7427 if ($where_prefs->{expect}) {
7430 talk => $where_prefs->{expect},
7432 } elsif ($where_prefs->{"expect-in-any-order"}) {
7434 mode => "expect-in-any-order",
7435 talk => $where_prefs->{"expect-in-any-order"},
7441 #-> sub CPAN::Distribution::clean ;
7444 my $make = $self->{modulebuild} ? "Build" : "make";
7445 $CPAN::Frontend->myprint("Running $make clean\n");
7446 unless (exists $self->{archived}) {
7447 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
7448 "/untarred, nothing done\n");
7451 unless (exists $self->{build_dir}) {
7452 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
7457 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
7458 push @e, "make clean already called once";
7459 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7461 chdir $self->{'build_dir'} or
7462 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7463 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
7465 if ($^O eq 'MacOS') {
7466 Mac::BuildTools::make_clean($self);
7471 if ($self->{modulebuild}) {
7472 unless (-f "Build") {
7474 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
7475 " in cwd[$cwd]. Danger, Will Robinson!");
7476 $CPAN::Frontend->mysleep(5);
7478 $system = sprintf "%s clean", $self->_build_command();
7480 $system = join " ", $self->_make_command(), "clean";
7482 my $system_ok = system($system) == 0;
7483 $self->introduce_myself;
7485 $CPAN::Frontend->myprint(" $system -- OK\n");
7489 # Jost Krieger pointed out that this "force" was wrong because
7490 # it has the effect that the next "install" on this distribution
7491 # will untar everything again. Instead we should bring the
7492 # object's state back to where it is after untarring.
7503 $self->{make_clean} = CPAN::Distrostatus->new("YES");
7506 # Hmmm, what to do if make clean failed?
7508 $self->{make_clean} = CPAN::Distrostatus->new("NO");
7509 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
7511 # 2006-02-27: seems silly to me to force a make now
7512 # $self->force("make"); # so that this directory won't be used again
7515 $self->store_persistent_state;
7518 #-> sub CPAN::Distribution::install ;
7520 my($self,$goto) = @_;
7521 my($method) = (caller(1))[3];
7522 CPAN->instance("CPAN::Distribution",$goto)->$method;
7525 #-> sub CPAN::Distribution::install ;
7528 if (my $goto = $self->prefs->{goto}) {
7529 return $self->goto($goto);
7533 delete $self->{force_update};
7536 my $make = $self->{modulebuild} ? "Build" : "make";
7537 $CPAN::Frontend->myprint("Running $make install\n");
7540 unless (exists $self->{make} or exists $self->{later}) {
7542 "Make had some problems, won't install";
7545 exists $self->{make} and
7547 UNIVERSAL::can($self->{make},"failed") ?
7548 $self->{make}->failed :
7549 $self->{make} =~ /^NO/
7551 push @e, "Make had returned bad status, install seems impossible";
7553 if (exists $self->{build_dir}) {
7555 push @e, "Has no own directory";
7558 if (exists $self->{make_test} and
7560 UNIVERSAL::can($self->{make_test},"failed") ?
7561 $self->{make_test}->failed :
7562 $self->{make_test} =~ /^NO/
7564 if ($self->{force_update}) {
7565 $self->{make_test}->text("FAILED but failure ignored because ".
7566 "'force' in effect");
7568 push @e, "make test had returned bad status, ".
7569 "won't install without force"
7572 if (exists $self->{install}) {
7573 if (UNIVERSAL::can($self->{install},"text") ?
7574 $self->{install}->text eq "YES" :
7575 $self->{install} =~ /^YES/
7577 push @e, "Already done";
7579 # comment in Todo on 2006-02-11; maybe retry?
7580 push @e, "Already tried without success";
7584 exists $self->{later} and length($self->{later}) and
7585 push @e, $self->{later};
7587 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7589 chdir $self->{'build_dir'} or
7590 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
7591 $self->debug("Changed directory to $self->{'build_dir'}")
7594 if ($^O eq 'MacOS') {
7595 Mac::BuildTools::make_install($self);
7600 if ($self->{modulebuild}) {
7601 my($mbuild_install_build_command) =
7602 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
7603 $CPAN::Config->{mbuild_install_build_command} ?
7604 $CPAN::Config->{mbuild_install_build_command} :
7605 $self->_build_command();
7606 $system = sprintf("%s install %s",
7607 $mbuild_install_build_command,
7608 $CPAN::Config->{mbuild_install_arg},
7611 my($make_install_make_command) =
7612 CPAN::HandleConfig->prefs_lookup($self,
7613 q{make_install_make_command})
7614 || $self->_make_command();
7615 $system = sprintf("%s install %s",
7616 $make_install_make_command,
7617 $CPAN::Config->{make_install_arg},
7621 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
7622 my $brip = CPAN::HandleConfig->prefs_lookup($self,
7623 q{build_requires_install_policy});
7626 my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
7627 my $want_install = "yes";
7628 if ($reqtype eq "b") {
7629 if ($brip eq "no") {
7630 $want_install = "no";
7631 } elsif ($brip =~ m|^ask/(.+)|) {
7633 $default = "yes" unless $default =~ /^(y|n)/i;
7635 CPAN::Shell::colorable_makemaker_prompt
7636 ("$id is just needed temporarily during building or testing. ".
7637 "Do you want to install it permanently? (Y/n)",
7641 unless ($want_install =~ /^y/i) {
7642 my $is_only = "is only 'build_requires'";
7643 $CPAN::Frontend->mywarn("Not installing because $is_only\n");
7644 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
7645 delete $self->{force_update};
7648 my($pipe) = FileHandle->new("$system $stderr |");
7651 print $_; # intentionally NOT use Frontend->myprint because it
7652 # looks irritating when we markup in color what we
7653 # just pass through from an external program
7657 my $close_ok = $? == 0;
7658 $self->introduce_myself;
7660 $CPAN::Frontend->myprint(" $system -- OK\n");
7661 $CPAN::META->is_installed($self->{build_dir});
7662 return $self->{install} = CPAN::Distrostatus->new("YES");
7664 $self->{install} = CPAN::Distrostatus->new("NO");
7665 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
7667 CPAN::HandleConfig->prefs_lookup($self,
7668 q{make_install_make_command});
7670 $makeout =~ /permission/s
7674 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
7678 $CPAN::Frontend->myprint(
7680 qq{ You may have to su }.
7681 qq{to root to install the package\n}.
7682 qq{ (Or you may want to run something like\n}.
7683 qq{ o conf make_install_make_command 'sudo make'\n}.
7684 qq{ to raise your permissions.}
7688 delete $self->{force_update};
7689 $self->store_persistent_state;
7692 sub introduce_myself {
7694 $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
7697 #-> sub CPAN::Distribution::dir ;
7699 shift->{'build_dir'};
7702 #-> sub CPAN::Distribution::perldoc ;
7706 my($dist) = $self->id;
7707 my $package = $self->called_for;
7709 $self->_display_url( $CPAN::Defaultdocs . $package );
7712 #-> sub CPAN::Distribution::_check_binary ;
7714 my ($dist,$shell,$binary) = @_;
7717 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
7720 if ($CPAN::META->has_inst("File::Which")) {
7721 return File::Which::which($binary);
7724 $pid = open README, "which $binary|"
7725 or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
7731 or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
7735 $CPAN::Frontend->myprint(qq{ + $out \n})
7736 if $CPAN::DEBUG && $out;
7741 #-> sub CPAN::Distribution::_display_url ;
7743 my($self,$url) = @_;
7744 my($res,$saved_file,$pid,$out);
7746 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
7749 # should we define it in the config instead?
7750 my $html_converter = "html2text";
7752 my $web_browser = $CPAN::Config->{'lynx'} || undef;
7753 my $web_browser_out = $web_browser
7754 ? CPAN::Distribution->_check_binary($self,$web_browser)
7757 if ($web_browser_out) {
7758 # web browser found, run the action
7759 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
7760 $CPAN::Frontend->myprint(qq{system[$browser $url]})
7762 $CPAN::Frontend->myprint(qq{
7765 with browser $browser
7767 $CPAN::Frontend->mysleep(1);
7768 system("$browser $url");
7769 if ($saved_file) { 1 while unlink($saved_file) }
7771 # web browser not found, let's try text only
7772 my $html_converter_out =
7773 CPAN::Distribution->_check_binary($self,$html_converter);
7774 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
7776 if ($html_converter_out ) {
7777 # html2text found, run it
7778 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
7779 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
7780 unless defined($saved_file);
7783 $pid = open README, "$html_converter $saved_file |"
7784 or $CPAN::Frontend->mydie(qq{
7785 Could not fork '$html_converter $saved_file': $!});
7787 if ($CPAN::META->has_inst("File::Temp")) {
7788 $fh = File::Temp->new(
7789 template => 'cpan_htmlconvert_XXXX',
7793 $filename = $fh->filename;
7795 $filename = "cpan_htmlconvert_$$.txt";
7796 $fh = FileHandle->new();
7797 open $fh, ">$filename" or die;
7803 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
7804 my $tmpin = $fh->filename;
7805 $CPAN::Frontend->myprint(sprintf(qq{
7807 saved output to %s\n},
7815 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
7816 my $fh_pager = FileHandle->new;
7817 local($SIG{PIPE}) = "IGNORE";
7818 my $pager = $CPAN::Config->{'pager'} || "cat";
7819 $fh_pager->open("|$pager")
7820 or $CPAN::Frontend->mydie(qq{
7821 Could not open pager '$pager': $!});
7822 $CPAN::Frontend->myprint(qq{
7827 $CPAN::Frontend->mysleep(1);
7828 $fh_pager->print(<FH>);
7831 # coldn't find the web browser or html converter
7832 $CPAN::Frontend->myprint(qq{
7833 You need to install lynx or $html_converter to use this feature.});
7838 #-> sub CPAN::Distribution::_getsave_url ;
7840 my($dist, $shell, $url) = @_;
7842 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
7846 if ($CPAN::META->has_inst("File::Temp")) {
7847 $fh = File::Temp->new(
7848 template => "cpan_getsave_url_XXXX",
7852 $filename = $fh->filename;
7854 $fh = FileHandle->new;
7855 $filename = "cpan_getsave_url_$$.html";
7857 my $tmpin = $filename;
7858 if ($CPAN::META->has_usable('LWP')) {
7859 $CPAN::Frontend->myprint("Fetching with LWP:
7863 CPAN::LWP::UserAgent->config;
7864 eval { $Ua = CPAN::LWP::UserAgent->new; };
7866 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
7870 $Ua->proxy('http', $var)
7871 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
7873 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
7876 my $req = HTTP::Request->new(GET => $url);
7877 $req->header('Accept' => 'text/html');
7878 my $res = $Ua->request($req);
7879 if ($res->is_success) {
7880 $CPAN::Frontend->myprint(" + request successful.\n")
7882 print $fh $res->content;
7884 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
7888 $CPAN::Frontend->myprint(sprintf(
7889 "LWP failed with code[%s], message[%s]\n",
7896 $CPAN::Frontend->mywarn(" LWP not available\n");
7901 # sub CPAN::Distribution::_build_command
7902 sub _build_command {
7904 if ($^O eq "MSWin32") { # special code needed at least up to
7905 # Module::Build 0.2611 and 0.2706; a fix
7906 # in M:B has been promised 2006-01-30
7907 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
7908 return "$perl ./Build";
7913 package CPAN::Bundle;
7918 $CPAN::Frontend->myprint($self->as_string);
7923 delete $self->{later};
7924 for my $c ( $self->contains ) {
7925 my $obj = CPAN::Shell->expandany($c) or next;
7930 # mark as dirty/clean
7931 #-> sub CPAN::Bundle::color_cmd_tmps ;
7932 sub color_cmd_tmps {
7934 my($depth) = shift || 0;
7935 my($color) = shift || 0;
7936 my($ancestors) = shift || [];
7937 # a module needs to recurse to its cpan_file, a distribution needs
7938 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
7940 return if exists $self->{incommandcolor}
7941 && $self->{incommandcolor}==$color;
7943 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
7945 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
7947 for my $c ( $self->contains ) {
7948 my $obj = CPAN::Shell->expandany($c) or next;
7949 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
7950 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
7953 delete $self->{badtestcnt};
7955 $self->{incommandcolor} = $color;
7958 #-> sub CPAN::Bundle::as_string ;
7962 # following line must be "=", not "||=" because we have a moving target
7963 $self->{INST_VERSION} = $self->inst_version;
7964 return $self->SUPER::as_string;
7967 #-> sub CPAN::Bundle::contains ;
7970 my($inst_file) = $self->inst_file || "";
7971 my($id) = $self->id;
7972 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
7973 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
7976 unless ($inst_file) {
7977 # Try to get at it in the cpan directory
7978 $self->debug("no inst_file") if $CPAN::DEBUG;
7980 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
7981 $cpan_file = $self->cpan_file;
7982 if ($cpan_file eq "N/A") {
7983 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
7984 Maybe stale symlink? Maybe removed during session? Giving up.\n");
7986 my $dist = $CPAN::META->instance('CPAN::Distribution',
7989 $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
7990 my($todir) = $CPAN::Config->{'cpan_home'};
7991 my(@me,$from,$to,$me);
7992 @me = split /::/, $self->id;
7994 $me = File::Spec->catfile(@me);
7995 $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
7996 $to = File::Spec->catfile($todir,$me);
7997 File::Path::mkpath(File::Basename::dirname($to));
7998 File::Copy::copy($from, $to)
7999 or Carp::confess("Couldn't copy $from to $to: $!");
8003 my $fh = FileHandle->new;
8005 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8007 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8009 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8010 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8011 next unless $in_cont;
8016 push @result, (split " ", $_, 2)[0];
8019 delete $self->{STATUS};
8020 $self->{CONTAINS} = \@result;
8021 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8023 $CPAN::Frontend->mywarn(qq{
8024 The bundle file "$inst_file" may be a broken
8025 bundlefile. It seems not to contain any bundle definition.
8026 Please check the file and if it is bogus, please delete it.
8027 Sorry for the inconvenience.
8033 #-> sub CPAN::Bundle::find_bundle_file
8034 # $where is in local format, $what is in unix format
8035 sub find_bundle_file {
8036 my($self,$where,$what) = @_;
8037 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8038 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8039 ### my $bu = File::Spec->catfile($where,$what);
8040 ### return $bu if -f $bu;
8041 my $manifest = File::Spec->catfile($where,"MANIFEST");
8042 unless (-f $manifest) {
8043 require ExtUtils::Manifest;
8044 my $cwd = CPAN::anycwd();
8045 $self->safe_chdir($where);
8046 ExtUtils::Manifest::mkmanifest();
8047 $self->safe_chdir($cwd);
8049 my $fh = FileHandle->new($manifest)
8050 or Carp::croak("Couldn't open $manifest: $!");
8052 my $bundle_filename = $what;
8053 $bundle_filename =~ s|Bundle.*/||;
8054 my $bundle_unixpath;
8057 my($file) = /(\S+)/;
8058 if ($file =~ m|\Q$what\E$|) {
8059 $bundle_unixpath = $file;
8060 # return File::Spec->catfile($where,$bundle_unixpath); # bad
8063 # retry if she managed to have no Bundle directory
8064 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8066 return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8067 if $bundle_unixpath;
8068 Carp::croak("Couldn't find a Bundle file in $where");
8071 # needs to work quite differently from Module::inst_file because of
8072 # cpan_home/Bundle/ directory and the possibility that we have
8073 # shadowing effect. As it makes no sense to take the first in @INC for
8074 # Bundles, we parse them all for $VERSION and take the newest.
8076 #-> sub CPAN::Bundle::inst_file ;
8081 @me = split /::/, $self->id;
8084 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8085 my $bfile = File::Spec->catfile($incdir, @me);
8086 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8087 next unless -f $bfile;
8088 my $foundv = MM->parse_version($bfile);
8089 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8090 $self->{INST_FILE} = $bfile;
8091 $self->{INST_VERSION} = $bestv = $foundv;
8097 #-> sub CPAN::Bundle::inst_version ;
8100 $self->inst_file; # finds INST_VERSION as side effect
8101 $self->{INST_VERSION};
8104 #-> sub CPAN::Bundle::rematein ;
8106 my($self,$meth) = @_;
8107 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8108 my($id) = $self->id;
8109 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8110 unless $self->inst_file || $self->cpan_file;
8112 for $s ($self->contains) {
8113 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8114 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8115 if ($type eq 'CPAN::Distribution') {
8116 $CPAN::Frontend->mywarn(qq{
8117 The Bundle }.$self->id.qq{ contains
8118 explicitly a file '$s'.
8119 Going to $meth that.
8121 $CPAN::Frontend->mysleep(5);
8123 # possibly noisy action:
8124 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8125 my $obj = $CPAN::META->instance($type,$s);
8126 $obj->{reqtype} = $self->{reqtype};
8128 if ($obj->isa('CPAN::Bundle')
8130 exists $obj->{install_failed}
8132 ref($obj->{install_failed}) eq "HASH"
8134 for (keys %{$obj->{install_failed}}) {
8135 $self->{install_failed}{$_} = undef; # propagate faiure up
8138 $fail{$s} = 1; # the bundle itself may have succeeded but
8143 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
8144 $success ||= $obj->{install} && $obj->{install} eq "YES";
8146 delete $self->{install_failed}{$s};
8153 # recap with less noise
8154 if ( $meth eq "install" ) {
8157 my $raw = sprintf(qq{Bundle summary:
8158 The following items in bundle %s had installation problems:},
8161 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
8162 $CPAN::Frontend->myprint("\n");
8165 for $s ($self->contains) {
8167 $paragraph .= "$s ";
8168 $self->{install_failed}{$s} = undef;
8169 $reported{$s} = undef;
8172 my $report_propagated;
8173 for $s (sort keys %{$self->{install_failed}}) {
8174 next if exists $reported{$s};
8175 $paragraph .= "and the following items had problems
8176 during recursive bundle calls: " unless $report_propagated++;
8177 $paragraph .= "$s ";
8179 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
8180 $CPAN::Frontend->myprint("\n");
8182 $self->{install} = 'YES';
8187 # If a bundle contains another that contains an xs_file we have here,
8188 # we just don't bother I suppose
8189 #-> sub CPAN::Bundle::xs_file
8194 #-> sub CPAN::Bundle::force ;
8195 sub force { shift->rematein('force',@_); }
8196 #-> sub CPAN::Bundle::notest ;
8197 sub notest { shift->rematein('notest',@_); }
8198 #-> sub CPAN::Bundle::get ;
8199 sub get { shift->rematein('get',@_); }
8200 #-> sub CPAN::Bundle::make ;
8201 sub make { shift->rematein('make',@_); }
8202 #-> sub CPAN::Bundle::test ;
8205 $self->{badtestcnt} ||= 0;
8206 $self->rematein('test',@_);
8208 #-> sub CPAN::Bundle::install ;
8211 $self->rematein('install',@_);
8213 #-> sub CPAN::Bundle::clean ;
8214 sub clean { shift->rematein('clean',@_); }
8216 #-> sub CPAN::Bundle::uptodate ;
8219 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8221 foreach $c ($self->contains) {
8222 my $obj = CPAN::Shell->expandany($c);
8223 return 0 unless $obj->uptodate;
8228 #-> sub CPAN::Bundle::readme ;
8231 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8232 No File found for bundle } . $self->id . qq{\n}), return;
8233 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8234 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8237 package CPAN::Module;
8241 # sub CPAN::Module::userid
8246 return $ro->{userid} || $ro->{CPAN_USERID};
8248 # sub CPAN::Module::description
8251 my $ro = $self->ro or return "";
8257 CPAN::Shell->expand("Distribution",$self->cpan_file);
8260 # sub CPAN::Module::undelay
8263 delete $self->{later};
8264 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8269 # mark as dirty/clean
8270 #-> sub CPAN::Module::color_cmd_tmps ;
8271 sub color_cmd_tmps {
8273 my($depth) = shift || 0;
8274 my($color) = shift || 0;
8275 my($ancestors) = shift || [];
8276 # a module needs to recurse to its cpan_file
8278 return if exists $self->{incommandcolor}
8279 && $self->{incommandcolor}==$color;
8280 return if $depth>=1 && $self->uptodate;
8282 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8284 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8286 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8287 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8290 delete $self->{badtestcnt};
8292 $self->{incommandcolor} = $color;
8295 #-> sub CPAN::Module::as_glimpse ;
8299 my $class = ref($self);
8300 $class =~ s/^CPAN:://;
8304 $CPAN::Shell::COLOR_REGISTERED
8306 $CPAN::META->has_inst("Term::ANSIColor")
8310 $color_on = Term::ANSIColor::color("green");
8311 $color_off = Term::ANSIColor::color("reset");
8313 my $uptodateness = " ";
8314 if ($class eq "Bundle") {
8315 } elsif ($self->uptodate) {
8316 $uptodateness = "=";
8317 } elsif ($self->inst_version) {
8318 $uptodateness = "<";
8320 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8326 ($self->distribution ?
8327 $self->distribution->pretty_id :
8334 #-> sub CPAN::Module::dslip_status
8338 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
8339 pre-alpha alpha beta released
8341 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
8342 developer comp.lang.perl.*
8344 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
8345 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
8347 object-oriented pragma
8349 @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8353 distribution_allowed
8354 restricted_distribution
8356 for my $x (qw(d s l i p)) {
8357 $stat->{$x}{' '} = 'unknown';
8358 $stat->{$x}{'?'} = 'unknown';
8361 return +{} unless $ro && $ro->{statd};
8368 DV => $stat->{D}{$ro->{statd}},
8369 SV => $stat->{S}{$ro->{stats}},
8370 LV => $stat->{L}{$ro->{statl}},
8371 IV => $stat->{I}{$ro->{stati}},
8372 PV => $stat->{P}{$ro->{statp}},
8376 #-> sub CPAN::Module::as_string ;
8380 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8381 my $class = ref($self);
8382 $class =~ s/^CPAN:://;
8384 push @m, $class, " id = $self->{ID}\n";
8385 my $sprintf = " %-12s %s\n";
8386 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8387 if $self->description;
8388 my $sprintf2 = " %-12s %s (%s)\n";
8390 $userid = $self->userid;
8393 if ($author = CPAN::Shell->expand('Author',$userid)) {
8396 if ($m = $author->email) {
8403 $author->fullname . $email
8407 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8408 if $self->cpan_version;
8409 if (my $cpan_file = $self->cpan_file){
8410 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8411 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8412 my $upload_date = $dist->upload_date;
8414 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8418 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8419 my $dslip = $self->dslip_status;
8423 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8425 my $local_file = $self->inst_file;
8426 unless ($self->{MANPAGE}) {
8429 $manpage = $self->manpage_headline($local_file);
8431 # If we have already untarred it, we should look there
8432 my $dist = $CPAN::META->instance('CPAN::Distribution',
8434 # warn "dist[$dist]";
8435 # mff=manifest file; mfh=manifest handle
8440 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
8442 $mfh = FileHandle->new($mff)
8444 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
8445 my $lfre = $self->id; # local file RE
8448 my($lfl); # local file file
8450 my(@mflines) = <$mfh>;
8455 while (length($lfre)>5 and !$lfl) {
8456 ($lfl) = grep /$lfre/, @mflines;
8457 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
8460 $lfl =~ s/\s.*//; # remove comments
8461 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
8462 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
8463 # warn "lfl_abs[$lfl_abs]";
8465 $manpage = $self->manpage_headline($lfl_abs);
8469 $self->{MANPAGE} = $manpage if $manpage;
8472 for $item (qw/MANPAGE/) {
8473 push @m, sprintf($sprintf, $item, $self->{$item})
8474 if exists $self->{$item};
8476 for $item (qw/CONTAINS/) {
8477 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
8478 if exists $self->{$item} && @{$self->{$item}};
8480 push @m, sprintf($sprintf, 'INST_FILE',
8481 $local_file || "(not installed)");
8482 push @m, sprintf($sprintf, 'INST_VERSION',
8483 $self->inst_version) if $local_file;
8487 sub manpage_headline {
8488 my($self,$local_file) = @_;
8489 my(@local_file) = $local_file;
8490 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
8491 push @local_file, $local_file;
8493 for $locf (@local_file) {
8494 next unless -f $locf;
8495 my $fh = FileHandle->new($locf)
8496 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
8500 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
8501 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
8518 #-> sub CPAN::Module::cpan_file ;
8519 # Note: also inherited by CPAN::Bundle
8522 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
8523 unless ($self->ro) {
8524 CPAN::Index->reload;
8527 if ($ro && defined $ro->{CPAN_FILE}){
8528 return $ro->{CPAN_FILE};
8530 my $userid = $self->userid;
8532 if ($CPAN::META->exists("CPAN::Author",$userid)) {
8533 my $author = $CPAN::META->instance("CPAN::Author",
8535 my $fullname = $author->fullname;
8536 my $email = $author->email;
8537 unless (defined $fullname && defined $email) {
8538 return sprintf("Contact Author %s",
8542 return "Contact Author $fullname <$email>";
8544 return "Contact Author $userid (Email address not available)";
8552 #-> sub CPAN::Module::cpan_version ;
8558 # Can happen with modules that are not on CPAN
8561 $ro->{CPAN_VERSION} = 'undef'
8562 unless defined $ro->{CPAN_VERSION};
8563 $ro->{CPAN_VERSION};
8566 #-> sub CPAN::Module::force ;
8569 $self->{'force_update'}++;
8574 # warn "XDEBUG: set notest for Module";
8575 $self->{'notest'}++;
8578 #-> sub CPAN::Module::rematein ;
8580 my($self,$meth) = @_;
8581 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
8584 my $cpan_file = $self->cpan_file;
8585 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
8586 $CPAN::Frontend->mywarn(sprintf qq{
8587 The module %s isn\'t available on CPAN.
8589 Either the module has not yet been uploaded to CPAN, or it is
8590 temporary unavailable. Please contact the author to find out
8591 more about the status. Try 'i %s'.
8598 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
8599 $pack->called_for($self->id);
8600 $pack->force($meth) if exists $self->{'force_update'};
8601 $pack->notest($meth) if exists $self->{'notest'};
8603 $pack->{reqtype} ||= "";
8604 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
8605 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
8606 if ($pack->{reqtype}) {
8607 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
8608 $pack->{reqtype} = $self->{reqtype};
8610 exists $pack->{install}
8613 UNIVERSAL::can($pack->{install},"failed") ?
8614 $pack->{install}->failed :
8615 $pack->{install} =~ /^NO/
8618 delete $pack->{install};
8619 $CPAN::Frontend->mywarn
8620 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
8624 $pack->{reqtype} = $self->{reqtype};
8631 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
8632 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
8633 delete $self->{'force_update'};
8634 delete $self->{'notest'};
8640 #-> sub CPAN::Module::perldoc ;
8641 sub perldoc { shift->rematein('perldoc') }
8642 #-> sub CPAN::Module::readme ;
8643 sub readme { shift->rematein('readme') }
8644 #-> sub CPAN::Module::look ;
8645 sub look { shift->rematein('look') }
8646 #-> sub CPAN::Module::cvs_import ;
8647 sub cvs_import { shift->rematein('cvs_import') }
8648 #-> sub CPAN::Module::get ;
8649 sub get { shift->rematein('get',@_) }
8650 #-> sub CPAN::Module::make ;
8651 sub make { shift->rematein('make') }
8652 #-> sub CPAN::Module::test ;
8655 $self->{badtestcnt} ||= 0;
8656 $self->rematein('test',@_);
8658 #-> sub CPAN::Module::uptodate ;
8661 local($_); # protect against a bug in MakeMaker 6.17
8662 my($latest) = $self->cpan_version;
8664 my($inst_file) = $self->inst_file;
8666 if (defined $inst_file) {
8667 $have = $self->inst_version;
8672 ! CPAN::Version->vgt($latest, $have)
8674 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
8675 "latest[$latest] have[$have]") if $CPAN::DEBUG;
8680 #-> sub CPAN::Module::install ;
8686 not exists $self->{'force_update'}
8688 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
8690 $self->inst_version,
8696 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
8697 $CPAN::Frontend->mywarn(qq{
8698 \n\n\n ***WARNING***
8699 The module $self->{ID} has no active maintainer.\n\n\n
8701 $CPAN::Frontend->mysleep(5);
8703 $self->rematein('install') if $doit;
8705 #-> sub CPAN::Module::clean ;
8706 sub clean { shift->rematein('clean') }
8708 #-> sub CPAN::Module::inst_file ;
8712 @packpath = split /::/, $self->{ID};
8713 $packpath[-1] .= ".pm";
8714 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
8715 unshift @packpath, "Term", "ReadLine"; # historical reasons
8717 foreach $dir (@INC) {
8718 my $pmfile = File::Spec->catfile($dir,@packpath);
8726 #-> sub CPAN::Module::xs_file ;
8730 @packpath = split /::/, $self->{ID};
8731 push @packpath, $packpath[-1];
8732 $packpath[-1] .= "." . $Config::Config{'dlext'};
8733 foreach $dir (@INC) {
8734 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
8742 #-> sub CPAN::Module::inst_version ;
8745 my $parsefile = $self->inst_file or return;
8746 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
8749 $have = MM->parse_version($parsefile);
8750 $have = "undef" unless defined $have && length $have;
8751 $have =~ s/^ //; # since the %vd hack these two lines here are needed
8752 $have =~ s/ $//; # trailing whitespace happens all the time
8754 # My thoughts about why %vd processing should happen here
8756 # Alt1 maintain it as string with leading v:
8757 # read index files do nothing
8758 # compare it use utility for compare
8759 # print it do nothing
8761 # Alt2 maintain it as what it is
8762 # read index files convert
8763 # compare it use utility because there's still a ">" vs "gt" issue
8764 # print it use CPAN::Version for print
8766 # Seems cleaner to hold it in memory as a string starting with a "v"
8768 # If the author of this module made a mistake and wrote a quoted
8769 # "v1.13" instead of v1.13, we simply leave it at that with the
8770 # effect that *we* will treat it like a v-tring while the rest of
8771 # perl won't. Seems sensible when we consider that any action we
8772 # could take now would just add complexity.
8774 $have = CPAN::Version->readable($have);
8776 $have =~ s/\s*//g; # stringify to float around floating point issues
8777 $have; # no stringify needed, \s* above matches always
8790 CPAN - query, download and build perl modules from CPAN sites
8796 perl -MCPAN -e shell;
8804 cpan> install Acme::Meta # in the shell
8806 CPAN::Shell->install("Acme::Meta"); # in perl
8810 cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
8813 install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
8817 $mo = CPAN::Shell->expandany($mod);
8818 $mo = CPAN::Shell->expand("Module",$mod); # same thing
8820 # distribution objects:
8822 $do = CPAN::Shell->expand("Module",$mod)->distribution;
8823 $do = CPAN::Shell->expandany($distro); # same thing
8824 $do = CPAN::Shell->expand("Distribution",
8825 $distro); # same thing
8829 This module and its competitor, the CPANPLUS module, are both much
8830 cooler than the other.
8832 =head1 COMPATIBILITY
8834 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
8835 newer versions. It is getting more and more difficult to get the
8836 minimal prerequisites working on older perls. It is close to
8837 impossible to get the whole Bundle::CPAN working there. If you're in
8838 the position to have only these old versions, be advised that CPAN is
8839 designed to work fine without the Bundle::CPAN installed.
8841 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
8842 compatible with ancient perls and that File::Temp is listed as a
8843 prerequisite but CPAN has reasonable workarounds if it is missing.
8847 The CPAN module is designed to automate the make and install of perl
8848 modules and extensions. It includes some primitive searching
8849 capabilities and knows how to use Net::FTP or LWP (or some external
8850 download clients) to fetch the raw data from the net.
8852 Modules are fetched from one or more of the mirrored CPAN
8853 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
8856 The CPAN module also supports the concept of named and versioned
8857 I<bundles> of modules. Bundles simplify the handling of sets of
8858 related modules. See Bundles below.
8860 The package contains a session manager and a cache manager. There is
8861 no status retained between sessions. The session manager keeps track
8862 of what has been fetched, built and installed in the current
8863 session. The cache manager keeps track of the disk space occupied by
8864 the make processes and deletes excess space according to a simple FIFO
8867 All methods provided are accessible in a programmer style and in an
8868 interactive shell style.
8870 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
8872 The interactive mode is entered by running
8874 perl -MCPAN -e shell
8876 which puts you into a readline interface. You will have the most fun if
8877 you install Term::ReadKey and Term::ReadLine to enjoy both history and
8880 Once you are on the command line, type 'h' and the rest should be
8883 The function call C<shell> takes two optional arguments, one is the
8884 prompt, the second is the default initial command line (the latter
8885 only works if a real ReadLine interface module is installed).
8887 The most common uses of the interactive modes are
8891 =item Searching for authors, bundles, distribution files and modules
8893 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
8894 for each of the four categories and another, C<i> for any of the
8895 mentioned four. Each of the four entities is implemented as a class
8896 with slightly differing methods for displaying an object.
8898 Arguments you pass to these commands are either strings exactly matching
8899 the identification string of an object or regular expressions that are
8900 then matched case-insensitively against various attributes of the
8901 objects. The parser recognizes a regular expression only if you
8902 enclose it between two slashes.
8904 The principle is that the number of found objects influences how an
8905 item is displayed. If the search finds one item, the result is
8906 displayed with the rather verbose method C<as_string>, but if we find
8907 more than one, we display each object with the terse method
8910 =item make, test, install, clean modules or distributions
8912 These commands take any number of arguments and investigate what is
8913 necessary to perform the action. If the argument is a distribution
8914 file name (recognized by embedded slashes), it is processed. If it is
8915 a module, CPAN determines the distribution file in which this module
8916 is included and processes that, following any dependencies named in
8917 the module's META.yml or Makefile.PL (this behavior is controlled by
8918 the configuration parameter C<prerequisites_policy>.)
8920 Any C<make> or C<test> are run unconditionally. An
8922 install <distribution_file>
8924 also is run unconditionally. But for
8928 CPAN checks if an install is actually needed for it and prints
8929 I<module up to date> in the case that the distribution file containing
8930 the module doesn't need to be updated.
8932 CPAN also keeps track of what it has done within the current session
8933 and doesn't try to build a package a second time regardless if it
8934 succeeded or not. The C<force> pragma may precede another command
8935 (currently: C<make>, C<test>, or C<install>) and executes the
8936 command from scratch and tries to continue in case of some errors.
8940 cpan> install OpenGL
8941 OpenGL is up to date.
8942 cpan> force install OpenGL
8945 OpenGL-0.4/COPYRIGHT
8948 The C<notest> pragma may be set to skip the test part in the build
8953 cpan> notest install Tk
8955 A C<clean> command results in a
8959 being executed within the distribution file's working directory.
8961 =item get, readme, perldoc, look module or distribution
8963 C<get> downloads a distribution file without further action. C<readme>
8964 displays the README file of the associated distribution. C<Look> gets
8965 and untars (if not yet done) the distribution file, changes to the
8966 appropriate directory and opens a subshell process in that directory.
8967 C<perldoc> displays the pod documentation of the module in html or
8972 =item ls globbing_expression
8974 The first form lists all distribution files in and below an author's
8975 CPAN directory as they are stored in the CHECKUMS files distributed on
8976 CPAN. The listing goes recursive into all subdirectories.
8978 The second form allows to limit or expand the output with shell
8979 globbing as in the following examples:
8985 The last example is very slow and outputs extra progress indicators
8986 that break the alignment of the result.
8988 Note that globbing only lists directories explicitly asked for, for
8989 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
8990 regarded as a bug and may be changed in future versions.
8994 The C<failed> command reports all distributions that failed on one of
8995 C<make>, C<test> or C<install> for some reason in the currently
8996 running shell session.
9000 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9001 Batch jobs can run without a lockfile and do not disturb each other.
9003 The shell offers to run in I<degraded mode> when another process is
9004 holding the lockfile. This is an experimental feature that is not yet
9005 tested very well. This second shell then does not write the history
9006 file, does not use the metadata file and has a different prompt.
9010 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9011 in the cpan-shell it is intended that you can press C<^C> anytime and
9012 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9013 to clean up and leave the shell loop. You can emulate the effect of a
9014 SIGTERM by sending two consecutive SIGINTs, which usually means by
9015 pressing C<^C> twice.
9017 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9018 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9019 Build.PL> subprocess.
9025 The commands that are available in the shell interface are methods in
9026 the package CPAN::Shell. If you enter the shell command, all your
9027 input is split by the Text::ParseWords::shellwords() routine which
9028 acts like most shells do. The first word is being interpreted as the
9029 method to be called and the rest of the words are treated as arguments
9030 to this method. Continuation lines are supported if a line ends with a
9035 C<autobundle> writes a bundle file into the
9036 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9037 a list of all modules that are both available from CPAN and currently
9038 installed within @INC. The name of the bundle file is based on the
9039 current date and a counter.
9043 This commands provides a statistical overview over recent download
9044 activities. The data for this is collected in the YAML file
9045 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9046 configured or YAML not installed, then no stats are provided.
9050 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9051 directory so that you can save your own preferences instead of the
9056 recompile() is a very special command in that it takes no argument and
9057 runs the make/test/install cycle with brute force over all installed
9058 dynamically loadable extensions (aka XS modules) with 'force' in
9059 effect. The primary purpose of this command is to finish a network
9060 installation. Imagine, you have a common source tree for two different
9061 architectures. You decide to do a completely independent fresh
9062 installation. You start on one architecture with the help of a Bundle
9063 file produced earlier. CPAN installs the whole Bundle for you, but
9064 when you try to repeat the job on the second architecture, CPAN
9065 responds with a C<"Foo up to date"> message for all modules. So you
9066 invoke CPAN's recompile on the second architecture and you're done.
9068 Another popular use for C<recompile> is to act as a rescue in case your
9069 perl breaks binary compatibility. If one of the modules that CPAN uses
9070 is in turn depending on binary compatibility (so you cannot run CPAN
9071 commands), then you should try the CPAN::Nox module for recovery.
9073 =head2 report Bundle|Distribution|Module
9075 The C<report> command temporarily turns on the C<test_report> config
9076 variable, then runs the C<force test> command with the given
9077 arguments. The C<force> pragma is used to re-run the tests and repeat
9078 every step that might have failed before.
9080 =head2 upgrade [Module|/Regex/]...
9082 The C<upgrade> command first runs an C<r> command with the given
9083 arguments and then installs the newest versions of all modules that
9084 were listed by that.
9086 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9088 Although it may be considered internal, the class hierarchy does matter
9089 for both users and programmer. CPAN.pm deals with above mentioned four
9090 classes, and all those classes share a set of methods. A classical
9091 single polymorphism is in effect. A metaclass object registers all
9092 objects of all kinds and indexes them with a string. The strings
9093 referencing objects have a separated namespace (well, not completely
9098 words containing a "/" (slash) Distribution
9099 words starting with Bundle:: Bundle
9100 everything else Module or Author
9102 Modules know their associated Distribution objects. They always refer
9103 to the most recent official release. Developers may mark their releases
9104 as unstable development versions (by inserting an underbar into the
9105 module version number which will also be reflected in the distribution
9106 name when you run 'make dist'), so the really hottest and newest
9107 distribution is not always the default. If a module Foo circulates
9108 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9109 way to install version 1.23 by saying
9113 This would install the complete distribution file (say
9114 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9115 like to install version 1.23_90, you need to know where the
9116 distribution file resides on CPAN relative to the authors/id/
9117 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9118 so you would have to say
9120 install BAR/Foo-1.23_90.tar.gz
9122 The first example will be driven by an object of the class
9123 CPAN::Module, the second by an object of class CPAN::Distribution.
9125 =head2 Integrating local directories
9127 Distribution objects are normally distributions from the CPAN, but
9128 there is a slightly degenerate case for Distribution objects, too,
9129 normally only needed by developers. If a distribution object ends with
9130 a dot or is a dot by itself, then it represents a local directory and
9131 all actions such as C<make>, C<test>, and C<install> are applied
9132 directly to that directory. This gives the command C<cpan .> an
9133 interesting touch: while the normal mantra of installing a CPAN module
9134 without CPAN.pm is one of
9136 perl Makefile.PL perl Build.PL
9137 ( go and get prerequisites )
9139 make test ./Build test
9140 make install ./Build install
9142 the command C<cpan .> does all of this at once. It figures out which
9143 of the two mantras is appropriate, fetches and installs all
9144 prerequisites, cares for them recursively and finally finishes the
9145 installation of the module in the current directory, be it a CPAN
9148 =head1 PROGRAMMER'S INTERFACE
9150 If you do not enter the shell, the available shell commands are both
9151 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
9152 functions in the calling package (C<install(...)>). Before calling low-level
9153 commands it makes sense to initialize components of CPAN you need, e.g.:
9155 CPAN::HandleConfig->load;
9156 CPAN::Shell::setup_output;
9157 CPAN::Index->reload;
9159 High-level commands do such initializations automatically.
9161 There's currently only one class that has a stable interface -
9162 CPAN::Shell. All commands that are available in the CPAN shell are
9163 methods of the class CPAN::Shell. Each of the commands that produce
9164 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
9165 the IDs of all modules within the list.
9169 =item expand($type,@things)
9171 The IDs of all objects available within a program are strings that can
9172 be expanded to the corresponding real objects with the
9173 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
9174 list of CPAN::Module objects according to the C<@things> arguments
9175 given. In scalar context it only returns the first element of the
9178 =item expandany(@things)
9180 Like expand, but returns objects of the appropriate type, i.e.
9181 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
9182 CPAN::Distribution objects for distributions. Note: it does not expand
9183 to CPAN::Author objects.
9185 =item Programming Examples
9187 This enables the programmer to do operations that combine
9188 functionalities that are available in the shell.
9190 # install everything that is outdated on my disk:
9191 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
9193 # install my favorite programs if necessary:
9194 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
9195 CPAN::Shell->install($mod);
9198 # list all modules on my disk that have no VERSION number
9199 for $mod (CPAN::Shell->expand("Module","/./")){
9200 next unless $mod->inst_file;
9201 # MakeMaker convention for undefined $VERSION:
9202 next unless $mod->inst_version eq "undef";
9203 print "No VERSION in ", $mod->id, "\n";
9206 # find out which distribution on CPAN contains a module:
9207 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
9209 Or if you want to write a cronjob to watch The CPAN, you could list
9210 all modules that need updating. First a quick and dirty way:
9212 perl -e 'use CPAN; CPAN::Shell->r;'
9214 If you don't want to get any output in the case that all modules are
9215 up to date, you can parse the output of above command for the regular
9216 expression //modules are up to date// and decide to mail the output
9217 only if it doesn't match. Ick?
9219 If you prefer to do it more in a programmer style in one single
9220 process, maybe something like this suits you better:
9222 # list all modules on my disk that have newer versions on CPAN
9223 for $mod (CPAN::Shell->expand("Module","/./")){
9224 next unless $mod->inst_file;
9225 next if $mod->uptodate;
9226 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
9227 $mod->id, $mod->inst_version, $mod->cpan_version;
9230 If that gives you too much output every day, you maybe only want to
9231 watch for three modules. You can write
9233 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
9235 as the first line instead. Or you can combine some of the above
9238 # watch only for a new mod_perl module
9239 $mod = CPAN::Shell->expand("Module","mod_perl");
9240 exit if $mod->uptodate;
9241 # new mod_perl arrived, let me know all update recommendations
9246 =head2 Methods in the other Classes
9248 The programming interface for the classes CPAN::Module,
9249 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
9250 beta and partially even alpha. In the following paragraphs only those
9251 methods are documented that have proven useful over a longer time and
9252 thus are unlikely to change.
9256 =item CPAN::Author::as_glimpse()
9258 Returns a one-line description of the author
9260 =item CPAN::Author::as_string()
9262 Returns a multi-line description of the author
9264 =item CPAN::Author::email()
9266 Returns the author's email address
9268 =item CPAN::Author::fullname()
9270 Returns the author's name
9272 =item CPAN::Author::name()
9274 An alias for fullname
9276 =item CPAN::Bundle::as_glimpse()
9278 Returns a one-line description of the bundle
9280 =item CPAN::Bundle::as_string()
9282 Returns a multi-line description of the bundle
9284 =item CPAN::Bundle::clean()
9286 Recursively runs the C<clean> method on all items contained in the bundle.
9288 =item CPAN::Bundle::contains()
9290 Returns a list of objects' IDs contained in a bundle. The associated
9291 objects may be bundles, modules or distributions.
9293 =item CPAN::Bundle::force($method,@args)
9295 Forces CPAN to perform a task that normally would have failed. Force
9296 takes as arguments a method name to be called and any number of
9297 additional arguments that should be passed to the called method. The
9298 internals of the object get the needed changes so that CPAN.pm does
9299 not refuse to take the action. The C<force> is passed recursively to
9300 all contained objects.
9302 =item CPAN::Bundle::get()
9304 Recursively runs the C<get> method on all items contained in the bundle
9306 =item CPAN::Bundle::inst_file()
9308 Returns the highest installed version of the bundle in either @INC or
9309 C<$CPAN::Config->{cpan_home}>. Note that this is different from
9310 CPAN::Module::inst_file.
9312 =item CPAN::Bundle::inst_version()
9314 Like CPAN::Bundle::inst_file, but returns the $VERSION
9316 =item CPAN::Bundle::uptodate()
9318 Returns 1 if the bundle itself and all its members are uptodate.
9320 =item CPAN::Bundle::install()
9322 Recursively runs the C<install> method on all items contained in the bundle
9324 =item CPAN::Bundle::make()
9326 Recursively runs the C<make> method on all items contained in the bundle
9328 =item CPAN::Bundle::readme()
9330 Recursively runs the C<readme> method on all items contained in the bundle
9332 =item CPAN::Bundle::test()
9334 Recursively runs the C<test> method on all items contained in the bundle
9336 =item CPAN::Distribution::as_glimpse()
9338 Returns a one-line description of the distribution
9340 =item CPAN::Distribution::as_string()
9342 Returns a multi-line description of the distribution
9344 =item CPAN::Distribution::author
9346 Returns the CPAN::Author object of the maintainer who uploaded this
9349 =item CPAN::Distribution::clean()
9351 Changes to the directory where the distribution has been unpacked and
9352 runs C<make clean> there.
9354 =item CPAN::Distribution::containsmods()
9356 Returns a list of IDs of modules contained in a distribution file.
9357 Only works for distributions listed in the 02packages.details.txt.gz
9358 file. This typically means that only the most recent version of a
9359 distribution is covered.
9361 =item CPAN::Distribution::cvs_import()
9363 Changes to the directory where the distribution has been unpacked and
9366 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
9370 =item CPAN::Distribution::dir()
9372 Returns the directory into which this distribution has been unpacked.
9374 =item CPAN::Distribution::force($method,@args)
9376 Forces CPAN to perform a task that normally would have failed. Force
9377 takes as arguments a method name to be called and any number of
9378 additional arguments that should be passed to the called method. The
9379 internals of the object get the needed changes so that CPAN.pm does
9380 not refuse to take the action.
9382 =item CPAN::Distribution::get()
9384 Downloads the distribution from CPAN and unpacks it. Does nothing if
9385 the distribution has already been downloaded and unpacked within the
9388 =item CPAN::Distribution::install()
9390 Changes to the directory where the distribution has been unpacked and
9391 runs the external command C<make install> there. If C<make> has not
9392 yet been run, it will be run first. A C<make test> will be issued in
9393 any case and if this fails, the install will be canceled. The
9394 cancellation can be avoided by letting C<force> run the C<install> for
9397 This install method has only the power to install the distribution if
9398 there are no dependencies in the way. To install an object and all of
9399 its dependencies, use CPAN::Shell->install.
9401 Note that install() gives no meaningful return value. See uptodate().
9403 =item CPAN::Distribution::isa_perl()
9405 Returns 1 if this distribution file seems to be a perl distribution.
9406 Normally this is derived from the file name only, but the index from
9407 CPAN can contain a hint to achieve a return value of true for other
9410 =item CPAN::Distribution::look()
9412 Changes to the directory where the distribution has been unpacked and
9413 opens a subshell there. Exiting the subshell returns.
9415 =item CPAN::Distribution::make()
9417 First runs the C<get> method to make sure the distribution is
9418 downloaded and unpacked. Changes to the directory where the
9419 distribution has been unpacked and runs the external commands C<perl
9420 Makefile.PL> or C<perl Build.PL> and C<make> there.
9422 =item CPAN::Distribution::perldoc()
9424 Downloads the pod documentation of the file associated with a
9425 distribution (in html format) and runs it through the external
9426 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
9427 isn't available, it converts it to plain text with external
9428 command html2text and runs it through the pager specified
9429 in C<$CPAN::Config->{pager}>
9431 =item CPAN::Distribution::prefs()
9433 Returns the hash reference from the first matching YAML file that the
9434 user has deposited in the C<prefs_dir/> directory. The first
9435 succeeding match wins. The files in the C<prefs_dir/> are processed
9436 alphabetically and the canonical distroname (e.g.
9437 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
9438 stored in the $root->{match}{distribution} attribute value.
9439 Additionally all module names contained in a distribution are matched
9440 agains the regular expressions in the $root->{match}{module} attribute
9441 value. The two match values are ANDed together. Each of the two
9442 attributes are optional.
9444 =item CPAN::Distribution::prereq_pm()
9446 Returns the hash reference that has been announced by a distribution
9447 as the merge of the C<requires> element and the C<build_requires>
9448 element of the META.yml or the C<PREREQ_PM> hash in the
9449 C<Makefile.PL>. Note: works only after an attempt has been made to
9450 C<make> the distribution. Returns undef otherwise.
9452 =item CPAN::Distribution::readme()
9454 Downloads the README file associated with a distribution and runs it
9455 through the pager specified in C<$CPAN::Config->{pager}>.
9457 =item CPAN::Distribution::read_yaml()
9459 Returns the content of the META.yml of this distro as a hashref. Note:
9460 works only after an attempt has been made to C<make> the distribution.
9461 Returns undef otherwise. Also returns undef if the content of META.yml
9464 =item CPAN::Distribution::test()
9466 Changes to the directory where the distribution has been unpacked and
9467 runs C<make test> there.
9469 =item CPAN::Distribution::uptodate()
9471 Returns 1 if all the modules contained in the distribution are
9472 uptodate. Relies on containsmods.
9474 =item CPAN::Index::force_reload()
9476 Forces a reload of all indices.
9478 =item CPAN::Index::reload()
9480 Reloads all indices if they have not been read for more than
9481 C<$CPAN::Config->{index_expire}> days.
9483 =item CPAN::InfoObj::dump()
9485 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
9486 inherit this method. It prints the data structure associated with an
9487 object. Useful for debugging. Note: the data structure is considered
9488 internal and thus subject to change without notice.
9490 =item CPAN::Module::as_glimpse()
9492 Returns a one-line description of the module in four columns: The
9493 first column contains the word C<Module>, the second column consists
9494 of one character: an equals sign if this module is already installed
9495 and uptodate, a less-than sign if this module is installed but can be
9496 upgraded, and a space if the module is not installed. The third column
9497 is the name of the module and the fourth column gives maintainer or
9498 distribution information.
9500 =item CPAN::Module::as_string()
9502 Returns a multi-line description of the module
9504 =item CPAN::Module::clean()
9506 Runs a clean on the distribution associated with this module.
9508 =item CPAN::Module::cpan_file()
9510 Returns the filename on CPAN that is associated with the module.
9512 =item CPAN::Module::cpan_version()
9514 Returns the latest version of this module available on CPAN.
9516 =item CPAN::Module::cvs_import()
9518 Runs a cvs_import on the distribution associated with this module.
9520 =item CPAN::Module::description()
9522 Returns a 44 character description of this module. Only available for
9523 modules listed in The Module List (CPAN/modules/00modlist.long.html
9524 or 00modlist.long.txt.gz)
9526 =item CPAN::Module::distribution()
9528 Returns the CPAN::Distribution object that contains the current
9529 version of this module.
9531 =item CPAN::Module::dslip_status()
9533 Returns a hash reference. The keys of the hash are the letters C<D>,
9534 C<S>, C<L>, C<I>, and <P>, for development status, support level,
9535 language, interface and public licence respectively. The data for the
9536 DSLIP status are collected by pause.perl.org when authors register
9537 their namespaces. The values of the 5 hash elements are one-character
9538 words whose meaning is described in the table below. There are also 5
9539 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
9540 verbose value of the 5 status variables.
9542 Where the 'DSLIP' characters have the following meanings:
9544 D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
9545 i - Idea, listed to gain consensus or as a placeholder
9546 c - under construction but pre-alpha (not yet released)
9547 a/b - Alpha/Beta testing
9549 M - Mature (no rigorous definition)
9550 S - Standard, supplied with Perl 5
9555 u - Usenet newsgroup comp.lang.perl.modules
9556 n - None known, try comp.lang.perl.modules
9557 a - abandoned; volunteers welcome to take over maintainance
9560 p - Perl-only, no compiler needed, should be platform independent
9561 c - C and perl, a C compiler will be needed
9562 h - Hybrid, written in perl with optional C code, no compiler needed
9563 + - C++ and perl, a C++ compiler will be needed
9564 o - perl and another language other than C or C++
9567 f - plain Functions, no references used
9568 h - hybrid, object and function interfaces available
9569 n - no interface at all (huh?)
9570 r - some use of unblessed References or ties
9571 O - Object oriented using blessed references and/or inheritance
9574 p - Standard-Perl: user may choose between GPL and Artistic
9575 g - GPL: GNU General Public License
9576 l - LGPL: "GNU Lesser General Public License" (previously known as
9577 "GNU Library General Public License")
9578 b - BSD: The BSD License
9579 a - Artistic license alone
9580 o - open source: appoved by www.opensource.org
9581 d - allows distribution without restrictions
9582 r - restricted distribtion
9583 n - no license at all
9585 =item CPAN::Module::force($method,@args)
9587 Forces CPAN to perform a task that normally would have failed. Force
9588 takes as arguments a method name to be called and any number of
9589 additional arguments that should be passed to the called method. The
9590 internals of the object get the needed changes so that CPAN.pm does
9591 not refuse to take the action.
9593 =item CPAN::Module::get()
9595 Runs a get on the distribution associated with this module.
9597 =item CPAN::Module::inst_file()
9599 Returns the filename of the module found in @INC. The first file found
9600 is reported just like perl itself stops searching @INC when it finds a
9603 =item CPAN::Module::inst_version()
9605 Returns the version number of the module in readable format.
9607 =item CPAN::Module::install()
9609 Runs an C<install> on the distribution associated with this module.
9611 =item CPAN::Module::look()
9613 Changes to the directory where the distribution associated with this
9614 module has been unpacked and opens a subshell there. Exiting the
9617 =item CPAN::Module::make()
9619 Runs a C<make> on the distribution associated with this module.
9621 =item CPAN::Module::manpage_headline()
9623 If module is installed, peeks into the module's manpage, reads the
9624 headline and returns it. Moreover, if the module has been downloaded
9625 within this session, does the equivalent on the downloaded module even
9626 if it is not installed.
9628 =item CPAN::Module::perldoc()
9630 Runs a C<perldoc> on this module.
9632 =item CPAN::Module::readme()
9634 Runs a C<readme> on the distribution associated with this module.
9636 =item CPAN::Module::test()
9638 Runs a C<test> on the distribution associated with this module.
9640 =item CPAN::Module::uptodate()
9642 Returns 1 if the module is installed and up-to-date.
9644 =item CPAN::Module::userid()
9646 Returns the author's ID of the module.
9650 =head2 Cache Manager
9652 Currently the cache manager only keeps track of the build directory
9653 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
9654 deletes complete directories below C<build_dir> as soon as the size of
9655 all directories there gets bigger than $CPAN::Config->{build_cache}
9656 (in MB). The contents of this cache may be used for later
9657 re-installations that you intend to do manually, but will never be
9658 trusted by CPAN itself. This is due to the fact that the user might
9659 use these directories for building modules on different architectures.
9661 There is another directory ($CPAN::Config->{keep_source_where}) where
9662 the original distribution files are kept. This directory is not
9663 covered by the cache manager and must be controlled by the user. If
9664 you choose to have the same directory as build_dir and as
9665 keep_source_where directory, then your sources will be deleted with
9666 the same fifo mechanism.
9670 A bundle is just a perl module in the namespace Bundle:: that does not
9671 define any functions or methods. It usually only contains documentation.
9673 It starts like a perl module with a package declaration and a $VERSION
9674 variable. After that the pod section looks like any other pod with the
9675 only difference being that I<one special pod section> exists starting with
9680 In this pod section each line obeys the format
9682 Module_Name [Version_String] [- optional text]
9684 The only required part is the first field, the name of a module
9685 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
9686 of the line is optional. The comment part is delimited by a dash just
9687 as in the man page header.
9689 The distribution of a bundle should follow the same convention as
9690 other distributions.
9692 Bundles are treated specially in the CPAN package. If you say 'install
9693 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
9694 the modules in the CONTENTS section of the pod. You can install your
9695 own Bundles locally by placing a conformant Bundle file somewhere into
9696 your @INC path. The autobundle() command which is available in the
9697 shell interface does that for you by including all currently installed
9698 modules in a snapshot bundle file.
9700 =head1 PREREQUISITES
9702 If you have a local mirror of CPAN and can access all files with
9703 "file:" URLs, then you only need a perl better than perl5.003 to run
9704 this module. Otherwise Net::FTP is strongly recommended. LWP may be
9705 required for non-UNIX systems or if your nearest CPAN site is
9706 associated with a URL that is not C<ftp:>.
9708 If you have neither Net::FTP nor LWP, there is a fallback mechanism
9709 implemented for an external ftp command or for an external lynx
9714 =head2 Finding packages and VERSION
9716 This module presumes that all packages on CPAN
9722 declare their $VERSION variable in an easy to parse manner. This
9723 prerequisite can hardly be relaxed because it consumes far too much
9724 memory to load all packages into the running program just to determine
9725 the $VERSION variable. Currently all programs that are dealing with
9726 version use something like this
9728 perl -MExtUtils::MakeMaker -le \
9729 'print MM->parse_version(shift)' filename
9731 If you are author of a package and wonder if your $VERSION can be
9732 parsed, please try the above method.
9736 come as compressed or gzipped tarfiles or as zip files and contain a
9737 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
9738 without much enthusiasm).
9744 The debugging of this module is a bit complex, because we have
9745 interferences of the software producing the indices on CPAN, of the
9746 mirroring process on CPAN, of packaging, of configuration, of
9747 synchronicity, and of bugs within CPAN.pm.
9749 For debugging the code of CPAN.pm itself in interactive mode some more
9750 or less useful debugging aid can be turned on for most packages within
9755 =item o debug package...
9757 sets debug mode for packages.
9759 =item o debug -package...
9761 unsets debug mode for packages.
9765 turns debugging on for all packages.
9767 =item o debug number
9771 which sets the debugging packages directly. Note that C<o debug 0>
9772 turns debugging off.
9774 What seems quite a successful strategy is the combination of C<reload
9775 cpan> and the debugging switches. Add a new debug statement while
9776 running in the shell and then issue a C<reload cpan> and see the new
9777 debugging messages immediately without losing the current context.
9779 C<o debug> without an argument lists the valid package names and the
9780 current set of packages in debugging mode. C<o debug> has built-in
9783 For debugging of CPAN data there is the C<dump> command which takes
9784 the same arguments as make/test/install and outputs each object's
9785 Data::Dumper dump. If an argument looks like a perl variable and
9786 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
9787 Data::Dumper directly.
9789 =head2 Floppy, Zip, Offline Mode
9791 CPAN.pm works nicely without network too. If you maintain machines
9792 that are not networked at all, you should consider working with file:
9793 URLs. Of course, you have to collect your modules somewhere first. So
9794 you might use CPAN.pm to put together all you need on a networked
9795 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
9796 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
9797 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
9798 with this floppy. See also below the paragraph about CD-ROM support.
9800 =head2 Basic Utilities for Programmers
9804 =item has_inst($module)
9806 Returns true if the module is installed. See the source for details.
9808 =item has_usable($module)
9810 Returns true if the module is installed and several and is in a usable
9811 state. Only useful for a handful of modules that are used internally.
9812 See the source for details.
9814 =item instance($module)
9816 The constructor for all the singletons used to represent modules,
9817 distributions, authors and bundles. If the object already exists, this
9818 method returns the object, otherwise it calls the constructor.
9822 =head1 CONFIGURATION
9824 When the CPAN module is used for the first time, a configuration
9825 dialog tries to determine a couple of site specific options. The
9826 result of the dialog is stored in a hash reference C< $CPAN::Config >
9827 in a file CPAN/Config.pm.
9829 The default values defined in the CPAN/Config.pm file can be
9830 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9831 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9832 added to the search path of the CPAN module before the use() or
9833 require() statements. The mkmyconfig command writes this file for you.
9835 The C<o conf> command has various bells and whistles:
9839 =item completion support
9841 If you have a ReadLine module installed, you can hit TAB at any point
9842 of the commandline and C<o conf> will offer you completion for the
9843 built-in subcommands and/or config variable names.
9845 =item displaying some help: o conf help
9847 Displays a short help
9849 =item displaying current values: o conf [KEY]
9851 Displays the current value(s) for this config variable. Without KEY
9852 displays all subcommands and config variables.
9858 =item changing of scalar values: o conf KEY VALUE
9860 Sets the config variable KEY to VALUE. The empty string can be
9861 specified as usual in shells, with C<''> or C<"">
9865 o conf wget /usr/bin/wget
9867 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9869 If a config variable name ends with C<list>, it is a list. C<o conf
9870 KEY shift> removes the first element of the list, C<o conf KEY pop>
9871 removes the last element of the list. C<o conf KEYS unshift LIST>
9872 prepends a list of values to the list, C<o conf KEYS push LIST>
9873 appends a list of valued to the list.
9875 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9878 Finally, any other list of arguments is taken as a new list value for
9879 the KEY variable discarding the previous value.
9883 o conf urllist unshift http://cpan.dev.local/CPAN
9884 o conf urllist splice 3 1
9885 o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9887 =item interactive editing: o conf init [MATCH|LIST]
9889 Runs an interactive configuration dialog for matching variables.
9890 Without argument runs the dialog over all supported config variables.
9891 To specify a MATCH the argument must be enclosed by slashes.
9895 o conf init ftp_passive ftp_proxy
9898 =item reverting to saved: o conf defaults
9900 Reverts all config variables to the state in the saved config file.
9902 =item saving the config: o conf commit
9904 Saves all config variables to the current config file (CPAN/Config.pm
9905 or CPAN/MyConfig.pm that was loaded at start).
9909 The configuration dialog can be started any time later again by
9910 issuing the command C< o conf init > in the CPAN shell. A subset of
9911 the configuration dialog can be run by issuing C<o conf init WORD>
9912 where WORD is any valid config variable or a regular expression.
9914 =head2 Config Variables
9916 Currently the following keys in the hash reference $CPAN::Config are
9919 build_cache size of cache for directories to build modules
9920 build_dir locally accessible directory to build modules
9921 build_dir_reuse boolean if distros in build_dir are persistent
9922 build_requires_install_policy
9923 to install or not to install: when a module is
9924 only needed for building. yes|no|ask/yes|ask/no
9925 bzip2 path to external prg
9926 cache_metadata use serializer to cache metadata
9927 commands_quote prefered character to use for quoting external
9928 commands when running them. Defaults to double
9929 quote on Windows, single tick everywhere else;
9930 can be set to space to disable quoting
9931 check_sigs if signatures should be verified
9932 colorize_output boolean if Term::ANSIColor should colorize output
9933 colorize_print Term::ANSIColor attributes for normal output
9934 colorize_warn Term::ANSIColor attributes for warnings
9935 commandnumber_in_prompt
9936 boolean if you want to see current command number
9937 cpan_home local directory reserved for this package
9938 curl path to external prg
9939 dontload_hash DEPRECATED
9940 dontload_list arrayref: modules in the list will not be
9941 loaded by the CPAN::has_inst() routine
9942 ftp path to external prg
9943 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
9944 ftp_proxy proxy host for ftp requests
9946 gpg path to external prg
9947 gzip location of external program gzip
9948 histfile file to maintain history between sessions
9949 histsize maximum number of lines to keep in histfile
9950 http_proxy proxy host for http requests
9951 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
9952 after this many seconds inactivity. Set to 0 to
9954 index_expire after this many days refetch index files
9955 inhibit_startup_message
9956 if true, does not print the startup message
9957 keep_source_where directory in which to keep the source (if we do)
9958 lynx path to external prg
9959 make location of external make program
9960 make_arg arguments that should always be passed to 'make'
9961 make_install_make_command
9962 the make command for running 'make install', for
9964 make_install_arg same as make_arg for 'make install'
9965 makepl_arg arguments passed to 'perl Makefile.PL'
9966 mbuild_arg arguments passed to './Build'
9967 mbuild_install_arg arguments passed to './Build install'
9968 mbuild_install_build_command
9969 command to use instead of './Build' when we are
9970 in the install stage, for example 'sudo ./Build'
9971 mbuildpl_arg arguments passed to 'perl Build.PL'
9972 ncftp path to external prg
9973 ncftpget path to external prg
9974 no_proxy don't proxy to these hosts/domains (comma separated list)
9975 pager location of external program more (or any pager)
9976 password your password if you CPAN server wants one
9977 patch path to external prg
9978 prefer_installer legal values are MB and EUMM: if a module comes
9979 with both a Makefile.PL and a Build.PL, use the
9980 former (EUMM) or the latter (MB); if the module
9981 comes with only one of the two, that one will be
9983 prerequisites_policy
9984 what to do if you are missing module prerequisites
9985 ('follow' automatically, 'ask' me, or 'ignore')
9986 prefs_dir local directory to store per-distro build options
9987 proxy_user username for accessing an authenticating proxy
9988 proxy_pass password for accessing an authenticating proxy
9989 randomize_urllist add some randomness to the sequence of the urllist
9990 scan_cache controls scanning of cache ('atstart' or 'never')
9991 shell your favorite shell
9992 show_upload_date boolean if commands should try to determine upload date
9993 tar location of external program tar
9994 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
9995 (and nonsense for characters outside latin range)
9996 term_ornaments boolean to turn ReadLine ornamenting on/off
9997 test_report email test reports (if CPAN::Reporter is installed)
9998 unzip location of external program unzip
9999 urllist arrayref to nearby CPAN sites (or equivalent locations)
10000 username your username if you CPAN server wants one
10001 wait_list arrayref to a wait server to try (See CPAN::WAIT)
10002 wget path to external prg
10003 yaml_module which module to use to read/write YAML files
10005 You can set and query each of these options interactively in the cpan
10006 shell with the command set defined within the C<o conf> command:
10010 =item C<o conf E<lt>scalar optionE<gt>>
10012 prints the current value of the I<scalar option>
10014 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10016 Sets the value of the I<scalar option> to I<value>
10018 =item C<o conf E<lt>list optionE<gt>>
10020 prints the current value of the I<list option> in MakeMaker's
10023 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10025 shifts or pops the array in the I<list option> variable
10027 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10029 works like the corresponding perl commands.
10033 =head2 CPAN::anycwd($path): Note on config variable getcwd
10035 CPAN.pm changes the current working directory often and needs to
10036 determine its own current working directory. Per default it uses
10037 Cwd::cwd but if this doesn't work on your system for some reason,
10038 alternatives can be configured according to the following table:
10056 Calls the external command cwd.
10060 =head2 Note on the format of the urllist parameter
10062 urllist parameters are URLs according to RFC 1738. We do a little
10063 guessing if your URL is not compliant, but if you have problems with
10064 C<file> URLs, please try the correct format. Either:
10066 file://localhost/whatever/ftp/pub/CPAN/
10070 file:///home/ftp/pub/CPAN/
10072 =head2 urllist parameter has CD-ROM support
10074 The C<urllist> parameter of the configuration table contains a list of
10075 URLs that are to be used for downloading. If the list contains any
10076 C<file> URLs, CPAN always tries to get files from there first. This
10077 feature is disabled for index files. So the recommendation for the
10078 owner of a CD-ROM with CPAN contents is: include your local, possibly
10079 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10081 o conf urllist push file://localhost/CDROM/CPAN
10083 CPAN.pm will then fetch the index files from one of the CPAN sites
10084 that come at the beginning of urllist. It will later check for each
10085 module if there is a local copy of the most recent version.
10087 Another peculiarity of urllist is that the site that we could
10088 successfully fetch the last file from automatically gets a preference
10089 token and is tried as the first site for the next request. So if you
10090 add a new site at runtime it may happen that the previously preferred
10091 site will be tried another time. This means that if you want to disallow
10092 a site for the next transfer, it must be explicitly removed from
10095 =head2 Maintaining the urllist parameter
10097 If you have YAML.pm (or some other YAML module configured in
10098 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10099 about recent downloads. You can view the statistics with the C<hosts>
10100 command or inspect them directly by looking into the C<FTPstats.yml>
10101 file in your C<cpan_home> directory.
10103 To get some interesting statistics it is recommended to set the
10104 C<randomize_urllist> parameter that introduces some amount of
10105 randomness into the URL selection.
10107 =head2 prefs_dir for avoiding interactive questions (ALPHA)
10109 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10110 still considered experimental and may still be changed)
10112 The files in the directory specified in C<prefs_dir> are YAML files
10113 that specify how CPAN.pm shall treat distributions that deviate from
10114 the normal non-interactive model of building and installing CPAN
10117 Some modules try to get some data from the user interactively thus
10118 disturbing the installation of large bundles like Phalanx100 or
10119 modules like Plagger.
10121 CPAN.pm can use YAML files to either pass additional arguments to one
10122 of the four commands, set environment variables or instantiate an
10123 Expect object that reads from the console and enters answers on your
10124 behalf (latter option requires Expect.pm installed). A further option
10125 is to apply patches from the local disk or from CPAN.
10127 CPAN.pm comes with a couple of such YAML files. The structure is
10128 currently not documented because in flux. Please see the distroprefs
10129 directory of the CPAN distribution for examples and follow the README
10132 Please note that setting the environment variable PERL_MM_USE_DEFAULT
10133 to a true value can also get you a long way if you want to always pick
10134 the default answers. But this only works if the author of a package
10135 used the prompt function provided by ExtUtils::MakeMaker and if the
10136 defaults are OK for you.
10140 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
10141 install foreign, unmasked, unsigned code on your machine. We compare
10142 to a checksum that comes from the net just as the distribution file
10143 itself. But we try to make it easy to add security on demand:
10145 =head2 Cryptographically signed modules
10147 Since release 1.77 CPAN.pm has been able to verify cryptographically
10148 signed module distributions using Module::Signature. The CPAN modules
10149 can be signed by their authors, thus giving more security. The simple
10150 unsigned MD5 checksums that were used before by CPAN protect mainly
10151 against accidental file corruption.
10153 You will need to have Module::Signature installed, which in turn
10154 requires that you have at least one of Crypt::OpenPGP module or the
10155 command-line F<gpg> tool installed.
10157 You will also need to be able to connect over the Internet to the public
10158 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
10160 The configuration parameter check_sigs is there to turn signature
10161 checking on or off.
10165 Most functions in package CPAN are exported per default. The reason
10166 for this is that the primary use is intended for the cpan shell or for
10171 When the CPAN shell enters a subshell via the look command, it sets
10172 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
10175 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
10177 When the config variable ftp_passive is set, all downloads will be run
10178 with the environment variable FTP_PASSIVE set to this value. This is
10179 in general a good idea as it influences both Net::FTP and LWP based
10180 connections. The same effect can be achieved by starting the cpan
10181 shell with this environment variable set. For Net::FTP alone, one can
10182 also always set passive mode by running libnetcfg.
10184 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
10186 Populating a freshly installed perl with my favorite modules is pretty
10187 easy if you maintain a private bundle definition file. To get a useful
10188 blueprint of a bundle definition file, the command autobundle can be used
10189 on the CPAN shell command line. This command writes a bundle definition
10190 file for all modules that are installed for the currently running perl
10191 interpreter. It's recommended to run this command only once and from then
10192 on maintain the file manually under a private name, say
10193 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
10195 cpan> install Bundle::my_bundle
10197 then answer a few questions and then go out for a coffee.
10199 Maintaining a bundle definition file means keeping track of two
10200 things: dependencies and interactivity. CPAN.pm sometimes fails on
10201 calculating dependencies because not all modules define all MakeMaker
10202 attributes correctly, so a bundle definition file should specify
10203 prerequisites as early as possible. On the other hand, it's a bit
10204 annoying that many distributions need some interactive configuring. So
10205 what I try to accomplish in my private bundle file is to have the
10206 packages that need to be configured early in the file and the gentle
10207 ones later, so I can go out after a few minutes and leave CPAN.pm
10210 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
10212 Thanks to Graham Barr for contributing the following paragraphs about
10213 the interaction between perl, and various firewall configurations. For
10214 further information on firewalls, it is recommended to consult the
10215 documentation that comes with the ncftp program. If you are unable to
10216 go through the firewall with a simple Perl setup, it is very likely
10217 that you can configure ncftp so that it works for your firewall.
10219 =head2 Three basic types of firewalls
10221 Firewalls can be categorized into three basic types.
10225 =item http firewall
10227 This is where the firewall machine runs a web server and to access the
10228 outside world you must do it via the web server. If you set environment
10229 variables like http_proxy or ftp_proxy to a values beginning with http://
10230 or in your web browser you have to set proxy information then you know
10231 you are running an http firewall.
10233 To access servers outside these types of firewalls with perl (even for
10234 ftp) you will need to use LWP.
10238 This where the firewall machine runs an ftp server. This kind of
10239 firewall will only let you access ftp servers outside the firewall.
10240 This is usually done by connecting to the firewall with ftp, then
10241 entering a username like "user@outside.host.com"
10243 To access servers outside these type of firewalls with perl you
10244 will need to use Net::FTP.
10246 =item One way visibility
10248 I say one way visibility as these firewalls try to make themselves look
10249 invisible to the users inside the firewall. An FTP data connection is
10250 normally created by sending the remote server your IP address and then
10251 listening for the connection. But the remote server will not be able to
10252 connect to you because of the firewall. So for these types of firewall
10253 FTP connections need to be done in a passive mode.
10255 There are two that I can think off.
10261 If you are using a SOCKS firewall you will need to compile perl and link
10262 it with the SOCKS library, this is what is normally called a 'socksified'
10263 perl. With this executable you will be able to connect to servers outside
10264 the firewall as if it is not there.
10266 =item IP Masquerade
10268 This is the firewall implemented in the Linux kernel, it allows you to
10269 hide a complete network behind one IP address. With this firewall no
10270 special compiling is needed as you can access hosts directly.
10272 For accessing ftp servers behind such firewalls you usually need to
10273 set the environment variable C<FTP_PASSIVE> or the config variable
10274 ftp_passive to a true value.
10280 =head2 Configuring lynx or ncftp for going through a firewall
10282 If you can go through your firewall with e.g. lynx, presumably with a
10285 /usr/local/bin/lynx -pscott:tiger
10287 then you would configure CPAN.pm with the command
10289 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
10291 That's all. Similarly for ncftp or ftp, you would configure something
10294 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
10296 Your mileage may vary...
10304 I installed a new version of module X but CPAN keeps saying,
10305 I have the old version installed
10307 Most probably you B<do> have the old version installed. This can
10308 happen if a module installs itself into a different directory in the
10309 @INC path than it was previously installed. This is not really a
10310 CPAN.pm problem, you would have the same problem when installing the
10311 module manually. The easiest way to prevent this behaviour is to add
10312 the argument C<UNINST=1> to the C<make install> call, and that is why
10313 many people add this argument permanently by configuring
10315 o conf make_install_arg UNINST=1
10319 So why is UNINST=1 not the default?
10321 Because there are people who have their precise expectations about who
10322 may install where in the @INC path and who uses which @INC array. In
10323 fine tuned environments C<UNINST=1> can cause damage.
10327 I want to clean up my mess, and install a new perl along with
10328 all modules I have. How do I go about it?
10330 Run the autobundle command for your old perl and optionally rename the
10331 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
10332 with the Configure option prefix, e.g.
10334 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
10336 Install the bundle file you produced in the first step with something like
10338 cpan> install Bundle::mybundle
10344 When I install bundles or multiple modules with one command
10345 there is too much output to keep track of.
10347 You may want to configure something like
10349 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
10350 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
10352 so that STDOUT is captured in a file for later inspection.
10357 I am not root, how can I install a module in a personal directory?
10359 First of all, you will want to use your own configuration, not the one
10360 that your root user installed. If you do not have permission to write
10361 in the cpan directory that root has configured, you will be asked if
10362 you want to create your own config. Answering "yes" will bring you into
10363 CPAN's configuration stage, using the system config for all defaults except
10364 things that have to do with CPAN's work directory, saving your choices to
10365 your MyConfig.pm file.
10367 You can also manually initiate this process with the following command:
10369 % perl -MCPAN -e 'mkmyconfig'
10375 from the CPAN shell.
10377 You will most probably also want to configure something like this:
10379 o conf makepl_arg "LIB=~/myperl/lib \
10380 INSTALLMAN1DIR=~/myperl/man/man1 \
10381 INSTALLMAN3DIR=~/myperl/man/man3"
10383 You can make this setting permanent like all C<o conf> settings with
10386 You will have to add ~/myperl/man to the MANPATH environment variable
10387 and also tell your perl programs to look into ~/myperl/lib, e.g. by
10390 use lib "$ENV{HOME}/myperl/lib";
10392 or setting the PERL5LIB environment variable.
10394 While we're speaking about $ENV{HOME}, it might be worth mentioning,
10395 that for Windows we use the File::HomeDir module that provides an
10396 equivalent to the concept of the home directory on Unix.
10398 Another thing you should bear in mind is that the UNINST parameter can
10399 be dnagerous when you are installing into a private area because you
10400 might accidentally remove modules that other people depend on that are
10401 not using the private area.
10405 How to get a package, unwrap it, and make a change before building it?
10407 Have a look at the C<look> (!) command.
10411 I installed a Bundle and had a couple of fails. When I
10412 retried, everything resolved nicely. Can this be fixed to work
10415 The reason for this is that CPAN does not know the dependencies of all
10416 modules when it starts out. To decide about the additional items to
10417 install, it just uses data found in the META.yml file or the generated
10418 Makefile. An undetected missing piece breaks the process. But it may
10419 well be that your Bundle installs some prerequisite later than some
10420 depending item and thus your second try is able to resolve everything.
10421 Please note, CPAN.pm does not know the dependency tree in advance and
10422 cannot sort the queue of things to install in a topologically correct
10423 order. It resolves perfectly well IF all modules declare the
10424 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
10425 the C<requires> stanza of Module::Build. For bundles which fail and
10426 you need to install often, it is recommended to sort the Bundle
10427 definition file manually.
10431 In our intranet we have many modules for internal use. How
10432 can I integrate these modules with CPAN.pm but without uploading
10433 the modules to CPAN?
10435 Have a look at the CPAN::Site module.
10439 When I run CPAN's shell, I get an error message about things in my
10440 /etc/inputrc (or ~/.inputrc) file.
10442 These are readline issues and can only be fixed by studying readline
10443 configuration on your architecture and adjusting the referenced file
10444 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
10445 and edit them. Quite often harmless changes like uppercasing or
10446 lowercasing some arguments solves the problem.
10450 Some authors have strange characters in their names.
10452 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
10453 expecting ISO-8859-1 charset, a converter can be activated by setting
10454 term_is_latin to a true value in your config file. One way of doing so
10457 cpan> o conf term_is_latin 1
10459 If other charset support is needed, please file a bugreport against
10460 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
10461 the support or maybe UTF-8 terminals become widely available.
10465 When an install fails for some reason and then I correct the error
10466 condition and retry, CPAN.pm refuses to install the module, saying
10467 C<Already tried without success>.
10469 Use the force pragma like so
10471 force install Foo::Bar
10473 This does a bit more than really needed because it untars the
10474 distribution again and runs make and test and only then install.
10476 Or, if you find this is too fast and you would prefer to do smaller
10481 first and then continue as always. C<Force get> I<forgets> previous
10488 and then 'make install' directly in the subshell.
10490 Or you leave the CPAN shell and start it again.
10492 For the really curious, by accessing internals directly, you I<could>
10494 !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
10496 but this is neither guaranteed to work in the future nor is it a
10501 How do I install a "DEVELOPER RELEASE" of a module?
10503 By default, CPAN will install the latest non-developer release of a
10504 module. If you want to install a dev release, you have to specify the
10505 partial path starting with the author id to the tarball you wish to
10508 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
10510 Note that you can use the C<ls> command to get this path listed.
10514 How do I install a module and all its dependencies from the commandline,
10515 without being prompted for anything, despite my CPAN configuration
10518 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
10519 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
10520 asked any questions at all (assuming the modules you are installing are
10521 nice about obeying that variable as well):
10523 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
10527 How do I create a Module::Build based Build.PL derived from an
10528 ExtUtils::MakeMaker focused Makefile.PL?
10530 http://search.cpan.org/search?query=Module::Build::Convert
10532 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
10536 What's the best CPAN site for me?
10538 The urllist config parameter is yours. You can add and remove sites at
10539 will. You should find out which sites have the best uptodateness,
10540 bandwidth, reliability, etc. and are topologically close to you. Some
10541 people prefer fast downloads, others uptodateness, others reliability.
10542 You decide which to try in which order.
10544 Henk P. Penning maintains a site that collects data about CPAN sites:
10546 http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
10552 Please report bugs via http://rt.cpan.org/
10554 Before submitting a bug, please make sure that the traditional method
10555 of building a Perl module package from a shell by following the
10556 installation instructions of that package still works in your
10559 =head1 SECURITY ADVICE
10561 This software enables you to upgrade software on your computer and so
10562 is inherently dangerous because the newly installed software may
10563 contain bugs and may alter the way your computer works or even make it
10564 unusable. Please consider backing up your data before every upgrade.
10568 Andreas Koenig C<< <andk@cpan.org> >>
10572 This program is free software; you can redistribute it and/or
10573 modify it under the same terms as Perl itself.
10575 See L<http://www.perl.com/perl/misc/Artistic.html>
10577 =head1 TRANSLATIONS
10579 Kawai,Takanori provides a Japanese translation of this manpage at
10580 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
10584 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)