1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $CPAN::VERSION = '1.9204';
5 $CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/;
7 use CPAN::HandleConfig;
12 use CPAN::DeferedCode;
18 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
19 # 5.005_04 does not work without
21 use File::Basename ();
29 use Sys::Hostname qw(hostname);
30 use Text::ParseWords ();
35 # we need to run chdir all over and we would get at wrong libraries
38 if (File::Spec->can("rel2abs")) {
40 $inc = File::Spec->rel2abs($inc) unless ref $inc;
46 require Mac::BuildTools if $^O eq 'MacOS';
47 $ENV{PERL5_CPAN_IS_RUNNING}=$$;
48 $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
50 END { $CPAN::End++; &cleanup; }
53 $CPAN::Frontend ||= "CPAN::Shell";
54 unless (@CPAN::Defaultsites) {
55 @CPAN::Defaultsites = map {
56 CPAN::URL->new(TEXT => $_, FROM => "DEF")
58 "http://www.perl.org/CPAN/",
59 "ftp://ftp.perl.org/pub/CPAN/";
61 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
62 $CPAN::Perl ||= CPAN::find_perl();
63 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
64 $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
65 $CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
67 # our globals are getting a mess
93 @CPAN::ISA = qw(CPAN::Debug Exporter);
95 # note that these functions live in CPAN::Shell and get executed via
96 # AUTOLOAD when called directly
123 sub soft_chdir_with_alternatives ($);
126 $autoload_recursion ||= 0;
128 #-> sub CPAN::AUTOLOAD ;
130 $autoload_recursion++;
134 warn "Refusing to autoload '$l' while signal pending";
135 $autoload_recursion--;
138 if ($autoload_recursion > 1) {
139 my $fullcommand = join " ", map { "'$_'" } $l, @_;
140 warn "Refusing to autoload $fullcommand in recursion\n";
141 $autoload_recursion--;
145 @export{@EXPORT} = '';
146 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
147 if (exists $export{$l}) {
150 die(qq{Unknown CPAN command "$AUTOLOAD". }.
151 qq{Type ? for help.\n});
153 $autoload_recursion--;
157 #-> sub CPAN::shell ;
160 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
161 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
163 my $oprompt = shift || CPAN::Prompt->new;
164 my $prompt = $oprompt;
165 my $commandline = shift || "";
166 $CPAN::CurrentCommandId ||= 1;
169 unless ($Suppress_readline) {
170 require Term::ReadLine;
173 $term->ReadLine eq "Term::ReadLine::Stub"
175 $term = Term::ReadLine->new('CPAN Monitor');
177 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
178 my $attribs = $term->Attribs;
179 $attribs->{attempted_completion_function} = sub {
180 &CPAN::Complete::gnu_cpl;
183 $readline::rl_completion_function =
184 $readline::rl_completion_function = 'CPAN::Complete::cpl';
186 if (my $histfile = $CPAN::Config->{'histfile'}) {{
187 unless ($term->can("AddHistory")) {
188 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
191 $META->readhist($term,$histfile);
193 for ($CPAN::Config->{term_ornaments}) { # alias
194 local $Term::ReadLine::termcap_nowarn = 1;
195 $term->ornaments($_) if defined;
197 # $term->OUT is autoflushed anyway
198 my $odef = select STDERR;
206 my @cwd = grep { defined $_ and length $_ }
208 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
209 File::Spec->rootdir();
210 my $try_detect_readline;
211 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
212 unless ($CPAN::Config->{inhibit_startup_message}) {
213 my $rl_avail = $Suppress_readline ? "suppressed" :
214 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
215 "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
216 $CPAN::Frontend->myprint(
218 cpan shell -- CPAN exploration and modules installation (v%s)
226 my($continuation) = "";
227 my $last_term_ornaments;
228 SHELLCOMMAND: while () {
229 if ($Suppress_readline) {
230 if ($Echo_readline) {
234 last SHELLCOMMAND unless defined ($_ = <> );
235 if ($Echo_readline) {
236 # backdoor: I could not find a way to record sessions
241 last SHELLCOMMAND unless
242 defined ($_ = $term->readline($prompt, $commandline));
244 $_ = "$continuation$_" if $continuation;
246 next SHELLCOMMAND if /^$/;
248 if (/^(?:q(?:uit)?|bye|exit)$/i) {
259 use vars qw($import_done);
260 CPAN->import(':DEFAULT') unless $import_done++;
261 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
268 eval { @line = Text::ParseWords::shellwords($_) };
269 warn($@), next SHELLCOMMAND if $@;
270 warn("Text::Parsewords could not parse the line [$_]"),
271 next SHELLCOMMAND unless @line;
272 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
273 my $command = shift @line;
274 eval { CPAN::Shell->$command(@line) };
280 my $dv = Dumpvalue->new();
281 Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
291 # pragmas for classic commands
300 # only commands that tell us something about failed distros
301 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
303 soft_chdir_with_alternatives(\@cwd);
304 $CPAN::Frontend->myprint("\n");
306 $CPAN::CurrentCommandId++;
310 $commandline = ""; # I do want to be able to pass a default to
311 # shell, but on the second command I see no
314 CPAN::Queue->nullify_queue;
315 if ($try_detect_readline) {
316 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
318 $CPAN::META->has_inst("Term::ReadLine::Perl")
320 delete $INC{"Term/ReadLine.pm"};
322 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
323 require Term::ReadLine;
324 $CPAN::Frontend->myprint("\n$redef subroutines in ".
325 "Term::ReadLine redefined\n");
329 if ($term and $term->can("ornaments")) {
330 for ($CPAN::Config->{term_ornaments}) { # alias
332 if (not defined $last_term_ornaments
333 or $_ != $last_term_ornaments
335 local $Term::ReadLine::termcap_nowarn = 1;
336 $term->ornaments($_);
337 $last_term_ornaments = $_;
340 undef $last_term_ornaments;
344 for my $class (qw(Module Distribution)) {
345 # again unsafe meta access?
346 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
347 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
348 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
349 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
353 $GOTOSHELL = 0; # not too often
354 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
359 soft_chdir_with_alternatives(\@cwd);
362 sub soft_chdir_with_alternatives ($) {
365 my $root = File::Spec->rootdir();
366 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
367 Trying '$root' as temporary haven.
372 if (chdir $cwd->[0]) {
376 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
377 Trying to chdir to "$cwd->[1]" instead.
381 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
389 if ($Config::Config{d_flock}) {
390 return flock $fh, $mode;
391 } elsif (!$Have_warned->{"d_flock"}++) {
392 $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
393 $CPAN::Frontend->mysleep(5);
400 sub _yaml_module () {
401 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
403 $yaml_module ne "YAML"
405 !$CPAN::META->has_inst($yaml_module)
407 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
408 $yaml_module = "YAML";
410 if ($yaml_module eq "YAML"
412 $CPAN::META->has_inst($yaml_module)
414 $YAML::VERSION < 0.60
416 !$Have_warned->{"YAML"}++
418 $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
419 "I'll continue but problems are *very* likely to happen.\n"
421 $CPAN::Frontend->mysleep(5);
426 # CPAN::_yaml_loadfile
428 my($self,$local_file) = @_;
429 return +[] unless -s $local_file;
430 my $yaml_module = _yaml_module;
431 if ($CPAN::META->has_inst($yaml_module)) {
432 # temporarly enable yaml code deserialisation
434 # 5.6.2 could not do the local() with the reference
435 local $YAML::LoadCode;
436 local $YAML::Syck::LoadCode;
437 ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
440 if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
442 eval { @yaml = $code->($local_file); };
444 # this shall not be done by the frontend
445 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
448 } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
450 open FH, $local_file or die "Could not open '$local_file': $!";
454 eval { @yaml = $code->($ystream); };
456 # this shall not be done by the frontend
457 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
462 # this shall not be done by the frontend
463 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
468 # CPAN::_yaml_dumpfile
470 my($self,$local_file,@what) = @_;
471 my $yaml_module = _yaml_module;
472 if ($CPAN::META->has_inst($yaml_module)) {
474 if (UNIVERSAL::isa($local_file, "FileHandle")) {
475 $code = UNIVERSAL::can($yaml_module, "Dump");
476 eval { print $local_file $code->(@what) };
477 } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
478 eval { $code->($local_file,@what); };
479 } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
481 open FH, ">$local_file" or die "Could not open '$local_file': $!";
482 print FH $code->(@what);
485 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
488 if (UNIVERSAL::isa($local_file, "FileHandle")) {
489 # I think this case does not justify a warning at all
491 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
496 sub _init_sqlite () {
497 unless ($CPAN::META->has_inst("CPAN::SQLite")) {
498 $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
499 unless $Have_warned->{"CPAN::SQLite"}++;
502 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
503 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
507 my $negative_cache = {};
508 sub _sqlite_running {
509 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
510 # need to cache the result, otherwise too slow
511 return $negative_cache->{fact};
513 $negative_cache = {}; # reset
515 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
516 return $ret if $ret; # fast anyway
517 $negative_cache->{time} = time;
518 return $negative_cache->{fact} = $ret;
522 package CPAN::CacheMgr;
524 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
529 use Fcntl qw(:flock);
530 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
531 @CPAN::FTP::ISA = qw(CPAN::Debug);
533 package CPAN::LWP::UserAgent;
535 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
536 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
538 package CPAN::Complete;
540 @CPAN::Complete::ISA = qw(CPAN::Debug);
541 # Q: where is the "How do I add a new command" HOWTO?
542 # A: svn diff -r 1048:1049 where andk added the report command
543 @CPAN::Complete::COMMANDS = sort qw(
544 ? ! a b d h i m o q r u
579 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
580 @CPAN::Index::ISA = qw(CPAN::Debug);
583 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
586 package CPAN::InfoObj;
588 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
590 package CPAN::Author;
592 @CPAN::Author::ISA = qw(CPAN::InfoObj);
594 package CPAN::Distribution;
596 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
598 package CPAN::Bundle;
600 @CPAN::Bundle::ISA = qw(CPAN::Module);
602 package CPAN::Module;
604 @CPAN::Module::ISA = qw(CPAN::InfoObj);
606 package CPAN::Exception::RecursiveDependency;
608 use overload '""' => "as_string";
610 # a module sees its distribution (no version)
611 # a distribution sees its prereqs (which are module names) (usually with versions)
612 # a bundle sees its module names and/or its distributions (no version)
617 my (@deps,%seen,$loop_starts_with);
618 DCHAIN: for my $dep (@$deps) {
619 push @deps, {name => $dep, display_as => $dep};
621 $loop_starts_with = $dep;
626 for my $i (0..$#deps) {
627 my $x = $deps[$i]{name};
628 $in_loop ||= $x eq $loop_starts_with;
629 my $xo = CPAN::Shell->expandany($x) or next;
630 if ($xo->isa("CPAN::Module")) {
631 my $have = $xo->inst_version || "N/A";
632 my($want,$d,$want_type);
633 if ($i>0 and $d = $deps[$i-1]{name}) {
634 my $do = CPAN::Shell->expandany($d);
635 $want = $do->{prereq_pm}{requires}{$x};
637 $want_type = "requires: ";
639 $want = $do->{prereq_pm}{build_requires}{$x};
641 $want_type = "build_requires: ";
643 $want_type = "unknown status";
648 $want = $xo->cpan_version;
649 $want_type = "want: ";
651 $deps[$i]{have} = $have;
652 $deps[$i]{want_type} = $want_type;
653 $deps[$i]{want} = $want;
654 $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
655 } elsif ($xo->isa("CPAN::Distribution")) {
656 $deps[$i]{display_as} = $xo->pretty_id;
658 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
660 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
662 $xo->store_persistent_state; # otherwise I will not reach
663 # all involved parties for
667 bless { deps => \@deps }, $class;
672 my $ret = "\nRecursive dependency detected:\n ";
673 $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
674 $ret .= ".\nCannot resolve.\n";
678 package CPAN::Exception::yaml_not_installed;
680 use overload '""' => "as_string";
683 my($class,$module,$file,$during) = @_;
684 bless { module => $module, file => $file, during => $during }, $class;
689 "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
692 package CPAN::Exception::yaml_process_error;
694 use overload '""' => "as_string";
697 my($class,$module,$file,$during,$error) = @_;
698 bless { module => $module,
701 error => $error }, $class;
706 if ($self->{during}) {
708 if ($self->{module}) {
709 if ($self->{error}) {
710 return "Alert: While trying to '$self->{during}' YAML file\n".
711 " '$self->{file}'\n".
712 "with '$self->{module}' the following error was encountered:\n".
715 return "Alert: While trying to '$self->{during}' YAML file\n".
716 " '$self->{file}'\n".
717 "with '$self->{module}' some unknown error was encountered\n";
720 return "Alert: While trying to '$self->{during}' YAML file\n".
721 " '$self->{file}'\n".
722 "some unknown error was encountered\n";
725 return "Alert: While trying to '$self->{during}' some YAML file\n".
726 "some unknown error was encountered\n";
729 return "Alert: unknown error encountered\n";
733 package CPAN::Prompt; use overload '""' => "as_string";
734 use vars qw($prompt);
736 $CPAN::CurrentCommandId ||= 0;
742 unless ($CPAN::META->{LOCK}) {
743 $word = "nolock_cpan";
745 if ($CPAN::Config->{commandnumber_in_prompt}) {
746 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
752 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
753 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
754 # planned are things like age or quality
756 my($class,%args) = @_;
768 $self->{TEXT} = $set;
773 package CPAN::Distrostatus;
774 use overload '""' => "as_string",
777 my($class,$arg) = @_;
780 FAILED => substr($arg,0,2) eq "NO",
781 COMMANDID => $CPAN::CurrentCommandId,
785 sub commandid { shift->{COMMANDID} }
786 sub failed { shift->{FAILED} }
790 $self->{TEXT} = $set;
810 @CPAN::Shell::ISA = qw(CPAN::Debug);
811 $COLOR_REGISTERED ||= 0;
814 '!' => "eval the rest of the line as perl",
816 autobundle => "wtite inventory into a bundle file",
817 b => "info about bundle",
819 clean => "clean up a distribution's build directory",
821 d => "info about a distribution",
824 failed => "list all failed actions within current session",
825 fforce => "redo a command from scratch",
826 force => "redo a command",
828 help => "overview over commands; 'help ...' explains specific commands",
829 hosts => "statistics about recently used hosts",
830 i => "info about authors/bundles/distributions/modules",
831 install => "install a distribution",
832 install_tested => "install all distributions tested OK",
833 is_tested => "list all distributions tested OK",
834 look => "open a subshell in a distribution's directory",
835 ls => "list distributions according to a glob",
836 m => "info about a module",
837 make => "make/build a distribution",
838 mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
839 notest => "run a (usually install) command but leave out the test phase",
840 o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
841 perldoc => "try to get a manpage for a module",
843 quit => "leave the cpan shell",
844 r => "review over upgradeable modules",
845 readme => "display the README of a distro woth a pager",
846 recent => "show recent uploads to the CPAN",
848 reload => "'reload cpan' or 'reload index'",
849 report => "test a distribution and send a test report to cpantesters",
850 reports => "info about reported tests from cpantesters",
853 test => "test a distribution",
854 u => "display uninstalled modules",
855 upgrade => "combine 'r' command with immediate installation",
858 $autoload_recursion ||= 0;
860 #-> sub CPAN::Shell::AUTOLOAD ;
862 $autoload_recursion++;
864 my $class = shift(@_);
865 # warn "autoload[$l] class[$class]";
868 warn "Refusing to autoload '$l' while signal pending";
869 $autoload_recursion--;
872 if ($autoload_recursion > 1) {
873 my $fullcommand = join " ", map { "'$_'" } $l, @_;
874 warn "Refusing to autoload $fullcommand in recursion\n";
875 $autoload_recursion--;
879 # XXX needs to be reconsidered
880 if ($CPAN::META->has_inst('CPAN::WAIT')) {
883 $CPAN::Frontend->mywarn(qq{
884 Commands starting with "w" require CPAN::WAIT to be installed.
885 Please consider installing CPAN::WAIT to use the fulltext index.
886 For this you just need to type
891 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
895 $autoload_recursion--;
902 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
904 # from here on only subs.
905 ################################################################################
907 sub _perl_fingerprint {
908 my($self,$other_fingerprint) = @_;
909 my $dll = eval {OS2::DLLname()};
912 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
914 my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
915 my $this_fingerprint = {
916 '$^X' => CPAN::find_perl,
917 sitearchexp => $Config::Config{sitearchexp},
918 'mtime_$^X' => $mtime_perl,
919 'mtime_dll' => $mtime_dll,
921 if ($other_fingerprint) {
922 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
923 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
925 # mandatory keys since 1.88_57
926 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
927 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
931 return $this_fingerprint;
935 sub suggest_myconfig () {
936 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
937 $CPAN::Frontend->myprint("You don't seem to have a user ".
938 "configuration (MyConfig.pm) yet.\n");
939 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
940 "user configuration now? (Y/n)",
943 CPAN::Shell->mkmyconfig();
946 $CPAN::Frontend->mydie("OK, giving up.");
951 #-> sub CPAN::all_objects ;
953 my($mgr,$class) = @_;
954 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
955 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
957 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
960 # Called by shell, not in batch mode. In batch mode I see no risk in
961 # having many processes updating something as installations are
962 # continually checked at runtime. In shell mode I suspect it is
963 # unintentional to open more than one shell at a time
965 #-> sub CPAN::checklock ;
968 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
969 if (-f $lockfile && -M _ > 0) {
970 my $fh = FileHandle->new($lockfile) or
971 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
972 my $otherpid = <$fh>;
973 my $otherhost = <$fh>;
975 if (defined $otherpid && $otherpid) {
978 if (defined $otherhost && $otherhost) {
981 my $thishost = hostname();
982 if (defined $otherhost && defined $thishost &&
983 $otherhost ne '' && $thishost ne '' &&
984 $otherhost ne $thishost) {
985 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
986 "reports other host $otherhost and other ".
987 "process $otherpid.\n".
988 "Cannot proceed.\n"));
989 } elsif ($RUN_DEGRADED) {
990 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
991 } elsif (defined $otherpid && $otherpid) {
992 return if $$ == $otherpid; # should never happen
993 $CPAN::Frontend->mywarn(
995 There seems to be running another CPAN process (pid $otherpid). Contacting...
997 if (kill 0, $otherpid) {
998 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
1000 CPAN::Shell::colorable_makemaker_prompt
1001 (qq{Shall I try to run in degraded }.
1002 qq{mode? (Y/n)},"y");
1003 if ($ans =~ /^y/i) {
1004 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1005 Please report if something unexpected happens\n");
1007 for ($CPAN::Config) {
1009 # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1010 $_->{commandnumber_in_prompt} = 0; # visibility
1011 $_->{histfile} = ""; # who should win otherwise?
1012 $_->{cache_metadata} = 0; # better would be a lock?
1013 $_->{use_sqlite} = 0; # better would be a write lock!
1016 $CPAN::Frontend->mydie("
1017 You may want to kill the other job and delete the lockfile. On UNIX try:
1022 } elsif (-w $lockfile) {
1024 CPAN::Shell::colorable_makemaker_prompt
1025 (qq{Other job not responding. Shall I overwrite }.
1026 qq{the lockfile '$lockfile'? (Y/n)},"y");
1027 $CPAN::Frontend->myexit("Ok, bye\n")
1028 unless $ans =~ /^y/i;
1031 qq{Lockfile '$lockfile' not writeable by you. }.
1032 qq{Cannot proceed.\n}.
1033 qq{ On UNIX try:\n}.
1034 qq{ rm '$lockfile'\n}.
1035 qq{ and then rerun us.\n}
1039 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1040 "'$lockfile', please remove. Cannot proceed.\n"));
1043 my $dotcpan = $CPAN::Config->{cpan_home};
1044 eval { File::Path::mkpath($dotcpan);};
1046 # A special case at least for Jarkko.
1047 my $firsterror = $@;
1051 $symlinkcpan = readlink $dotcpan;
1052 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1053 eval { File::Path::mkpath($symlinkcpan); };
1057 $CPAN::Frontend->mywarn(qq{
1058 Working directory $symlinkcpan created.
1062 unless (-d $dotcpan) {
1064 Your configuration suggests "$dotcpan" as your
1065 CPAN.pm working directory. I could not create this directory due
1066 to this error: $firsterror\n};
1068 As "$dotcpan" is a symlink to "$symlinkcpan",
1069 I tried to create that, but I failed with this error: $seconderror
1072 Please make sure the directory exists and is writable.
1074 $CPAN::Frontend->mywarn($mess);
1075 return suggest_myconfig;
1077 } # $@ after eval mkpath $dotcpan
1078 if (0) { # to test what happens when a race condition occurs
1079 for (reverse 1..10) {
1085 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1087 unless ($fh = FileHandle->new("+>>$lockfile")) {
1088 if ($! =~ /Permission/) {
1089 $CPAN::Frontend->mywarn(qq{
1091 Your configuration suggests that CPAN.pm should use a working
1093 $CPAN::Config->{cpan_home}
1094 Unfortunately we could not create the lock file
1096 due to permission problems.
1098 Please make sure that the configuration variable
1099 \$CPAN::Config->{cpan_home}
1100 points to a directory where you can write a .lock file. You can set
1101 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1104 return suggest_myconfig;
1108 while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
1110 $CPAN::Frontend->mydie("Giving up\n");
1112 $CPAN::Frontend->mysleep($sleep++);
1113 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1119 $fh->print($$, "\n");
1120 $fh->print(hostname(), "\n");
1121 $self->{LOCK} = $lockfile;
1122 $self->{LOCKFH} = $fh;
1127 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1132 &cleanup if $Signal;
1133 die "Got yet another signal" if $Signal > 1;
1134 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1135 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1139 # From: Larry Wall <larry@wall.org>
1140 # Subject: Re: deprecating SIGDIE
1141 # To: perl5-porters@perl.org
1142 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1144 # The original intent of __DIE__ was only to allow you to substitute one
1145 # kind of death for another on an application-wide basis without respect
1146 # to whether you were in an eval or not. As a global backstop, it should
1147 # not be used any more lightly (or any more heavily :-) than class
1148 # UNIVERSAL. Any attempt to build a general exception model on it should
1149 # be politely squashed. Any bug that causes every eval {} to have to be
1150 # modified should be not so politely squashed.
1152 # Those are my current opinions. It is also my optinion that polite
1153 # arguments degenerate to personal arguments far too frequently, and that
1154 # when they do, it's because both people wanted it to, or at least didn't
1155 # sufficiently want it not to.
1159 # global backstop to cleanup if we should really die
1160 $SIG{__DIE__} = \&cleanup;
1161 $self->debug("Signal handler set.") if $CPAN::DEBUG;
1164 #-> sub CPAN::DESTROY ;
1166 &cleanup; # need an eval?
1169 #-> sub CPAN::anycwd ;
1172 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1177 sub cwd {Cwd::cwd();}
1179 #-> sub CPAN::getcwd ;
1180 sub getcwd {Cwd::getcwd();}
1182 #-> sub CPAN::fastcwd ;
1183 sub fastcwd {Cwd::fastcwd();}
1185 #-> sub CPAN::backtickcwd ;
1186 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1188 #-> sub CPAN::find_perl ;
1190 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1191 my $pwd = $CPAN::iCwd = CPAN::anycwd();
1192 my $candidate = File::Spec->catfile($pwd,$^X);
1193 $perl ||= $candidate if MM->maybe_command($candidate);
1196 my ($component,$perl_name);
1197 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1198 PATH_COMPONENT: foreach $component (File::Spec->path(),
1199 $Config::Config{'binexp'}) {
1200 next unless defined($component) && $component;
1201 my($abs) = File::Spec->catfile($component,$perl_name);
1202 if (MM->maybe_command($abs)) {
1214 #-> sub CPAN::exists ;
1216 my($mgr,$class,$id) = @_;
1217 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1218 CPAN::Index->reload;
1219 ### Carp::croak "exists called without class argument" unless $class;
1221 $id =~ s/:+/::/g if $class eq "CPAN::Module";
1223 if (CPAN::_sqlite_running) {
1224 $exists = (exists $META->{readonly}{$class}{$id} or
1225 $CPAN::SQLite->set($class, $id));
1227 $exists = exists $META->{readonly}{$class}{$id};
1229 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1232 #-> sub CPAN::delete ;
1234 my($mgr,$class,$id) = @_;
1235 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1236 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1239 #-> sub CPAN::has_usable
1240 # has_inst is sometimes too optimistic, we should replace it with this
1241 # has_usable whenever a case is given
1243 my($self,$mod,$message) = @_;
1244 return 1 if $HAS_USABLE->{$mod};
1245 my $has_inst = $self->has_inst($mod,$message);
1246 return unless $has_inst;
1249 LWP => [ # we frequently had "Can't locate object
1250 # method "new" via package "LWP::UserAgent" at
1251 # (eval 69) line 2006
1253 sub {require LWP::UserAgent},
1254 sub {require HTTP::Request},
1255 sub {require URI::URL},
1258 sub {require Net::FTP},
1259 sub {require Net::Config},
1261 'File::HomeDir' => [
1262 sub {require File::HomeDir;
1263 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
1264 for ("Will not use File::HomeDir, need 0.52\n") {
1265 $CPAN::Frontend->mywarn($_);
1272 sub {require Archive::Tar;
1273 unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
1274 for ("Will not use Archive::Tar, need 1.00\n") {
1275 $CPAN::Frontend->mywarn($_);
1282 # XXX we should probably delete from
1283 # %INC too so we can load after we
1284 # installed a new enough version --
1286 sub {require File::Temp;
1287 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1288 for ("Will not use File::Temp, need 0.16\n") {
1289 $CPAN::Frontend->mywarn($_);
1296 if ($usable->{$mod}) {
1297 for my $c (0..$#{$usable->{$mod}}) {
1298 my $code = $usable->{$mod}[$c];
1299 my $ret = eval { &$code() };
1300 $ret = "" unless defined $ret;
1302 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1307 return $HAS_USABLE->{$mod} = 1;
1310 #-> sub CPAN::has_inst
1312 my($self,$mod,$message) = @_;
1313 Carp::croak("CPAN->has_inst() called without an argument")
1314 unless defined $mod;
1315 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1316 keys %{$CPAN::Config->{dontload_hash}||{}},
1317 @{$CPAN::Config->{dontload_list}||[]};
1318 if (defined $message && $message eq "no" # afair only used by Nox
1322 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1330 # checking %INC is wrong, because $INC{LWP} may be true
1331 # although $INC{"URI/URL.pm"} may have failed. But as
1332 # I really want to say "bla loaded OK", I have to somehow
1334 ### warn "$file in %INC"; #debug
1336 } elsif (eval { require $file }) {
1337 # eval is good: if we haven't yet read the database it's
1338 # perfect and if we have installed the module in the meantime,
1339 # it tries again. The second require is only a NOOP returning
1340 # 1 if we had success, otherwise it's retrying
1342 my $mtime = (stat $INC{$file})[9];
1343 # privileged files loaded by has_inst; Note: we use $mtime
1344 # as a proxy for a checksum.
1345 $CPAN::Shell::reload->{$file} = $mtime;
1346 my $v = eval "\$$mod\::VERSION";
1347 $v = $v ? " (v$v)" : "";
1348 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1349 if ($mod eq "CPAN::WAIT") {
1350 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1353 } elsif ($mod eq "Net::FTP") {
1354 $CPAN::Frontend->mywarn(qq{
1355 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1357 install Bundle::libnet
1359 }) unless $Have_warned->{"Net::FTP"}++;
1360 $CPAN::Frontend->mysleep(3);
1361 } elsif ($mod eq "Digest::SHA") {
1362 if ($Have_warned->{"Digest::SHA"}++) {
1363 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
1364 qq{because Digest::SHA not installed.\n});
1366 $CPAN::Frontend->mywarn(qq{
1367 CPAN: checksum security checks disabled because Digest::SHA not installed.
1368 Please consider installing the Digest::SHA module.
1371 $CPAN::Frontend->mysleep(2);
1373 } elsif ($mod eq "Module::Signature") {
1374 # NOT prefs_lookup, we are not a distro
1375 my $check_sigs = $CPAN::Config->{check_sigs};
1376 if (not $check_sigs) {
1377 # they do not want us:-(
1378 } elsif (not $Have_warned->{"Module::Signature"}++) {
1379 # No point in complaining unless the user can
1380 # reasonably install and use it.
1381 if (eval { require Crypt::OpenPGP; 1 } ||
1383 defined $CPAN::Config->{'gpg'}
1385 $CPAN::Config->{'gpg'} =~ /\S/
1388 $CPAN::Frontend->mywarn(qq{
1389 CPAN: Module::Signature security checks disabled because Module::Signature
1390 not installed. Please consider installing the Module::Signature module.
1391 You may also need to be able to connect over the Internet to the public
1392 keyservers like pgp.mit.edu (port 11371).
1395 $CPAN::Frontend->mysleep(2);
1399 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1404 #-> sub CPAN::instance ;
1406 my($mgr,$class,$id) = @_;
1407 CPAN::Index->reload;
1409 # unsafe meta access, ok?
1410 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1411 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1419 #-> sub CPAN::cleanup ;
1421 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1422 local $SIG{__DIE__} = '';
1427 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1428 $ineval = 1, last if
1429 $subroutine eq '(eval)';
1431 return if $ineval && !$CPAN::End;
1432 return unless defined $META->{LOCK};
1433 return unless -f $META->{LOCK};
1435 close $META->{LOCKFH};
1436 unlink $META->{LOCK};
1438 # Carp::cluck("DEBUGGING");
1439 if ( $CPAN::CONFIG_DIRTY ) {
1440 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1442 $CPAN::Frontend->myprint("Lockfile removed.\n");
1445 #-> sub CPAN::readhist
1447 my($self,$term,$histfile) = @_;
1448 my($fh) = FileHandle->new;
1449 open $fh, "<$histfile" or last;
1453 $term->AddHistory($_);
1458 #-> sub CPAN::savehist
1461 my($histfile,$histsize);
1462 unless ($histfile = $CPAN::Config->{'histfile'}) {
1463 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1466 $histsize = $CPAN::Config->{'histsize'} || 100;
1468 unless ($CPAN::term->can("GetHistory")) {
1469 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1475 my @h = $CPAN::term->GetHistory;
1476 splice @h, 0, @h-$histsize if @h>$histsize;
1477 my($fh) = FileHandle->new;
1478 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1479 local $\ = local $, = "\n";
1484 #-> sub CPAN::is_tested
1486 my($self,$what,$when) = @_;
1488 Carp::cluck("DEBUG: empty what");
1491 $self->{is_tested}{$what} = $when;
1494 #-> sub CPAN::is_installed
1495 # unsets the is_tested flag: as soon as the thing is installed, it is
1496 # not needed in set_perl5lib anymore
1498 my($self,$what) = @_;
1499 delete $self->{is_tested}{$what};
1502 sub _list_sorted_descending_is_tested {
1505 { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1506 keys %{$self->{is_tested}}
1509 #-> sub CPAN::set_perl5lib
1511 my($self,$for) = @_;
1513 (undef,undef,undef,$for) = caller(1);
1516 $self->{is_tested} ||= {};
1517 return unless %{$self->{is_tested}};
1518 my $env = $ENV{PERL5LIB};
1519 $env = $ENV{PERLLIB} unless defined $env;
1521 push @env, $env if defined $env and length $env;
1522 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1523 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1525 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1527 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1528 } elsif (@dirs < 24) {
1529 my @d = map {my $cp = $_;
1530 $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1533 $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1534 "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1538 my $cnt = keys %{$self->{is_tested}};
1539 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1540 "$cnt build dirs to PERL5LIB; ".
1545 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1548 package CPAN::CacheMgr;
1551 #-> sub CPAN::CacheMgr::as_string ;
1553 eval { require Data::Dumper };
1555 return shift->SUPER::as_string;
1557 return Data::Dumper::Dumper(shift);
1561 #-> sub CPAN::CacheMgr::cachesize ;
1566 #-> sub CPAN::CacheMgr::tidyup ;
1569 return unless $CPAN::META->{LOCK};
1570 return unless -d $self->{ID};
1571 my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1572 for my $current (0..$#toremove) {
1573 my $toremove = $toremove[$current];
1574 $CPAN::Frontend->myprint(sprintf(
1575 "DEL(%d/%d): %s \n",
1581 return if $CPAN::Signal;
1582 $self->_clean_cache($toremove);
1583 return if $CPAN::Signal;
1587 #-> sub CPAN::CacheMgr::dir ;
1592 #-> sub CPAN::CacheMgr::entries ;
1594 my($self,$dir) = @_;
1595 return unless defined $dir;
1596 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1597 $dir ||= $self->{ID};
1598 my($cwd) = CPAN::anycwd();
1599 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1600 my $dh = DirHandle->new(File::Spec->curdir)
1601 or Carp::croak("Couldn't opendir $dir: $!");
1604 next if $_ eq "." || $_ eq "..";
1606 push @entries, File::Spec->catfile($dir,$_);
1608 push @entries, File::Spec->catdir($dir,$_);
1610 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1613 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1614 sort { -M $a <=> -M $b} @entries;
1617 #-> sub CPAN::CacheMgr::disk_usage ;
1619 my($self,$dir,$fast) = @_;
1620 return if exists $self->{SIZE}{$dir};
1621 return if $CPAN::Signal;
1626 unless (chmod 0755, $dir) {
1627 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1628 "permission to change the permission; cannot ".
1629 "estimate disk usage of '$dir'\n");
1630 $CPAN::Frontend->mysleep(5);
1635 # nothing to say, no matter what the permissions
1638 $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1642 $Du = 0; # placeholder
1646 $File::Find::prune++ if $CPAN::Signal;
1648 if ($^O eq 'MacOS') {
1650 my $cat = Mac::Files::FSpGetCatInfo($_);
1651 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1655 unless (chmod 0755, $_) {
1656 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1657 "the permission to change the permission; ".
1658 "can only partially estimate disk usage ".
1660 $CPAN::Frontend->mysleep(5);
1672 return if $CPAN::Signal;
1673 $self->{SIZE}{$dir} = $Du/1024/1024;
1674 unshift @{$self->{FIFO}}, $dir;
1675 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1676 $self->{DU} += $Du/1024/1024;
1680 #-> sub CPAN::CacheMgr::_clean_cache ;
1682 my($self,$dir) = @_;
1683 return unless -e $dir;
1684 unless (File::Spec->canonpath(File::Basename::dirname($dir))
1685 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1686 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1687 "will not remove\n");
1688 $CPAN::Frontend->mysleep(5);
1691 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1693 File::Path::rmtree($dir);
1695 if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1696 my $yaml_module = CPAN::_yaml_module;
1697 if ($CPAN::META->has_inst($yaml_module)) {
1698 my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1700 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1701 unlink "$dir.yml" or
1702 $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1704 } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1705 $CPAN::META->delete("CPAN::Distribution", $id);
1707 # XXX we should restore the state NOW, otherise this
1708 # distro does not exist until we read an index. BUG ALERT(?)
1710 # $CPAN::Frontend->mywarn (" +++\n");
1714 unlink "$dir.yml"; # may fail
1715 unless ($id_deleted) {
1716 CPAN->debug("no distro found associated with '$dir'");
1719 $self->{DU} -= $self->{SIZE}{$dir};
1720 delete $self->{SIZE}{$dir};
1723 #-> sub CPAN::CacheMgr::new ;
1730 ID => $CPAN::Config->{build_dir},
1731 MAX => $CPAN::Config->{'build_cache'},
1732 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1735 File::Path::mkpath($self->{ID});
1736 my $dh = DirHandle->new($self->{ID});
1737 bless $self, $class;
1740 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1742 CPAN->debug($debug) if $CPAN::DEBUG;
1746 #-> sub CPAN::CacheMgr::scan_cache ;
1749 return if $self->{SCAN} eq 'never';
1750 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1751 unless $self->{SCAN} eq 'atstart';
1752 return unless $CPAN::META->{LOCK};
1753 $CPAN::Frontend->myprint(
1754 sprintf("Scanning cache %s for sizes\n",
1757 my @entries = $self->entries($self->{ID});
1762 if ($self->{DU} > $self->{MAX}) {
1764 $self->disk_usage($e,1);
1766 $self->disk_usage($e);
1769 while (($painted/76) < ($i/@entries)) {
1770 $CPAN::Frontend->myprint($symbol);
1773 return if $CPAN::Signal;
1775 $CPAN::Frontend->myprint("DONE\n");
1779 package CPAN::Shell;
1782 #-> sub CPAN::Shell::h ;
1784 my($class,$about) = @_;
1785 if (defined $about) {
1787 if (exists $Help->{$about}) {
1788 if (ref $Help->{$about}) { # aliases
1789 $about = ${$Help->{$about}};
1791 $help = $Help->{$about};
1793 $help = "No help available";
1795 $CPAN::Frontend->myprint("$about\: $help\n");
1797 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1798 $CPAN::Frontend->myprint(qq{
1799 Display Information $filler (ver $CPAN::VERSION)
1800 command argument description
1801 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1802 i WORD or /REGEXP/ about any of the above
1803 ls AUTHOR or GLOB about files in the author's directory
1804 (with WORD being a module, bundle or author name or a distribution
1805 name of the form AUTHOR/DISTRIBUTION)
1807 Download, Test, Make, Install...
1808 get download clean make clean
1809 make make (implies get) look open subshell in dist directory
1810 test make test (implies make) readme display these README files
1811 install make install (implies test) perldoc display POD documentation
1814 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1815 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1818 force CMD try hard to do command fforce CMD try harder
1819 notest CMD skip testing
1822 h,? display this menu ! perl-code eval a perl command
1823 o conf [opt] set and query options q quit the cpan shell
1824 reload cpan load CPAN.pm again reload index load newer indices
1825 autobundle Snapshot recent latest CPAN uploads});
1831 #-> sub CPAN::Shell::a ;
1833 my($self,@arg) = @_;
1834 # authors are always UPPERCASE
1836 $_ = uc $_ unless /=/;
1838 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1841 #-> sub CPAN::Shell::globls ;
1843 my($self,$s,$pragmas) = @_;
1844 # ls is really very different, but we had it once as an ordinary
1845 # command in the Shell (upto rev. 321) and we could not handle
1847 my(@accept,@preexpand);
1848 if ($s =~ /[\*\?\/]/) {
1849 if ($CPAN::META->has_inst("Text::Glob")) {
1850 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1851 my $rau = Text::Glob::glob_to_regex(uc $au);
1852 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1854 push @preexpand, map { $_->id . "/" . $pathglob }
1855 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1857 my $rau = Text::Glob::glob_to_regex(uc $s);
1858 push @preexpand, map { $_->id }
1859 CPAN::Shell->expand_by_method('CPAN::Author',
1864 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1867 push @preexpand, uc $s;
1870 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1871 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1876 my $silent = @accept>1;
1877 my $last_alpha = "";
1879 for my $a (@accept) {
1880 my($author,$pathglob);
1881 if ($a =~ m|(.*?)/(.*)|) {
1884 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1887 or $CPAN::Frontend->mydie("No author found for $a2\n");
1889 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1892 or $CPAN::Frontend->mydie("No author found for $a\n");
1895 my $alpha = substr $author->id, 0, 1;
1897 if ($alpha eq $last_alpha) {
1901 $last_alpha = $alpha;
1903 $CPAN::Frontend->myprint($ad);
1905 for my $pragma (@$pragmas) {
1906 if ($author->can($pragma)) {
1910 push @results, $author->ls($pathglob,$silent); # silent if
1913 for my $pragma (@$pragmas) {
1914 my $unpragma = "un$pragma";
1915 if ($author->can($unpragma)) {
1916 $author->$unpragma();
1923 #-> sub CPAN::Shell::local_bundles ;
1925 my($self,@which) = @_;
1926 my($incdir,$bdir,$dh);
1927 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1928 my @bbase = "Bundle";
1929 while (my $bbase = shift @bbase) {
1930 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1931 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1932 if ($dh = DirHandle->new($bdir)) { # may fail
1934 for $entry ($dh->read) {
1935 next if $entry =~ /^\./;
1936 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1937 if (-d File::Spec->catdir($bdir,$entry)) {
1938 push @bbase, "$bbase\::$entry";
1940 next unless $entry =~ s/\.pm(?!\n)\Z//;
1941 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1949 #-> sub CPAN::Shell::b ;
1951 my($self,@which) = @_;
1952 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1953 $self->local_bundles;
1954 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1957 #-> sub CPAN::Shell::d ;
1958 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1960 #-> sub CPAN::Shell::m ;
1961 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1963 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1966 #-> sub CPAN::Shell::i ;
1970 @args = '/./' unless @args;
1972 for my $type (qw/Bundle Distribution Module/) {
1973 push @result, $self->expand($type,@args);
1975 # Authors are always uppercase.
1976 push @result, $self->expand("Author", map { uc $_ } @args);
1978 my $result = @result == 1 ?
1979 $result[0]->as_string :
1981 "No objects found of any type for argument @args\n" :
1983 (map {$_->as_glimpse} @result),
1984 scalar @result, " items found\n",
1986 $CPAN::Frontend->myprint($result);
1989 #-> sub CPAN::Shell::o ;
1991 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1992 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1993 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1994 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1996 my($self,$o_type,@o_what) = @_;
1998 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1999 if ($o_type eq 'conf') {
2000 my($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
2001 if (!@o_what or $cfilter) { # print all things, "o conf"
2003 my $qrfilter = eval 'qr/$cfilter/';
2005 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
2007 if (exists $INC{'CPAN/Config.pm'}) {
2008 push @from, $INC{'CPAN/Config.pm'};
2010 if (exists $INC{'CPAN/MyConfig.pm'}) {
2011 push @from, $INC{'CPAN/MyConfig.pm'};
2013 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
2014 $CPAN::Frontend->myprint(":\n");
2015 for $k (sort keys %CPAN::HandleConfig::can) {
2016 next unless $k =~ /$qrfilter/;
2017 $v = $CPAN::HandleConfig::can{$k};
2018 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
2020 $CPAN::Frontend->myprint("\n");
2021 for $k (sort keys %CPAN::HandleConfig::keys) {
2022 next unless $k =~ /$qrfilter/;
2023 CPAN::HandleConfig->prettyprint($k);
2025 $CPAN::Frontend->myprint("\n");
2027 if (CPAN::HandleConfig->edit(@o_what)) {
2029 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2033 } elsif ($o_type eq 'debug') {
2035 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2038 my($what) = shift @o_what;
2039 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2040 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2043 if ( exists $CPAN::DEBUG{$what} ) {
2044 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2045 } elsif ($what =~ /^\d/) {
2046 $CPAN::DEBUG = $what;
2047 } elsif (lc $what eq 'all') {
2049 for (values %CPAN::DEBUG) {
2052 $CPAN::DEBUG = $max;
2055 for (keys %CPAN::DEBUG) {
2056 next unless lc($_) eq lc($what);
2057 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2060 $CPAN::Frontend->myprint("unknown argument [$what]\n")
2065 my $raw = "Valid options for debug are ".
2066 join(", ",sort(keys %CPAN::DEBUG), 'all').
2067 qq{ or a number. Completion works on the options. }.
2068 qq{Case is ignored.};
2070 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2071 $CPAN::Frontend->myprint("\n\n");
2074 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2076 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2077 $v = $CPAN::DEBUG{$k};
2078 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
2079 if $v & $CPAN::DEBUG;
2082 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2085 $CPAN::Frontend->myprint(qq{
2087 conf set or get configuration variables
2088 debug set or get debugging options
2093 # CPAN::Shell::paintdots_onreload
2094 sub paintdots_onreload {
2097 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2101 # $CPAN::Frontend->myprint(".($subr)");
2102 $CPAN::Frontend->myprint(".");
2103 if ($subr =~ /\bshell\b/i) {
2104 # warn "debug[$_[0]]";
2106 # It would be nice if we could detect that a
2107 # subroutine has actually changed, but for now we
2108 # practically always set the GOTOSHELL global
2118 #-> sub CPAN::Shell::hosts ;
2121 my $fullstats = CPAN::FTP->_ftp_statistics();
2122 my $history = $fullstats->{history} || [];
2124 while (my $last = pop @$history) {
2125 my $attempts = $last->{attempts} or next;
2128 $start = $attempts->[-1]{start};
2129 if ($#$attempts > 0) {
2130 for my $i (0..$#$attempts-1) {
2131 my $url = $attempts->[$i]{url} or next;
2136 $start = $last->{start};
2138 next unless $last->{thesiteurl}; # C-C? bad filenames?
2140 $S{end} ||= $last->{end};
2141 my $dltime = $last->{end} - $start;
2142 my $dlsize = $last->{filesize} || 0;
2143 my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2144 my $s = $S{ok}{$url} ||= {};
2147 $s->{dlsize} += $dlsize/1024;
2149 $s->{dltime} += $dltime;
2152 for my $url (keys %{$S{ok}}) {
2153 next if $S{ok}{$url}{dltime} == 0; # div by zero
2154 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2155 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2159 for my $url (keys %{$S{no}}) {
2160 push @{$res->{no}}, [$S{no}{$url},
2164 my $R = ""; # report
2165 if ($S{start} && $S{end}) {
2166 $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2167 $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
2169 if ($res->{ok} && @{$res->{ok}}) {
2170 $R .= sprintf "\nSuccessful downloads:
2171 N kB secs kB/s url\n";
2173 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2174 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2178 if ($res->{no} && @{$res->{no}}) {
2179 $R .= sprintf "\nUnsuccessful downloads:\n";
2181 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2182 $R .= sprintf "%4d %s\n", @$_;
2186 $CPAN::Frontend->myprint($R);
2189 #-> sub CPAN::Shell::reload ;
2191 my($self,$command,@arg) = @_;
2193 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2194 if ($command =~ /^cpan$/i) {
2196 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2201 "CPAN/FirstTime.pm",
2202 "CPAN/HandleConfig.pm",
2205 "CPAN/Reporter/Config.pm",
2206 "CPAN/Reporter/History.pm",
2212 MFILE: for my $f (@relo) {
2213 next unless exists $INC{$f};
2217 $CPAN::Frontend->myprint("($p");
2218 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2219 $self->_reload_this($f) or $failed++;
2220 my $v = eval "$p\::->VERSION";
2221 $CPAN::Frontend->myprint("v$v)");
2223 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2225 my $errors = $failed == 1 ? "error" : "errors";
2226 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2229 } elsif ($command =~ /^index$/i) {
2230 CPAN::Index->force_reload;
2232 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
2233 index re-reads the index files\n});
2237 # reload means only load again what we have loaded before
2238 #-> sub CPAN::Shell::_reload_this ;
2240 my($self,$f,$args) = @_;
2241 CPAN->debug("f[$f]") if $CPAN::DEBUG;
2242 return 1 unless $INC{$f}; # we never loaded this, so we do not
2244 my $pwd = CPAN::anycwd();
2245 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2247 for my $inc (@INC) {
2248 $file = File::Spec->catfile($inc,split /\//, $f);
2252 CPAN->debug("file[$file]") if $CPAN::DEBUG;
2254 unless ($file && -f $file) {
2255 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2257 unless (CPAN->has_inst("File::Basename")) {
2258 @inc = File::Basename::dirname($file);
2260 # do we ever need this?
2261 @inc = substr($file,0,-length($f)-1); # bring in back to me!
2264 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2266 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2269 my $mtime = (stat $file)[9];
2270 if ($reload->{$f}) {
2271 } elsif ($^T < $mtime) {
2272 # since we started the file has changed, force it to be reloaded
2275 $reload->{$f} = $mtime;
2277 my $must_reload = $mtime != $reload->{$f};
2279 $must_reload ||= $args->{reloforce}; # o conf defaults needs this
2281 my $fh = FileHandle->new($file) or
2282 $CPAN::Frontend->mydie("Could not open $file: $!");
2285 my $content = <$fh>;
2286 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2290 eval "require '$f'";
2295 $reload->{$f} = $mtime;
2297 $CPAN::Frontend->myprint("__unchanged__");
2302 #-> sub CPAN::Shell::mkmyconfig ;
2304 my($self, $cpanpm, %args) = @_;
2305 require CPAN::FirstTime;
2306 my $home = CPAN::HandleConfig::home;
2307 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2308 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2309 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2310 CPAN::HandleConfig::require_myconfig_or_config;
2311 $CPAN::Config ||= {};
2316 keep_source_where => undef,
2319 CPAN::FirstTime::init($cpanpm, %args);
2322 #-> sub CPAN::Shell::_binary_extensions ;
2323 sub _binary_extensions {
2324 my($self) = shift @_;
2325 my(@result,$module,%seen,%need,$headerdone);
2326 for $module ($self->expand('Module','/./')) {
2327 my $file = $module->cpan_file;
2328 next if $file eq "N/A";
2329 next if $file =~ /^Contact Author/;
2330 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2331 next if $dist->isa_perl;
2332 next unless $module->xs_file;
2334 $CPAN::Frontend->myprint(".");
2335 push @result, $module;
2337 # print join " | ", @result;
2338 $CPAN::Frontend->myprint("\n");
2342 #-> sub CPAN::Shell::recompile ;
2344 my($self) = shift @_;
2345 my($module,@module,$cpan_file,%dist);
2346 @module = $self->_binary_extensions();
2347 for $module (@module) { # we force now and compile later, so we
2349 $cpan_file = $module->cpan_file;
2350 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2352 $dist{$cpan_file}++;
2354 for $cpan_file (sort keys %dist) {
2355 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
2356 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2358 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2359 # stop a package from recompiling,
2360 # e.g. IO-1.12 when we have perl5.003_10
2364 #-> sub CPAN::Shell::scripts ;
2366 my($self, $arg) = @_;
2367 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2369 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2370 unless ($CPAN::META->has_inst($req)) {
2371 $CPAN::Frontend->mywarn(" $req not available\n");
2374 my $p = HTML::LinkExtor->new();
2375 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2376 unless (-f $indexfile) {
2377 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2379 $p->parse_file($indexfile);
2382 if ($arg =~ s|^/(.+)/$|$1|) {
2383 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2385 for my $l ($p->links) {
2386 my $tag = shift @$l;
2387 next unless $tag eq "a";
2389 my $href = $att{href};
2390 next unless $href =~ s|^\.\./authors/id/./../||;
2393 if ($href =~ $qrarg) {
2397 if ($href =~ /\Q$arg\E/) {
2405 # now filter for the latest version if there is more than one of a name
2411 $stems{$stem} ||= [];
2412 push @{$stems{$stem}}, $href;
2414 for (sort keys %stems) {
2416 if (@{$stems{$_}} > 1) {
2417 $highest = List::Util::reduce {
2418 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2421 $highest = $stems{$_}[0];
2423 $CPAN::Frontend->myprint("$highest\n");
2427 #-> sub CPAN::Shell::report ;
2429 my($self,@args) = @_;
2430 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2431 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2433 local $CPAN::Config->{test_report} = 1;
2434 $self->force("test",@args); # force is there so that the test be
2435 # re-run (as documented)
2438 # compare with is_tested
2439 #-> sub CPAN::Shell::install_tested
2440 sub install_tested {
2441 my($self,@some) = @_;
2442 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2444 CPAN::Index->reload;
2446 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2447 my $yaml = "$b.yml";
2449 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2452 my $yaml_content = CPAN->_yaml_loadfile($yaml);
2453 my $id = $yaml_content->[0]{distribution}{ID};
2455 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2458 my $do = CPAN::Shell->expandany($id);
2460 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2463 unless ($do->{build_dir}) {
2464 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2467 unless ($do->{build_dir} eq $b) {
2468 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2474 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2475 return unless @some;
2477 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2478 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2479 return unless @some;
2481 # @some = grep { not $_->uptodate } @some;
2482 # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2483 # return unless @some;
2485 CPAN->debug("some[@some]");
2487 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2488 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2489 $CPAN::Frontend->mysleep(1);
2494 #-> sub CPAN::Shell::upgrade ;
2496 my($self,@args) = @_;
2497 $self->install($self->r(@args));
2500 #-> sub CPAN::Shell::_u_r_common ;
2502 my($self) = shift @_;
2503 my($what) = shift @_;
2504 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2505 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2506 $what && $what =~ /^[aru]$/;
2508 @args = '/./' unless @args;
2509 my(@result,$module,%seen,%need,$headerdone,
2510 $version_undefs,$version_zeroes,
2511 @version_undefs,@version_zeroes);
2512 $version_undefs = $version_zeroes = 0;
2513 my $sprintf = "%s%-25s%s %9s %9s %s\n";
2514 my @expand = $self->expand('Module',@args);
2515 my $expand = scalar @expand;
2516 if (0) { # Looks like noise to me, was very useful for debugging
2517 # for metadata cache
2518 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2520 MODULE: for $module (@expand) {
2521 my $file = $module->cpan_file;
2522 next MODULE unless defined $file; # ??
2523 $file =~ s!^./../!!;
2524 my($latest) = $module->cpan_version;
2525 my($inst_file) = $module->inst_file;
2527 return if $CPAN::Signal;
2530 $have = $module->inst_version;
2531 } elsif ($what eq "r") {
2532 $have = $module->inst_version;
2534 if ($have eq "undef") {
2536 push @version_undefs, $module->as_glimpse;
2537 } elsif (CPAN::Version->vcmp($have,0)==0) {
2539 push @version_zeroes, $module->as_glimpse;
2541 next MODULE unless CPAN::Version->vgt($latest, $have);
2542 # to be pedantic we should probably say:
2543 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2544 # to catch the case where CPAN has a version 0 and we have a version undef
2545 } elsif ($what eq "u") {
2551 } elsif ($what eq "r") {
2553 } elsif ($what eq "u") {
2557 return if $CPAN::Signal; # this is sometimes lengthy
2560 push @result, sprintf "%s %s\n", $module->id, $have;
2561 } elsif ($what eq "r") {
2562 push @result, $module->id;
2563 next MODULE if $seen{$file}++;
2564 } elsif ($what eq "u") {
2565 push @result, $module->id;
2566 next MODULE if $seen{$file}++;
2567 next MODULE if $file =~ /^Contact/;
2569 unless ($headerdone++) {
2570 $CPAN::Frontend->myprint("\n");
2571 $CPAN::Frontend->myprint(sprintf(
2574 "Package namespace",
2586 $CPAN::META->has_inst("Term::ANSIColor")
2588 $module->description
2590 $color_on = Term::ANSIColor::color("green");
2591 $color_off = Term::ANSIColor::color("reset");
2593 $CPAN::Frontend->myprint(sprintf $sprintf,
2600 $need{$module->id}++;
2604 $CPAN::Frontend->myprint("No modules found for @args\n");
2605 } elsif ($what eq "r") {
2606 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2610 if ($version_zeroes) {
2611 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2612 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2613 qq{a version number of 0\n});
2614 if ($CPAN::Config->{show_zero_versions}) {
2616 $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
2617 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2618 qq{to hide them)\n});
2620 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2621 qq{to show them)\n});
2624 if ($version_undefs) {
2625 my $s_has = $version_undefs > 1 ? "s have" : " has";
2626 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2627 qq{parseable version number\n});
2628 if ($CPAN::Config->{show_unparsable_versions}) {
2630 $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
2631 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2632 qq{to hide them)\n});
2634 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2635 qq{to show them)\n});
2642 #-> sub CPAN::Shell::r ;
2644 shift->_u_r_common("r",@_);
2647 #-> sub CPAN::Shell::u ;
2649 shift->_u_r_common("u",@_);
2652 #-> sub CPAN::Shell::failed ;
2654 my($self,$only_id,$silent) = @_;
2656 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2658 NAY: for my $nosayer ( # order matters!
2667 next unless exists $d->{$nosayer};
2668 next unless defined $d->{$nosayer};
2670 UNIVERSAL::can($d->{$nosayer},"failed") ?
2671 $d->{$nosayer}->failed :
2672 $d->{$nosayer} =~ /^NO/
2674 next NAY if $only_id && $only_id != (
2675 UNIVERSAL::can($d->{$nosayer},"commandid")
2677 $d->{$nosayer}->commandid
2679 $CPAN::CurrentCommandId
2684 next DIST unless $failed;
2688 # " %-45s: %s %s\n",
2691 UNIVERSAL::can($d->{$failed},"failed") ?
2693 $d->{$failed}->commandid,
2696 $d->{$failed}->text,
2697 $d->{$failed}{TIME}||0,
2710 $scope = "this command";
2711 } elsif ($CPAN::Index::HAVE_REANIMATED) {
2712 $scope = "this or a previous session";
2713 # it might be nice to have a section for previous session and
2716 $scope = "this session";
2723 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2724 sort { $a->[0] <=> $b->[0] } @failed;
2727 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2734 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2735 } elsif (!$only_id || !$silent) {
2736 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2740 # XXX intentionally undocumented because completely bogus, unportable,
2743 #-> sub CPAN::Shell::status ;
2746 require Devel::Size;
2747 my $ps = FileHandle->new;
2748 open $ps, "/proc/$$/status";
2751 next unless /VmSize:\s+(\d+)/;
2755 $CPAN::Frontend->mywarn(sprintf(
2756 "%-27s %6d\n%-27s %6d\n",
2760 Devel::Size::total_size($CPAN::META)/1024,
2762 for my $k (sort keys %$CPAN::META) {
2763 next unless substr($k,0,4) eq "read";
2764 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2765 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2766 warn sprintf " %-25s %6d (keys: %6d)\n",
2768 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2769 scalar keys %{$CPAN::META->{$k}{$k2}};
2774 # compare with install_tested
2775 #-> sub CPAN::Shell::is_tested
2778 CPAN::Index->reload;
2779 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2781 if ($CPAN::META->{is_tested}{$b}) {
2782 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2784 $time = scalar localtime;
2787 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2791 #-> sub CPAN::Shell::autobundle ;
2794 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2795 my(@bundle) = $self->_u_r_common("a",@_);
2796 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2797 File::Path::mkpath($todir);
2798 unless (-d $todir) {
2799 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2802 my($y,$m,$d) = (localtime)[5,4,3];
2806 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2807 my($to) = File::Spec->catfile($todir,"$me.pm");
2809 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2810 $to = File::Spec->catfile($todir,"$me.pm");
2812 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2814 "package Bundle::$me;\n\n",
2815 "\$VERSION = '0.01';\n\n",
2819 "Bundle::$me - Snapshot of installation on ",
2820 $Config::Config{'myhostname'},
2823 "\n\n=head1 SYNOPSIS\n\n",
2824 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2825 "=head1 CONTENTS\n\n",
2826 join("\n", @bundle),
2827 "\n\n=head1 CONFIGURATION\n\n",
2829 "\n\n=head1 AUTHOR\n\n",
2830 "This Bundle has been generated automatically ",
2831 "by the autobundle routine in CPAN.pm.\n",
2834 $CPAN::Frontend->myprint("\nWrote bundle file
2838 #-> sub CPAN::Shell::expandany ;
2841 CPAN->debug("s[$s]") if $CPAN::DEBUG;
2842 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2843 $s = CPAN::Distribution->normalize($s);
2844 return $CPAN::META->instance('CPAN::Distribution',$s);
2845 # Distributions spring into existence, not expand
2846 } elsif ($s =~ m|^Bundle::|) {
2847 $self->local_bundles; # scanning so late for bundles seems
2848 # both attractive and crumpy: always
2849 # current state but easy to forget
2851 return $self->expand('Bundle',$s);
2853 return $self->expand('Module',$s)
2854 if $CPAN::META->exists('CPAN::Module',$s);
2859 #-> sub CPAN::Shell::expand ;
2862 my($type,@args) = @_;
2863 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2864 my $class = "CPAN::$type";
2865 my $methods = ['id'];
2866 for my $meth (qw(name)) {
2867 next unless $class->can($meth);
2868 push @$methods, $meth;
2870 $self->expand_by_method($class,$methods,@args);
2873 #-> sub CPAN::Shell::expand_by_method ;
2874 sub expand_by_method {
2876 my($class,$methods,@args) = @_;
2879 my($regex,$command);
2880 if ($arg =~ m|^/(.*)/$|) {
2882 # FIXME: there seem to be some ='s in the author data, which trigger
2883 # a failure here. This needs to be contemplated.
2884 # } elsif ($arg =~ m/=/) {
2888 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2890 defined $regex ? $regex : "UNDEFINED",
2891 defined $command ? $command : "UNDEFINED",
2893 if (defined $regex) {
2894 if (CPAN::_sqlite_running) {
2895 $CPAN::SQLite->search($class, $regex);
2898 $CPAN::META->all_objects($class)
2900 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
2901 # BUG, we got an empty object somewhere
2902 require Data::Dumper;
2903 CPAN->debug(sprintf(
2904 "Bug in CPAN: Empty id on obj[%s][%s]",
2906 Data::Dumper::Dumper($obj)
2910 for my $method (@$methods) {
2911 my $match = eval {$obj->$method() =~ /$regex/i};
2913 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2914 $err ||= $@; # if we were too restrictive above
2915 $CPAN::Frontend->mydie("$err\n");
2922 } elsif ($command) {
2923 die "equal sign in command disabled (immature interface), ".
2925 ! \$CPAN::Shell::ADVANCED_QUERY=1
2926 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2927 that may go away anytime.\n"
2928 unless $ADVANCED_QUERY;
2929 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2930 my($matchcrit) = $criterion =~ m/^~(.+)/;
2934 $CPAN::META->all_objects($class)
2936 my $lhs = $self->$method() or next; # () for 5.00503
2938 push @m, $self if $lhs =~ m/$matchcrit/;
2940 push @m, $self if $lhs eq $criterion;
2945 if ( $class eq 'CPAN::Bundle' ) {
2946 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2947 } elsif ($class eq "CPAN::Distribution") {
2948 $xarg = CPAN::Distribution->normalize($arg);
2952 if ($CPAN::META->exists($class,$xarg)) {
2953 $obj = $CPAN::META->instance($class,$xarg);
2954 } elsif ($CPAN::META->exists($class,$arg)) {
2955 $obj = $CPAN::META->instance($class,$arg);
2962 @m = sort {$a->id cmp $b->id} @m;
2963 if ( $CPAN::DEBUG ) {
2964 my $wantarray = wantarray;
2965 my $join_m = join ",", map {$_->id} @m;
2966 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2968 return wantarray ? @m : $m[0];
2971 #-> sub CPAN::Shell::format_result ;
2974 my($type,@args) = @_;
2975 @args = '/./' unless @args;
2976 my(@result) = $self->expand($type,@args);
2977 my $result = @result == 1 ?
2978 $result[0]->as_string :
2980 "No objects of type $type found for argument @args\n" :
2982 (map {$_->as_glimpse} @result),
2983 scalar @result, " items found\n",
2988 #-> sub CPAN::Shell::report_fh ;
2990 my $installation_report_fh;
2991 my $previously_noticed = 0;
2994 return $installation_report_fh if $installation_report_fh;
2995 if ($CPAN::META->has_usable("File::Temp")) {
2996 $installation_report_fh
2998 dir => File::Spec->tmpdir,
2999 template => 'cpan_install_XXXX',
3004 unless ( $installation_report_fh ) {
3005 warn("Couldn't open installation report file; " .
3006 "no report file will be generated."
3007 ) unless $previously_noticed++;
3013 # The only reason for this method is currently to have a reliable
3014 # debugging utility that reveals which output is going through which
3015 # channel. No, I don't like the colors ;-)
3017 # to turn colordebugging on, write
3018 # cpan> o conf colorize_output 1
3020 #-> sub CPAN::Shell::print_ornamented ;
3022 my $print_ornamented_have_warned = 0;
3023 sub colorize_output {
3024 my $colorize_output = $CPAN::Config->{colorize_output};
3025 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3026 unless ($print_ornamented_have_warned++) {
3027 # no myprint/mywarn within myprint/mywarn!
3028 warn "Colorize_output is set to true but Term::ANSIColor is not
3029 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3031 $colorize_output = 0;
3033 return $colorize_output;
3038 #-> sub CPAN::Shell::print_ornamented ;
3039 sub print_ornamented {
3040 my($self,$what,$ornament) = @_;
3041 return unless defined $what;
3043 local $| = 1; # Flush immediately
3044 if ( $CPAN::Be_Silent ) {
3045 print {report_fh()} $what;
3048 my $swhat = "$what"; # stringify if it is an object
3049 if ($CPAN::Config->{term_is_latin}) {
3050 # note: deprecated, need to switch to $LANG and $LC_*
3053 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3055 if ($self->colorize_output) {
3056 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3057 # if you want to have this configurable, please file a bugreport
3058 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
3060 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3062 print "Term::ANSIColor rejects color[$ornament]: $@\n
3063 Please choose a different color (Hint: try 'o conf init /color/')\n";
3065 # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
3066 # $trailer construct. We want the newline be the last thing if
3067 # there is a newline at the end ensuring that the next line is
3068 # empty for other players
3070 $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
3073 Term::ANSIColor::color("reset"),
3080 #-> sub CPAN::Shell::myprint ;
3082 # where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3083 # I think, we send everything to STDOUT and use print for normal/good
3084 # news and warn for news that need more attention. Yes, this is our
3085 # working contract for now.
3087 my($self,$what) = @_;
3088 $self->print_ornamented($what,
3089 $CPAN::Config->{colorize_print}||'bold blue on_white',
3094 my($self,$category,$what) = @_;
3095 my $vname = $category . "_verbosity";
3096 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3097 if (!$CPAN::Config->{$vname}
3098 || $CPAN::Config->{$vname} =~ /^v/
3100 $CPAN::Frontend->myprint($what);
3104 #-> sub CPAN::Shell::myexit ;
3106 my($self,$what) = @_;
3107 $self->myprint($what);
3111 #-> sub CPAN::Shell::mywarn ;
3113 my($self,$what) = @_;
3114 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
3117 # only to be used for shell commands
3118 #-> sub CPAN::Shell::mydie ;
3120 my($self,$what) = @_;
3121 $self->mywarn($what);
3123 # If it is the shell, we want the following die to be silent,
3124 # but if it is not the shell, we would need a 'die $what'. We need
3125 # to take care that only shell commands use mydie. Is this
3131 # sub CPAN::Shell::colorable_makemaker_prompt ;
3132 sub colorable_makemaker_prompt {
3134 if (CPAN::Shell->colorize_output) {
3135 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
3136 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3139 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3140 if (CPAN::Shell->colorize_output) {
3141 print Term::ANSIColor::color('reset');
3146 # use this only for unrecoverable errors!
3147 #-> sub CPAN::Shell::unrecoverable_error ;
3148 sub unrecoverable_error {
3149 my($self,$what) = @_;
3150 my @lines = split /\n/, $what;
3152 for my $l (@lines) {
3153 $longest = length $l if length $l > $longest;
3155 $longest = 62 if $longest > 62;
3156 for my $l (@lines) {
3157 if ($l =~ /^\s*$/) {
3162 if (length $l < 66) {
3163 $l = pack "A66 A*", $l, "<==";
3167 unshift @lines, "\n";
3168 $self->mydie(join "", @lines);
3171 #-> sub CPAN::Shell::mysleep ;
3173 my($self, $sleep) = @_;
3174 if (CPAN->has_inst("Time::HiRes")) {
3175 Time::HiRes::sleep($sleep);
3177 sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3181 #-> sub CPAN::Shell::setup_output ;
3183 return if -t STDOUT;
3184 my $odef = select STDERR;
3191 #-> sub CPAN::Shell::rematein ;
3192 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3195 my($meth,@some) = @_;
3197 while($meth =~ /^(ff?orce|notest)$/) {
3198 push @pragma, $meth;
3199 $meth = shift @some or
3200 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3204 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3206 # Here is the place to set "test_count" on all involved parties to
3207 # 0. We then can pass this counter on to the involved
3208 # distributions and those can refuse to test if test_count > X. In
3209 # the first stab at it we could use a 1 for "X".
3211 # But when do I reset the distributions to start with 0 again?
3212 # Jost suggested to have a random or cycling interaction ID that
3213 # we pass through. But the ID is something that is just left lying
3214 # around in addition to the counter, so I'd prefer to set the
3215 # counter to 0 now, and repeat at the end of the loop. But what
3216 # about dependencies? They appear later and are not reset, they
3217 # enter the queue but not its copy. How do they get a sensible
3220 # With configure_requires, "get" is vulnerable in recursion.
3222 my $needs_recursion_protection = "get|make|test|install";
3224 # construct the queue
3226 STHING: foreach $s (@some) {
3229 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3231 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3232 } elsif ($s =~ m|^/|) { # looks like a regexp
3233 if (substr($s,-1,1) eq ".") {
3234 $obj = CPAN::Shell->expandany($s);
3236 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3237 "not supported.\nRejecting argument '$s'\n");
3238 $CPAN::Frontend->mysleep(2);
3241 } elsif ($meth eq "ls") {
3242 $self->globls($s,\@pragma);
3245 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3246 $obj = CPAN::Shell->expandany($s);
3249 } elsif (ref $obj) {
3250 if ($meth =~ /^($needs_recursion_protection)$/) {
3251 # it would be silly to check for recursion for look or dump
3252 # (we are in CPAN::Shell::rematein)
3253 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3254 eval { $obj->color_cmd_tmps(0,1); };
3257 and $@->isa("CPAN::Exception::RecursiveDependency")) {
3258 $CPAN::Frontend->mywarn($@);
3262 Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3268 CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
3270 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3271 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3272 if ($meth =~ /^(dump|ls|reports)$/) {
3275 $CPAN::Frontend->mywarn(
3277 "Don't be silly, you can't $meth ",
3281 $CPAN::Frontend->mysleep(2);
3283 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3284 CPAN::InfoObj->dump($s);
3287 ->mywarn(qq{Warning: Cannot $meth $s, }.
3288 qq{don't know what it is.
3293 to find objects with matching identifiers.
3295 $CPAN::Frontend->mysleep(2);
3299 # queuerunner (please be warned: when I started to change the
3300 # queue to hold objects instead of names, I made one or two
3301 # mistakes and never found which. I reverted back instead)
3302 while (my $q = CPAN::Queue->first) {
3304 my $s = $q->as_string;
3305 my $reqtype = $q->reqtype || "";
3306 $obj = CPAN::Shell->expandany($s);
3308 # don't know how this can happen, maybe we should panic,
3309 # but maybe we get a solution from the first user who hits
3310 # this unfortunate exception?
3311 $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3312 "to an object. Skipping.\n");
3313 $CPAN::Frontend->mysleep(5);
3314 CPAN::Queue->delete_first($s);
3317 $obj->{reqtype} ||= "";
3319 # force debugging because CPAN::SQLite somehow delivers us
3322 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3324 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3325 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3327 if ($obj->{reqtype}) {
3328 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3329 $obj->{reqtype} = $reqtype;
3331 exists $obj->{install}
3334 UNIVERSAL::can($obj->{install},"failed") ?
3335 $obj->{install}->failed :
3336 $obj->{install} =~ /^NO/
3339 delete $obj->{install};
3340 $CPAN::Frontend->mywarn
3341 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3345 $obj->{reqtype} = $reqtype;
3348 for my $pragma (@pragma) {
3351 $obj->can($pragma)) {
3352 $obj->$pragma($meth);
3355 if (UNIVERSAL::can($obj, 'called_for')) {
3356 $obj->called_for($s);
3358 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3359 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3362 if ($meth =~ /^(report)$/) { # they came here with a pragma?
3364 } elsif (! UNIVERSAL::can($obj,$meth)) {
3366 my $serialized = "";
3368 } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3369 $serialized = YAML::Syck::Dump($obj);
3370 } elsif ($CPAN::META->has_inst("YAML")) {
3371 $serialized = YAML::Dump($obj);
3372 } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3373 $serialized = Data::Dumper::Dumper($obj);
3376 $serialized = overload::StrVal($obj);
3378 CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3379 $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3380 } elsif ($obj->$meth()) {
3381 CPAN::Queue->delete($s);
3382 CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3384 CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3388 for my $pragma (@pragma) {
3389 my $unpragma = "un$pragma";
3390 if ($obj->can($unpragma)) {
3394 CPAN::Queue->delete_first($s);
3396 if ($meth =~ /^($needs_recursion_protection)$/) {
3397 for my $obj (@qcopy) {
3398 $obj->color_cmd_tmps(0,0);
3403 #-> sub CPAN::Shell::recent ;
3406 if ($CPAN::META->has_inst("XML::LibXML")) {
3407 my $url = $CPAN::Defaultrecent;
3408 $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3409 unless ($CPAN::META->has_usable("LWP")) {
3410 $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3412 CPAN::LWP::UserAgent->config;
3414 eval { $Ua = CPAN::LWP::UserAgent->new; };
3416 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3418 my $resp = $Ua->get($url);
3419 unless ($resp->is_success) {
3420 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3422 $CPAN::Frontend->myprint("DONE\n\n");
3423 my $xml = XML::LibXML->new->parse_string($resp->content);
3425 my $s = $xml->serialize(2);
3426 $s =~ s/\n\s*\n/\n/g;
3427 $CPAN::Frontend->myprint($s);
3431 if ($url =~ /winnipeg/) {
3432 my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3433 $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
3434 for my $eitem ($xml->findnodes("/rss/channel/item")) {
3435 my $distro = $eitem->findvalue("enclosure/\@url");
3436 $distro =~ s|.*?/authors/id/./../||;
3437 my $size = $eitem->findvalue("enclosure/\@length");
3438 my $desc = $eitem->findvalue("description");
3439 \0 $desc =~ s/.+? - //;
3440 $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
3441 push @distros, $distro;
3443 } elsif ($url =~ /search.*uploads.rdf/) {
3444 # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3445 # xmlns="http://purl.org/rss/1.0/"
3446 # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3447 # xmlns:dc="http://purl.org/dc/elements/1.1/"
3448 # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3449 # xmlns:admin="http://webns.net/mvcb/"
3452 my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3453 $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
3454 my $finish_eitem = 0;
3455 local $SIG{INT} = sub { $finish_eitem = 1 };
3456 EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3457 my $distro = $eitem->findvalue("\@rdf:about");
3458 $distro =~ s|.*~||; # remove up to the tilde before the name
3459 $distro =~ s|/$||; # remove trailing slash
3460 $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3461 my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3462 my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
3464 SUBDIRTEST: while () {
3465 last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3466 if (my @ret = $self->globls("$distro*")) {
3467 @ret = grep {$_->[2] !~ /meta/} @ret;
3468 @ret = grep {length $_->[2]} @ret;
3470 $distro = "$author/$ret[0][2]";
3474 $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3477 next EITEM if $distro =~ m|\*|; # did not find the thing
3478 $CPAN::Frontend->myprint("____$desc\n");
3479 push @distros, $distro;
3480 last EITEM if $finish_eitem;
3485 # deprecated old version
3486 $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3490 #-> sub CPAN::Shell::smoke ;
3493 my $distros = $self->recent;
3494 DISTRO: for my $distro (@$distros) {
3495 $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3498 local $SIG{INT} = sub { $skip = 1 };
3500 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3503 $CPAN::Frontend->myprint(" skipped\n");
3508 $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
3509 $self->test($distro);
3514 # set up the dispatching methods
3516 for my $command (qw(
3533 *$command = sub { shift->rematein($command, @_); };
3537 package CPAN::LWP::UserAgent;
3541 return if $SETUPDONE;
3542 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3543 require LWP::UserAgent;
3544 @ISA = qw(Exporter LWP::UserAgent);
3547 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
3551 sub get_basic_credentials {
3552 my($self, $realm, $uri, $proxy) = @_;
3553 if ($USER && $PASSWD) {
3554 return ($USER, $PASSWD);
3557 ($USER,$PASSWD) = $self->get_proxy_credentials();
3559 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3561 return($USER,$PASSWD);
3564 sub get_proxy_credentials {
3566 my ($user, $password);
3567 if ( defined $CPAN::Config->{proxy_user} &&
3568 defined $CPAN::Config->{proxy_pass}) {
3569 $user = $CPAN::Config->{proxy_user};
3570 $password = $CPAN::Config->{proxy_pass};
3571 return ($user, $password);
3573 my $username_prompt = "\nProxy authentication needed!
3574 (Note: to permanently configure username and password run
3575 o conf proxy_user your_username
3576 o conf proxy_pass your_password
3578 ($user, $password) =
3579 _get_username_and_password_from_user($username_prompt);
3580 return ($user,$password);
3583 sub get_non_proxy_credentials {
3585 my ($user,$password);
3586 if ( defined $CPAN::Config->{username} &&
3587 defined $CPAN::Config->{password}) {
3588 $user = $CPAN::Config->{username};
3589 $password = $CPAN::Config->{password};
3590 return ($user, $password);
3592 my $username_prompt = "\nAuthentication needed!
3593 (Note: to permanently configure username and password run
3594 o conf username your_username
3595 o conf password your_password
3598 ($user, $password) =
3599 _get_username_and_password_from_user($username_prompt);
3600 return ($user,$password);
3603 sub _get_username_and_password_from_user {
3604 my $username_message = shift;
3605 my ($username,$password);
3607 ExtUtils::MakeMaker->import(qw(prompt));
3608 $username = prompt($username_message);
3609 if ($CPAN::META->has_inst("Term::ReadKey")) {
3610 Term::ReadKey::ReadMode("noecho");
3613 $CPAN::Frontend->mywarn(
3614 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3617 $password = prompt("Password:");
3619 if ($CPAN::META->has_inst("Term::ReadKey")) {
3620 Term::ReadKey::ReadMode("restore");
3622 $CPAN::Frontend->myprint("\n\n");
3623 return ($username,$password);
3626 # mirror(): Its purpose is to deal with proxy authentication. When we
3627 # call SUPER::mirror, we relly call the mirror method in
3628 # LWP::UserAgent. LWP::UserAgent will then call
3629 # $self->get_basic_credentials or some equivalent and this will be
3630 # $self->dispatched to our own get_basic_credentials method.
3632 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3634 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3635 # although we have gone through our get_basic_credentials, the proxy
3636 # server refuses to connect. This could be a case where the username or
3637 # password has changed in the meantime, so I'm trying once again without
3638 # $USER and $PASSWD to give the get_basic_credentials routine another
3639 # chance to set $USER and $PASSWD.
3641 # mirror(): Its purpose is to deal with proxy authentication. When we
3642 # call SUPER::mirror, we relly call the mirror method in
3643 # LWP::UserAgent. LWP::UserAgent will then call
3644 # $self->get_basic_credentials or some equivalent and this will be
3645 # $self->dispatched to our own get_basic_credentials method.
3647 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3649 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3650 # although we have gone through our get_basic_credentials, the proxy
3651 # server refuses to connect. This could be a case where the username or
3652 # password has changed in the meantime, so I'm trying once again without
3653 # $USER and $PASSWD to give the get_basic_credentials routine another
3654 # chance to set $USER and $PASSWD.
3657 my($self,$url,$aslocal) = @_;
3658 my $result = $self->SUPER::mirror($url,$aslocal);
3659 if ($result->code == 407) {
3662 $result = $self->SUPER::mirror($url,$aslocal);
3670 #-> sub CPAN::FTP::ftp_statistics
3671 # if they want to rewrite, they need to pass in a filehandle
3672 sub _ftp_statistics {
3674 my $locktype = $fh ? LOCK_EX : LOCK_SH;
3675 $fh ||= FileHandle->new;
3676 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3677 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3680 while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
3681 $waitstart ||= localtime();
3683 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3685 $CPAN::Frontend->mysleep($sleep);
3688 } elsif ($sleep <=6) {
3692 my $stats = eval { CPAN->_yaml_loadfile($file); };
3695 if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3696 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3698 } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3699 $CPAN::Frontend->mydie($@);
3702 $CPAN::Frontend->mydie($@);
3708 #-> sub CPAN::FTP::_mytime
3710 if (CPAN->has_inst("Time::HiRes")) {
3711 return Time::HiRes::time();
3717 #-> sub CPAN::FTP::_new_stats
3719 my($self,$file) = @_;
3728 #-> sub CPAN::FTP::_add_to_statistics
3729 sub _add_to_statistics {
3730 my($self,$stats) = @_;
3731 my $yaml_module = CPAN::_yaml_module;
3732 $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3733 if ($CPAN::META->has_inst($yaml_module)) {
3734 $stats->{thesiteurl} = $ThesiteURL;
3735 if (CPAN->has_inst("Time::HiRes")) {
3736 $stats->{end} = Time::HiRes::time();
3738 $stats->{end} = time;
3740 my $fh = FileHandle->new;
3744 @debug = $time if $sdebug;
3745 my $fullstats = $self->_ftp_statistics($fh);
3747 $fullstats->{history} ||= [];
3748 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3749 push @debug, time if $sdebug;
3750 push @{$fullstats->{history}}, $stats;
3751 # arbitrary hardcoded constants until somebody demands to have
3752 # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3753 # YAML::Syck 0.82 has no noticable performance problem with 999;
3755 @{$fullstats->{history}} > 99
3756 || $time - $fullstats->{history}[0]{start} > 14*86400
3758 shift @{$fullstats->{history}}
3760 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3761 push @debug, time if $sdebug;
3762 push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3763 # need no eval because if this fails, it is serious
3764 my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3765 CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3767 local $CPAN::DEBUG = 512; # FTP
3769 CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3770 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3774 # Win32 cannot rename a file to an existing filename
3775 unlink($sfile) if ($^O eq 'MSWin32');
3776 rename "$sfile.$$", $sfile
3777 or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3781 # if file is CHECKSUMS, suggest the place where we got the file to be
3782 # checked from, maybe only for young files?
3783 #-> sub CPAN::FTP::_recommend_url_for
3784 sub _recommend_url_for {
3785 my($self, $file) = @_;
3786 my $urllist = $self->_get_urllist;
3787 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3788 my $fullstats = $self->_ftp_statistics();
3789 my $history = $fullstats->{history} || [];
3790 while (my $last = pop @$history) {
3791 last if $last->{end} - time > 3600; # only young results are interesting
3792 next unless $last->{file}; # dirname of nothing dies!
3793 next unless $file eq File::Basename::dirname($last->{file});
3794 return $last->{thesiteurl};
3797 if ($CPAN::Config->{randomize_urllist}
3799 rand(1) < $CPAN::Config->{randomize_urllist}
3801 $urllist->[int rand scalar @$urllist];
3807 #-> sub CPAN::FTP::_get_urllist
3810 $CPAN::Config->{urllist} ||= [];
3811 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3812 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
3813 $CPAN::Config->{urllist} = [];
3815 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3816 for my $u (@urllist) {
3817 CPAN->debug("u[$u]") if $CPAN::DEBUG;
3818 if (UNIVERSAL::can($u,"text")) {
3819 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3821 $u .= "/" unless substr($u,-1) eq "/";
3822 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3828 #-> sub CPAN::FTP::ftp_get ;
3830 my($class,$host,$dir,$file,$target) = @_;
3832 qq[Going to fetch file [$file] from dir [$dir]
3833 on host [$host] as local [$target]\n]
3835 my $ftp = Net::FTP->new($host);
3837 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
3840 return 0 unless defined $ftp;
3841 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3842 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3843 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
3844 my $msg = $ftp->message;
3845 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
3848 unless ( $ftp->cwd($dir) ) {
3849 my $msg = $ftp->message;
3850 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
3854 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3855 unless ( $ftp->get($file,$target) ) {
3856 my $msg = $ftp->message;
3857 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
3860 $ftp->quit; # it's ok if this fails
3864 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3866 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
3867 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
3869 # > *** 1562,1567 ****
3870 # > --- 1562,1580 ----
3871 # > return 1 if substr($url,0,4) eq "file";
3872 # > return 1 unless $url =~ m|://([^/]+)|;
3874 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3876 # > + $proxy =~ m|://([^/:]+)|;
3878 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3879 # > + if ($noproxy) {
3880 # > + if ($host !~ /$noproxy$/) {
3881 # > + $host = $proxy;
3884 # > + $host = $proxy;
3887 # > require Net::Ping;
3888 # > return 1 unless $Net::Ping::VERSION >= 2;
3892 #-> sub CPAN::FTP::localize ;
3894 my($self,$file,$aslocal,$force) = @_;
3896 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3897 unless defined $aslocal;
3898 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3901 if ($^O eq 'MacOS') {
3902 # Comment by AK on 2000-09-03: Uniq short filenames would be
3903 # available in CHECKSUMS file
3904 my($name, $path) = File::Basename::fileparse($aslocal, '');
3905 if (length($name) > 31) {
3916 my $size = 31 - length($suf);
3917 while (length($name) > $size) {
3921 $aslocal = File::Spec->catfile($path, $name);
3925 if (-f $aslocal && -r _ && !($force & 1)) {
3927 if ($size = -s $aslocal) {
3928 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3931 # empty file from a previous unsuccessful attempt to download it
3933 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3934 "could not remove.");
3937 my($maybe_restore) = 0;
3939 rename $aslocal, "$aslocal.bak$$";
3943 my($aslocal_dir) = File::Basename::dirname($aslocal);
3944 $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
3945 # Inheritance is not easier to manage than a few if/else branches
3946 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3948 CPAN::LWP::UserAgent->config;
3949 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3951 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3955 $Ua->proxy('ftp', $var)
3956 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3957 $Ua->proxy('http', $var)
3958 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3960 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3964 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3965 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3968 # Try the list of urls for each single object. We keep a record
3969 # where we did get a file from
3970 my(@reordered,$last);
3971 my $ccurllist = $self->_get_urllist;
3972 $last = $#$ccurllist;
3973 if ($force & 2) { # local cpans probably out of date, don't reorder
3974 @reordered = (0..$last);
3978 (substr($ccurllist->[$b],0,4) eq "file")
3980 (substr($ccurllist->[$a],0,4) eq "file")
3982 defined($ThesiteURL)
3984 ($ccurllist->[$b] eq $ThesiteURL)
3986 ($ccurllist->[$a] eq $ThesiteURL)
3991 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3997 ["dleasy", "http","defaultsites"],
3998 ["dlhard", "http","defaultsites"],
3999 ["dleasy", "ftp", "defaultsites"],
4000 ["dlhard", "ftp", "defaultsites"],
4001 ["dlhardest","", "defaultsites"],
4004 @levels = grep {$_->[0] eq $Themethod} @all_levels;
4005 push @levels, grep {$_->[0] ne $Themethod} @all_levels;
4007 @levels = @all_levels;
4009 @levels = qw/dleasy/ if $^O eq 'MacOS';
4011 local $ENV{FTP_PASSIVE} =
4012 exists $CPAN::Config->{ftp_passive} ?
4013 $CPAN::Config->{ftp_passive} : 1;
4015 my $stats = $self->_new_stats($file);
4016 LEVEL: for $levelno (0..$#levels) {
4017 my $level_tuple = $levels[$levelno];
4018 my($level,$scheme,$sitetag) = @$level_tuple;
4019 my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4021 if ($defaultsites) {
4022 unless (defined $connect_to_internet_ok) {
4023 $CPAN::Frontend->myprint(sprintf qq{
4024 I would like to connect to one of the following sites to get '%s':
4029 join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4031 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4032 if ($answer =~ /^y/i) {
4033 $connect_to_internet_ok = 1;
4035 $connect_to_internet_ok = 0;
4038 if ($connect_to_internet_ok) {
4039 @urllist = @CPAN::Defaultsites;
4044 my @host_seq = $level =~ /dleasy/ ?
4045 @reordered : 0..$last; # reordered has file and $Thesiteurl first
4046 @urllist = map { $ccurllist->[$_] } @host_seq;
4048 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4049 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4050 if (my $recommend = $self->_recommend_url_for($file)) {
4051 @urllist = grep { $_ ne $recommend } @urllist;
4052 unshift @urllist, $recommend;
4054 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
4055 $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4057 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4058 if ($ret eq $aslocal_tempfile) {
4059 # if we got it exactly as we asked for, only then we
4061 rename $aslocal_tempfile, $aslocal
4062 or $CPAN::Frontend->mydie("Error while trying to rename ".
4063 "'$ret' to '$aslocal': $!");
4066 $Themethod = $level;
4068 # utime $now, $now, $aslocal; # too bad, if we do that, we
4069 # might alter a local mirror
4070 $self->debug("level[$level]") if $CPAN::DEBUG;
4073 unlink $aslocal_tempfile;
4074 last if $CPAN::Signal; # need to cleanup
4078 $stats->{filesize} = -s $ret;
4080 $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
4081 $self->_add_to_statistics($stats);
4082 $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
4084 unlink "$aslocal.bak$$";
4087 unless ($CPAN::Signal) {
4090 if (@{$CPAN::Config->{urllist}}) {
4092 qq{Please check, if the URLs I found in your configuration file \(}.
4093 join(", ", @{$CPAN::Config->{urllist}}).
4096 push @mess, qq{Your urllist is empty!};
4098 push @mess, qq{The urllist can be edited.},
4099 qq{E.g. with 'o conf urllist push ftp://myurl/'};
4100 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4101 $CPAN::Frontend->mywarn("Could not fetch $file\n");
4102 $CPAN::Frontend->mysleep(2);
4104 if ($maybe_restore) {
4105 rename "$aslocal.bak$$", $aslocal;
4106 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4107 $self->ls($aslocal));
4114 my($self, $aslocal_dir) = @_;
4115 File::Path::mkpath($aslocal_dir);
4116 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4117 qq{directory "$aslocal_dir".
4118 I\'ll continue, but if you encounter problems, they may be due
4119 to insufficient permissions.\n}) unless -w $aslocal_dir;
4127 $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4128 my $method = "host$level";
4129 $self->$method($h, @_);
4133 my($self,$stats,$method,$url) = @_;
4134 push @{$stats->{attempts}}, {
4141 # package CPAN::FTP;
4143 my($self,$host_seq,$file,$aslocal,$stats) = @_;
4145 HOSTEASY: for $ro_url (@$host_seq) {
4146 $self->_set_attempt($stats,"dleasy",$ro_url);
4147 my $url .= "$ro_url$file";
4148 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4149 if ($url =~ /^file:/) {
4151 if ($CPAN::META->has_inst('URI::URL')) {
4152 my $u = URI::URL->new($url);
4154 } else { # works only on Unix, is poorly constructed, but
4155 # hopefully better than nothing.
4156 # RFC 1738 says fileurl BNF is
4157 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4158 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4160 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4161 $l =~ s|^file:||; # assume they
4165 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
4167 $self->debug("local file[$l]") if $CPAN::DEBUG;
4168 if ( -f $l && -r _) {
4169 $ThesiteURL = $ro_url;
4172 if ($l =~ /(.+)\.gz$/) {
4174 if ( -f $ungz && -r _) {
4175 $ThesiteURL = $ro_url;
4179 # Maybe mirror has compressed it?
4181 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4182 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4184 $ThesiteURL = $ro_url;
4188 $CPAN::Frontend->mywarn("Could not find '$l'\n");
4190 $self->debug("it was not a file URL") if $CPAN::DEBUG;
4191 if ($CPAN::META->has_usable('LWP')) {
4192 $CPAN::Frontend->myprint("Fetching with LWP:
4196 CPAN::LWP::UserAgent->config;
4197 eval { $Ua = CPAN::LWP::UserAgent->new; };
4199 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4202 my $res = $Ua->mirror($url, $aslocal);
4203 if ($res->is_success) {
4204 $ThesiteURL = $ro_url;
4206 utime $now, $now, $aslocal; # download time is more
4207 # important than upload
4210 } elsif ($url !~ /\.gz(?!\n)\Z/) {
4211 my $gzurl = "$url.gz";
4212 $CPAN::Frontend->myprint("Fetching with LWP:
4215 $res = $Ua->mirror($gzurl, "$aslocal.gz");
4216 if ($res->is_success) {
4217 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4218 $ThesiteURL = $ro_url;
4223 $CPAN::Frontend->myprint(sprintf(
4224 "LWP failed with code[%s] message[%s]\n",
4228 # Alan Burlison informed me that in firewall environments
4229 # Net::FTP can still succeed where LWP fails. So we do not
4230 # skip Net::FTP anymore when LWP is available.
4233 $CPAN::Frontend->mywarn(" LWP not available\n");
4235 return if $CPAN::Signal;
4236 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4237 # that's the nice and easy way thanks to Graham
4238 $self->debug("recognized ftp") if $CPAN::DEBUG;
4239 my($host,$dir,$getfile) = ($1,$2,$3);
4240 if ($CPAN::META->has_usable('Net::FTP')) {
4242 $CPAN::Frontend->myprint("Fetching with Net::FTP:
4245 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4246 "aslocal[$aslocal]") if $CPAN::DEBUG;
4247 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4248 $ThesiteURL = $ro_url;
4251 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4252 my $gz = "$aslocal.gz";
4253 $CPAN::Frontend->myprint("Fetching with Net::FTP
4256 if (CPAN::FTP->ftp_get($host,
4260 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4262 $ThesiteURL = $ro_url;
4268 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4272 UNIVERSAL::can($ro_url,"text")
4274 $ro_url->{FROM} eq "USER"
4276 ##address #17973: default URLs should not try to override
4277 ##user-defined URLs just because LWP is not available
4278 my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
4279 return $ret if $ret;
4281 return if $CPAN::Signal;
4285 # package CPAN::FTP;
4287 my($self,$host_seq,$file,$aslocal,$stats) = @_;
4289 # Came back if Net::FTP couldn't establish connection (or
4290 # failed otherwise) Maybe they are behind a firewall, but they
4291 # gave us a socksified (or other) ftp program...
4294 my($devnull) = $CPAN::Config->{devnull} || "";
4296 my($aslocal_dir) = File::Basename::dirname($aslocal);
4297 File::Path::mkpath($aslocal_dir);
4298 HOSTHARD: for $ro_url (@$host_seq) {
4299 $self->_set_attempt($stats,"dlhard",$ro_url);
4300 my $url = "$ro_url$file";
4301 my($proto,$host,$dir,$getfile);
4303 # Courtesy Mark Conty mark_conty@cargill.com change from
4304 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4306 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4307 # proto not yet used
4308 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4310 next HOSTHARD; # who said, we could ftp anything except ftp?
4312 next HOSTHARD if $proto eq "file"; # file URLs would have had
4313 # success above. Likely a bogus URL
4315 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
4317 # Try the most capable first and leave ncftp* for last as it only
4319 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
4320 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4321 next unless defined $funkyftp;
4322 next if $funkyftp =~ /^\s*$/;
4324 my($asl_ungz, $asl_gz);
4325 ($asl_ungz = $aslocal) =~ s/\.gz//;
4326 $asl_gz = "$asl_ungz.gz";
4328 my($src_switch) = "";
4330 my($stdout_redir) = " > $asl_ungz";
4332 $src_switch = " -source";
4333 } elsif ($f eq "ncftp") {
4334 $src_switch = " -c";
4335 } elsif ($f eq "wget") {
4336 $src_switch = " -O $asl_ungz";
4338 } elsif ($f eq 'curl') {
4339 $src_switch = ' -L -f -s -S --netrc-optional';
4342 if ($f eq "ncftpget") {
4343 $chdir = "cd $aslocal_dir && ";
4346 $CPAN::Frontend->myprint(
4348 Trying with "$funkyftp$src_switch" to get
4352 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4353 $self->debug("system[$system]") if $CPAN::DEBUG;
4354 my($wstatus) = system($system);
4356 # lynx returns 0 when it fails somewhere
4358 my $content = do { local *FH;
4359 open FH, $asl_ungz or die;
4362 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4363 $CPAN::Frontend->mywarn(qq{
4364 No success, the file that lynx has downloaded looks like an error message:
4367 $CPAN::Frontend->mysleep(1);
4371 $CPAN::Frontend->myprint(qq{
4372 No success, the file that lynx has downloaded is an empty file.
4377 if ($wstatus == 0) {
4380 } elsif ($asl_ungz ne $aslocal) {
4381 # test gzip integrity
4382 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4383 # e.g. foo.tar is gzipped --> foo.tar.gz
4384 rename $asl_ungz, $aslocal;
4386 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4389 $ThesiteURL = $ro_url;
4391 } elsif ($url !~ /\.gz(?!\n)\Z/) {
4393 -f $asl_ungz && -s _ == 0;
4394 my $gz = "$aslocal.gz";
4395 my $gzurl = "$url.gz";
4396 $CPAN::Frontend->myprint(
4398 Trying with "$funkyftp$src_switch" to get
4401 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4402 $self->debug("system[$system]") if $CPAN::DEBUG;
4404 if (($wstatus = system($system)) == 0
4408 # test gzip integrity
4409 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4410 if ($ct && $ct->gtest) {
4411 $ct->gunzip($aslocal);
4413 # somebody uncompressed file for us?
4414 rename $asl_ungz, $aslocal;
4416 $ThesiteURL = $ro_url;
4419 unlink $asl_gz if -f $asl_gz;
4422 my $estatus = $wstatus >> 8;
4423 my $size = -f $aslocal ?
4424 ", left\n$aslocal with size ".-s _ :
4425 "\nWarning: expected file [$aslocal] doesn't exist";
4426 $CPAN::Frontend->myprint(qq{
4427 System call "$system"
4428 returned status $estatus (wstat $wstatus)$size
4431 return if $CPAN::Signal;
4432 } # transfer programs
4436 # package CPAN::FTP;
4438 my($self,$host_seq,$file,$aslocal,$stats) = @_;
4440 return unless @$host_seq;
4442 my($aslocal_dir) = File::Basename::dirname($aslocal);
4443 File::Path::mkpath($aslocal_dir);
4444 my $ftpbin = $CPAN::Config->{ftp};
4445 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4446 $CPAN::Frontend->myprint("No external ftp command available\n\n");
4449 $CPAN::Frontend->mywarn(qq{
4450 As a last ressort we now switch to the external ftp command '$ftpbin'
4453 Doing so often leads to problems that are hard to diagnose.
4455 If you're victim of such problems, please consider unsetting the ftp
4456 config variable with
4462 $CPAN::Frontend->mysleep(2);
4463 HOSTHARDEST: for $ro_url (@$host_seq) {
4464 $self->_set_attempt($stats,"dlhardest",$ro_url);
4465 my $url = "$ro_url$file";
4466 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4467 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4470 my($host,$dir,$getfile) = ($1,$2,$3);
4472 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4473 $ctime,$blksize,$blocks) = stat($aslocal);
4474 $timestamp = $mtime ||= 0;
4475 my($netrc) = CPAN::FTP::netrc->new;
4476 my($netrcfile) = $netrc->netrc;
4477 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4478 my $targetfile = File::Basename::basename($aslocal);
4484 map("cd $_", split /\//, $dir), # RFC 1738
4486 "get $getfile $targetfile",
4490 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4491 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4492 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4494 $netrc->contains($host))) if $CPAN::DEBUG;
4495 if ($netrc->protected) {
4496 my $dialog = join "", map { " $_\n" } @dialog;
4498 if ($netrc->contains($host)) {
4499 $netrc_explain = "Relying that your .netrc entry for '$host' ".
4500 "manages the login";
4502 $netrc_explain = "Relying that your default .netrc entry ".
4503 "manages the login";
4505 $CPAN::Frontend->myprint(qq{
4506 Trying with external ftp to get
4509 Going to send the dialog
4513 $self->talk_ftp("$ftpbin$verbose $host",
4515 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4516 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4518 if ($mtime > $timestamp) {
4519 $CPAN::Frontend->myprint("GOT $aslocal\n");
4520 $ThesiteURL = $ro_url;
4523 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4525 return if $CPAN::Signal;
4527 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4528 qq{correctly protected.\n});
4531 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4532 nor does it have a default entry\n");
4535 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4536 # then and login manually to host, using e-mail as
4538 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4542 "user anonymous $Config::Config{'cf_email'}"
4544 my $dialog = join "", map { " $_\n" } @dialog;
4545 $CPAN::Frontend->myprint(qq{
4546 Trying with external ftp to get
4548 Going to send the dialog
4552 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4553 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4554 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4556 if ($mtime > $timestamp) {
4557 $CPAN::Frontend->myprint("GOT $aslocal\n");
4558 $ThesiteURL = $ro_url;
4561 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4563 return if $CPAN::Signal;
4564 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4565 $CPAN::Frontend->mysleep(2);
4569 # package CPAN::FTP;
4571 my($self,$command,@dialog) = @_;
4572 my $fh = FileHandle->new;
4573 $fh->open("|$command") or die "Couldn't open ftp: $!";
4574 foreach (@dialog) { $fh->print("$_\n") }
4575 $fh->close; # Wait for process to complete
4577 my $estatus = $wstatus >> 8;
4578 $CPAN::Frontend->myprint(qq{
4579 Subprocess "|$command"
4580 returned status $estatus (wstat $wstatus)
4584 # find2perl needs modularization, too, all the following is stolen
4588 my($self,$name) = @_;
4589 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4590 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4592 my($perms,%user,%group);
4596 $blocks = int(($blocks + 1) / 2);
4599 $blocks = int(($sizemm + 1023) / 1024);
4602 if (-f _) { $perms = '-'; }
4603 elsif (-d _) { $perms = 'd'; }
4604 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4605 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4606 elsif (-p _) { $perms = 'p'; }
4607 elsif (-S _) { $perms = 's'; }
4608 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4610 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4611 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4612 my $tmpmode = $mode;
4613 my $tmp = $rwx[$tmpmode & 7];
4615 $tmp = $rwx[$tmpmode & 7] . $tmp;
4617 $tmp = $rwx[$tmpmode & 7] . $tmp;
4618 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4619 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4620 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4623 my $user = $user{$uid} || $uid; # too lazy to implement lookup
4624 my $group = $group{$gid} || $gid;
4626 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4628 my($moname) = $moname[$mon];
4629 if (-M _ > 365.25 / 2) {
4630 $timeyear = $year + 1900;
4633 $timeyear = sprintf("%02d:%02d", $hour, $min);
4636 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4650 package CPAN::FTP::netrc;
4653 # package CPAN::FTP::netrc;
4656 my $home = CPAN::HandleConfig::home;
4657 my $file = File::Spec->catfile($home,".netrc");
4659 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4660 $atime,$mtime,$ctime,$blksize,$blocks)
4665 my($fh,@machines,$hasdefault);
4667 $fh = FileHandle->new or die "Could not create a filehandle";
4669 if($fh->open($file)) {
4670 $protected = ($mode & 077) == 0;
4672 NETRC: while (<$fh>) {
4673 my(@tokens) = split " ", $_;
4674 TOKEN: while (@tokens) {
4675 my($t) = shift @tokens;
4676 if ($t eq "default") {
4680 last TOKEN if $t eq "macdef";
4681 if ($t eq "machine") {
4682 push @machines, shift @tokens;
4687 $file = $hasdefault = $protected = "";
4691 'mach' => [@machines],
4693 'hasdefault' => $hasdefault,
4694 'protected' => $protected,
4698 # CPAN::FTP::netrc::hasdefault;
4699 sub hasdefault { shift->{'hasdefault'} }
4700 sub netrc { shift->{'netrc'} }
4701 sub protected { shift->{'protected'} }
4703 my($self,$mach) = @_;
4704 for ( @{$self->{'mach'}} ) {
4705 return 1 if $_ eq $mach;
4710 package CPAN::Complete;
4714 my($text, $line, $start, $end) = @_;
4715 my(@perlret) = cpl($text, $line, $start);
4716 # find longest common match. Can anybody show me how to peruse
4717 # T::R::Gnu to have this done automatically? Seems expensive.
4718 return () unless @perlret;
4719 my($newtext) = $text;
4720 for (my $i = length($text)+1;;$i++) {
4721 last unless length($perlret[0]) && length($perlret[0]) >= $i;
4722 my $try = substr($perlret[0],0,$i);
4723 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4724 # warn "try[$try]tries[@tries]";
4725 if (@tries == @perlret) {
4731 ($newtext,@perlret);
4734 #-> sub CPAN::Complete::cpl ;
4736 my($word,$line,$pos) = @_;
4740 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4742 if ($line =~ s/^((?:notest|f?force)\s*)//) {
4746 if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4747 @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
4748 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4750 } elsif ($line =~ /^(a|ls)\s/) {
4751 @return = cplx('CPAN::Author',uc($word));
4752 } elsif ($line =~ /^b\s/) {
4753 CPAN::Shell->local_bundles;
4754 @return = cplx('CPAN::Bundle',$word);
4755 } elsif ($line =~ /^d\s/) {
4756 @return = cplx('CPAN::Distribution',$word);
4757 } elsif ($line =~ m/^(
4758 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4760 if ($word =~ /^Bundle::/) {
4761 CPAN::Shell->local_bundles;
4763 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4764 } elsif ($line =~ /^i\s/) {
4765 @return = cpl_any($word);
4766 } elsif ($line =~ /^reload\s/) {
4767 @return = cpl_reload($word,$line,$pos);
4768 } elsif ($line =~ /^o\s/) {
4769 @return = cpl_option($word,$line,$pos);
4770 } elsif ($line =~ m/^\S+\s/ ) {
4771 # fallback for future commands and what we have forgotten above
4772 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4779 #-> sub CPAN::Complete::cplx ;
4781 my($class, $word) = @_;
4782 if (CPAN::_sqlite_running) {
4783 $CPAN::SQLite->search($class, "^\Q$word\E");
4785 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4788 #-> sub CPAN::Complete::cpl_any ;
4792 cplx('CPAN::Author',$word),
4793 cplx('CPAN::Bundle',$word),
4794 cplx('CPAN::Distribution',$word),
4795 cplx('CPAN::Module',$word),
4799 #-> sub CPAN::Complete::cpl_reload ;
4801 my($word,$line,$pos) = @_;
4803 my(@words) = split " ", $line;
4804 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4805 my(@ok) = qw(cpan index);
4806 return @ok if @words == 1;
4807 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4810 #-> sub CPAN::Complete::cpl_option ;
4812 my($word,$line,$pos) = @_;
4814 my(@words) = split " ", $line;
4815 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4816 my(@ok) = qw(conf debug);
4817 return @ok if @words == 1;
4818 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4820 } elsif ($words[1] eq 'index') {
4822 } elsif ($words[1] eq 'conf') {
4823 return CPAN::HandleConfig::cpl(@_);
4824 } elsif ($words[1] eq 'debug') {
4825 return sort grep /^\Q$word\E/i,
4826 sort keys %CPAN::DEBUG, 'all';
4830 package CPAN::Index;
4833 #-> sub CPAN::Index::force_reload ;
4836 $CPAN::Index::LAST_TIME = 0;
4840 #-> sub CPAN::Index::reload ;
4842 my($self,$force) = @_;
4845 # XXX check if a newer one is available. (We currently read it
4846 # from time to time)
4847 for ($CPAN::Config->{index_expire}) {
4848 $_ = 0.001 unless $_ && $_ > 0.001;
4850 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4851 # debug here when CPAN doesn't seem to read the Metadata
4853 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4855 unless ($CPAN::META->{PROTOCOL}) {
4856 $self->read_metadata_cache;
4857 $CPAN::META->{PROTOCOL} ||= "1.0";
4859 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
4860 # warn "Setting last_time to 0";
4861 $LAST_TIME = 0; # No warning necessary
4863 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4866 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4868 # IFF we are developing, it helps to wipe out the memory
4869 # between reloads, otherwise it is not what a user expects.
4870 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4871 $CPAN::META = CPAN->new;
4874 local $LAST_TIME = $time;
4875 local $CPAN::META->{PROTOCOL} = PROTOCOL;
4877 my $needshort = $^O eq "dos";
4879 $self->rd_authindex($self
4881 "authors/01mailrc.txt.gz",
4883 File::Spec->catfile('authors', '01mailrc.gz') :
4884 File::Spec->catfile('authors', '01mailrc.txt.gz'),
4887 $debug = "timing reading 01[".($t2 - $time)."]";
4889 return if $CPAN::Signal; # this is sometimes lengthy
4890 $self->rd_modpacks($self
4892 "modules/02packages.details.txt.gz",
4894 File::Spec->catfile('modules', '02packag.gz') :
4895 File::Spec->catfile('modules', '02packages.details.txt.gz'),
4898 $debug .= "02[".($t2 - $time)."]";
4900 return if $CPAN::Signal; # this is sometimes lengthy
4901 $self->rd_modlist($self
4903 "modules/03modlist.data.gz",
4905 File::Spec->catfile('modules', '03mlist.gz') :
4906 File::Spec->catfile('modules', '03modlist.data.gz'),
4908 $self->write_metadata_cache;
4910 $debug .= "03[".($t2 - $time)."]";
4912 CPAN->debug($debug) if $CPAN::DEBUG;
4914 if ($CPAN::Config->{build_dir_reuse}) {
4915 $self->reanimate_build_dir;
4917 if (CPAN::_sqlite_running) {
4918 $CPAN::SQLite->reload(time => $time, force => $force)
4922 $CPAN::META->{PROTOCOL} = PROTOCOL;
4925 #-> sub CPAN::Index::reanimate_build_dir ;
4926 sub reanimate_build_dir {
4928 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4931 return if $HAVE_REANIMATED++;
4932 my $d = $CPAN::Config->{build_dir};
4933 my $dh = DirHandle->new;
4934 opendir $dh, $d or return; # does not exist
4939 $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4940 my @candidates = map { $_->[0] }
4941 sort { $b->[1] <=> $a->[1] }
4942 map { [ $_, -M File::Spec->catfile($d,$_) ] }
4943 grep {/\.yml$/} readdir $dh;
4944 DISTRO: for $i (0..$#candidates) {
4945 my $dirent = $candidates[$i];
4946 my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4948 warn "Error while parsing file '$dirent'; error: '$@'";
4952 if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4953 my $key = $c->{distribution}{ID};
4954 for my $k (keys %{$c->{distribution}}) {
4955 if ($c->{distribution}{$k}
4956 && ref $c->{distribution}{$k}
4957 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4958 $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4962 #we tried to restore only if element already
4963 #exists; but then we do not work with metadata
4966 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4967 = $c->{distribution};
4968 for my $skipper (qw(
4970 configure_requires_later
4971 configure_requires_later_for
4979 delete $do->{$skipper};
4982 if ($do->{make_test}
4984 && !(UNIVERSAL::can($do->{make_test},"failed") ?
4985 $do->{make_test}->failed :
4986 $do->{make_test} =~ /^YES/
4991 $do->{install}->failed
4994 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4999 while (($painted/76) < ($i/@candidates)) {
5000 $CPAN::Frontend->myprint(".");
5004 $CPAN::Frontend->myprint(sprintf(
5005 "DONE\nFound %s old build%s, restored the state of %s\n",
5006 @candidates ? sprintf("%d",scalar @candidates) : "no",
5007 @candidates==1 ? "" : "s",
5008 $restored || "none",
5013 #-> sub CPAN::Index::reload_x ;
5015 my($cl,$wanted,$localname,$force) = @_;
5016 $force |= 2; # means we're dealing with an index here
5017 CPAN::HandleConfig->load; # we should guarantee loading wherever
5018 # we rely on Config XXX
5019 $localname ||= $wanted;
5020 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
5024 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5027 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5028 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5029 qq{day$s. I\'ll use that.});
5032 $force |= 1; # means we're quite serious about it.
5034 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5037 #-> sub CPAN::Index::rd_authindex ;
5039 my($cl, $index_target) = @_;
5040 return unless defined $index_target;
5041 return if CPAN::_sqlite_running;
5043 $CPAN::Frontend->myprint("Going to read $index_target\n");
5045 tie *FH, 'CPAN::Tarzip', $index_target;
5048 push @lines, split /\012/ while <FH>;
5052 my($userid,$fullname,$email) =
5053 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
5054 $fullname ||= $email;
5055 if ($userid && $fullname && $email) {
5056 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5057 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5059 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5062 while (($painted/76) < ($i/@lines)) {
5063 $CPAN::Frontend->myprint(".");
5066 return if $CPAN::Signal;
5068 $CPAN::Frontend->myprint("DONE\n");
5072 my($self,$dist) = @_;
5073 $dist = $self->{'id'} unless defined $dist;
5074 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5078 #-> sub CPAN::Index::rd_modpacks ;
5080 my($self, $index_target) = @_;
5081 return unless defined $index_target;
5082 return if CPAN::_sqlite_running;
5083 $CPAN::Frontend->myprint("Going to read $index_target\n");
5084 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5086 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5089 while (my $bytes = $fh->READ(\$chunk,8192)) {
5092 my @lines = split /\012/, $slurp;
5093 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5096 my($line_count,$last_updated);
5098 my $shift = shift(@lines);
5099 last if $shift =~ /^\s*$/;
5100 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
5101 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
5103 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
5104 if (not defined $line_count) {
5106 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
5107 Please check the validity of the index file by comparing it to more
5108 than one CPAN mirror. I'll continue but problems seem likely to
5112 $CPAN::Frontend->mysleep(5);
5113 } elsif ($line_count != scalar @lines) {
5115 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
5116 contains a Line-Count header of %d but I see %d lines there. Please
5117 check the validity of the index file by comparing it to more than one
5118 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
5119 $index_target, $line_count, scalar(@lines));
5122 if (not defined $last_updated) {
5124 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
5125 Please check the validity of the index file by comparing it to more
5126 than one CPAN mirror. I'll continue but problems seem likely to
5130 $CPAN::Frontend->mysleep(5);
5134 ->myprint(sprintf qq{ Database was generated on %s\n},
5136 $DATE_OF_02 = $last_updated;
5139 if ($CPAN::META->has_inst('HTTP::Date')) {
5141 $age -= HTTP::Date::str2time($last_updated);
5143 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
5144 require Time::Local;
5145 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5146 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5147 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5154 qq{Warning: This index file is %d days old.
5155 Please check the host you chose as your CPAN mirror for staleness.
5156 I'll continue but problems seem likely to happen.\a\n},
5159 } elsif ($age < -1) {
5163 qq{Warning: Your system date is %d days behind this index file!
5165 Timestamp index file: %s
5166 Please fix your system time, problems with the make command expected.\n},
5176 # A necessity since we have metadata_cache: delete what isn't
5178 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5179 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5184 # before 1.56 we split into 3 and discarded the rest. From
5185 # 1.57 we assign remaining text to $comment thus allowing to
5186 # influence isa_perl
5187 my($mod,$version,$dist,$comment) = split " ", $_, 4;
5188 my($bundle,$id,$userid);
5190 if ($mod eq 'CPAN' &&
5192 CPAN::Queue->exists('Bundle::CPAN') ||
5193 CPAN::Queue->exists('CPAN')
5197 if ($version > $CPAN::VERSION) {
5198 $CPAN::Frontend->mywarn(qq{
5199 New CPAN.pm version (v$version) available.
5200 [Currently running version is v$CPAN::VERSION]
5201 You might want to try
5204 to both upgrade CPAN.pm and run the new version without leaving
5205 the current session.
5208 $CPAN::Frontend->mysleep(2);
5209 $CPAN::Frontend->myprint(qq{\n});
5211 last if $CPAN::Signal;
5212 } elsif ($mod =~ /^Bundle::(.*)/) {
5217 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
5218 # Let's make it a module too, because bundles have so much
5219 # in common with modules.
5221 # Changed in 1.57_63: seems like memory bloat now without
5222 # any value, so commented out
5224 # $CPAN::META->instance('CPAN::Module',$mod);
5228 # instantiate a module object
5229 $id = $CPAN::META->instance('CPAN::Module',$mod);
5233 # Although CPAN prohibits same name with different version the
5234 # indexer may have changed the version for the same distro
5235 # since the last time ("Force Reindexing" feature)
5236 if ($id->cpan_file ne $dist
5238 $id->cpan_version ne $version
5240 $userid = $id->userid || $self->userid($dist);
5242 'CPAN_USERID' => $userid,
5243 'CPAN_VERSION' => $version,
5244 'CPAN_FILE' => $dist,
5248 # instantiate a distribution object
5249 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5250 # we do not need CONTAINSMODS unless we do something with
5251 # this dist, so we better produce it on demand.
5253 ## my $obj = $CPAN::META->instance(
5254 ## 'CPAN::Distribution' => $dist
5256 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5258 $CPAN::META->instance(
5259 'CPAN::Distribution' => $dist
5261 'CPAN_USERID' => $userid,
5262 'CPAN_COMMENT' => $comment,
5266 for my $name ($mod,$dist) {
5267 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
5268 $exists{$name} = undef;
5272 while (($painted/76) < ($i/@lines)) {
5273 $CPAN::Frontend->myprint(".");
5276 return if $CPAN::Signal;
5278 $CPAN::Frontend->myprint("DONE\n");
5280 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5281 for my $o ($CPAN::META->all_objects($class)) {
5282 next if exists $exists{$o->{ID}};
5283 $CPAN::META->delete($class,$o->{ID});
5284 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5291 #-> sub CPAN::Index::rd_modlist ;
5293 my($cl,$index_target) = @_;
5294 return unless defined $index_target;
5295 return if CPAN::_sqlite_running;
5296 $CPAN::Frontend->myprint("Going to read $index_target\n");
5297 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
5301 while (my $bytes = $fh->READ(\$chunk,8192)) {
5304 my @eval2 = split /\012/, $slurp;
5307 my $shift = shift(@eval2);
5308 if ($shift =~ /^Date:\s+(.*)/) {
5309 if ($DATE_OF_03 eq $1) {
5310 $CPAN::Frontend->myprint("Unchanged.\n");
5315 last if $shift =~ /^\s*$/;
5317 push @eval2, q{CPAN::Modulelist->data;};
5319 my($comp) = Safe->new("CPAN::Safe1");
5320 my($eval2) = join("\n", @eval2);
5321 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5322 my $ret = $comp->reval($eval2);
5323 Carp::confess($@) if $@;
5324 return if $CPAN::Signal;
5326 my $until = keys(%$ret);
5328 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
5330 my $obj = $CPAN::META->instance("CPAN::Module",$_);
5331 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
5332 $obj->set(%{$ret->{$_}});
5334 while (($painted/76) < ($i/$until)) {
5335 $CPAN::Frontend->myprint(".");
5338 return if $CPAN::Signal;
5340 $CPAN::Frontend->myprint("DONE\n");
5343 #-> sub CPAN::Index::write_metadata_cache ;
5344 sub write_metadata_cache {
5346 return unless $CPAN::Config->{'cache_metadata'};
5347 return if CPAN::_sqlite_running;
5348 return unless $CPAN::META->has_usable("Storable");
5350 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5351 CPAN::Distribution)) {
5352 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5354 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5355 $cache->{last_time} = $LAST_TIME;
5356 $cache->{DATE_OF_02} = $DATE_OF_02;
5357 $cache->{PROTOCOL} = PROTOCOL;
5358 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5359 eval { Storable::nstore($cache, $metadata_file) };
5360 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5363 #-> sub CPAN::Index::read_metadata_cache ;
5364 sub read_metadata_cache {
5366 return unless $CPAN::Config->{'cache_metadata'};
5367 return if CPAN::_sqlite_running;
5368 return unless $CPAN::META->has_usable("Storable");
5369 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5370 return unless -r $metadata_file and -f $metadata_file;
5371 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5373 eval { $cache = Storable::retrieve($metadata_file) };
5374 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5375 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
5379 if (exists $cache->{PROTOCOL}) {
5380 if (PROTOCOL > $cache->{PROTOCOL}) {
5381 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5382 "with protocol v%s, requiring v%s\n",
5389 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5390 "with protocol v1.0\n");
5395 while(my($class,$v) = each %$cache) {
5396 next unless $class =~ /^CPAN::/;
5397 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5398 while (my($id,$ro) = each %$v) {
5399 $CPAN::META->{readwrite}{$class}{$id} ||=
5400 $class->new(ID=>$id, RO=>$ro);
5405 unless ($clcnt) { # sanity check
5406 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5409 if ($idcnt < 1000) {
5410 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5411 "in $metadata_file\n");
5414 $CPAN::META->{PROTOCOL} ||=
5415 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5416 # does initialize to some protocol
5417 $LAST_TIME = $cache->{last_time};
5418 $DATE_OF_02 = $cache->{DATE_OF_02};
5419 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
5420 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5424 package CPAN::InfoObj;
5429 exists $self->{RO} and return $self->{RO};
5432 #-> sub CPAN::InfoObj::cpan_userid
5437 return $ro->{CPAN_USERID} || "N/A";
5439 $self->debug("ID[$self->{ID}]");
5440 # N/A for bundles found locally
5445 sub id { shift->{ID}; }
5447 #-> sub CPAN::InfoObj::new ;
5449 my $this = bless {}, shift;
5454 # The set method may only be used by code that reads index data or
5455 # otherwise "objective" data from the outside world. All session
5456 # related material may do anything else with instance variables but
5457 # must not touch the hash under the RO attribute. The reason is that
5458 # the RO hash gets written to Metadata file and is thus persistent.
5460 #-> sub CPAN::InfoObj::safe_chdir ;
5462 my($self,$todir) = @_;
5463 # we die if we cannot chdir and we are debuggable
5464 Carp::confess("safe_chdir called without todir argument")
5465 unless defined $todir and length $todir;
5467 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5471 unless (-x $todir) {
5472 unless (chmod 0755, $todir) {
5473 my $cwd = CPAN::anycwd();
5474 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5475 "permission to change the permission; cannot ".
5476 "chdir to '$todir'\n");
5477 $CPAN::Frontend->mysleep(5);
5478 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5479 qq{to todir[$todir]: $!});
5483 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5486 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5489 my $cwd = CPAN::anycwd();
5490 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5491 qq{to todir[$todir] (a chmod has been issued): $!});
5496 #-> sub CPAN::InfoObj::set ;
5498 my($self,%att) = @_;
5499 my $class = ref $self;
5501 # This must be ||=, not ||, because only if we write an empty
5502 # reference, only then the set method will write into the readonly
5503 # area. But for Distributions that spring into existence, maybe
5504 # because of a typo, we do not like it that they are written into
5505 # the readonly area and made permanent (at least for a while) and
5506 # that is why we do not "allow" other places to call ->set.
5507 unless ($self->id) {
5508 CPAN->debug("Bug? Empty ID, rejecting");
5511 my $ro = $self->{RO} =
5512 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5514 while (my($k,$v) = each %att) {
5519 #-> sub CPAN::InfoObj::as_glimpse ;
5523 my $class = ref($self);
5524 $class =~ s/^CPAN:://;
5525 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5526 push @m, sprintf "%-15s %s\n", $class, $id;
5530 #-> sub CPAN::InfoObj::as_string ;
5534 my $class = ref($self);
5535 $class =~ s/^CPAN:://;
5536 push @m, $class, " id = $self->{ID}\n";
5538 unless ($ro = $self->ro) {
5539 if (substr($self->{ID},-1,1) eq ".") { # directory
5542 $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5543 $CPAN::Frontend->mysleep(5);
5547 for (sort keys %$ro) {
5548 # next if m/^(ID|RO)$/;
5550 if ($_ eq "CPAN_USERID") {
5552 $extra .= $self->fullname;
5553 my $email; # old perls!
5554 if ($email = $CPAN::META->instance("CPAN::Author",
5557 $extra .= " <$email>";
5559 $extra .= " <no email>";
5562 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5563 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
5566 next unless defined $ro->{$_};
5567 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
5569 KEY: for (sort keys %$self) {
5570 next if m/^(ID|RO)$/;
5571 unless (defined $self->{$_}) {
5575 if (ref($self->{$_}) eq "ARRAY") {
5576 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
5577 } elsif (ref($self->{$_}) eq "HASH") {
5579 if (/^CONTAINSMODS$/) {
5580 $value = join(" ",sort keys %{$self->{$_}});
5581 } elsif (/^prereq_pm$/) {
5583 my $v = $self->{$_};
5584 for my $x (sort keys %$v) {
5586 for my $y (sort keys %{$v->{$x}}) {
5587 push @svalue, "$y=>$v->{$x}{$y}";
5589 push @value, "$x\:" . join ",", @svalue if @svalue;
5591 $value = join ";", @value;
5593 $value = $self->{$_};
5601 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
5607 #-> sub CPAN::InfoObj::fullname ;
5610 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5613 #-> sub CPAN::InfoObj::dump ;
5615 my($self, $what) = @_;
5616 unless ($CPAN::META->has_inst("Data::Dumper")) {
5617 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5619 local $Data::Dumper::Sortkeys;
5620 $Data::Dumper::Sortkeys = 1;
5621 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5622 if (length $out > 100000) {
5623 my $fh_pager = FileHandle->new;
5624 local($SIG{PIPE}) = "IGNORE";
5625 my $pager = $CPAN::Config->{'pager'} || "cat";
5626 $fh_pager->open("|$pager")
5627 or die "Could not open pager $pager\: $!";
5628 $fh_pager->print($out);
5631 $CPAN::Frontend->myprint($out);
5635 package CPAN::Author;
5638 #-> sub CPAN::Author::force
5644 #-> sub CPAN::Author::force
5647 delete $self->{force};
5650 #-> sub CPAN::Author::id
5653 my $id = $self->{ID};
5654 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5658 #-> sub CPAN::Author::as_glimpse ;
5662 my $class = ref($self);
5663 $class =~ s/^CPAN:://;
5664 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5672 #-> sub CPAN::Author::fullname ;
5674 shift->ro->{FULLNAME};
5678 #-> sub CPAN::Author::email ;
5679 sub email { shift->ro->{EMAIL}; }
5681 #-> sub CPAN::Author::ls ;
5684 my $glob = shift || "";
5685 my $silent = shift || 0;
5688 # adapted from CPAN::Distribution::verifyCHECKSUM ;
5689 my(@csf); # chksumfile
5690 @csf = $self->id =~ /(.)(.)(.*)/;
5691 $csf[1] = join "", @csf[0,1];
5692 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5694 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5695 unless (grep {$_->[2] eq $csf[1]} @dl) {
5696 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5699 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5700 unless (grep {$_->[2] eq $csf[2]} @dl) {
5701 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5704 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5706 if ($CPAN::META->has_inst("Text::Glob")) {
5707 my $rglob = Text::Glob::glob_to_regex($glob);
5708 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5710 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5713 unless ($silent >= 2) {
5714 $CPAN::Frontend->myprint(join "", map {
5715 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5716 } sort { $a->[2] cmp $b->[2] } @dl);
5721 # returns an array of arrays, the latter contain (size,mtime,filename)
5722 #-> sub CPAN::Author::dir_listing ;
5725 my $chksumfile = shift;
5726 my $recursive = shift;
5727 my $may_ftp = shift;
5730 File::Spec->catfile($CPAN::Config->{keep_source_where},
5731 "authors", "id", @$chksumfile);
5735 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5736 # hazard. (Without GPG installed they are not that much better,
5738 $fh = FileHandle->new;
5739 if (open($fh, $lc_want)) {
5740 my $line = <$fh>; close $fh;
5741 unlink($lc_want) unless $line =~ /PGP/;
5745 # connect "force" argument with "index_expire".
5746 my $force = $self->{force};
5747 if (my @stat = stat $lc_want) {
5748 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5752 $lc_file = CPAN::FTP->localize(
5753 "authors/id/@$chksumfile",
5758 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5759 $chksumfile->[-1] .= ".gz";
5760 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5763 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5764 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5770 $lc_file = $lc_want;
5771 # we *could* second-guess and if the user has a file: URL,
5772 # then we could look there. But on the other hand, if they do
5773 # have a file: URL, wy did they choose to set
5774 # $CPAN::Config->{show_upload_date} to false?
5777 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5778 $fh = FileHandle->new;
5780 if (open $fh, $lc_file) {
5783 $eval =~ s/\015?\012/\n/g;
5785 my($comp) = Safe->new();
5786 $cksum = $comp->reval($eval);
5788 rename $lc_file, "$lc_file.bad";
5789 Carp::confess($@) if $@;
5791 } elsif ($may_ftp) {
5792 Carp::carp "Could not open '$lc_file' for reading.";
5794 # Maybe should warn: "You may want to set show_upload_date to a true value"
5798 for $f (sort keys %$cksum) {
5799 if (exists $cksum->{$f}{isdir}) {
5801 my(@dir) = @$chksumfile;
5803 push @dir, $f, "CHECKSUMS";
5805 [$_->[0], $_->[1], "$f/$_->[2]"]
5806 } $self->dir_listing(\@dir,1,$may_ftp);
5808 push @result, [ 0, "-", $f ];
5812 ($cksum->{$f}{"size"}||0),
5813 $cksum->{$f}{"mtime"}||"---",
5821 #-> sub CPAN::Author::reports
5823 $CPAN::Frontend->mywarn("reports on authors not implemented.
5824 Please file a bugreport if you need this.\n");
5827 package CPAN::Distribution;
5833 my $ro = $self->ro or return;
5837 #-> CPAN::Distribution::undelay
5841 "configure_requires_later",
5842 "configure_requires_later_for",
5846 delete $self->{$delayer};
5850 #-> CPAN::Distribution::is_dot_dist
5853 return substr($self->id,-1,1) eq ".";
5856 # add the A/AN/ stuff
5857 #-> CPAN::Distribution::normalize
5860 $s = $self->id unless defined $s;
5861 if (substr($s,-1,1) eq ".") {
5862 # using a global because we are sometimes called as static method
5863 if (!$CPAN::META->{LOCK}
5864 && !$CPAN::Have_warned->{"$s is unlocked"}++
5866 $CPAN::Frontend->mywarn("You are visiting the local directory
5868 without lock, take care that concurrent processes do not do likewise.\n");
5869 $CPAN::Frontend->mysleep(1);
5872 $s = "$CPAN::iCwd/.";
5873 } elsif (File::Spec->file_name_is_absolute($s)) {
5874 } elsif (File::Spec->can("rel2abs")) {
5875 $s = File::Spec->rel2abs($s);
5877 $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5879 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5880 unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5881 for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5882 $_->{build_dir} = $s;
5883 $_->{archived} = "local_directory";
5884 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5890 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5892 return $s if $s =~ m:^N/A|^Contact Author: ;
5893 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5894 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5895 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5900 #-> sub CPAN::Distribution::author ;
5904 if (substr($self->id,-1,1) eq ".") {
5905 $authorid = "LOCAL";
5907 ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5909 CPAN::Shell->expand("Author",$authorid);
5912 # tries to get the yaml from CPAN instead of the distro itself:
5913 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5916 my $meta = $self->pretty_id;
5917 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5918 my(@ls) = CPAN::Shell->globls($meta);
5919 my $norm = $self->normalize($meta);
5923 File::Spec->catfile(
5924 $CPAN::Config->{keep_source_where},
5929 $self->debug("Doing localize") if $CPAN::DEBUG;
5930 unless ($local_file =
5931 CPAN::FTP->localize("authors/id/$norm",
5933 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5935 my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5938 #-> sub CPAN::Distribution::cpan_userid
5941 if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5944 return $self->SUPER::cpan_userid;
5947 #-> sub CPAN::Distribution::pretty_id
5951 return $id unless $id =~ m|^./../|;
5955 #-> sub CPAN::Distribution::base_id
5958 my $id = $self->pretty_id();
5959 my $base_id = File::Basename::basename($id);
5960 $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
5964 # mark as dirty/clean for the sake of recursion detection. $color=1
5965 # means "in use", $color=0 means "not in use anymore". $color=2 means
5966 # we have determined prereqs now and thus insist on passing this
5967 # through (at least) once again.
5969 #-> sub CPAN::Distribution::color_cmd_tmps ;
5970 sub color_cmd_tmps {
5972 my($depth) = shift || 0;
5973 my($color) = shift || 0;
5974 my($ancestors) = shift || [];
5975 # a distribution needs to recurse into its prereq_pms
5977 return if exists $self->{incommandcolor}
5979 && $self->{incommandcolor}==$color;
5980 if ($depth>=$CPAN::MAX_RECURSION) {
5981 die(CPAN::Exception::RecursiveDependency->new($ancestors));
5983 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5984 my $prereq_pm = $self->prereq_pm;
5985 if (defined $prereq_pm) {
5986 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5987 keys %{$prereq_pm->{build_requires}||{}}) {
5988 next PREREQ if $pre eq "perl";
5990 unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5991 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5992 $CPAN::Frontend->mysleep(2);
5995 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5999 delete $self->{sponsored_mods};
6001 # as we are at the end of a command, we'll give up this
6002 # reminder of a broken test. Other commands may test this guy
6003 # again. Maybe 'badtestcnt' should be renamed to
6004 # 'make_test_failed_within_command'?
6005 delete $self->{badtestcnt};
6007 $self->{incommandcolor} = $color;
6010 #-> sub CPAN::Distribution::as_string ;
6013 $self->containsmods;
6015 $self->SUPER::as_string(@_);
6018 #-> sub CPAN::Distribution::containsmods ;
6021 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6022 my $dist_id = $self->{ID};
6023 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6024 my $mod_file = $mod->cpan_file or next;
6025 my $mod_id = $mod->{ID} or next;
6026 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6028 if ($CPAN::Signal) {
6029 delete $self->{CONTAINSMODS};
6032 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
6034 keys %{$self->{CONTAINSMODS}||={}};
6037 #-> sub CPAN::Distribution::upload_date ;
6040 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6041 my(@local_wanted) = split(/\//,$self->id);
6042 my $filename = pop @local_wanted;
6043 push @local_wanted, "CHECKSUMS";
6044 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6045 return unless $author;
6046 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6048 my($dirent) = grep { $_->[2] eq $filename } @dl;
6049 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6050 return unless $dirent->[1];
6051 return $self->{UPLOAD_DATE} = $dirent->[1];
6054 #-> sub CPAN::Distribution::uptodate ;
6058 foreach $c ($self->containsmods) {
6059 my $obj = CPAN::Shell->expandany($c);
6060 unless ($obj->uptodate) {
6061 my $id = $self->pretty_id;
6062 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6069 #-> sub CPAN::Distribution::called_for ;
6072 $self->{CALLED_FOR} = $id if defined $id;
6073 return $self->{CALLED_FOR};
6076 #-> sub CPAN::Distribution::get ;
6079 $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
6080 if (my $goto = $self->prefs->{goto}) {
6081 $CPAN::Frontend->mywarn
6083 "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6085 $self->{prefs_file},
6086 $self->{prefs_file_doc},
6088 return $self->goto($goto);
6090 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6092 : ($ENV{PERLLIB} || "");
6094 $CPAN::META->set_perl5lib;
6095 local $ENV{MAKEFLAGS}; # protect us from outer make calls
6099 my $goodbye_message;
6100 $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
6101 if ($self->prefs->{disabled}) {
6103 "Disabled via prefs file '%s' doc %d",
6104 $self->{prefs_file},
6105 $self->{prefs_file_doc},
6108 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6109 $goodbye_message = "[disabled] -- NA $why";
6110 # note: not intended to be persistent but at least visible
6111 # during this session
6113 if (exists $self->{build_dir} && -d $self->{build_dir}
6114 && ($self->{modulebuild}||$self->{writemakefile})
6116 # this deserves print, not warn:
6117 $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
6118 "$self->{build_dir}\n"
6123 # although we talk about 'force' we shall not test on
6124 # force directly. New model of force tries to refrain from
6125 # direct checking of force.
6126 exists $self->{unwrapped} and (
6127 UNIVERSAL::can($self->{unwrapped},"failed") ?
6128 $self->{unwrapped}->failed :
6129 $self->{unwrapped} =~ /^NO/
6131 and push @e, "Unwrapping had some problem, won't try again without force";
6134 $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6135 if ($goodbye_message) {
6136 $self->goodbye($goodbye_message);
6141 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6144 unless ($self->{build_dir} && -d $self->{build_dir}) {
6145 $self->get_file_onto_local_disk;
6146 return if $CPAN::Signal;
6147 $self->check_integrity;
6148 return if $CPAN::Signal;
6149 (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6150 $packagedir ||= $self->{build_dir};
6151 $self->{build_dir} = $packagedir;
6154 if ($CPAN::Signal) {
6155 $self->safe_chdir($sub_wd);
6158 return $self->run_MM_or_MB($local_file);
6161 #-> CPAN::Distribution::get_file_onto_local_disk
6162 sub get_file_onto_local_disk {
6165 return if $self->is_dot_dist;
6168 File::Spec->catfile(
6169 $CPAN::Config->{keep_source_where},
6172 split(/\//,$self->id)
6175 $self->debug("Doing localize") if $CPAN::DEBUG;
6176 unless ($local_file =
6177 CPAN::FTP->localize("authors/id/$self->{ID}",
6180 if ($CPAN::Index::DATE_OF_02) {
6181 $note = "Note: Current database in memory was generated ".
6182 "on $CPAN::Index::DATE_OF_02\n";
6184 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6187 $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
6188 $self->{localfile} = $local_file;
6192 #-> CPAN::Distribution::check_integrity
6193 sub check_integrity {
6196 return if $self->is_dot_dist;
6197 if ($CPAN::META->has_inst("Digest::SHA")) {
6198 $self->debug("Digest::SHA is installed, verifying");
6199 $self->verifyCHECKSUM;
6201 $self->debug("Digest::SHA is NOT installed");
6205 #-> CPAN::Distribution::run_preps_on_packagedir
6206 sub run_preps_on_packagedir {
6208 return if $self->is_dot_dist;
6210 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6211 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6212 $self->safe_chdir($builddir);
6213 $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6214 File::Path::rmtree("tmp-$$");
6215 unless (mkdir "tmp-$$", 0755) {
6216 $CPAN::Frontend->unrecoverable_error(<<EOF);
6217 Couldn't mkdir '$builddir/tmp-$$': $!
6219 Cannot continue: Please find the reason why I cannot make the
6222 and fix the problem, then retry.
6226 if ($CPAN::Signal) {
6229 $self->safe_chdir("tmp-$$");
6234 my $local_file = $self->{localfile};
6235 my $ct = eval{CPAN::Tarzip->new($local_file)};
6237 $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6238 delete $self->{build_dir};
6241 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
6242 $self->{was_uncompressed}++ unless eval{$ct->gtest()};
6243 $self->untar_me($ct);
6244 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
6245 $self->unzip_me($ct);
6247 $self->{was_uncompressed}++ unless $ct->gtest();
6248 $local_file = $self->handle_singlefile($local_file);
6251 # we are still in the tmp directory!
6252 # Let's check if the package has its own directory.
6253 my $dh = DirHandle->new(File::Spec->curdir)
6254 or Carp::croak("Couldn't opendir .: $!");
6255 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6258 # XXX here we want in each branch File::Temp to protect all build_dir directories
6259 if (CPAN->has_usable("File::Temp")) {
6263 if (@readdir == 1 && -d $readdir[0]) {
6264 $tdir_base = $readdir[0];
6265 $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6266 my $dh2 = DirHandle->new($from_dir)
6267 or Carp::croak("Couldn't opendir $from_dir: $!");
6268 @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6270 my $userid = $self->cpan_userid;
6271 CPAN->debug("userid[$userid]");
6272 if (!$userid or $userid eq "N/A") {
6275 $tdir_base = $userid;
6276 $from_dir = File::Spec->curdir;
6277 @dirents = @readdir;
6279 $packagedir = File::Temp::tempdir(
6280 "$tdir_base-XXXXXX",
6285 for $f (@dirents) { # is already without "." and ".."
6286 my $from = File::Spec->catdir($from_dir,$f);
6287 my $to = File::Spec->catdir($packagedir,$f);
6288 unless (File::Copy::move($from,$to)) {
6290 $from = File::Spec->rel2abs($from);
6291 Carp::confess("Couldn't move $from to $to: $err");
6294 } else { # older code below, still better than nothing when there is no File::Temp
6296 if (@readdir == 1 && -d $readdir[0]) {
6297 $distdir = $readdir[0];
6298 $packagedir = File::Spec->catdir($builddir,$distdir);
6299 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6301 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6303 File::Path::rmtree($packagedir);
6304 unless (File::Copy::move($distdir,$packagedir)) {
6305 $CPAN::Frontend->unrecoverable_error(<<EOF);
6306 Couldn't move '$distdir' to '$packagedir': $!
6308 Cannot continue: Please find the reason why I cannot move
6309 $builddir/tmp-$$/$distdir
6312 and fix the problem, then retry
6316 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6323 my $userid = $self->cpan_userid;
6324 CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
6325 if (!$userid or $userid eq "N/A") {
6328 my $pragmatic_dir = $userid . '000';
6329 $pragmatic_dir =~ s/\W_//g;
6330 $pragmatic_dir++ while -d "../$pragmatic_dir";
6331 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6332 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6333 File::Path::mkpath($packagedir);
6335 for $f (@readdir) { # is already without "." and ".."
6336 my $to = File::Spec->catdir($packagedir,$f);
6337 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6341 $self->{build_dir} = $packagedir;
6342 $self->safe_chdir($builddir);
6343 File::Path::rmtree("tmp-$$");
6345 $self->safe_chdir($packagedir);
6346 $self->_signature_business();
6347 $self->safe_chdir($builddir);
6349 return($packagedir,$local_file);
6352 #-> sub CPAN::Distribution::parse_meta_yml ;
6353 sub parse_meta_yml {
6355 my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6356 my $yaml = File::Spec->catfile($build_dir,"META.yml");
6357 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6358 return unless -f $yaml;
6361 require Parse::Metayaml; # hypothetical
6362 $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6364 unless ($early_yaml) {
6365 eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6367 unless ($early_yaml) {
6373 #-> sub CPAN::Distribution::satisfy_configure_requires ;
6374 sub satisfy_configure_requires {
6376 my $enable_configure_requires = 1;
6377 if (!$enable_configure_requires) {
6379 # if we return 1 here, everything is as before we introduced
6380 # configure_requires that means, things with
6381 # configure_requires simply fail, all others succeed
6383 my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6384 if ($self->{configure_requires_later}) {
6385 for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6386 if ($self->{configure_requires_later_for}{$k}>1) {
6387 # we must not come here a second time
6388 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6390 $CPAN::Frontend->mydie
6393 ({self=>$self, prereq=>\@prereq})
6398 if ($prereq[0][0] eq "perl") {
6399 my $need = "requires perl '$prereq[0][1]'";
6400 my $id = $self->pretty_id;
6401 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6402 $self->{make} = CPAN::Distrostatus->new("NO $need");
6403 $self->store_persistent_state;
6404 return $self->goodbye("[prereq] -- NOT OK");
6407 $self->follow_prereqs("configure_requires_later", @prereq);
6412 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6413 $CPAN::Frontend->mywarn($@);
6414 return $self->goodbye("[depend] -- NOT OK");
6417 die "never reached";
6420 #-> sub CPAN::Distribution::run_MM_or_MB ;
6422 my($self,$local_file) = @_;
6423 $self->satisfy_configure_requires() or return;
6424 my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
6425 my($mpl_exists) = -f $mpl;
6426 unless ($mpl_exists) {
6427 # NFS has been reported to have racing problems after the
6428 # renaming of a directory in some environments.
6430 $CPAN::Frontend->mysleep(1);
6431 my $mpldh = DirHandle->new($self->{build_dir})
6432 or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
6433 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6436 my $prefer_installer = "eumm"; # eumm|mb
6437 if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
6438 if ($mpl_exists) { # they *can* choose
6439 if ($CPAN::META->has_inst("Module::Build")) {
6440 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6441 q{prefer_installer});
6444 $prefer_installer = "mb";
6447 return unless $self->patch;
6448 if (lc($prefer_installer) eq "rand") {
6449 $prefer_installer = rand()<.5 ? "eumm" : "mb";
6451 if (lc($prefer_installer) eq "mb") {
6452 $self->{modulebuild} = 1;
6453 } elsif ($self->{archived} eq "patch") {
6454 # not an edge case, nothing to install for sure
6455 my $why = "A patch file cannot be installed";
6456 $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6457 $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6458 } elsif (! $mpl_exists) {
6459 $self->_edge_cases($mpl,$local_file);
6461 if ($self->{build_dir}
6463 $CPAN::Config->{build_dir_reuse}
6465 $self->store_persistent_state;
6470 #-> CPAN::Distribution::store_persistent_state
6471 sub store_persistent_state {
6473 my $dir = $self->{build_dir};
6474 unless (File::Spec->canonpath(File::Basename::dirname($dir))
6475 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6476 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6477 "will not store persistent state\n");
6480 my $file = sprintf "%s.yml", $dir;
6481 my $yaml_module = CPAN::_yaml_module;
6482 if ($CPAN::META->has_inst($yaml_module)) {
6483 CPAN->_yaml_dumpfile(
6487 perl => CPAN::_perl_fingerprint,
6488 distribution => $self,
6492 $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6493 "will not store persistent state\n");
6497 #-> CPAN::Distribution::try_download
6499 my($self,$patch) = @_;
6500 my $norm = $self->normalize($patch);
6502 File::Spec->catfile(
6503 $CPAN::Config->{keep_source_where},
6508 $self->debug("Doing localize") if $CPAN::DEBUG;
6509 return CPAN::FTP->localize("authors/id/$norm",
6514 my $stdpatchargs = "";
6515 #-> CPAN::Distribution::patch
6518 $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6519 my $patches = $self->prefs->{patches};
6521 $self->debug("patches[$patches]") if $CPAN::DEBUG;
6523 return unless @$patches;
6524 $self->safe_chdir($self->{build_dir});
6525 CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6526 my $patchbin = $CPAN::Config->{patch};
6527 unless ($patchbin && length $patchbin) {
6528 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6529 "Please run 'o conf init /patch/'\n\n");
6531 unless (MM->maybe_command($patchbin)) {
6532 $CPAN::Frontend->mydie("No external patch command available\n\n".
6533 "Please run 'o conf init /patch/'\n\n");
6535 $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6536 local $ENV{PATCH_GET} = 0; # formerly known as -g0
6537 unless ($stdpatchargs) {
6538 my $system = "$patchbin --version |";
6540 open FH, $system or die "Could not fork '$system': $!";
6543 PARSEVERSION: while (<FH>) {
6544 if (/^patch\s+([\d\.]+)/) {
6550 $stdpatchargs = "-N --fuzz=3";
6552 $stdpatchargs = "-N";
6555 my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6556 $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6557 for my $patch (@$patches) {
6558 unless (-f $patch) {
6559 if (my $trydl = $self->try_download($patch)) {
6562 my $fail = "Could not find patch '$patch'";
6563 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6564 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6565 delete $self->{build_dir};
6569 $CPAN::Frontend->myprint(" $patch\n");
6570 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6573 my $ppp = $self->_patch_p_parameter($readfh);
6574 if ($ppp eq "applypatch") {
6575 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6577 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6578 $pcommand = "$patchbin $thispatchargs";
6581 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6582 my $writefh = FileHandle->new;
6583 $CPAN::Frontend->myprint(" $pcommand\n");
6584 unless (open $writefh, "|$pcommand") {
6585 my $fail = "Could not fork '$pcommand'";
6586 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6587 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6588 delete $self->{build_dir};
6591 while (my $x = $readfh->READLINE) {
6594 unless (close $writefh) {
6595 my $fail = "Could not apply patch '$patch'";
6596 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6597 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6598 delete $self->{build_dir};
6608 sub _patch_p_parameter {
6611 my $cnt_p0files = 0;
6613 while ($_ = $fh->READLINE) {
6615 $CPAN::Config->{applypatch}
6617 /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6621 next unless /^[\*\+]{3}\s(\S+)/;
6624 $cnt_p0files++ if -f $file;
6625 CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6628 return "-p1" unless $cnt_files;
6629 return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6632 #-> sub CPAN::Distribution::_edge_cases
6633 # with "configure" or "Makefile" or single file scripts
6635 my($self,$mpl,$local_file) = @_;
6636 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6640 my $build_dir = $self->{build_dir};
6641 my($configure) = File::Spec->catfile($build_dir,"Configure");
6642 if (-f $configure) {
6643 # do we have anything to do?
6644 $self->{configure} = $configure;
6645 } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6646 $CPAN::Frontend->mywarn(qq{
6647 Package comes with a Makefile and without a Makefile.PL.
6648 We\'ll try to build it with that Makefile then.
6650 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6651 $CPAN::Frontend->mysleep(2);
6653 my $cf = $self->called_for || "unknown";
6658 $cf =~ s|[/\\:]||g; # risk of filesystem damage
6659 $cf = "unknown" unless length($cf);
6660 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6661 (The test -f "$mpl" returned false.)
6662 Writing one on our own (setting NAME to $cf)\a\n});
6663 $self->{had_no_makefile_pl}++;
6664 $CPAN::Frontend->mysleep(3);
6666 # Writing our own Makefile.PL
6669 if ($self->{archived} eq "maybe_pl") {
6670 my $fh = FileHandle->new;
6671 my $script_file = File::Spec->catfile($build_dir,$local_file);
6672 $fh->open($script_file)
6673 or Carp::croak("Could not open script '$script_file': $!");
6675 # name parsen und prereq
6676 my($state) = "poddir";
6677 my($name, $prereq) = ("", "");
6679 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6682 } elsif ($1 eq 'PREREQUISITES') {
6685 } elsif ($state =~ m{^(name|prereq)$}) {
6690 } elsif ($state eq "name") {
6695 } elsif ($state eq "prereq") {
6698 } elsif (/^=cut\b/) {
6705 s{.*<}{}; # strip X<...>
6709 $prereq = join " ", split /\s+/, $prereq;
6710 my($PREREQ_PM) = join("\n", map {
6711 s{.*<}{}; # strip X<...>
6713 if (/[\s\'\"]/) { # prose?
6715 s/[^\w:]$//; # period?
6716 " "x28 . "'$_' => 0,";
6718 } split /\s*,\s*/, $prereq);
6721 EXE_FILES => ['$name'],
6727 my $to_file = File::Spec->catfile($build_dir, $name);
6728 rename $script_file, $to_file
6729 or die "Can't rename $script_file to $to_file: $!";
6733 my $fh = FileHandle->new;
6735 or Carp::croak("Could not open >$mpl: $!");
6737 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6738 # because there was no Makefile.PL supplied.
6739 # Autogenerated on: }.scalar localtime().qq{
6741 use ExtUtils::MakeMaker;
6743 NAME => q[$cf],$script
6750 #-> CPAN::Distribution::_signature_business
6751 sub _signature_business {
6753 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6756 if ($CPAN::META->has_inst("Module::Signature")) {
6757 if (-f "SIGNATURE") {
6758 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6759 my $rv = Module::Signature::verify();
6760 if ($rv != Module::Signature::SIGNATURE_OK() and
6761 $rv != Module::Signature::SIGNATURE_MISSING()) {
6762 $CPAN::Frontend->mywarn(
6763 qq{\nSignature invalid for }.
6764 qq{distribution file. }.
6765 qq{Please investigate.\n\n}
6769 sprintf(qq{I'd recommend removing %s. Some error occured }.
6770 qq{while checking its signature, so it could }.
6771 qq{be invalid. Maybe you have configured }.
6772 qq{your 'urllist' with a bad URL. Please check this }.
6773 qq{array with 'o conf urllist' and retry. Or }.
6774 qq{examine the distribution in a subshell. Try
6782 $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6783 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6784 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6786 $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6787 $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6790 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6793 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6798 #-> CPAN::Distribution::untar_me ;
6801 $self->{archived} = "tar";
6803 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6805 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6809 # CPAN::Distribution::unzip_me ;
6812 $self->{archived} = "zip";
6814 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6816 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6821 sub handle_singlefile {
6822 my($self,$local_file) = @_;
6824 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
6825 $self->{archived} = "pm";
6826 } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6827 $self->{archived} = "patch";
6829 $self->{archived} = "maybe_pl";
6832 my $to = File::Basename::basename($local_file);
6833 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6834 if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6835 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6837 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6840 if (File::Copy::cp($local_file,".")) {
6841 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6843 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6849 #-> sub CPAN::Distribution::new ;
6851 my($class,%att) = @_;
6853 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6855 my $this = { %att };
6856 return bless $this, $class;
6859 #-> sub CPAN::Distribution::look ;
6863 if ($^O eq 'MacOS') {
6864 $self->Mac::BuildTools::look;
6868 if ( $CPAN::Config->{'shell'} ) {
6869 $CPAN::Frontend->myprint(qq{
6870 Trying to open a subshell in the build directory...
6873 $CPAN::Frontend->myprint(qq{
6874 Your configuration does not define a value for subshells.
6875 Please define it with "o conf shell <your shell>"
6879 my $dist = $self->id;
6881 unless ($dir = $self->dir) {
6884 unless ($dir ||= $self->dir) {
6885 $CPAN::Frontend->mywarn(qq{
6886 Could not determine which directory to use for looking at $dist.
6890 my $pwd = CPAN::anycwd();
6891 $self->safe_chdir($dir);
6892 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6894 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6895 $ENV{CPAN_SHELL_LEVEL} += 1;
6896 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6897 unless (system($shell) == 0) {
6899 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6902 $self->safe_chdir($pwd);
6905 # CPAN::Distribution::cvs_import ;
6909 my $dir = $self->dir;
6911 my $package = $self->called_for;
6912 my $module = $CPAN::META->instance('CPAN::Module', $package);
6913 my $version = $module->cpan_version;
6915 my $userid = $self->cpan_userid;
6917 my $cvs_dir = (split /\//, $dir)[-1];
6918 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6920 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6922 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6923 if ($cvs_site_perl) {
6924 $cvs_dir = "$cvs_site_perl/$cvs_dir";
6926 my $cvs_log = qq{"imported $package $version sources"};
6927 $version =~ s/\./_/g;
6928 # XXX cvs: undocumented and unclear how it was meant to work
6929 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6930 "$cvs_dir", $userid, "v$version");
6932 my $pwd = CPAN::anycwd();
6933 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6935 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6937 $CPAN::Frontend->myprint(qq{@cmd\n});
6938 system(@cmd) == 0 or
6940 $CPAN::Frontend->mydie("cvs import failed");
6941 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6944 #-> sub CPAN::Distribution::readme ;
6947 my($dist) = $self->id;
6948 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6949 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6952 File::Spec->catfile(
6953 $CPAN::Config->{keep_source_where},
6956 split(/\//,"$sans.readme"),
6958 $self->debug("Doing localize") if $CPAN::DEBUG;
6959 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6961 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6963 if ($^O eq 'MacOS') {
6964 Mac::BuildTools::launch_file($local_file);
6968 my $fh_pager = FileHandle->new;
6969 local($SIG{PIPE}) = "IGNORE";
6970 my $pager = $CPAN::Config->{'pager'} || "cat";
6971 $fh_pager->open("|$pager")
6972 or die "Could not open pager $pager\: $!";
6973 my $fh_readme = FileHandle->new;
6974 $fh_readme->open($local_file)
6975 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6976 $CPAN::Frontend->myprint(qq{
6981 $fh_pager->print(<$fh_readme>);
6985 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6986 sub verifyCHECKSUM {
6990 $self->{CHECKSUM_STATUS} ||= "";
6991 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6992 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6994 my($lc_want,$lc_file,@local,$basename);
6995 @local = split(/\//,$self->id);
6997 push @local, "CHECKSUMS";
6999 File::Spec->catfile($CPAN::Config->{keep_source_where},
7000 "authors", "id", @local);
7002 if (my $size = -s $lc_want) {
7003 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7004 if ($self->CHECKSUM_check_file($lc_want,1)) {
7005 return $self->{CHECKSUM_STATUS} = "OK";
7008 $lc_file = CPAN::FTP->localize("authors/id/@local",
7011 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
7012 $local[-1] .= ".gz";
7013 $lc_file = CPAN::FTP->localize("authors/id/@local",
7016 $lc_file =~ s/\.gz(?!\n)\Z//;
7017 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7022 if ($self->CHECKSUM_check_file($lc_file)) {
7023 return $self->{CHECKSUM_STATUS} = "OK";
7027 #-> sub CPAN::Distribution::SIG_check_file ;
7028 sub SIG_check_file {
7029 my($self,$chk_file) = @_;
7030 my $rv = eval { Module::Signature::_verify($chk_file) };
7032 if ($rv == Module::Signature::SIGNATURE_OK()) {
7033 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7034 return $self->{SIG_STATUS} = "OK";
7036 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7037 qq{distribution file. }.
7038 qq{Please investigate.\n\n}.
7040 $CPAN::META->instance(
7045 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
7046 is invalid. Maybe you have configured your 'urllist' with
7047 a bad URL. Please check this array with 'o conf urllist', and
7050 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7054 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
7056 # sloppy is 1 when we have an old checksums file that maybe is good
7059 sub CHECKSUM_check_file {
7060 my($self,$chk_file,$sloppy) = @_;
7061 my($cksum,$file,$basename);
7064 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
7065 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7068 if ($CPAN::META->has_inst("Module::Signature")) {
7069 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7070 $self->SIG_check_file($chk_file);
7072 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7076 $file = $self->{localfile};
7077 $basename = File::Basename::basename($file);
7078 my $fh = FileHandle->new;
7079 if (open $fh, $chk_file) {
7082 $eval =~ s/\015?\012/\n/g;
7084 my($comp) = Safe->new();
7085 $cksum = $comp->reval($eval);
7087 rename $chk_file, "$chk_file.bad";
7088 Carp::confess($@) if $@;
7091 Carp::carp "Could not open $chk_file for reading";
7094 if (! ref $cksum or ref $cksum ne "HASH") {
7095 $CPAN::Frontend->mywarn(qq{
7096 Warning: checksum file '$chk_file' broken.
7098 When trying to read that file I expected to get a hash reference
7099 for further processing, but got garbage instead.
7101 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
7102 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7103 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
7105 } elsif (exists $cksum->{$basename}{sha256}) {
7106 $self->debug("Found checksum for $basename:" .
7107 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7111 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7113 $fh = CPAN::Tarzip->TIEHANDLE($file);
7116 my $dg = Digest::SHA->new(256);
7119 while ($fh->READ($ref, 4096) > 0) {
7122 my $hexdigest = $dg->hexdigest;
7123 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7127 $CPAN::Frontend->myprint("Checksum for $file ok\n");
7128 return $self->{CHECKSUM_STATUS} = "OK";
7130 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7131 qq{distribution file. }.
7132 qq{Please investigate.\n\n}.
7134 $CPAN::META->instance(
7139 my $wrap = qq{I\'d recommend removing $file. Its
7140 checksum is incorrect. Maybe you have configured your 'urllist' with
7141 a bad URL. Please check this array with 'o conf urllist', and
7144 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7146 # former versions just returned here but this seems a
7147 # serious threat that deserves a die
7149 # $CPAN::Frontend->myprint("\n\n");
7153 # close $fh if fileno($fh);
7156 unless ($self->{CHECKSUM_STATUS}) {
7157 $CPAN::Frontend->mywarn(qq{
7158 Warning: No checksum for $basename in $chk_file.
7160 The cause for this may be that the file is very new and the checksum
7161 has not yet been calculated, but it may also be that something is
7162 going awry right now.
7164 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
7165 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7167 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
7172 #-> sub CPAN::Distribution::eq_CHECKSUM ;
7174 my($self,$fh,$expect) = @_;
7175 if ($CPAN::META->has_inst("Digest::SHA")) {
7176 my $dg = Digest::SHA->new(256);
7178 while (read($fh, $data, 4096)) {
7181 my $hexdigest = $dg->hexdigest;
7182 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7183 return $hexdigest eq $expect;
7188 #-> sub CPAN::Distribution::force ;
7190 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
7191 # effect by autoinspection, not by inspecting a global variable. One
7192 # of the reason why this was chosen to work that way was the treatment
7193 # of dependencies. They should not automatically inherit the force
7194 # status. But this has the downside that ^C and die() will return to
7195 # the prompt but will not be able to reset the force_update
7196 # attributes. We try to correct for it currently in the read_metadata
7197 # routine, and immediately before we check for a Signal. I hope this
7198 # works out in one of v1.57_53ff
7200 # "Force get forgets previous error conditions"
7202 #-> sub CPAN::Distribution::fforce ;
7204 my($self, $method) = @_;
7205 $self->force($method,1);
7208 #-> sub CPAN::Distribution::force ;
7210 my($self, $method,$fforce) = @_;
7228 "prereq_pm_detected",
7242 my $methodmatch = 0;
7244 PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7245 $methodmatch = 1 if $fforce || $phase eq $method;
7246 next unless $methodmatch;
7247 ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
7248 if ($phase eq "get") {
7249 if (substr($self->id,-1,1) eq "."
7250 && $att =~ /(unwrapped|build_dir|archived)/ ) {
7251 # cannot be undone for local distros
7254 if ($att eq "build_dir"
7255 && $self->{build_dir}
7256 && $CPAN::META->{is_tested}
7258 delete $CPAN::META->{is_tested}{$self->{build_dir}};
7260 } elsif ($phase eq "test") {
7261 if ($att eq "make_test"
7262 && $self->{make_test}
7263 && $self->{make_test}{COMMANDID}
7264 && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7266 # endless loop too likely
7270 delete $self->{$att};
7271 if ($ldebug || $CPAN::DEBUG) {
7272 # local $CPAN::DEBUG = 16; # Distribution
7273 CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7277 if ($method && $method =~ /make|test|install/) {
7278 $self->{force_update} = 1; # name should probably have been force_install
7282 #-> sub CPAN::Distribution::notest ;
7284 my($self, $method) = @_;
7285 # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
7286 $self->{"notest"}++; # name should probably have been force_install
7289 #-> sub CPAN::Distribution::unnotest ;
7292 # warn "XDEBUG: deleting notest";
7293 delete $self->{notest};
7296 #-> sub CPAN::Distribution::unforce ;
7299 delete $self->{force_update};
7302 #-> sub CPAN::Distribution::isa_perl ;
7305 my $file = File::Basename::basename($self->id);
7306 if ($file =~ m{ ^ perl
7315 \.tar[._-](?:gz|bz2)
7319 } elsif ($self->cpan_comment
7321 $self->cpan_comment =~ /isa_perl\(.+?\)/) {
7327 #-> sub CPAN::Distribution::perl ;
7332 carp __PACKAGE__ . "::perl was called without parameters.";
7334 return CPAN::HandleConfig->safe_quote($CPAN::Perl);
7338 #-> sub CPAN::Distribution::make ;
7341 if (my $goto = $self->prefs->{goto}) {
7342 return $self->goto($goto);
7344 my $make = $self->{modulebuild} ? "Build" : "make";
7345 # Emergency brake if they said install Pippi and get newest perl
7346 if ($self->isa_perl) {
7348 $self->called_for ne $self->id &&
7349 ! $self->{force_update}
7351 # if we die here, we break bundles
7354 qq{The most recent version "%s" of the module "%s"
7355 is part of the perl-%s distribution. To install that, you need to run
7356 force install %s --or--
7359 $CPAN::META->instance(
7368 $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7369 $CPAN::Frontend->mysleep(1);
7373 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
7375 if ($self->{configure_requires_later}) {
7378 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7380 : ($ENV{PERLLIB} || "");
7381 $CPAN::META->set_perl5lib;
7382 local $ENV{MAKEFLAGS}; # protect us from outer make calls
7384 if ($CPAN::Signal) {
7385 delete $self->{force_update};
7392 if (!$self->{archived} || $self->{archived} eq "NO") {
7393 push @e, "Is neither a tar nor a zip archive.";
7396 if (!$self->{unwrapped}
7398 UNIVERSAL::can($self->{unwrapped},"failed") ?
7399 $self->{unwrapped}->failed :
7400 $self->{unwrapped} =~ /^NO/
7402 push @e, "Had problems unarchiving. Please build manually";
7405 unless ($self->{force_update}) {
7406 exists $self->{signature_verify} and
7408 UNIVERSAL::can($self->{signature_verify},"failed") ?
7409 $self->{signature_verify}->failed :
7410 $self->{signature_verify} =~ /^NO/
7412 and push @e, "Did not pass the signature test.";
7415 if (exists $self->{writemakefile} &&
7417 UNIVERSAL::can($self->{writemakefile},"failed") ?
7418 $self->{writemakefile}->failed :
7419 $self->{writemakefile} =~ /^NO/
7421 # XXX maybe a retry would be in order?
7422 my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
7423 $self->{writemakefile}->text :
7424 $self->{writemakefile};
7426 $err ||= "Had some problem writing Makefile";
7427 $err .= ", won't make";
7431 if (defined $self->{make}) {
7432 if (UNIVERSAL::can($self->{make},"failed") ?
7433 $self->{make}->failed :
7434 $self->{make} =~ /^NO/) {
7435 if ($self->{force_update}) {
7436 # Trying an already failed 'make' (unless somebody else blocks)
7438 # introduced for turning recursion detection into a distrostatus
7439 my $error = length $self->{make}>3
7440 ? substr($self->{make},3) : "Unknown error";
7441 $CPAN::Frontend->mywarn("Could not make: $error\n");
7442 $self->store_persistent_state;
7446 push @e, "Has already been made";
7450 my $later = $self->{later} || $self->{configure_requires_later};
7451 if ($later) { # see also undelay
7457 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7458 $builddir = $self->dir or
7459 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7460 unless (chdir $builddir) {
7461 push @e, "Couldn't chdir to '$builddir': $!";
7463 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
7465 if ($CPAN::Signal) {
7466 delete $self->{force_update};
7469 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
7470 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7472 if ($^O eq 'MacOS') {
7473 Mac::BuildTools::make($self);
7478 while (my($k,$v) = each %ENV) {
7479 next unless defined $v;
7484 if (my $commandline = $self->prefs->{pl}{commandline}) {
7485 $system = $commandline;
7487 } elsif ($self->{'configure'}) {
7488 $system = $self->{'configure'};
7489 } elsif ($self->{modulebuild}) {
7490 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7491 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7493 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7495 # This needs a handler that can be turned on or off:
7496 # $switch = "-MExtUtils::MakeMaker ".
7497 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7499 my $makepl_arg = $self->make_x_arg("pl");
7500 $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7502 $system = sprintf("%s%s Makefile.PL%s",
7504 $switch ? " $switch" : "",
7505 $makepl_arg ? " $makepl_arg" : "",
7508 if (my $env = $self->prefs->{pl}{env}) {
7509 for my $e (keys %$env) {
7510 $ENV{$e} = $env->{$e};
7513 if (exists $self->{writemakefile}) {
7515 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7516 my($ret,$pid,$output);
7519 if ($CPAN::Config->{inactivity_timeout}) {
7521 if ($Config::Config{d_alarm}
7523 $Config::Config{d_alarm} eq "define"
7527 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7528 "variable 'inactivity_timeout' to ".
7529 "'$CPAN::Config->{inactivity_timeout}'. But ".
7530 "on this machine the system call 'alarm' ".
7531 "isn't available. This means that we cannot ".
7532 "provide the feature of intercepting long ".
7533 "waiting code and will turn this feature off.\n"
7535 $CPAN::Config->{inactivity_timeout} = 0;
7538 if ($go_via_alarm) {
7539 if ( $self->_should_report('pl') ) {
7540 ($output, $ret) = CPAN::Reporter::record_command(
7542 $CPAN::Config->{inactivity_timeout},
7544 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7548 alarm $CPAN::Config->{inactivity_timeout};
7549 local $SIG{CHLD}; # = sub { wait };
7550 if (defined($pid = fork)) {
7555 # note, this exec isn't necessary if
7556 # inactivity_timeout is 0. On the Mac I'd
7557 # suggest, we set it always to 0.
7561 $CPAN::Frontend->myprint("Cannot fork: $!");
7570 $CPAN::Frontend->myprint($err);
7571 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7573 $self->store_persistent_state;
7574 return $self->goodbye("$system -- TIMED OUT");
7578 if (my $expect_model = $self->_prefs_with_expect("pl")) {
7579 # XXX probably want to check _should_report here and warn
7580 # about not being able to use CPAN::Reporter with expect
7581 $ret = $self->_run_via_expect($system,$expect_model);
7583 && $self->{writemakefile}
7584 && $self->{writemakefile}->failed) {
7589 elsif ( $self->_should_report('pl') ) {
7590 ($output, $ret) = CPAN::Reporter::record_command($system);
7591 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7594 $ret = system($system);
7597 $self->{writemakefile} = CPAN::Distrostatus
7598 ->new("NO '$system' returned status $ret");
7599 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7600 $self->store_persistent_state;
7601 return $self->goodbye("$system -- NOT OK");
7604 if (-f "Makefile" || -f "Build") {
7605 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7606 delete $self->{make_clean}; # if cleaned before, enable next
7608 my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7609 $self->{writemakefile} = CPAN::Distrostatus
7610 ->new(qq{NO -- No $makefile created});
7611 $self->store_persistent_state;
7612 return $self->goodbye("$system -- NO $makefile created");
7615 if ($CPAN::Signal) {
7616 delete $self->{force_update};
7619 if (my @prereq = $self->unsat_prereq("later")) {
7620 if ($prereq[0][0] eq "perl") {
7621 my $need = "requires perl '$prereq[0][1]'";
7622 my $id = $self->pretty_id;
7623 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7624 $self->{make} = CPAN::Distrostatus->new("NO $need");
7625 $self->store_persistent_state;
7626 return $self->goodbye("[prereq] -- NOT OK");
7628 my $follow = eval { $self->follow_prereqs("later",@prereq); };
7631 # signal success to the queuerunner
7633 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7634 $CPAN::Frontend->mywarn($@);
7635 return $self->goodbye("[depend] -- NOT OK");
7639 if ($CPAN::Signal) {
7640 delete $self->{force_update};
7643 if (my $commandline = $self->prefs->{make}{commandline}) {
7644 $system = $commandline;
7645 $ENV{PERL} = CPAN::find_perl;
7647 if ($self->{modulebuild}) {
7648 unless (-f "Build") {
7649 my $cwd = CPAN::anycwd();
7650 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7651 " in cwd[$cwd]. Danger, Will Robinson!\n");
7652 $CPAN::Frontend->mysleep(5);
7654 $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7656 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
7658 $system =~ s/\s+$//;
7659 my $make_arg = $self->make_x_arg("make");
7660 $system = sprintf("%s%s",
7662 $make_arg ? " $make_arg" : "",
7665 if (my $env = $self->prefs->{make}{env}) { # overriding the local
7666 # ENV of PL, not the
7668 # unlikely to be a risk
7669 for my $e (keys %$env) {
7670 $ENV{$e} = $env->{$e};
7673 my $expect_model = $self->_prefs_with_expect("make");
7674 my $want_expect = 0;
7675 if ( $expect_model && @{$expect_model->{talk}} ) {
7676 my $can_expect = $CPAN::META->has_inst("Expect");
7680 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7686 # XXX probably want to check _should_report here and
7687 # warn about not being able to use CPAN::Reporter with expect
7688 $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7690 elsif ( $self->_should_report('make') ) {
7691 my ($output, $ret) = CPAN::Reporter::record_command($system);
7692 CPAN::Reporter::grade_make( $self, $system, $output, $ret );
7693 $system_ok = ! $ret;
7696 $system_ok = system($system) == 0;
7698 $self->introduce_myself;
7700 $CPAN::Frontend->myprint(" $system -- OK\n");
7701 $self->{make} = CPAN::Distrostatus->new("YES");
7703 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7704 $self->{make} = CPAN::Distrostatus->new("NO");
7705 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
7707 $self->store_persistent_state;
7710 # CPAN::Distribution::goodbye ;
7712 my($self,$goodbye) = @_;
7713 my $id = $self->pretty_id;
7714 $CPAN::Frontend->mywarn(" $id\n $goodbye\n");
7718 # CPAN::Distribution::_run_via_expect ;
7719 sub _run_via_expect {
7720 my($self,$system,$expect_model) = @_;
7721 CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7722 if ($CPAN::META->has_inst("Expect")) {
7723 my $expo = Expect->new; # expo Expect object;
7724 $expo->spawn($system);
7725 $expect_model->{mode} ||= "deterministic";
7726 if ($expect_model->{mode} eq "deterministic") {
7727 return $self->_run_via_expect_deterministic($expo,$expect_model);
7728 } elsif ($expect_model->{mode} eq "anyorder") {
7729 return $self->_run_via_expect_anyorder($expo,$expect_model);
7731 die "Panic: Illegal expect mode: $expect_model->{mode}";
7734 $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7735 return system($system);
7739 sub _run_via_expect_anyorder {
7740 my($self,$expo,$expect_model) = @_;
7741 my $timeout = $expect_model->{timeout} || 5;
7742 my $reuse = $expect_model->{reuse};
7743 my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7746 my($eof,$ran_into_timeout);
7747 my @match = $expo->expect($timeout,
7752 $ran_into_timeout++;
7759 $but .= $expo->clear_accum;
7762 return $expo->exitstatus();
7763 } elsif ($ran_into_timeout) {
7764 # warn "DEBUG: they are asking a question, but[$but]";
7765 for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7766 my($next,$send) = @expectacopy[$i,$i+1];
7767 my $regex = eval "qr{$next}";
7768 # warn "DEBUG: will compare with regex[$regex].";
7769 if ($but =~ /$regex/) {
7770 # warn "DEBUG: will send send[$send]";
7772 # never allow reusing an QA pair unless they told us
7773 splice @expectacopy, $i, 2 unless $reuse;
7777 my $why = "could not answer a question during the dialog";
7778 $CPAN::Frontend->mywarn("Failing: $why\n");
7779 $self->{writemakefile} =
7780 CPAN::Distrostatus->new("NO $why");
7786 sub _run_via_expect_deterministic {
7787 my($self,$expo,$expect_model) = @_;
7788 my $ran_into_timeout;
7789 my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7790 my $expecta = $expect_model->{talk};
7791 EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7792 my($re,$send) = @$expecta[$i,$i+1];
7793 CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7794 my $regex = eval "qr{$re}";
7795 $expo->expect($timeout,
7797 my $but = $expo->clear_accum;
7798 $CPAN::Frontend->mywarn("EOF (maybe harmless)
7799 expected[$regex]\nbut[$but]\n\n");
7803 my $but = $expo->clear_accum;
7804 $CPAN::Frontend->mywarn("TIMEOUT
7805 expected[$regex]\nbut[$but]\n\n");
7806 $ran_into_timeout++;
7809 if ($ran_into_timeout) {
7810 # note that the caller expects 0 for success
7811 $self->{writemakefile} =
7812 CPAN::Distrostatus->new("NO timeout during expect dialog");
7818 return $expo->exitstatus();
7821 #-> CPAN::Distribution::_validate_distropref
7822 sub _validate_distropref {
7823 my($self,@args) = @_;
7825 $CPAN::META->has_inst("CPAN::Kwalify")
7827 $CPAN::META->has_inst("Kwalify")
7829 eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7831 $CPAN::Frontend->mywarn($@);
7834 CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7838 #-> CPAN::Distribution::_find_prefs
7841 my $distroid = $self->pretty_id;
7842 #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7843 my $prefs_dir = $CPAN::Config->{prefs_dir};
7844 return if $prefs_dir =~ /^\s*$/;
7845 eval { File::Path::mkpath($prefs_dir); };
7847 $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7849 my $yaml_module = CPAN::_yaml_module;
7851 if ($CPAN::META->has_inst($yaml_module)) {
7852 push @extensions, "yml";
7855 if ($CPAN::META->has_inst("Data::Dumper")) {
7856 push @extensions, "dd";
7857 push @fallbacks, "Data::Dumper";
7859 if ($CPAN::META->has_inst("Storable")) {
7860 push @extensions, "st";
7861 push @fallbacks, "Storable";
7865 unless ($self->{have_complained_about_missing_yaml}++) {
7866 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7867 "to @fallbacks to read prefs '$prefs_dir'\n");
7870 unless ($self->{have_complained_about_missing_yaml}++) {
7871 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7872 "read prefs '$prefs_dir'\n");
7877 my $dh = DirHandle->new($prefs_dir)
7878 or die Carp::croak("Couldn't open '$prefs_dir': $!");
7879 DIRENT: for (sort $dh->read) {
7880 next if $_ eq "." || $_ eq "..";
7881 my $exte = join "|", @extensions;
7882 next unless /\.($exte)$/;
7884 my $abs = File::Spec->catfile($prefs_dir, $_);
7886 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7888 if ($thisexte eq "yml") {
7889 # need no eval because if we have no YAML we do not try to read *.yml
7890 #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7891 @distropref = @{CPAN->_yaml_loadfile($abs)};
7892 #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7893 } elsif ($thisexte eq "dd") {
7896 open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7902 $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7905 while (${"VAR".$i}) {
7906 push @distropref, ${"VAR".$i};
7909 } elsif ($thisexte eq "st") {
7910 # eval because Storable is never forward compatible
7911 eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7913 $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7914 "$_, skipping\: $@");
7915 $CPAN::Frontend->mysleep(4);
7920 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7921 ELEMENT: for my $y (0..$#distropref) {
7922 my $distropref = $distropref[$y];
7923 $self->_validate_distropref($distropref,$abs,$y);
7924 my $match = $distropref->{match};
7926 #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7930 # do not take the order of C<keys %$match> because
7931 # "module" is by far the slowest
7932 my $saw_valid_subkeys = 0;
7933 for my $sub_attribute (qw(distribution perl perlconfig module)) {
7934 next unless exists $match->{$sub_attribute};
7935 $saw_valid_subkeys++;
7936 my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7937 if ($sub_attribute eq "module") {
7939 #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7940 my @modules = $self->containsmods;
7941 #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7942 MODULE: for my $module (@modules) {
7943 $okm ||= $module =~ /$qr/;
7944 last MODULE if $okm;
7947 } elsif ($sub_attribute eq "distribution") {
7948 my $okd = $distroid =~ /$qr/;
7950 } elsif ($sub_attribute eq "perl") {
7951 my $okp = CPAN::find_perl =~ /$qr/;
7953 } elsif ($sub_attribute eq "perlconfig") {
7954 for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7955 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7956 # XXX should probably warn if Config does not exist
7957 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7962 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7963 "unknown sub_attribut '$sub_attribute'. ".
7965 "remove, cannot continue.");
7967 last if $ok == 0; # short circuit
7969 unless ($saw_valid_subkeys) {
7970 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7971 "missing match/* subattribute. ".
7973 "remove, cannot continue.");
7975 #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7978 prefs => $distropref,
7980 prefs_file_doc => $y,
7992 # CPAN::Distribution::prefs
7995 if (exists $self->{negative_prefs_cache}
7997 $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7999 delete $self->{negative_prefs_cache};
8000 delete $self->{prefs};
8002 if (exists $self->{prefs}) {
8003 return $self->{prefs}; # XXX comment out during debugging
8005 if ($CPAN::Config->{prefs_dir}) {
8006 CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
8007 my $prefs = $self->_find_prefs();
8008 $prefs ||= ""; # avoid warning next line
8009 CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
8011 for my $x (qw(prefs prefs_file prefs_file_doc)) {
8012 $self->{$x} = $prefs->{$x};
8016 File::Basename::basename($self->{prefs_file}),
8017 $self->{prefs_file_doc},
8019 my $filler1 = "_" x 22;
8020 my $filler2 = int(66 - length($bs))/2;
8021 $filler2 = 0 if $filler2 < 0;
8022 $filler2 = " " x $filler2;
8023 $CPAN::Frontend->myprint("
8024 $filler1 D i s t r o P r e f s $filler1
8025 $filler2 $bs $filler2
8027 $CPAN::Frontend->mysleep(1);
8028 return $self->{prefs};
8031 $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8032 return $self->{prefs} = +{};
8035 # CPAN::Distribution::make_x_arg
8037 my($self, $whixh) = @_;
8039 my $prefs = $self->prefs;
8042 && exists $prefs->{$whixh}
8043 && exists $prefs->{$whixh}{args}
8044 && $prefs->{$whixh}{args}
8046 $make_x_arg = join(" ",
8047 map {CPAN::HandleConfig
8048 ->safe_quote($_)} @{$prefs->{$whixh}{args}},
8051 my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
8052 $make_x_arg ||= $CPAN::Config->{$what};
8056 # CPAN::Distribution::_make_command
8063 CPAN::HandleConfig->prefs_lookup($self,
8065 || $Config::Config{make}
8069 # Old style call, without object. Deprecated
8070 Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8073 CPAN::HandleConfig->prefs_lookup($self,q{make})
8074 || $CPAN::Config->{make}
8075 || $Config::Config{make}
8080 #-> sub CPAN::Distribution::follow_prereqs ;
8081 sub follow_prereqs {
8084 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8085 return unless @prereq_tuples;
8086 my @prereq = map { $_->[0] } @prereq_tuples;
8087 my $pretty_id = $self->pretty_id;
8089 b => "build_requires",
8093 my($filler1,$filler2,$filler3,$filler4);
8095 my $unsat = "Unsatisfied dependencies detected during";
8096 my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8098 my $r = int(($w - length($unsat))/2);
8099 my $l = $w - length($unsat) - $r;
8100 $filler1 = "-"x4 . " "x$l;
8101 $filler2 = " "x$r . "-"x4 . "\n";
8104 my $r = int(($w - length($pretty_id))/2);
8105 my $l = $w - length($pretty_id) - $r;
8106 $filler3 = "-"x4 . " "x$l;
8107 $filler4 = " "x$r . "-"x4 . "\n";
8110 myprint("$filler1 $unsat $filler2".
8111 "$filler3 $pretty_id $filler4".
8112 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
8115 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
8117 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
8118 my $answer = CPAN::Shell::colorable_makemaker_prompt(
8119 "Shall I follow them and prepend them to the queue
8120 of modules we are processing right now?", "yes");
8121 $follow = $answer =~ /^\s*y/i;
8125 myprint(" Ignoring dependencies on modules @prereq\n");
8129 # color them as dirty
8130 for my $p (@prereq) {
8131 # warn "calling color_cmd_tmps(0,1)";
8132 my $any = CPAN::Shell->expandany($p);
8133 $self->{$slot . "_for"}{$any->id}++;
8135 $any->color_cmd_tmps(0,2);
8137 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8138 $CPAN::Frontend->mysleep(2);
8141 # queue them and re-queue yourself
8142 CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8143 map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples);
8144 $self->{$slot} = "Delayed until after prerequisites";
8145 return 1; # signal success to the queuerunner
8150 #-> sub CPAN::Distribution::unsat_prereq ;
8151 # return ([Foo=>1],[Bar=>1.2]) for normal modules
8152 # return ([perl=>5.008]) if we need a newer perl than we are running under
8154 my($self,$slot) = @_;
8155 my(%merged,$prereq_pm);
8156 my $prefs_depends = $self->prefs->{depends}||{};
8157 if ($slot eq "configure_requires_later") {
8158 my $meta_yml = $self->parse_meta_yml();
8159 %merged = (%{$meta_yml->{configure_requires}||{}},
8160 %{$prefs_depends->{configure_requires}||{}});
8161 $prereq_pm = {}; # configure_requires defined as "b"
8162 } elsif ($slot eq "later") {
8163 my $prereq_pm_0 = $self->prereq_pm || {};
8164 for my $reqtype (qw(requires build_requires)) {
8165 $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8166 for my $k (keys %{$prefs_depends->{$reqtype}||{}}) {
8167 $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k};
8170 %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8172 die "Panic: illegal slot '$slot'";
8175 my @merged = %merged;
8176 CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
8177 NEED: while (my($need_module, $need_version) = each %merged) {
8178 my($available_version,$available_file,$nmo);
8179 if ($need_module eq "perl") {
8180 $available_version = $];
8181 $available_file = CPAN::find_perl;
8183 $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
8184 next if $nmo->uptodate;
8185 $available_file = $nmo->available_file;
8187 # if they have not specified a version, we accept any installed one
8188 if (defined $available_file
8189 and ( # a few quick shortcurcuits
8190 not defined $need_version
8191 or $need_version eq '0' # "==" would trigger warning when not numeric
8192 or $need_version eq "undef"
8197 $available_version = $nmo->available_version;
8200 # We only want to install prereqs if either they're not installed
8201 # or if the installed version is too old. We cannot omit this
8202 # check, because if 'force' is in effect, nobody else will check.
8203 if (defined $available_file) {
8204 my(@all_requirements) = split /\s*,\s*/, $need_version;
8207 RQ: for my $rq (@all_requirements) {
8208 if ($rq =~ s|>=\s*||) {
8209 } elsif ($rq =~ s|>\s*||) {
8211 if (CPAN::Version->vgt($available_version,$rq)) {
8215 } elsif ($rq =~ s|!=\s*||) {
8217 if (CPAN::Version->vcmp($available_version,$rq)) {
8223 } elsif ($rq =~ m|<=?\s*|) {
8225 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8229 if (! CPAN::Version->vgt($rq, $available_version)) {
8232 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8233 "available_version[%s]rq[%s]ok[%d]",
8237 CPAN::Version->readable($rq),
8241 next NEED if $ok == @all_requirements;
8244 if ($need_module eq "perl") {
8245 return ["perl", $need_version];
8247 $self->{sponsored_mods}{$need_module} ||= 0;
8248 CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8249 if ($self->{sponsored_mods}{$need_module}++) {
8250 # We have already sponsored it and for some reason it's still
8251 # not available. So we do ... what??
8253 # if we push it again, we have a potential infinite loop
8255 # The following "next" was a very problematic construct.
8256 # It helped a lot but broke some day and had to be
8259 # We must be able to deal with modules that come again and
8260 # again as a prereq and have themselves prereqs and the
8261 # queue becomes long but finally we would find the correct
8262 # order. The RecursiveDependency check should trigger a
8263 # die when it's becoming too weird. Unfortunately removing
8264 # this next breaks many other things.
8266 # The bug that brought this up is described in Todo under
8267 # "5.8.9 cannot install Compress::Zlib"
8269 # next; # this is the next that had to go away
8271 # The following "next NEED" are fine and the error message
8272 # explains well what is going on. For example when the DBI
8273 # fails and consequently DBD::SQLite fails and now we are
8274 # processing CPAN::SQLite. Then we must have a "next" for
8275 # DBD::SQLite. How can we get it and how can we identify
8276 # all other cases we must identify?
8278 my $do = $nmo->distribution;
8279 next NEED unless $do; # not on CPAN
8280 if (CPAN::Version->vcmp($need_version, $nmo->{CPAN_VERSION}) > 0){
8281 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8282 "'$need_module => $need_version' ".
8283 "for '$self->{ID}' seems ".
8284 "not available according the the indexes\n"
8288 NOSAYER: for my $nosayer (
8297 if ($do->{$nosayer}) {
8298 if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8299 $do->{$nosayer}->failed :
8300 $do->{$nosayer} =~ /^NO/) {
8301 if ($nosayer eq "make_test"
8303 $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8307 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8308 "'$need_module => $need_version' ".
8309 "for '$self->{ID}' failed when ".
8310 "processing '$do->{ID}' with ".
8311 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8312 "but chances to succeed are limited.\n"
8315 } else { # the other guy succeeded
8316 if ($nosayer eq "install") {
8318 # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8320 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8321 "'$need_module => $need_version' ".
8322 "for '$self->{ID}' already installed ".
8323 "but installation looks suspicious. ".
8324 "Skipping another installation attempt, ".
8325 "to prevent looping endlessly.\n"
8333 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8334 push @need, [$need_module,$needed_as];
8336 my @unfolded = map { "[".join(",",@$_)."]" } @need;
8337 CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
8341 #-> sub CPAN::Distribution::read_yaml ;
8344 return $self->{yaml_content} if exists $self->{yaml_content};
8345 my $build_dir = $self->{build_dir};
8346 my $yaml = File::Spec->catfile($build_dir,"META.yml");
8347 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
8348 return unless -f $yaml;
8349 eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
8351 $CPAN::Frontend->mywarn("Could not read ".
8352 "'$yaml'. Falling back to other ".
8353 "methods to determine prerequisites\n");
8354 return $self->{yaml_content} = undef; # if we die, then we
8355 # cannot read YAML's own
8358 # not "authoritative"
8359 if (not exists $self->{yaml_content}{dynamic_config}
8360 or $self->{yaml_content}{dynamic_config}
8362 $self->{yaml_content} = undef;
8364 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8366 return $self->{yaml_content};
8369 #-> sub CPAN::Distribution::prereq_pm ;
8372 $self->{prereq_pm_detected} ||= 0;
8373 CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
8374 return $self->{prereq_pm} if $self->{prereq_pm_detected};
8375 return unless $self->{writemakefile} # no need to have succeeded
8376 # but we must have run it
8377 || $self->{modulebuild};
8378 CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8379 $self->{writemakefile}||"",
8380 $self->{modulebuild}||"",
8383 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8384 $req = $yaml->{requires} || {};
8385 $breq = $yaml->{build_requires} || {};
8386 undef $req unless ref $req eq "HASH" && %$req;
8388 if ($yaml->{generated_by} &&
8389 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
8390 my $eummv = do { local $^W = 0; $1+0; };
8391 if ($eummv < 6.2501) {
8392 # thanks to Slaven for digging that out: MM before
8393 # that could be wrong because it could reflect a
8400 while (my($k,$v) = each %{$req||{}}) {
8403 } elsif ($k =~ /[A-Za-z]/ &&
8405 $CPAN::META->exists("Module",$v)
8407 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8408 "requires hash: $k => $v; I'll take both ".
8409 "key and value as a module name\n");
8410 $CPAN::Frontend->mysleep(1);
8416 $req = $areq if $do_replace;
8419 unless ($req || $breq) {
8420 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8421 my $makefile = File::Spec->catfile($build_dir,"Makefile");
8425 $fh = FileHandle->new("<$makefile\0")) {
8426 CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
8429 last if /MakeMaker post_initialize section/;
8431 \s+PREREQ_PM\s+=>\s+(.+)
8434 # warn "Found prereq expr[$p]";
8436 # Regexp modified by A.Speer to remember actual version of file
8437 # PREREQ_PM hash key wants, then add to
8438 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
8439 # In case a prereq is mentioned twice, complain.
8440 if ( defined $req->{$1} ) {
8441 warn "Warning: PREREQ_PM mentions $1 more than once, ".
8442 "last mention wins";
8444 my($m,$n) = ($1,$2);
8445 if ($n =~ /^q\[(.*?)\]$/) {
8454 unless ($req || $breq) {
8455 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8456 my $buildfile = File::Spec->catfile($build_dir,"Build");
8457 if (-f $buildfile) {
8458 CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8459 my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8460 if (-f $build_prereqs) {
8461 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8462 my $content = do { local *FH;
8463 open FH, $build_prereqs
8464 or $CPAN::Frontend->mydie("Could not open ".
8465 "'$build_prereqs': $!");
8469 my $bphash = eval $content;
8472 $req = $bphash->{requires} || +{};
8473 $breq = $bphash->{build_requires} || +{};
8479 && ! -f "Makefile.PL"
8480 && ! exists $req->{"Module::Build"}
8481 && ! $CPAN::META->has_inst("Module::Build")) {
8482 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
8483 "undeclared prerequisite.\n".
8484 " Adding it now as such.\n"
8486 $CPAN::Frontend->mysleep(5);
8487 $req->{"Module::Build"} = 0;
8488 delete $self->{writemakefile};
8490 if ($req || $breq) {
8491 $self->{prereq_pm_detected}++;
8492 return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8496 #-> sub CPAN::Distribution::test ;
8499 if (my $goto = $self->prefs->{goto}) {
8500 return $self->goto($goto);
8503 if ($CPAN::Signal) {
8504 delete $self->{force_update};
8507 # warn "XDEBUG: checking for notest: $self->{notest} $self";
8508 if ($self->{notest}) {
8509 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8513 my $make = $self->{modulebuild} ? "Build" : "make";
8515 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8517 : ($ENV{PERLLIB} || "");
8519 $CPAN::META->set_perl5lib;
8520 local $ENV{MAKEFLAGS}; # protect us from outer make calls
8522 $CPAN::Frontend->myprint("Running $make test\n");
8526 if ($self->{make} or $self->{later}) {
8530 "Make had some problems, won't test";
8533 exists $self->{make} and
8535 UNIVERSAL::can($self->{make},"failed") ?
8536 $self->{make}->failed :
8537 $self->{make} =~ /^NO/
8538 ) and push @e, "Can't test without successful make";
8539 $self->{badtestcnt} ||= 0;
8540 if ($self->{badtestcnt} > 0) {
8541 require Data::Dumper;
8542 CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8543 push @e, "Won't repeat unsuccessful test during this command";
8546 push @e, $self->{later} if $self->{later};
8547 push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8549 if (exists $self->{build_dir}) {
8550 if (exists $self->{make_test}) {
8552 UNIVERSAL::can($self->{make_test},"failed") ?
8553 $self->{make_test}->failed :
8554 $self->{make_test} =~ /^NO/
8557 UNIVERSAL::can($self->{make_test},"commandid")
8559 $self->{make_test}->commandid == $CPAN::CurrentCommandId
8561 push @e, "Has already been tested within this command";
8564 push @e, "Has already been tested successfully";
8568 push @e, "Has no own directory";
8570 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
8571 unless (chdir $self->{build_dir}) {
8572 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8574 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
8576 $self->debug("Changed directory to $self->{build_dir}")
8579 if ($^O eq 'MacOS') {
8580 Mac::BuildTools::make_test($self);
8584 if ($self->{modulebuild}) {
8585 my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8586 if (CPAN::Version->vlt($v,2.62)) {
8587 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8588 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8589 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8595 my $prefs_test = $self->prefs->{test};
8597 = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
8598 $system = $commandline;
8599 $ENV{PERL} = CPAN::find_perl;
8600 } elsif ($self->{modulebuild}) {
8601 $system = sprintf "%s test", $self->_build_command();
8603 $system = join " ", $self->_make_command(), "test";
8605 my $make_test_arg = $self->make_x_arg("test");
8606 $system = sprintf("%s%s",
8608 $make_test_arg ? " $make_test_arg" : "",
8612 while (my($k,$v) = each %ENV) {
8613 next unless defined $v;
8617 if (my $env = $self->prefs->{test}{env}) {
8618 for my $e (keys %$env) {
8619 $ENV{$e} = $env->{$e};
8622 my $expect_model = $self->_prefs_with_expect("test");
8623 my $want_expect = 0;
8624 if ( $expect_model && @{$expect_model->{talk}} ) {
8625 my $can_expect = $CPAN::META->has_inst("Expect");
8629 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8630 "testing without\n");
8634 if ($self->_should_report('test')) {
8635 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8636 "not supported when distroprefs specify ".
8637 "an interactive test\n");
8639 $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8640 } elsif ( $self->_should_report('test') ) {
8641 $tests_ok = CPAN::Reporter::test($self, $system);
8643 $tests_ok = system($system) == 0;
8645 $self->introduce_myself;
8650 # local $CPAN::DEBUG = 16; # Distribution
8651 for my $m (keys %{$self->{sponsored_mods}}) {
8652 next unless $self->{sponsored_mods}{$m} > 0;
8653 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8654 # XXX we need available_version which reflects
8655 # $ENV{PERL5LIB} so that already tested but not yet
8656 # installed modules are counted.
8657 my $available_version = $m_obj->available_version;
8658 my $available_file = $m_obj->available_file;
8659 if ($available_version &&
8660 !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8662 CPAN->debug("m[$m] good enough available_version[$available_version]")
8664 } elsif ($available_file
8666 !$self->{prereq_pm}{$m}
8668 $self->{prereq_pm}{$m} == 0
8671 # lex Class::Accessor::Chained::Fast which has no $VERSION
8672 CPAN->debug("m[$m] have available_file[$available_file]")
8680 my $which = join ",", @prereq;
8681 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8682 "$cnt dependencies missing ($which)";
8683 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8684 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8685 $self->store_persistent_state;
8686 return $self->goodbye("[dependencies] -- NA");
8690 $CPAN::Frontend->myprint(" $system -- OK\n");
8691 $self->{make_test} = CPAN::Distrostatus->new("YES");
8692 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8693 # probably impossible to need the next line because badtestcnt
8694 # has a lifespan of one command
8695 delete $self->{badtestcnt};
8697 $self->{make_test} = CPAN::Distrostatus->new("NO");
8698 $self->{badtestcnt}++;
8699 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
8700 CPAN::Shell->optprint
8703 ("//hint// to see the cpan-testers results for installing this module, try:
8707 $self->store_persistent_state;
8710 sub _prefs_with_expect {
8711 my($self,$where) = @_;
8712 return unless my $prefs = $self->prefs;
8713 return unless my $where_prefs = $prefs->{$where};
8714 if ($where_prefs->{expect}) {
8716 mode => "deterministic",
8718 talk => $where_prefs->{expect},
8720 } elsif ($where_prefs->{"eexpect"}) {
8721 return $where_prefs->{"eexpect"};
8726 #-> sub CPAN::Distribution::clean ;
8729 my $make = $self->{modulebuild} ? "Build" : "make";
8730 $CPAN::Frontend->myprint("Running $make clean\n");
8731 unless (exists $self->{archived}) {
8732 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8733 "/untarred, nothing done\n");
8736 unless (exists $self->{build_dir}) {
8737 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8740 if (exists $self->{writemakefile}
8741 and $self->{writemakefile}->failed
8743 $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8748 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8749 push @e, "make clean already called once";
8750 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
8752 chdir $self->{build_dir} or
8753 Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8754 $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8756 if ($^O eq 'MacOS') {
8757 Mac::BuildTools::make_clean($self);
8762 if ($self->{modulebuild}) {
8763 unless (-f "Build") {
8764 my $cwd = CPAN::anycwd();
8765 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8766 " in cwd[$cwd]. Danger, Will Robinson!");
8767 $CPAN::Frontend->mysleep(5);
8769 $system = sprintf "%s clean", $self->_build_command();
8771 $system = join " ", $self->_make_command(), "clean";
8773 my $system_ok = system($system) == 0;
8774 $self->introduce_myself;
8776 $CPAN::Frontend->myprint(" $system -- OK\n");
8780 # Jost Krieger pointed out that this "force" was wrong because
8781 # it has the effect that the next "install" on this distribution
8782 # will untar everything again. Instead we should bring the
8783 # object's state back to where it is after untarring.
8794 $self->{make_clean} = CPAN::Distrostatus->new("YES");
8797 # Hmmm, what to do if make clean failed?
8799 $self->{make_clean} = CPAN::Distrostatus->new("NO");
8800 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
8802 # 2006-02-27: seems silly to me to force a make now
8803 # $self->force("make"); # so that this directory won't be used again
8806 $self->store_persistent_state;
8809 #-> sub CPAN::Distribution::goto ;
8811 my($self,$goto) = @_;
8812 $goto = $self->normalize($goto);
8814 "Goto '$goto' via prefs file '%s' doc %d",
8815 $self->{prefs_file},
8816 $self->{prefs_file_doc},
8818 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
8819 # 2007-07-16 akoenig : Better than NA would be if we could inherit
8820 # the status of the $goto distro but given the exceptional nature
8821 # of 'goto' I feel reluctant to implement it
8822 my $goodbye_message = "[goto] -- NA $why";
8823 $self->goodbye($goodbye_message);
8825 # inject into the queue
8827 CPAN::Queue->delete($self->id);
8828 CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
8830 # and run where we left off
8832 my($method) = (caller(1))[3];
8833 CPAN->instance("CPAN::Distribution",$goto)->$method();
8834 CPAN::Queue->delete_first($goto);
8837 #-> sub CPAN::Distribution::install ;
8840 if (my $goto = $self->prefs->{goto}) {
8841 return $self->goto($goto);
8844 unless ($self->{badtestcnt}) {
8847 if ($CPAN::Signal) {
8848 delete $self->{force_update};
8851 my $make = $self->{modulebuild} ? "Build" : "make";
8852 $CPAN::Frontend->myprint("Running $make install\n");
8855 if ($self->{make} or $self->{later}) {
8859 "Make had some problems, won't install";
8862 exists $self->{make} and
8864 UNIVERSAL::can($self->{make},"failed") ?
8865 $self->{make}->failed :
8866 $self->{make} =~ /^NO/
8868 push @e, "Make had returned bad status, install seems impossible";
8870 if (exists $self->{build_dir}) {
8872 push @e, "Has no own directory";
8875 if (exists $self->{make_test} and
8877 UNIVERSAL::can($self->{make_test},"failed") ?
8878 $self->{make_test}->failed :
8879 $self->{make_test} =~ /^NO/
8881 if ($self->{force_update}) {
8882 $self->{make_test}->text("FAILED but failure ignored because ".
8883 "'force' in effect");
8885 push @e, "make test had returned bad status, ".
8886 "won't install without force"
8889 if (exists $self->{install}) {
8890 if (UNIVERSAL::can($self->{install},"text") ?
8891 $self->{install}->text eq "YES" :
8892 $self->{install} =~ /^YES/
8894 $CPAN::Frontend->myprint(" Already done\n");
8895 $CPAN::META->is_installed($self->{build_dir});
8898 # comment in Todo on 2006-02-11; maybe retry?
8899 push @e, "Already tried without success";
8903 push @e, $self->{later} if $self->{later};
8904 push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
8906 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
8907 unless (chdir $self->{build_dir}) {
8908 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8910 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
8912 $self->debug("Changed directory to $self->{build_dir}")
8915 if ($^O eq 'MacOS') {
8916 Mac::BuildTools::make_install($self);
8921 if (my $commandline = $self->prefs->{install}{commandline}) {
8922 $system = $commandline;
8923 $ENV{PERL} = CPAN::find_perl;
8924 } elsif ($self->{modulebuild}) {
8925 my($mbuild_install_build_command) =
8926 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8927 $CPAN::Config->{mbuild_install_build_command} ?
8928 $CPAN::Config->{mbuild_install_build_command} :
8929 $self->_build_command();
8930 $system = sprintf("%s install %s",
8931 $mbuild_install_build_command,
8932 $CPAN::Config->{mbuild_install_arg},
8935 my($make_install_make_command) =
8936 CPAN::HandleConfig->prefs_lookup($self,
8937 q{make_install_make_command})
8938 || $self->_make_command();
8939 $system = sprintf("%s install %s",
8940 $make_install_make_command,
8941 $CPAN::Config->{make_install_arg},
8945 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8946 my $brip = CPAN::HandleConfig->prefs_lookup($self,
8947 q{build_requires_install_policy});
8950 my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8951 my $want_install = "yes";
8952 if ($reqtype eq "b") {
8953 if ($brip eq "no") {
8954 $want_install = "no";
8955 } elsif ($brip =~ m|^ask/(.+)|) {
8957 $default = "yes" unless $default =~ /^(y|n)/i;
8959 CPAN::Shell::colorable_makemaker_prompt
8960 ("$id is just needed temporarily during building or testing. ".
8961 "Do you want to install it permanently? (Y/n)",
8965 unless ($want_install =~ /^y/i) {
8966 my $is_only = "is only 'build_requires'";
8967 $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8968 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8969 delete $self->{force_update};
8972 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8974 : ($ENV{PERLLIB} || "");
8976 $CPAN::META->set_perl5lib;
8977 my($pipe) = FileHandle->new("$system $stderr |");
8980 print $_; # intentionally NOT use Frontend->myprint because it
8981 # looks irritating when we markup in color what we
8982 # just pass through from an external program
8986 my $close_ok = $? == 0;
8987 $self->introduce_myself;
8989 $CPAN::Frontend->myprint(" $system -- OK\n");
8990 $CPAN::META->is_installed($self->{build_dir});
8991 $self->{install} = CPAN::Distrostatus->new("YES");
8993 $self->{install} = CPAN::Distrostatus->new("NO");
8994 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
8996 CPAN::HandleConfig->prefs_lookup($self,
8997 q{make_install_make_command});
8999 $makeout =~ /permission/s
9003 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9007 $CPAN::Frontend->myprint(
9009 qq{ You may have to su }.
9010 qq{to root to install the package\n}.
9011 qq{ (Or you may want to run something like\n}.
9012 qq{ o conf make_install_make_command 'sudo make'\n}.
9013 qq{ to raise your permissions.}
9017 delete $self->{force_update};
9019 $self->store_persistent_state;
9022 sub introduce_myself {
9024 $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
9027 #-> sub CPAN::Distribution::dir ;
9032 #-> sub CPAN::Distribution::perldoc ;
9036 my($dist) = $self->id;
9037 my $package = $self->called_for;
9039 $self->_display_url( $CPAN::Defaultdocs . $package );
9042 #-> sub CPAN::Distribution::_check_binary ;
9044 my ($dist,$shell,$binary) = @_;
9047 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9050 if ($CPAN::META->has_inst("File::Which")) {
9051 return File::Which::which($binary);
9054 $pid = open README, "which $binary|"
9055 or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9061 or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9065 $CPAN::Frontend->myprint(qq{ + $out \n})
9066 if $CPAN::DEBUG && $out;
9071 #-> sub CPAN::Distribution::_display_url ;
9073 my($self,$url) = @_;
9074 my($res,$saved_file,$pid,$out);
9076 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9079 # should we define it in the config instead?
9080 my $html_converter = "html2text.pl";
9082 my $web_browser = $CPAN::Config->{'lynx'} || undef;
9083 my $web_browser_out = $web_browser
9084 ? CPAN::Distribution->_check_binary($self,$web_browser)
9087 if ($web_browser_out) {
9088 # web browser found, run the action
9089 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
9090 $CPAN::Frontend->myprint(qq{system[$browser $url]})
9092 $CPAN::Frontend->myprint(qq{
9095 with browser $browser
9097 $CPAN::Frontend->mysleep(1);
9098 system("$browser $url");
9099 if ($saved_file) { 1 while unlink($saved_file) }
9101 # web browser not found, let's try text only
9102 my $html_converter_out =
9103 CPAN::Distribution->_check_binary($self,$html_converter);
9104 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
9106 if ($html_converter_out ) {
9107 # html2text found, run it
9108 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
9109 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9110 unless defined($saved_file);
9113 $pid = open README, "$html_converter $saved_file |"
9114 or $CPAN::Frontend->mydie(qq{
9115 Could not fork '$html_converter $saved_file': $!});
9117 if ($CPAN::META->has_usable("File::Temp")) {
9118 $fh = File::Temp->new(
9119 dir => File::Spec->tmpdir,
9120 template => 'cpan_htmlconvert_XXXX',
9124 $filename = $fh->filename;
9126 $filename = "cpan_htmlconvert_$$.txt";
9127 $fh = FileHandle->new();
9128 open $fh, ">$filename" or die;
9134 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
9135 my $tmpin = $fh->filename;
9136 $CPAN::Frontend->myprint(sprintf(qq{
9138 saved output to %s\n},
9146 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
9147 my $fh_pager = FileHandle->new;
9148 local($SIG{PIPE}) = "IGNORE";
9149 my $pager = $CPAN::Config->{'pager'} || "cat";
9150 $fh_pager->open("|$pager")
9151 or $CPAN::Frontend->mydie(qq{
9152 Could not open pager '$pager': $!});
9153 $CPAN::Frontend->myprint(qq{
9158 $CPAN::Frontend->mysleep(1);
9159 $fh_pager->print(<FH>);
9162 # coldn't find the web browser or html converter
9163 $CPAN::Frontend->myprint(qq{
9164 You need to install lynx or $html_converter to use this feature.});
9169 #-> sub CPAN::Distribution::_getsave_url ;
9171 my($dist, $shell, $url) = @_;
9173 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9177 if ($CPAN::META->has_usable("File::Temp")) {
9178 $fh = File::Temp->new(
9179 dir => File::Spec->tmpdir,
9180 template => "cpan_getsave_url_XXXX",
9184 $filename = $fh->filename;
9186 $fh = FileHandle->new;
9187 $filename = "cpan_getsave_url_$$.html";
9189 my $tmpin = $filename;
9190 if ($CPAN::META->has_usable('LWP')) {
9191 $CPAN::Frontend->myprint("Fetching with LWP:
9195 CPAN::LWP::UserAgent->config;
9196 eval { $Ua = CPAN::LWP::UserAgent->new; };
9198 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9202 $Ua->proxy('http', $var)
9203 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
9205 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
9208 my $req = HTTP::Request->new(GET => $url);
9209 $req->header('Accept' => 'text/html');
9210 my $res = $Ua->request($req);
9211 if ($res->is_success) {
9212 $CPAN::Frontend->myprint(" + request successful.\n")
9214 print $fh $res->content;
9216 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9220 $CPAN::Frontend->myprint(sprintf(
9221 "LWP failed with code[%s], message[%s]\n",
9228 $CPAN::Frontend->mywarn(" LWP not available\n");
9233 #-> sub CPAN::Distribution::_build_command
9234 sub _build_command {
9236 if ($^O eq "MSWin32") { # special code needed at least up to
9237 # Module::Build 0.2611 and 0.2706; a fix
9238 # in M:B has been promised 2006-01-30
9239 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9240 return "$perl ./Build";
9245 #-> sub CPAN::Distribution::_should_report
9246 sub _should_report {
9247 my($self, $phase) = @_;
9248 die "_should_report() requires a 'phase' argument"
9249 if ! defined $phase;
9252 my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9254 return unless $test_report;
9256 # don't repeat if we cached a result
9257 return $self->{should_report}
9258 if exists $self->{should_report};
9261 if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9262 $CPAN::Frontend->mywarn(
9263 "CPAN::Reporter not installed. No reports will be sent.\n"
9265 return $self->{should_report} = 0;
9269 my $crv = CPAN::Reporter->VERSION;
9270 if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9271 # don't cache $self->{should_report} -- need to check each phase
9272 if ( $phase eq 'test' ) {
9276 $CPAN::Frontend->mywarn(
9277 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9278 "you only have version $crv\. Only 'test' phase reports will be sent.\n"
9285 if ($self->is_dot_dist) {
9286 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9287 "for local directories\n");
9288 return $self->{should_report} = 0;
9290 if ($self->prefs->{patches}
9292 @{$self->prefs->{patches}}
9296 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9297 "when the source has been patched\n");
9298 return $self->{should_report} = 0;
9301 # proceed and cache success
9302 return $self->{should_report} = 1;
9305 #-> sub CPAN::Distribution::reports
9308 my $pathname = $self->id;
9309 $CPAN::Frontend->myprint("Distribution: $pathname\n");
9311 unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9312 $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9314 unless ($CPAN::META->has_usable("LWP")) {
9315 $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9317 unless ($CPAN::META->has_usable("File::Temp")) {
9318 $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9321 my $d = CPAN::DistnameInfo->new($pathname);
9323 my $dist = $d->dist; # "CPAN-DistnameInfo"
9324 my $version = $d->version; # "0.02"
9325 my $maturity = $d->maturity; # "released"
9326 my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
9327 my $cpanid = $d->cpanid; # "GBARR"
9328 my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9330 my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9332 CPAN::LWP::UserAgent->config;
9334 eval { $Ua = CPAN::LWP::UserAgent->new; };
9336 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9338 $CPAN::Frontend->myprint("Fetching '$url'...");
9339 my $resp = $Ua->get($url);
9340 unless ($resp->is_success) {
9341 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9343 $CPAN::Frontend->myprint("DONE\n\n");
9344 my $yaml = $resp->content;
9345 # was fuer ein Umweg!
9346 my $fh = File::Temp->new(
9347 dir => File::Spec->tmpdir,
9348 template => 'cpan_reports_XXXX',
9352 my $tfilename = $fh->filename;
9354 close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9355 my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9356 unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9358 my $this_version_seen;
9359 for my $rep (@$unserialized) {
9360 my $rversion = $rep->{version};
9361 if ($rversion eq $version) {
9362 unless ($this_version_seen++) {
9363 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9365 $CPAN::Frontend->myprint
9366 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9367 $rep->{archname} eq $Config::Config{archname}?"*":"",
9368 $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9371 ucfirst $rep->{osname},
9376 $other_versions{$rep->{version}}++;
9379 unless ($this_version_seen) {
9380 $CPAN::Frontend->myprint("No reports found for version '$version'
9381 Reports for other versions:\n");
9382 for my $v (sort keys %other_versions) {
9383 $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9386 $url =~ s/\.yaml/.html/;
9387 $CPAN::Frontend->myprint("See $url for details\n");
9390 package CPAN::Bundle;
9395 $CPAN::Frontend->myprint($self->as_string);
9398 #-> CPAN::Bundle::undelay
9401 delete $self->{later};
9402 for my $c ( $self->contains ) {
9403 my $obj = CPAN::Shell->expandany($c) or next;
9408 # mark as dirty/clean
9409 #-> sub CPAN::Bundle::color_cmd_tmps ;
9410 sub color_cmd_tmps {
9412 my($depth) = shift || 0;
9413 my($color) = shift || 0;
9414 my($ancestors) = shift || [];
9415 # a module needs to recurse to its cpan_file, a distribution needs
9416 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9418 return if exists $self->{incommandcolor}
9420 && $self->{incommandcolor}==$color;
9421 if ($depth>=$CPAN::MAX_RECURSION) {
9422 die(CPAN::Exception::RecursiveDependency->new($ancestors));
9424 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9426 for my $c ( $self->contains ) {
9427 my $obj = CPAN::Shell->expandany($c) or next;
9428 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
9429 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9431 # never reached code?
9433 #delete $self->{badtestcnt};
9435 $self->{incommandcolor} = $color;
9438 #-> sub CPAN::Bundle::as_string ;
9442 # following line must be "=", not "||=" because we have a moving target
9443 $self->{INST_VERSION} = $self->inst_version;
9444 return $self->SUPER::as_string;
9447 #-> sub CPAN::Bundle::contains ;
9450 my($inst_file) = $self->inst_file || "";
9451 my($id) = $self->id;
9452 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
9453 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9456 unless ($inst_file) {
9457 # Try to get at it in the cpan directory
9458 $self->debug("no inst_file") if $CPAN::DEBUG;
9460 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9461 $cpan_file = $self->cpan_file;
9462 if ($cpan_file eq "N/A") {
9463 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9464 Maybe stale symlink? Maybe removed during session? Giving up.\n");
9466 my $dist = $CPAN::META->instance('CPAN::Distribution',
9468 $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
9470 $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
9471 my($todir) = $CPAN::Config->{'cpan_home'};
9472 my(@me,$from,$to,$me);
9473 @me = split /::/, $self->id;
9475 $me = File::Spec->catfile(@me);
9476 $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
9477 $to = File::Spec->catfile($todir,$me);
9478 File::Path::mkpath(File::Basename::dirname($to));
9479 File::Copy::copy($from, $to)
9480 or Carp::confess("Couldn't copy $from to $to: $!");
9484 my $fh = FileHandle->new;
9486 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9488 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9490 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
9491 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
9492 next unless $in_cont;
9497 push @result, (split " ", $_, 2)[0];
9500 delete $self->{STATUS};
9501 $self->{CONTAINS} = \@result;
9502 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9504 $CPAN::Frontend->mywarn(qq{
9505 The bundle file "$inst_file" may be a broken
9506 bundlefile. It seems not to contain any bundle definition.
9507 Please check the file and if it is bogus, please delete it.
9508 Sorry for the inconvenience.
9514 #-> sub CPAN::Bundle::find_bundle_file
9515 # $where is in local format, $what is in unix format
9516 sub find_bundle_file {
9517 my($self,$where,$what) = @_;
9518 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
9519 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
9520 ### my $bu = File::Spec->catfile($where,$what);
9521 ### return $bu if -f $bu;
9522 my $manifest = File::Spec->catfile($where,"MANIFEST");
9523 unless (-f $manifest) {
9524 require ExtUtils::Manifest;
9525 my $cwd = CPAN::anycwd();
9526 $self->safe_chdir($where);
9527 ExtUtils::Manifest::mkmanifest();
9528 $self->safe_chdir($cwd);
9530 my $fh = FileHandle->new($manifest)
9531 or Carp::croak("Couldn't open $manifest: $!");
9533 my $bundle_filename = $what;
9534 $bundle_filename =~ s|Bundle.*/||;
9535 my $bundle_unixpath;
9538 my($file) = /(\S+)/;
9539 if ($file =~ m|\Q$what\E$|) {
9540 $bundle_unixpath = $file;
9541 # return File::Spec->catfile($where,$bundle_unixpath); # bad
9544 # retry if she managed to have no Bundle directory
9545 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
9547 return File::Spec->catfile($where, split /\//, $bundle_unixpath)
9548 if $bundle_unixpath;
9549 Carp::croak("Couldn't find a Bundle file in $where");
9552 # needs to work quite differently from Module::inst_file because of
9553 # cpan_home/Bundle/ directory and the possibility that we have
9554 # shadowing effect. As it makes no sense to take the first in @INC for
9555 # Bundles, we parse them all for $VERSION and take the newest.
9557 #-> sub CPAN::Bundle::inst_file ;
9562 @me = split /::/, $self->id;
9565 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
9566 my $bfile = File::Spec->catfile($incdir, @me);
9567 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
9568 next unless -f $bfile;
9569 my $foundv = MM->parse_version($bfile);
9570 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
9571 $self->{INST_FILE} = $bfile;
9572 $self->{INST_VERSION} = $bestv = $foundv;
9578 #-> sub CPAN::Bundle::inst_version ;
9581 $self->inst_file; # finds INST_VERSION as side effect
9582 $self->{INST_VERSION};
9585 #-> sub CPAN::Bundle::rematein ;
9587 my($self,$meth) = @_;
9588 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
9589 my($id) = $self->id;
9590 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9591 unless $self->inst_file || $self->cpan_file;
9593 for $s ($self->contains) {
9594 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9595 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9596 if ($type eq 'CPAN::Distribution') {
9597 $CPAN::Frontend->mywarn(qq{
9598 The Bundle }.$self->id.qq{ contains
9599 explicitly a file '$s'.
9600 Going to $meth that.
9602 $CPAN::Frontend->mysleep(5);
9604 # possibly noisy action:
9605 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9606 my $obj = $CPAN::META->instance($type,$s);
9607 $obj->{reqtype} = $self->{reqtype};
9612 # If a bundle contains another that contains an xs_file we have here,
9613 # we just don't bother I suppose
9614 #-> sub CPAN::Bundle::xs_file
9619 #-> sub CPAN::Bundle::force ;
9620 sub fforce { shift->rematein('fforce',@_); }
9621 #-> sub CPAN::Bundle::force ;
9622 sub force { shift->rematein('force',@_); }
9623 #-> sub CPAN::Bundle::notest ;
9624 sub notest { shift->rematein('notest',@_); }
9625 #-> sub CPAN::Bundle::get ;
9626 sub get { shift->rematein('get',@_); }
9627 #-> sub CPAN::Bundle::make ;
9628 sub make { shift->rematein('make',@_); }
9629 #-> sub CPAN::Bundle::test ;
9632 # $self->{badtestcnt} ||= 0;
9633 $self->rematein('test',@_);
9635 #-> sub CPAN::Bundle::install ;
9638 $self->rematein('install',@_);
9640 #-> sub CPAN::Bundle::clean ;
9641 sub clean { shift->rematein('clean',@_); }
9643 #-> sub CPAN::Bundle::uptodate ;
9646 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9648 foreach $c ($self->contains) {
9649 my $obj = CPAN::Shell->expandany($c);
9650 return 0 unless $obj->uptodate;
9655 #-> sub CPAN::Bundle::readme ;
9658 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9659 No File found for bundle } . $self->id . qq{\n}), return;
9660 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9661 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9664 package CPAN::Module;
9668 #-> sub CPAN::Module::userid
9673 return $ro->{userid} || $ro->{CPAN_USERID};
9675 #-> sub CPAN::Module::description
9678 my $ro = $self->ro or return "";
9682 #-> sub CPAN::Module::distribution
9685 CPAN::Shell->expand("Distribution",$self->cpan_file);
9688 #-> sub CPAN::Module::undelay
9691 delete $self->{later};
9692 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9697 # mark as dirty/clean
9698 #-> sub CPAN::Module::color_cmd_tmps ;
9699 sub color_cmd_tmps {
9701 my($depth) = shift || 0;
9702 my($color) = shift || 0;
9703 my($ancestors) = shift || [];
9704 # a module needs to recurse to its cpan_file
9706 return if exists $self->{incommandcolor}
9708 && $self->{incommandcolor}==$color;
9709 return if $color==0 && !$self->{incommandcolor};
9711 if ( $self->uptodate ) {
9712 $self->{incommandcolor} = $color;
9714 } elsif (my $have_version = $self->available_version) {
9715 # maybe what we have is good enough
9717 my $who_asked_for_me = $ancestors->[-1];
9718 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9720 } elsif ($obj->isa("CPAN::Bundle")) {
9721 # bundles cannot specify a minimum version
9723 } elsif ($obj->isa("CPAN::Distribution")) {
9724 if (my $prereq_pm = $obj->prereq_pm) {
9725 for my $k (keys %$prereq_pm) {
9726 if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9727 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9728 $self->{incommandcolor} = $color;
9738 $self->{incommandcolor} = $color; # set me before recursion,
9739 # so we can break it
9741 if ($depth>=$CPAN::MAX_RECURSION) {
9742 die(CPAN::Exception::RecursiveDependency->new($ancestors));
9744 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9746 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9747 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9751 # delete $self->{badtestcnt};
9753 $self->{incommandcolor} = $color;
9756 #-> sub CPAN::Module::as_glimpse ;
9760 my $class = ref($self);
9761 $class =~ s/^CPAN:://;
9765 $CPAN::Shell::COLOR_REGISTERED
9767 $CPAN::META->has_inst("Term::ANSIColor")
9771 $color_on = Term::ANSIColor::color("green");
9772 $color_off = Term::ANSIColor::color("reset");
9774 my $uptodateness = " ";
9775 unless ($class eq "Bundle") {
9776 my $u = $self->uptodate;
9777 $uptodateness = $u ? "=" : "<" if defined $u;
9780 my $d = $self->distribution;
9781 $d ? $d -> pretty_id : $self->cpan_userid;
9783 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9794 #-> sub CPAN::Module::dslip_status
9798 # development status
9799 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
9800 pre-alpha alpha beta released
9803 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
9804 developer comp.lang.perl.*
9807 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
9809 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
9811 object-oriented pragma
9814 @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
9816 BSD Artistic Artistic_2
9818 distribution_allowed
9819 restricted_distribution
9821 for my $x (qw(d s l i p)) {
9822 $stat->{$x}{' '} = 'unknown';
9823 $stat->{$x}{'?'} = 'unknown';
9826 return +{} unless $ro && $ro->{statd};
9833 DV => $stat->{D}{$ro->{statd}},
9834 SV => $stat->{S}{$ro->{stats}},
9835 LV => $stat->{L}{$ro->{statl}},
9836 IV => $stat->{I}{$ro->{stati}},
9837 PV => $stat->{P}{$ro->{statp}},
9841 #-> sub CPAN::Module::as_string ;
9845 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9846 my $class = ref($self);
9847 $class =~ s/^CPAN:://;
9849 push @m, $class, " id = $self->{ID}\n";
9850 my $sprintf = " %-12s %s\n";
9851 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9852 if $self->description;
9853 my $sprintf2 = " %-12s %s (%s)\n";
9855 $userid = $self->userid;
9858 if ($author = CPAN::Shell->expand('Author',$userid)) {
9861 if ($m = $author->email) {
9868 $author->fullname . $email
9872 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9873 if $self->cpan_version;
9874 if (my $cpan_file = $self->cpan_file) {
9875 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9876 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9877 my $upload_date = $dist->upload_date;
9879 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9883 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9884 my $dslip = $self->dslip_status;
9888 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9890 my $local_file = $self->inst_file;
9891 unless ($self->{MANPAGE}) {
9894 $manpage = $self->manpage_headline($local_file);
9896 # If we have already untarred it, we should look there
9897 my $dist = $CPAN::META->instance('CPAN::Distribution',
9899 # warn "dist[$dist]";
9900 # mff=manifest file; mfh=manifest handle
9905 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9907 $mfh = FileHandle->new($mff)
9909 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9910 my $lfre = $self->id; # local file RE
9913 my($lfl); # local file file
9915 my(@mflines) = <$mfh>;
9920 while (length($lfre)>5 and !$lfl) {
9921 ($lfl) = grep /$lfre/, @mflines;
9922 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9925 $lfl =~ s/\s.*//; # remove comments
9926 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9927 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9928 # warn "lfl_abs[$lfl_abs]";
9930 $manpage = $self->manpage_headline($lfl_abs);
9934 $self->{MANPAGE} = $manpage if $manpage;
9937 for $item (qw/MANPAGE/) {
9938 push @m, sprintf($sprintf, $item, $self->{$item})
9939 if exists $self->{$item};
9941 for $item (qw/CONTAINS/) {
9942 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9943 if exists $self->{$item} && @{$self->{$item}};
9945 push @m, sprintf($sprintf, 'INST_FILE',
9946 $local_file || "(not installed)");
9947 push @m, sprintf($sprintf, 'INST_VERSION',
9948 $self->inst_version) if $local_file;
9952 #-> sub CPAN::Module::manpage_headline
9953 sub manpage_headline {
9954 my($self,$local_file) = @_;
9955 my(@local_file) = $local_file;
9956 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9957 push @local_file, $local_file;
9959 for $locf (@local_file) {
9960 next unless -f $locf;
9961 my $fh = FileHandle->new($locf)
9962 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9966 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9967 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9984 #-> sub CPAN::Module::cpan_file ;
9985 # Note: also inherited by CPAN::Bundle
9988 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9989 unless ($self->ro) {
9990 CPAN::Index->reload;
9993 if ($ro && defined $ro->{CPAN_FILE}) {
9994 return $ro->{CPAN_FILE};
9996 my $userid = $self->userid;
9998 if ($CPAN::META->exists("CPAN::Author",$userid)) {
9999 my $author = $CPAN::META->instance("CPAN::Author",
10001 my $fullname = $author->fullname;
10002 my $email = $author->email;
10003 unless (defined $fullname && defined $email) {
10004 return sprintf("Contact Author %s",
10008 return "Contact Author $fullname <$email>";
10010 return "Contact Author $userid (Email address not available)";
10018 #-> sub CPAN::Module::cpan_version ;
10022 my $ro = $self->ro;
10024 # Can happen with modules that are not on CPAN
10027 $ro->{CPAN_VERSION} = 'undef'
10028 unless defined $ro->{CPAN_VERSION};
10029 $ro->{CPAN_VERSION};
10032 #-> sub CPAN::Module::force ;
10035 $self->{force_update} = 1;
10038 #-> sub CPAN::Module::fforce ;
10041 $self->{force_update} = 2;
10044 #-> sub CPAN::Module::notest ;
10047 # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10051 #-> sub CPAN::Module::rematein ;
10053 my($self,$meth) = @_;
10054 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
10057 my $cpan_file = $self->cpan_file;
10058 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10059 $CPAN::Frontend->mywarn(sprintf qq{
10060 The module %s isn\'t available on CPAN.
10062 Either the module has not yet been uploaded to CPAN, or it is
10063 temporary unavailable. Please contact the author to find out
10064 more about the status. Try 'i %s'.
10071 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10072 $pack->called_for($self->id);
10073 if (exists $self->{force_update}) {
10074 if ($self->{force_update} == 2) {
10075 $pack->fforce($meth);
10077 $pack->force($meth);
10080 $pack->notest($meth) if exists $self->{notest} && $self->{notest};
10082 $pack->{reqtype} ||= "";
10083 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10084 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10085 if ($pack->{reqtype}) {
10086 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10087 $pack->{reqtype} = $self->{reqtype};
10089 exists $pack->{install}
10092 UNIVERSAL::can($pack->{install},"failed") ?
10093 $pack->{install}->failed :
10094 $pack->{install} =~ /^NO/
10097 delete $pack->{install};
10098 $CPAN::Frontend->mywarn
10099 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10103 $pack->{reqtype} = $self->{reqtype};
10106 my $success = eval {
10110 $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
10111 $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
10112 delete $self->{force_update};
10113 delete $self->{notest};
10120 #-> sub CPAN::Module::perldoc ;
10121 sub perldoc { shift->rematein('perldoc') }
10122 #-> sub CPAN::Module::readme ;
10123 sub readme { shift->rematein('readme') }
10124 #-> sub CPAN::Module::look ;
10125 sub look { shift->rematein('look') }
10126 #-> sub CPAN::Module::cvs_import ;
10127 sub cvs_import { shift->rematein('cvs_import') }
10128 #-> sub CPAN::Module::get ;
10129 sub get { shift->rematein('get',@_) }
10130 #-> sub CPAN::Module::make ;
10131 sub make { shift->rematein('make') }
10132 #-> sub CPAN::Module::test ;
10135 # $self->{badtestcnt} ||= 0;
10136 $self->rematein('test',@_);
10138 #-> sub CPAN::Module::uptodate ;
10142 my $inst = $self->inst_version or return undef;
10143 my $cpan = $self->cpan_version;
10145 CPAN::Version->vgt($cpan,$inst) and return 0;
10146 CPAN->debug(join("",
10147 "returning uptodate. inst_file[",
10149 "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10152 #-> sub CPAN::Module::install ;
10156 if ($self->uptodate
10158 not exists $self->{force_update}
10160 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
10162 $self->inst_version,
10167 my $ro = $self->ro;
10168 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
10169 $CPAN::Frontend->mywarn(qq{
10170 \n\n\n ***WARNING***
10171 The module $self->{ID} has no active maintainer.\n\n\n
10173 $CPAN::Frontend->mysleep(5);
10175 $self->rematein('install') if $doit;
10177 #-> sub CPAN::Module::clean ;
10178 sub clean { shift->rematein('clean') }
10180 #-> sub CPAN::Module::inst_file ;
10183 $self->_file_in_path([@INC]);
10186 #-> sub CPAN::Module::available_file ;
10187 sub available_file {
10189 my $sep = $Config::Config{path_sep};
10190 my $perllib = $ENV{PERL5LIB};
10191 $perllib = $ENV{PERLLIB} unless defined $perllib;
10192 my @perllib = split(/$sep/,$perllib) if defined $perllib;
10193 $self->_file_in_path([@perllib,@INC]);
10196 #-> sub CPAN::Module::file_in_path ;
10197 sub _file_in_path {
10198 my($self,$path) = @_;
10199 my($dir,@packpath);
10200 @packpath = split /::/, $self->{ID};
10201 $packpath[-1] .= ".pm";
10202 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10203 unshift @packpath, "Term", "ReadLine"; # historical reasons
10205 foreach $dir (@$path) {
10206 my $pmfile = File::Spec->catfile($dir,@packpath);
10214 #-> sub CPAN::Module::xs_file ;
10217 my($dir,@packpath);
10218 @packpath = split /::/, $self->{ID};
10219 push @packpath, $packpath[-1];
10220 $packpath[-1] .= "." . $Config::Config{'dlext'};
10221 foreach $dir (@INC) {
10222 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10230 #-> sub CPAN::Module::inst_version ;
10233 my $parsefile = $self->inst_file or return;
10234 my $have = $self->parse_version($parsefile);
10238 #-> sub CPAN::Module::inst_version ;
10239 sub available_version {
10241 my $parsefile = $self->available_file or return;
10242 my $have = $self->parse_version($parsefile);
10246 #-> sub CPAN::Module::parse_version ;
10247 sub parse_version {
10248 my($self,$parsefile) = @_;
10249 my $have = MM->parse_version($parsefile);
10250 $have = "undef" unless defined $have && length $have;
10251 $have =~ s/^ //; # since the %vd hack these two lines here are needed
10252 $have =~ s/ $//; # trailing whitespace happens all the time
10254 $have = CPAN::Version->readable($have);
10256 $have =~ s/\s*//g; # stringify to float around floating point issues
10257 $have; # no stringify needed, \s* above matches always
10260 #-> sub CPAN::Module::reports
10263 $self->distribution->reports;
10276 CPAN - query, download and build perl modules from CPAN sites
10282 perl -MCPAN -e shell
10292 cpan> install Acme::Meta # in the shell
10294 CPAN::Shell->install("Acme::Meta"); # in perl
10298 cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
10301 install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
10305 $mo = CPAN::Shell->expandany($mod);
10306 $mo = CPAN::Shell->expand("Module",$mod); # same thing
10308 # distribution objects:
10310 $do = CPAN::Shell->expand("Module",$mod)->distribution;
10311 $do = CPAN::Shell->expandany($distro); # same thing
10312 $do = CPAN::Shell->expand("Distribution",
10313 $distro); # same thing
10317 The CPAN module automates or at least simplifies the make and install
10318 of perl modules and extensions. It includes some primitive searching
10319 capabilities and knows how to use Net::FTP or LWP or some external
10320 download clients to fetch the distributions from the net.
10322 These are fetched from one or more of the mirrored CPAN (Comprehensive
10323 Perl Archive Network) sites and unpacked in a dedicated directory.
10325 The CPAN module also supports the concept of named and versioned
10326 I<bundles> of modules. Bundles simplify the handling of sets of
10327 related modules. See Bundles below.
10329 The package contains a session manager and a cache manager. The
10330 session manager keeps track of what has been fetched, built and
10331 installed in the current session. The cache manager keeps track of the
10332 disk space occupied by the make processes and deletes excess space
10333 according to a simple FIFO mechanism.
10335 All methods provided are accessible in a programmer style and in an
10336 interactive shell style.
10338 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
10340 The interactive mode is entered by running
10342 perl -MCPAN -e shell
10348 which puts you into a readline interface. If C<Term::ReadKey> and
10349 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10350 it supports both history and command completion.
10352 Once you are on the command line, type C<h> to get a one page help
10353 screen and the rest should be self-explanatory.
10355 The function call C<shell> takes two optional arguments, one is the
10356 prompt, the second is the default initial command line (the latter
10357 only works if a real ReadLine interface module is installed).
10359 The most common uses of the interactive modes are
10363 =item Searching for authors, bundles, distribution files and modules
10365 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
10366 for each of the four categories and another, C<i> for any of the
10367 mentioned four. Each of the four entities is implemented as a class
10368 with slightly differing methods for displaying an object.
10370 Arguments you pass to these commands are either strings exactly matching
10371 the identification string of an object or regular expressions that are
10372 then matched case-insensitively against various attributes of the
10373 objects. The parser recognizes a regular expression only if you
10374 enclose it between two slashes.
10376 The principle is that the number of found objects influences how an
10377 item is displayed. If the search finds one item, the result is
10378 displayed with the rather verbose method C<as_string>, but if we find
10379 more than one, we display each object with the terse method
10382 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10384 These commands take any number of arguments and investigate what is
10385 necessary to perform the action. If the argument is a distribution
10386 file name (recognized by embedded slashes), it is processed. If it is
10387 a module, CPAN determines the distribution file in which this module
10388 is included and processes that, following any dependencies named in
10389 the module's META.yml or Makefile.PL (this behavior is controlled by
10390 the configuration parameter C<prerequisites_policy>.)
10392 C<get> downloads a distribution file and untars or unzips it, C<make>
10393 builds it, C<test> runs the test suite, and C<install> installs it.
10395 Any C<make> or C<test> are run unconditionally. An
10397 install <distribution_file>
10399 also is run unconditionally. But for
10403 CPAN checks if an install is actually needed for it and prints
10404 I<module up to date> in the case that the distribution file containing
10405 the module doesn't need to be updated.
10407 CPAN also keeps track of what it has done within the current session
10408 and doesn't try to build a package a second time regardless if it
10409 succeeded or not. It does not repeat a test run if the test
10410 has been run successfully before. Same for install runs.
10412 The C<force> pragma may precede another command (currently: C<get>,
10413 C<make>, C<test>, or C<install>) and executes the command from scratch
10414 and tries to continue in case of some errors. See the section below on
10415 the C<force> and the C<fforce> pragma.
10417 The C<notest> pragma may be used to skip the test part in the build
10422 cpan> notest install Tk
10424 A C<clean> command results in a
10428 being executed within the distribution file's working directory.
10430 =item C<readme>, C<perldoc>, C<look> module or distribution
10432 C<readme> displays the README file of the associated distribution.
10433 C<Look> gets and untars (if not yet done) the distribution file,
10434 changes to the appropriate directory and opens a subshell process in
10435 that directory. C<perldoc> displays the pod documentation of the
10436 module in html or plain text format.
10440 =item C<ls> globbing_expression
10442 The first form lists all distribution files in and below an author's
10443 CPAN directory as they are stored in the CHECKUMS files distributed on
10444 CPAN. The listing goes recursive into all subdirectories.
10446 The second form allows to limit or expand the output with shell
10447 globbing as in the following examples:
10453 The last example is very slow and outputs extra progress indicators
10454 that break the alignment of the result.
10456 Note that globbing only lists directories explicitly asked for, for
10457 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
10458 regarded as a bug and may be changed in future versions.
10462 The C<failed> command reports all distributions that failed on one of
10463 C<make>, C<test> or C<install> for some reason in the currently
10464 running shell session.
10466 =item Persistence between sessions
10468 If the C<YAML> or the C<YAML::Syck> module is installed a record of
10469 the internal state of all modules is written to disk after each step.
10470 The files contain a signature of the currently running perl version
10473 If the configurations variable C<build_dir_reuse> is set to a true
10474 value, then CPAN.pm reads the collected YAML files. If the stored
10475 signature matches the currently running perl the stored state is
10476 loaded into memory such that effectively persistence between sessions
10479 =item The C<force> and the C<fforce> pragma
10481 To speed things up in complex installation scenarios, CPAN.pm keeps
10482 track of what it has already done and refuses to do some things a
10483 second time. A C<get>, a C<make>, and an C<install> are not repeated.
10484 A C<test> is only repeated if the previous test was unsuccessful. The
10485 diagnostic message when CPAN.pm refuses to do something a second time
10486 is one of I<Has already been >C<unwrapped|made|tested successfully> or
10487 something similar. Another situation where CPAN refuses to act is an
10488 C<install> if the according C<test> was not successful.
10490 In all these cases, the user can override the goatish behaviour by
10491 prepending the command with the word force, for example:
10493 cpan> force get Foo
10494 cpan> force make AUTHOR/Bar-3.14.tar.gz
10495 cpan> force test Baz
10496 cpan> force install Acme::Meta
10498 Each I<forced> command is executed with the according part of its
10501 The C<fforce> pragma is a variant that emulates a C<force get> which
10502 erases the entire memory followed by the action specified, effectively
10503 restarting the whole get/make/test/install procedure from scratch.
10507 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
10508 Batch jobs can run without a lockfile and do not disturb each other.
10510 The shell offers to run in I<degraded mode> when another process is
10511 holding the lockfile. This is an experimental feature that is not yet
10512 tested very well. This second shell then does not write the history
10513 file, does not use the metadata file and has a different prompt.
10517 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
10518 in the cpan-shell it is intended that you can press C<^C> anytime and
10519 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
10520 to clean up and leave the shell loop. You can emulate the effect of a
10521 SIGTERM by sending two consecutive SIGINTs, which usually means by
10522 pressing C<^C> twice.
10524 CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
10525 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
10526 Build.PL> subprocess.
10532 The commands that are available in the shell interface are methods in
10533 the package CPAN::Shell. If you enter the shell command, all your
10534 input is split by the Text::ParseWords::shellwords() routine which
10535 acts like most shells do. The first word is being interpreted as the
10536 method to be called and the rest of the words are treated as arguments
10537 to this method. Continuation lines are supported if a line ends with a
10542 C<autobundle> writes a bundle file into the
10543 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
10544 a list of all modules that are both available from CPAN and currently
10545 installed within @INC. The name of the bundle file is based on the
10546 current date and a counter.
10550 Note: this feature is still in alpha state and may change in future
10551 versions of CPAN.pm
10553 This commands provides a statistical overview over recent download
10554 activities. The data for this is collected in the YAML file
10555 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
10556 configured or YAML not installed, then no stats are provided.
10560 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
10561 directory so that you can save your own preferences instead of the
10564 =head2 recent ***EXPERIMENTAL COMMAND***
10566 The C<recent> command downloads a list of recent uploads to CPAN and
10567 displays them I<slowly>. While the command is running $SIG{INT} is
10568 defined to mean that the loop shall be left after having displayed the
10571 B<Note>: This command requires XML::LibXML installed.
10573 B<Note>: This whole command currently is a bit klunky and will
10574 probably change in future versions of CPAN.pm but the general
10575 approach will likely stay.
10577 B<Note>: See also L<smoke>
10581 recompile() is a very special command in that it takes no argument and
10582 runs the make/test/install cycle with brute force over all installed
10583 dynamically loadable extensions (aka XS modules) with 'force' in
10584 effect. The primary purpose of this command is to finish a network
10585 installation. Imagine, you have a common source tree for two different
10586 architectures. You decide to do a completely independent fresh
10587 installation. You start on one architecture with the help of a Bundle
10588 file produced earlier. CPAN installs the whole Bundle for you, but
10589 when you try to repeat the job on the second architecture, CPAN
10590 responds with a C<"Foo up to date"> message for all modules. So you
10591 invoke CPAN's recompile on the second architecture and you're done.
10593 Another popular use for C<recompile> is to act as a rescue in case your
10594 perl breaks binary compatibility. If one of the modules that CPAN uses
10595 is in turn depending on binary compatibility (so you cannot run CPAN
10596 commands), then you should try the CPAN::Nox module for recovery.
10598 =head2 report Bundle|Distribution|Module
10600 The C<report> command temporarily turns on the C<test_report> config
10601 variable, then runs the C<force test> command with the given
10602 arguments. The C<force> pragma is used to re-run the tests and repeat
10603 every step that might have failed before.
10605 =head2 smoke ***EXPERIMENTAL COMMAND***
10607 B<*** WARNING: this command downloads and executes software from CPAN to
10608 your computer of completely unknown status. You should never do
10609 this with your normal account and better have a dedicated well
10610 separated and secured machine to do this. ***>
10612 The C<smoke> command takes the list of recent uploads to CPAN as
10613 provided by the C<recent> command and tests them all. While the
10614 command is running $SIG{INT} is defined to mean that the current item
10617 B<Note>: This whole command currently is a bit klunky and will
10618 probably change in future versions of CPAN.pm but the general
10619 approach will likely stay.
10621 B<Note>: See also L<recent>
10623 =head2 upgrade [Module|/Regex/]...
10625 The C<upgrade> command first runs an C<r> command with the given
10626 arguments and then installs the newest versions of all modules that
10627 were listed by that.
10629 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10631 Although it may be considered internal, the class hierarchy does matter
10632 for both users and programmer. CPAN.pm deals with above mentioned four
10633 classes, and all those classes share a set of methods. A classical
10634 single polymorphism is in effect. A metaclass object registers all
10635 objects of all kinds and indexes them with a string. The strings
10636 referencing objects have a separated namespace (well, not completely
10641 words containing a "/" (slash) Distribution
10642 words starting with Bundle:: Bundle
10643 everything else Module or Author
10645 Modules know their associated Distribution objects. They always refer
10646 to the most recent official release. Developers may mark their releases
10647 as unstable development versions (by inserting an underbar into the
10648 module version number which will also be reflected in the distribution
10649 name when you run 'make dist'), so the really hottest and newest
10650 distribution is not always the default. If a module Foo circulates
10651 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10652 way to install version 1.23 by saying
10656 This would install the complete distribution file (say
10657 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10658 like to install version 1.23_90, you need to know where the
10659 distribution file resides on CPAN relative to the authors/id/
10660 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10661 so you would have to say
10663 install BAR/Foo-1.23_90.tar.gz
10665 The first example will be driven by an object of the class
10666 CPAN::Module, the second by an object of class CPAN::Distribution.
10668 =head2 Integrating local directories
10670 Note: this feature is still in alpha state and may change in future
10671 versions of CPAN.pm
10673 Distribution objects are normally distributions from the CPAN, but
10674 there is a slightly degenerate case for Distribution objects, too, of
10675 projects held on the local disk. These distribution objects have the
10676 same name as the local directory and end with a dot. A dot by itself
10677 is also allowed for the current directory at the time CPAN.pm was
10678 used. All actions such as C<make>, C<test>, and C<install> are applied
10679 directly to that directory. This gives the command C<cpan .> an
10680 interesting touch: while the normal mantra of installing a CPAN module
10681 without CPAN.pm is one of
10683 perl Makefile.PL perl Build.PL
10684 ( go and get prerequisites )
10686 make test ./Build test
10687 make install ./Build install
10689 the command C<cpan .> does all of this at once. It figures out which
10690 of the two mantras is appropriate, fetches and installs all
10691 prerequisites, cares for them recursively and finally finishes the
10692 installation of the module in the current directory, be it a CPAN
10695 The typical usage case is for private modules or working copies of
10696 projects from remote repositories on the local disk.
10698 =head1 CONFIGURATION
10700 When the CPAN module is used for the first time, a configuration
10701 dialog tries to determine a couple of site specific options. The
10702 result of the dialog is stored in a hash reference C< $CPAN::Config >
10703 in a file CPAN/Config.pm.
10705 The default values defined in the CPAN/Config.pm file can be
10706 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10707 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10708 added to the search path of the CPAN module before the use() or
10709 require() statements. The mkmyconfig command writes this file for you.
10711 The C<o conf> command has various bells and whistles:
10715 =item completion support
10717 If you have a ReadLine module installed, you can hit TAB at any point
10718 of the commandline and C<o conf> will offer you completion for the
10719 built-in subcommands and/or config variable names.
10721 =item displaying some help: o conf help
10723 Displays a short help
10725 =item displaying current values: o conf [KEY]
10727 Displays the current value(s) for this config variable. Without KEY
10728 displays all subcommands and config variables.
10734 If KEY starts and ends with a slash the string in between is
10735 interpreted as a regular expression and only keys matching this regex
10742 =item changing of scalar values: o conf KEY VALUE
10744 Sets the config variable KEY to VALUE. The empty string can be
10745 specified as usual in shells, with C<''> or C<"">
10749 o conf wget /usr/bin/wget
10751 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10753 If a config variable name ends with C<list>, it is a list. C<o conf
10754 KEY shift> removes the first element of the list, C<o conf KEY pop>
10755 removes the last element of the list. C<o conf KEYS unshift LIST>
10756 prepends a list of values to the list, C<o conf KEYS push LIST>
10757 appends a list of valued to the list.
10759 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10762 Finally, any other list of arguments is taken as a new list value for
10763 the KEY variable discarding the previous value.
10767 o conf urllist unshift http://cpan.dev.local/CPAN
10768 o conf urllist splice 3 1
10769 o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10771 =item reverting to saved: o conf defaults
10773 Reverts all config variables to the state in the saved config file.
10775 =item saving the config: o conf commit
10777 Saves all config variables to the current config file (CPAN/Config.pm
10778 or CPAN/MyConfig.pm that was loaded at start).
10782 The configuration dialog can be started any time later again by
10783 issuing the command C< o conf init > in the CPAN shell. A subset of
10784 the configuration dialog can be run by issuing C<o conf init WORD>
10785 where WORD is any valid config variable or a regular expression.
10787 =head2 Config Variables
10789 Currently the following keys in the hash reference $CPAN::Config are
10792 applypatch path to external prg
10793 auto_commit commit all changes to config variables to disk
10794 build_cache size of cache for directories to build modules
10795 build_dir locally accessible directory to build modules
10796 build_dir_reuse boolean if distros in build_dir are persistent
10797 build_requires_install_policy
10798 to install or not to install when a module is
10799 only needed for building. yes|no|ask/yes|ask/no
10800 bzip2 path to external prg
10801 cache_metadata use serializer to cache metadata
10802 commands_quote prefered character to use for quoting external
10803 commands when running them. Defaults to double
10804 quote on Windows, single tick everywhere else;
10805 can be set to space to disable quoting
10806 check_sigs if signatures should be verified
10807 colorize_debug Term::ANSIColor attributes for debugging output
10808 colorize_output boolean if Term::ANSIColor should colorize output
10809 colorize_print Term::ANSIColor attributes for normal output
10810 colorize_warn Term::ANSIColor attributes for warnings
10811 commandnumber_in_prompt
10812 boolean if you want to see current command number
10813 cpan_home local directory reserved for this package
10814 curl path to external prg
10815 dontload_hash DEPRECATED
10816 dontload_list arrayref: modules in the list will not be
10817 loaded by the CPAN::has_inst() routine
10818 ftp path to external prg
10819 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
10820 ftp_proxy proxy host for ftp requests
10822 gpg path to external prg
10823 gzip location of external program gzip
10824 histfile file to maintain history between sessions
10825 histsize maximum number of lines to keep in histfile
10826 http_proxy proxy host for http requests
10827 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10828 after this many seconds inactivity. Set to 0 to
10830 index_expire after this many days refetch index files
10831 inhibit_startup_message
10832 if true, does not print the startup message
10833 keep_source_where directory in which to keep the source (if we do)
10834 load_module_verbosity
10835 report loading of optional modules used by CPAN.pm
10836 lynx path to external prg
10837 make location of external make program
10838 make_arg arguments that should always be passed to 'make'
10839 make_install_make_command
10840 the make command for running 'make install', for
10841 example 'sudo make'
10842 make_install_arg same as make_arg for 'make install'
10843 makepl_arg arguments passed to 'perl Makefile.PL'
10844 mbuild_arg arguments passed to './Build'
10845 mbuild_install_arg arguments passed to './Build install'
10846 mbuild_install_build_command
10847 command to use instead of './Build' when we are
10848 in the install stage, for example 'sudo ./Build'
10849 mbuildpl_arg arguments passed to 'perl Build.PL'
10850 ncftp path to external prg
10851 ncftpget path to external prg
10852 no_proxy don't proxy to these hosts/domains (comma separated list)
10853 pager location of external program more (or any pager)
10854 password your password if you CPAN server wants one
10855 patch path to external prg
10856 prefer_installer legal values are MB and EUMM: if a module comes
10857 with both a Makefile.PL and a Build.PL, use the
10858 former (EUMM) or the latter (MB); if the module
10859 comes with only one of the two, that one will be
10861 prerequisites_policy
10862 what to do if you are missing module prerequisites
10863 ('follow' automatically, 'ask' me, or 'ignore')
10864 prefs_dir local directory to store per-distro build options
10865 proxy_user username for accessing an authenticating proxy
10866 proxy_pass password for accessing an authenticating proxy
10867 randomize_urllist add some randomness to the sequence of the urllist
10868 scan_cache controls scanning of cache ('atstart' or 'never')
10869 shell your favorite shell
10870 show_unparsable_versions
10871 boolean if r command tells which modules are versionless
10872 show_upload_date boolean if commands should try to determine upload date
10873 show_zero_versions boolean if r command tells for which modules $version==0
10874 tar location of external program tar
10875 tar_verbosity verbosity level for the tar command
10876 term_is_latin deprecated: if true Unicode is translated to ISO-8859-1
10877 (and nonsense for characters outside latin range)
10878 term_ornaments boolean to turn ReadLine ornamenting on/off
10879 test_report email test reports (if CPAN::Reporter is installed)
10880 unzip location of external program unzip
10881 urllist arrayref to nearby CPAN sites (or equivalent locations)
10882 use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
10883 username your username if you CPAN server wants one
10884 wait_list arrayref to a wait server to try (See CPAN::WAIT)
10885 wget path to external prg
10886 yaml_load_code enable YAML code deserialisation
10887 yaml_module which module to use to read/write YAML files
10889 You can set and query each of these options interactively in the cpan
10890 shell with the C<o conf> or the C<o conf init> command as specified below.
10894 =item C<o conf E<lt>scalar optionE<gt>>
10896 prints the current value of the I<scalar option>
10898 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10900 Sets the value of the I<scalar option> to I<value>
10902 =item C<o conf E<lt>list optionE<gt>>
10904 prints the current value of the I<list option> in MakeMaker's
10907 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10909 shifts or pops the array in the I<list option> variable
10911 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10913 works like the corresponding perl commands.
10915 =item interactive editing: o conf init [MATCH|LIST]
10917 Runs an interactive configuration dialog for matching variables.
10918 Without argument runs the dialog over all supported config variables.
10919 To specify a MATCH the argument must be enclosed by slashes.
10923 o conf init ftp_passive ftp_proxy
10924 o conf init /color/
10926 Note: this method of setting config variables often provides more
10927 explanation about the functioning of a variable than the manpage.
10931 =head2 CPAN::anycwd($path): Note on config variable getcwd
10933 CPAN.pm changes the current working directory often and needs to
10934 determine its own current working directory. Per default it uses
10935 Cwd::cwd but if this doesn't work on your system for some reason,
10936 alternatives can be configured according to the following table:
10954 Calls the external command cwd.
10958 =head2 Note on the format of the urllist parameter
10960 urllist parameters are URLs according to RFC 1738. We do a little
10961 guessing if your URL is not compliant, but if you have problems with
10962 C<file> URLs, please try the correct format. Either:
10964 file://localhost/whatever/ftp/pub/CPAN/
10968 file:///home/ftp/pub/CPAN/
10970 =head2 The urllist parameter has CD-ROM support
10972 The C<urllist> parameter of the configuration table contains a list of
10973 URLs that are to be used for downloading. If the list contains any
10974 C<file> URLs, CPAN always tries to get files from there first. This
10975 feature is disabled for index files. So the recommendation for the
10976 owner of a CD-ROM with CPAN contents is: include your local, possibly
10977 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10979 o conf urllist push file://localhost/CDROM/CPAN
10981 CPAN.pm will then fetch the index files from one of the CPAN sites
10982 that come at the beginning of urllist. It will later check for each
10983 module if there is a local copy of the most recent version.
10985 Another peculiarity of urllist is that the site that we could
10986 successfully fetch the last file from automatically gets a preference
10987 token and is tried as the first site for the next request. So if you
10988 add a new site at runtime it may happen that the previously preferred
10989 site will be tried another time. This means that if you want to disallow
10990 a site for the next transfer, it must be explicitly removed from
10993 =head2 Maintaining the urllist parameter
10995 If you have YAML.pm (or some other YAML module configured in
10996 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10997 about recent downloads. You can view the statistics with the C<hosts>
10998 command or inspect them directly by looking into the C<FTPstats.yml>
10999 file in your C<cpan_home> directory.
11001 To get some interesting statistics it is recommended to set the
11002 C<randomize_urllist> parameter that introduces some amount of
11003 randomness into the URL selection.
11005 =head2 The C<requires> and C<build_requires> dependency declarations
11007 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11008 a distribution are treated differently depending on the config
11009 variable C<build_requires_install_policy>. By setting
11010 C<build_requires_install_policy> to C<no> such a module is not being
11011 installed. It is only built and tested and then kept in the list of
11012 tested but uninstalled modules. As such it is available during the
11013 build of the dependent module by integrating the path to the
11014 C<blib/arch> and C<blib/lib> directories in the environment variable
11015 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11016 both modules declared as C<requires> and those declared as
11017 C<build_requires> are treated alike. By setting to C<ask/yes> or
11018 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
11020 =head2 Configuration for individual distributions (I<Distroprefs>)
11022 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11023 still considered beta quality)
11025 Distributions on the CPAN usually behave according to what we call the
11026 CPAN mantra. Or since the event of Module::Build we should talk about
11029 perl Makefile.PL perl Build.PL
11031 make test ./Build test
11032 make install ./Build install
11034 But some modules cannot be built with this mantra. They try to get
11035 some extra data from the user via the environment, extra arguments or
11036 interactively thus disturbing the installation of large bundles like
11037 Phalanx100 or modules with many dependencies like Plagger.
11039 The distroprefs system of C<CPAN.pm> addresses this problem by
11040 allowing the user to specify extra informations and recipes in YAML
11047 pass additional arguments to one of the four commands,
11051 set environment variables
11055 instantiate an Expect object that reads from the console, waits for
11056 some regular expressions and enters some answers
11060 temporarily override assorted C<CPAN.pm> configuration variables
11064 specify dependencies that the original maintainer forgot to specify
11068 disable the installation of an object altogether
11072 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11073 distribution in the C<distroprefs/> directory for examples.
11077 The YAML files themselves must have the C<.yml> extension, all other
11078 files are ignored (for two exceptions see I<Fallback Data::Dumper and
11079 Storable> below). The containing directory can be specified in
11080 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11081 prefs_dir> in the CPAN shell to set and activate the distroprefs
11084 Every YAML file may contain arbitrary documents according to the YAML
11085 specification and every single document is treated as an entity that
11086 can specify the treatment of a single distribution.
11088 The names of the files can be picked freely, C<CPAN.pm> always reads
11089 all files (in alphabetical order) and takes the key C<match> (see
11090 below in I<Language Specs>) as a hashref containing match criteria
11091 that determine if the current distribution matches the YAML document
11094 =head2 Fallback Data::Dumper and Storable
11096 If neither your configured C<yaml_module> nor YAML.pm is installed
11097 CPAN.pm falls back to using Data::Dumper and Storable and looks for
11098 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11099 directory. These files are expected to contain one or more hashrefs.
11100 For Data::Dumper generated files, this is expected to be done with by
11101 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11104 ysh < somefile.yml > somefile.dd
11106 For Storable files the rule is that they must be constructed such that
11107 C<Storable::retrieve(file)> returns an array reference and the array
11108 elements represent one distropref object each. The conversion from
11109 YAML would look like so:
11111 perl -MYAML=LoadFile -MStorable=nstore -e '
11112 @y=LoadFile(shift);
11113 nstore(\@y, shift)' somefile.yml somefile.st
11115 In bootstrapping situations it is usually sufficient to translate only
11116 a few YAML files to Data::Dumper for the crucial modules like
11117 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11118 over Data::Dumper, remember to pull out a Storable version that writes
11119 an older format than all the other Storable versions that will need to
11124 The following example contains all supported keywords and structures
11125 with the exception of C<eexpect> which can be used instead of
11131 module: "Dancing::Queen"
11132 distribution: "^CHACHACHA/Dancing-"
11133 perl: "/usr/local/cariba-perl/bin/perl"
11135 archname: "freebsd"
11141 - "--somearg=specialcase"
11146 - "Which is your favorite fruit"
11158 commendline: "echo SKIPPING make"
11171 WANT_TO_INSTALL: YES
11174 - "Do you really want to install"
11178 - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
11181 configure_requires:
11184 Test::Exception: 0.25
11189 =head2 Language Specs
11191 Every YAML document represents a single hash reference. The valid keys
11192 in this hash are as follows:
11196 =item comment [scalar]
11200 =item cpanconfig [hash]
11202 Temporarily override assorted C<CPAN.pm> configuration variables.
11204 Supported are: C<build_requires_install_policy>, C<check_sigs>,
11205 C<make>, C<make_install_make_command>, C<prefer_installer>,
11206 C<test_report>. Please report as a bug when you need another one
11209 =item depends [hash] *** EXPERIMENTAL FEATURE ***
11211 All three types, namely C<configure_requires>, C<build_requires>, and
11212 C<requires> are supported in the way specified in the META.yml
11213 specification. The current implementation I<merges> the specified
11214 dependencies with those declared by the package maintainer. In a
11215 future implementation this may be changed to override the original
11218 =item disabled [boolean]
11220 Specifies that this distribution shall not be processed at all.
11222 =item goto [string]
11224 The canonical name of a delegate distribution that shall be installed
11225 instead. Useful when a new version, although it tests OK itself,
11226 breaks something else or a developer release or a fork is already
11227 uploaded that is better than the last released version.
11229 =item install [hash]
11231 Processing instructions for the C<make install> or C<./Build install>
11232 phase of the CPAN mantra. See below under I<Processiong Instructions>.
11236 Processing instructions for the C<make> or C<./Build> phase of the
11237 CPAN mantra. See below under I<Processiong Instructions>.
11241 A hashref with one or more of the keys C<distribution>, C<modules>,
11242 C<perl>, and C<perlconfig> that specify if a document is targeted at a
11243 specific CPAN distribution or installation.
11245 The corresponding values are interpreted as regular expressions. The
11246 C<distribution> related one will be matched against the canonical
11247 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
11249 The C<module> related one will be matched against I<all> modules
11250 contained in the distribution until one module matches.
11252 The C<perl> related one will be matched against C<$^X> (but with the
11255 The value associated with C<perlconfig> is itself a hashref that is
11256 matched against corresponding values in the C<%Config::Config> hash
11257 living in the C< Config.pm > module.
11259 If more than one restriction of C<module>, C<distribution>, and
11260 C<perl> is specified, the results of the separately computed match
11261 values must all match. If this is the case then the hashref
11262 represented by the YAML document is returned as the preference
11263 structure for the current distribution.
11265 =item patches [array]
11267 An array of patches on CPAN or on the local disk to be applied in
11268 order via the external patch program. If the value for the C<-p>
11269 parameter is C<0> or C<1> is determined by reading the patch
11272 Note: if the C<applypatch> program is installed and C<CPAN::Config>
11273 knows about it B<and> a patch is written by the C<makepatch> program,
11274 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11275 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11280 Processing instructions for the C<perl Makefile.PL> or C<perl
11281 Build.PL> phase of the CPAN mantra. See below under I<Processiong
11286 Processing instructions for the C<make test> or C<./Build test> phase
11287 of the CPAN mantra. See below under I<Processiong Instructions>.
11291 =head2 Processing Instructions
11297 Arguments to be added to the command line
11301 A full commandline that will be executed as it stands by a system
11302 call. During the execution the environment variable PERL will is set
11303 to $^X (but with an absolute path). If C<commandline> is specified,
11304 the content of C<args> is not used.
11306 =item eexpect [hash]
11308 Extended C<expect>. This is a hash reference with four allowed keys,
11309 C<mode>, C<timeout>, C<reuse>, and C<talk>.
11311 C<mode> may have the values C<deterministic> for the case where all
11312 questions come in the order written down and C<anyorder> for the case
11313 where the questions may come in any order. The default mode is
11316 C<timeout> denotes a timeout in seconds. Floating point timeouts are
11317 OK. In the case of a C<mode=deterministic> the timeout denotes the
11318 timeout per question, in the case of C<mode=anyorder> it denotes the
11319 timeout per byte received from the stream or questions.
11321 C<talk> is a reference to an array that contains alternating questions
11322 and answers. Questions are regular expressions and answers are literal
11323 strings. The Expect module will then watch the stream coming from the
11324 execution of the external program (C<perl Makefile.PL>, C<perl
11325 Build.PL>, C<make>, etc.).
11327 In the case of C<mode=deterministic> the CPAN.pm will inject the
11328 according answer as soon as the stream matches the regular expression.
11330 In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11331 as the timeout is reached for the next byte in the input stream. In
11332 this mode you can use the C<reuse> parameter to decide what shall
11333 happen with a question-answer pair after it has been used. In the
11334 default case (reuse=0) it is removed from the array, so it cannot be
11335 used again accidentally. In this case, if you want to answer the
11336 question C<Do you really want to do that> several times, then it must
11337 be included in the array at least as often as you want this answer to
11338 be given. Setting the parameter C<reuse> to 1 makes this repetition
11343 Environment variables to be set during the command
11345 =item expect [array]
11347 C<< expect: <array> >> is a short notation for
11350 mode: deterministic
11356 =head2 Schema verification with C<Kwalify>
11358 If you have the C<Kwalify> module installed (which is part of the
11359 Bundle::CPANxxl), then all your distroprefs files are checked for
11360 syntactical correctness.
11362 =head2 Example Distroprefs Files
11364 C<CPAN.pm> comes with a collection of example YAML files. Note that these
11365 are really just examples and should not be used without care because
11366 they cannot fit everybody's purpose. After all the authors of the
11367 packages that ask questions had a need to ask, so you should watch
11368 their questions and adjust the examples to your environment and your
11369 needs. You have beend warned:-)
11371 =head1 PROGRAMMER'S INTERFACE
11373 If you do not enter the shell, the available shell commands are both
11374 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11375 functions in the calling package (C<install(...)>). Before calling low-level
11376 commands it makes sense to initialize components of CPAN you need, e.g.:
11378 CPAN::HandleConfig->load;
11379 CPAN::Shell::setup_output;
11380 CPAN::Index->reload;
11382 High-level commands do such initializations automatically.
11384 There's currently only one class that has a stable interface -
11385 CPAN::Shell. All commands that are available in the CPAN shell are
11386 methods of the class CPAN::Shell. Each of the commands that produce
11387 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11388 the IDs of all modules within the list.
11392 =item expand($type,@things)
11394 The IDs of all objects available within a program are strings that can
11395 be expanded to the corresponding real objects with the
11396 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11397 list of CPAN::Module objects according to the C<@things> arguments
11398 given. In scalar context it only returns the first element of the
11401 =item expandany(@things)
11403 Like expand, but returns objects of the appropriate type, i.e.
11404 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11405 CPAN::Distribution objects for distributions. Note: it does not expand
11406 to CPAN::Author objects.
11408 =item Programming Examples
11410 This enables the programmer to do operations that combine
11411 functionalities that are available in the shell.
11413 # install everything that is outdated on my disk:
11414 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11416 # install my favorite programs if necessary:
11417 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
11418 CPAN::Shell->install($mod);
11421 # list all modules on my disk that have no VERSION number
11422 for $mod (CPAN::Shell->expand("Module","/./")) {
11423 next unless $mod->inst_file;
11424 # MakeMaker convention for undefined $VERSION:
11425 next unless $mod->inst_version eq "undef";
11426 print "No VERSION in ", $mod->id, "\n";
11429 # find out which distribution on CPAN contains a module:
11430 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
11432 Or if you want to write a cronjob to watch The CPAN, you could list
11433 all modules that need updating. First a quick and dirty way:
11435 perl -e 'use CPAN; CPAN::Shell->r;'
11437 If you don't want to get any output in the case that all modules are
11438 up to date, you can parse the output of above command for the regular
11439 expression //modules are up to date// and decide to mail the output
11440 only if it doesn't match. Ick?
11442 If you prefer to do it more in a programmer style in one single
11443 process, maybe something like this suits you better:
11445 # list all modules on my disk that have newer versions on CPAN
11446 for $mod (CPAN::Shell->expand("Module","/./")) {
11447 next unless $mod->inst_file;
11448 next if $mod->uptodate;
11449 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
11450 $mod->id, $mod->inst_version, $mod->cpan_version;
11453 If that gives you too much output every day, you maybe only want to
11454 watch for three modules. You can write
11456 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
11458 as the first line instead. Or you can combine some of the above
11461 # watch only for a new mod_perl module
11462 $mod = CPAN::Shell->expand("Module","mod_perl");
11463 exit if $mod->uptodate;
11464 # new mod_perl arrived, let me know all update recommendations
11469 =head2 Methods in the other Classes
11473 =item CPAN::Author::as_glimpse()
11475 Returns a one-line description of the author
11477 =item CPAN::Author::as_string()
11479 Returns a multi-line description of the author
11481 =item CPAN::Author::email()
11483 Returns the author's email address
11485 =item CPAN::Author::fullname()
11487 Returns the author's name
11489 =item CPAN::Author::name()
11491 An alias for fullname
11493 =item CPAN::Bundle::as_glimpse()
11495 Returns a one-line description of the bundle
11497 =item CPAN::Bundle::as_string()
11499 Returns a multi-line description of the bundle
11501 =item CPAN::Bundle::clean()
11503 Recursively runs the C<clean> method on all items contained in the bundle.
11505 =item CPAN::Bundle::contains()
11507 Returns a list of objects' IDs contained in a bundle. The associated
11508 objects may be bundles, modules or distributions.
11510 =item CPAN::Bundle::force($method,@args)
11512 Forces CPAN to perform a task that it normally would have refused to
11513 do. Force takes as arguments a method name to be called and any number
11514 of additional arguments that should be passed to the called method.
11515 The internals of the object get the needed changes so that CPAN.pm
11516 does not refuse to take the action. The C<force> is passed recursively
11517 to all contained objects. See also the section above on the C<force>
11518 and the C<fforce> pragma.
11520 =item CPAN::Bundle::get()
11522 Recursively runs the C<get> method on all items contained in the bundle
11524 =item CPAN::Bundle::inst_file()
11526 Returns the highest installed version of the bundle in either @INC or
11527 C<$CPAN::Config->{cpan_home}>. Note that this is different from
11528 CPAN::Module::inst_file.
11530 =item CPAN::Bundle::inst_version()
11532 Like CPAN::Bundle::inst_file, but returns the $VERSION
11534 =item CPAN::Bundle::uptodate()
11536 Returns 1 if the bundle itself and all its members are uptodate.
11538 =item CPAN::Bundle::install()
11540 Recursively runs the C<install> method on all items contained in the bundle
11542 =item CPAN::Bundle::make()
11544 Recursively runs the C<make> method on all items contained in the bundle
11546 =item CPAN::Bundle::readme()
11548 Recursively runs the C<readme> method on all items contained in the bundle
11550 =item CPAN::Bundle::test()
11552 Recursively runs the C<test> method on all items contained in the bundle
11554 =item CPAN::Distribution::as_glimpse()
11556 Returns a one-line description of the distribution
11558 =item CPAN::Distribution::as_string()
11560 Returns a multi-line description of the distribution
11562 =item CPAN::Distribution::author
11564 Returns the CPAN::Author object of the maintainer who uploaded this
11567 =item CPAN::Distribution::pretty_id()
11569 Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
11570 author's PAUSE ID and TARBALL is the distribution filename.
11572 =item CPAN::Distribution::base_id()
11574 Returns the distribution filename without any archive suffix. E.g
11577 =item CPAN::Distribution::clean()
11579 Changes to the directory where the distribution has been unpacked and
11580 runs C<make clean> there.
11582 =item CPAN::Distribution::containsmods()
11584 Returns a list of IDs of modules contained in a distribution file.
11585 Only works for distributions listed in the 02packages.details.txt.gz
11586 file. This typically means that only the most recent version of a
11587 distribution is covered.
11589 =item CPAN::Distribution::cvs_import()
11591 Changes to the directory where the distribution has been unpacked and
11592 runs something like
11594 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
11598 =item CPAN::Distribution::dir()
11600 Returns the directory into which this distribution has been unpacked.
11602 =item CPAN::Distribution::force($method,@args)
11604 Forces CPAN to perform a task that it normally would have refused to
11605 do. Force takes as arguments a method name to be called and any number
11606 of additional arguments that should be passed to the called method.
11607 The internals of the object get the needed changes so that CPAN.pm
11608 does not refuse to take the action. See also the section above on the
11609 C<force> and the C<fforce> pragma.
11611 =item CPAN::Distribution::get()
11613 Downloads the distribution from CPAN and unpacks it. Does nothing if
11614 the distribution has already been downloaded and unpacked within the
11617 =item CPAN::Distribution::install()
11619 Changes to the directory where the distribution has been unpacked and
11620 runs the external command C<make install> there. If C<make> has not
11621 yet been run, it will be run first. A C<make test> will be issued in
11622 any case and if this fails, the install will be canceled. The
11623 cancellation can be avoided by letting C<force> run the C<install> for
11626 This install method has only the power to install the distribution if
11627 there are no dependencies in the way. To install an object and all of
11628 its dependencies, use CPAN::Shell->install.
11630 Note that install() gives no meaningful return value. See uptodate().
11632 =item CPAN::Distribution::install_tested()
11634 Install all the distributions that have been tested sucessfully but
11635 not yet installed. See also C<is_tested>.
11637 =item CPAN::Distribution::isa_perl()
11639 Returns 1 if this distribution file seems to be a perl distribution.
11640 Normally this is derived from the file name only, but the index from
11641 CPAN can contain a hint to achieve a return value of true for other
11644 =item CPAN::Distribution::is_tested()
11646 List all the distributions that have been tested sucessfully but not
11647 yet installed. See also C<install_tested>.
11649 =item CPAN::Distribution::look()
11651 Changes to the directory where the distribution has been unpacked and
11652 opens a subshell there. Exiting the subshell returns.
11654 =item CPAN::Distribution::make()
11656 First runs the C<get> method to make sure the distribution is
11657 downloaded and unpacked. Changes to the directory where the
11658 distribution has been unpacked and runs the external commands C<perl
11659 Makefile.PL> or C<perl Build.PL> and C<make> there.
11661 =item CPAN::Distribution::perldoc()
11663 Downloads the pod documentation of the file associated with a
11664 distribution (in html format) and runs it through the external
11665 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11666 isn't available, it converts it to plain text with external
11667 command html2text and runs it through the pager specified
11668 in C<$CPAN::Config->{pager}>
11670 =item CPAN::Distribution::prefs()
11672 Returns the hash reference from the first matching YAML file that the
11673 user has deposited in the C<prefs_dir/> directory. The first
11674 succeeding match wins. The files in the C<prefs_dir/> are processed
11675 alphabetically and the canonical distroname (e.g.
11676 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11677 stored in the $root->{match}{distribution} attribute value.
11678 Additionally all module names contained in a distribution are matched
11679 agains the regular expressions in the $root->{match}{module} attribute
11680 value. The two match values are ANDed together. Each of the two
11681 attributes are optional.
11683 =item CPAN::Distribution::prereq_pm()
11685 Returns the hash reference that has been announced by a distribution
11686 as the the C<requires> and C<build_requires> elements. These can be
11687 declared either by the C<META.yml> (if authoritative) or can be
11688 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11689 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11690 a comment in the produced C<Makefile>. I<Note>: this method only works
11691 after an attempt has been made to C<make> the distribution. Returns
11694 =item CPAN::Distribution::readme()
11696 Downloads the README file associated with a distribution and runs it
11697 through the pager specified in C<$CPAN::Config->{pager}>.
11699 =item CPAN::Distribution::reports()
11701 Downloads report data for this distribution from cpantesters.perl.org
11702 and displays a subset of them.
11704 =item CPAN::Distribution::read_yaml()
11706 Returns the content of the META.yml of this distro as a hashref. Note:
11707 works only after an attempt has been made to C<make> the distribution.
11708 Returns undef otherwise. Also returns undef if the content of META.yml
11709 is not authoritative. (The rules about what exactly makes the content
11710 authoritative are still in flux.)
11712 =item CPAN::Distribution::test()
11714 Changes to the directory where the distribution has been unpacked and
11715 runs C<make test> there.
11717 =item CPAN::Distribution::uptodate()
11719 Returns 1 if all the modules contained in the distribution are
11720 uptodate. Relies on containsmods.
11722 =item CPAN::Index::force_reload()
11724 Forces a reload of all indices.
11726 =item CPAN::Index::reload()
11728 Reloads all indices if they have not been read for more than
11729 C<$CPAN::Config->{index_expire}> days.
11731 =item CPAN::InfoObj::dump()
11733 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11734 inherit this method. It prints the data structure associated with an
11735 object. Useful for debugging. Note: the data structure is considered
11736 internal and thus subject to change without notice.
11738 =item CPAN::Module::as_glimpse()
11740 Returns a one-line description of the module in four columns: The
11741 first column contains the word C<Module>, the second column consists
11742 of one character: an equals sign if this module is already installed
11743 and uptodate, a less-than sign if this module is installed but can be
11744 upgraded, and a space if the module is not installed. The third column
11745 is the name of the module and the fourth column gives maintainer or
11746 distribution information.
11748 =item CPAN::Module::as_string()
11750 Returns a multi-line description of the module
11752 =item CPAN::Module::clean()
11754 Runs a clean on the distribution associated with this module.
11756 =item CPAN::Module::cpan_file()
11758 Returns the filename on CPAN that is associated with the module.
11760 =item CPAN::Module::cpan_version()
11762 Returns the latest version of this module available on CPAN.
11764 =item CPAN::Module::cvs_import()
11766 Runs a cvs_import on the distribution associated with this module.
11768 =item CPAN::Module::description()
11770 Returns a 44 character description of this module. Only available for
11771 modules listed in The Module List (CPAN/modules/00modlist.long.html
11772 or 00modlist.long.txt.gz)
11774 =item CPAN::Module::distribution()
11776 Returns the CPAN::Distribution object that contains the current
11777 version of this module.
11779 =item CPAN::Module::dslip_status()
11781 Returns a hash reference. The keys of the hash are the letters C<D>,
11782 C<S>, C<L>, C<I>, and <P>, for development status, support level,
11783 language, interface and public licence respectively. The data for the
11784 DSLIP status are collected by pause.perl.org when authors register
11785 their namespaces. The values of the 5 hash elements are one-character
11786 words whose meaning is described in the table below. There are also 5
11787 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11788 verbose value of the 5 status variables.
11790 Where the 'DSLIP' characters have the following meanings:
11792 D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
11793 i - Idea, listed to gain consensus or as a placeholder
11794 c - under construction but pre-alpha (not yet released)
11795 a/b - Alpha/Beta testing
11797 M - Mature (no rigorous definition)
11798 S - Standard, supplied with Perl 5
11803 u - Usenet newsgroup comp.lang.perl.modules
11804 n - None known, try comp.lang.perl.modules
11805 a - abandoned; volunteers welcome to take over maintainance
11808 p - Perl-only, no compiler needed, should be platform independent
11809 c - C and perl, a C compiler will be needed
11810 h - Hybrid, written in perl with optional C code, no compiler needed
11811 + - C++ and perl, a C++ compiler will be needed
11812 o - perl and another language other than C or C++
11814 I - Interface Style
11815 f - plain Functions, no references used
11816 h - hybrid, object and function interfaces available
11817 n - no interface at all (huh?)
11818 r - some use of unblessed References or ties
11819 O - Object oriented using blessed references and/or inheritance
11822 p - Standard-Perl: user may choose between GPL and Artistic
11823 g - GPL: GNU General Public License
11824 l - LGPL: "GNU Lesser General Public License" (previously known as
11825 "GNU Library General Public License")
11826 b - BSD: The BSD License
11827 a - Artistic license alone
11828 2 - Artistic license 2.0 or later
11829 o - open source: appoved by www.opensource.org
11830 d - allows distribution without restrictions
11831 r - restricted distribtion
11832 n - no license at all
11834 =item CPAN::Module::force($method,@args)
11836 Forces CPAN to perform a task that it normally would have refused to
11837 do. Force takes as arguments a method name to be called and any number
11838 of additional arguments that should be passed to the called method.
11839 The internals of the object get the needed changes so that CPAN.pm
11840 does not refuse to take the action. See also the section above on the
11841 C<force> and the C<fforce> pragma.
11843 =item CPAN::Module::get()
11845 Runs a get on the distribution associated with this module.
11847 =item CPAN::Module::inst_file()
11849 Returns the filename of the module found in @INC. The first file found
11850 is reported just like perl itself stops searching @INC when it finds a
11853 =item CPAN::Module::available_file()
11855 Returns the filename of the module found in PERL5LIB or @INC. The
11856 first file found is reported. The advantage of this method over
11857 C<inst_file> is that modules that have been tested but not yet
11858 installed are included because PERL5LIB keeps track of tested modules.
11860 =item CPAN::Module::inst_version()
11862 Returns the version number of the installed module in readable format.
11864 =item CPAN::Module::available_version()
11866 Returns the version number of the available module in readable format.
11868 =item CPAN::Module::install()
11870 Runs an C<install> on the distribution associated with this module.
11872 =item CPAN::Module::look()
11874 Changes to the directory where the distribution associated with this
11875 module has been unpacked and opens a subshell there. Exiting the
11878 =item CPAN::Module::make()
11880 Runs a C<make> on the distribution associated with this module.
11882 =item CPAN::Module::manpage_headline()
11884 If module is installed, peeks into the module's manpage, reads the
11885 headline and returns it. Moreover, if the module has been downloaded
11886 within this session, does the equivalent on the downloaded module even
11887 if it is not installed.
11889 =item CPAN::Module::perldoc()
11891 Runs a C<perldoc> on this module.
11893 =item CPAN::Module::readme()
11895 Runs a C<readme> on the distribution associated with this module.
11897 =item CPAN::Module::reports()
11899 Calls the reports() method on the associated distribution object.
11901 =item CPAN::Module::test()
11903 Runs a C<test> on the distribution associated with this module.
11905 =item CPAN::Module::uptodate()
11907 Returns 1 if the module is installed and up-to-date.
11909 =item CPAN::Module::userid()
11911 Returns the author's ID of the module.
11915 =head2 Cache Manager
11917 Currently the cache manager only keeps track of the build directory
11918 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11919 deletes complete directories below C<build_dir> as soon as the size of
11920 all directories there gets bigger than $CPAN::Config->{build_cache}
11921 (in MB). The contents of this cache may be used for later
11922 re-installations that you intend to do manually, but will never be
11923 trusted by CPAN itself. This is due to the fact that the user might
11924 use these directories for building modules on different architectures.
11926 There is another directory ($CPAN::Config->{keep_source_where}) where
11927 the original distribution files are kept. This directory is not
11928 covered by the cache manager and must be controlled by the user. If
11929 you choose to have the same directory as build_dir and as
11930 keep_source_where directory, then your sources will be deleted with
11931 the same fifo mechanism.
11935 A bundle is just a perl module in the namespace Bundle:: that does not
11936 define any functions or methods. It usually only contains documentation.
11938 It starts like a perl module with a package declaration and a $VERSION
11939 variable. After that the pod section looks like any other pod with the
11940 only difference being that I<one special pod section> exists starting with
11945 In this pod section each line obeys the format
11947 Module_Name [Version_String] [- optional text]
11949 The only required part is the first field, the name of a module
11950 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11951 of the line is optional. The comment part is delimited by a dash just
11952 as in the man page header.
11954 The distribution of a bundle should follow the same convention as
11955 other distributions.
11957 Bundles are treated specially in the CPAN package. If you say 'install
11958 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11959 the modules in the CONTENTS section of the pod. You can install your
11960 own Bundles locally by placing a conformant Bundle file somewhere into
11961 your @INC path. The autobundle() command which is available in the
11962 shell interface does that for you by including all currently installed
11963 modules in a snapshot bundle file.
11965 =head1 PREREQUISITES
11967 If you have a local mirror of CPAN and can access all files with
11968 "file:" URLs, then you only need a perl better than perl5.003 to run
11969 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11970 required for non-UNIX systems or if your nearest CPAN site is
11971 associated with a URL that is not C<ftp:>.
11973 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11974 implemented for an external ftp command or for an external lynx
11979 =head2 Finding packages and VERSION
11981 This module presumes that all packages on CPAN
11987 declare their $VERSION variable in an easy to parse manner. This
11988 prerequisite can hardly be relaxed because it consumes far too much
11989 memory to load all packages into the running program just to determine
11990 the $VERSION variable. Currently all programs that are dealing with
11991 version use something like this
11993 perl -MExtUtils::MakeMaker -le \
11994 'print MM->parse_version(shift)' filename
11996 If you are author of a package and wonder if your $VERSION can be
11997 parsed, please try the above method.
12001 come as compressed or gzipped tarfiles or as zip files and contain a
12002 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12003 without much enthusiasm).
12009 The debugging of this module is a bit complex, because we have
12010 interferences of the software producing the indices on CPAN, of the
12011 mirroring process on CPAN, of packaging, of configuration, of
12012 synchronicity, and of bugs within CPAN.pm.
12014 For debugging the code of CPAN.pm itself in interactive mode some more
12015 or less useful debugging aid can be turned on for most packages within
12016 CPAN.pm with one of
12020 =item o debug package...
12022 sets debug mode for packages.
12024 =item o debug -package...
12026 unsets debug mode for packages.
12030 turns debugging on for all packages.
12032 =item o debug number
12036 which sets the debugging packages directly. Note that C<o debug 0>
12037 turns debugging off.
12039 What seems quite a successful strategy is the combination of C<reload
12040 cpan> and the debugging switches. Add a new debug statement while
12041 running in the shell and then issue a C<reload cpan> and see the new
12042 debugging messages immediately without losing the current context.
12044 C<o debug> without an argument lists the valid package names and the
12045 current set of packages in debugging mode. C<o debug> has built-in
12046 completion support.
12048 For debugging of CPAN data there is the C<dump> command which takes
12049 the same arguments as make/test/install and outputs each object's
12050 Data::Dumper dump. If an argument looks like a perl variable and
12051 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12052 Data::Dumper directly.
12054 =head2 Floppy, Zip, Offline Mode
12056 CPAN.pm works nicely without network too. If you maintain machines
12057 that are not networked at all, you should consider working with file:
12058 URLs. Of course, you have to collect your modules somewhere first. So
12059 you might use CPAN.pm to put together all you need on a networked
12060 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12061 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12062 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12063 with this floppy. See also below the paragraph about CD-ROM support.
12065 =head2 Basic Utilities for Programmers
12069 =item has_inst($module)
12071 Returns true if the module is installed. Used to load all modules into
12072 the running CPAN.pm which are considered optional. The config variable
12073 C<dontload_list> can be used to intercept the C<has_inst()> call such
12074 that an optional module is not loaded despite being available. For
12075 example the following command will prevent that C<YAML.pm> is being
12078 cpan> o conf dontload_list push YAML
12080 See the source for details.
12082 =item has_usable($module)
12084 Returns true if the module is installed and is in a usable state. Only
12085 useful for a handful of modules that are used internally. See the
12086 source for details.
12088 =item instance($module)
12090 The constructor for all the singletons used to represent modules,
12091 distributions, authors and bundles. If the object already exists, this
12092 method returns the object, otherwise it calls the constructor.
12098 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12099 install foreign, unmasked, unsigned code on your machine. We compare
12100 to a checksum that comes from the net just as the distribution file
12101 itself. But we try to make it easy to add security on demand:
12103 =head2 Cryptographically signed modules
12105 Since release 1.77 CPAN.pm has been able to verify cryptographically
12106 signed module distributions using Module::Signature. The CPAN modules
12107 can be signed by their authors, thus giving more security. The simple
12108 unsigned MD5 checksums that were used before by CPAN protect mainly
12109 against accidental file corruption.
12111 You will need to have Module::Signature installed, which in turn
12112 requires that you have at least one of Crypt::OpenPGP module or the
12113 command-line F<gpg> tool installed.
12115 You will also need to be able to connect over the Internet to the public
12116 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
12118 The configuration parameter check_sigs is there to turn signature
12119 checking on or off.
12123 Most functions in package CPAN are exported per default. The reason
12124 for this is that the primary use is intended for the cpan shell or for
12129 When the CPAN shell enters a subshell via the look command, it sets
12130 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12133 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12134 to the ID of the running process. It also sets
12135 PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12136 happen with older versions of Module::Install.
12138 When running C<perl Makefile.PL>, the environment variable
12139 C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12140 C<Makefile.PL> that is being executed. This prevents runaway processes
12141 with newer versions of Module::Install.
12143 When the config variable ftp_passive is set, all downloads will be run
12144 with the environment variable FTP_PASSIVE set to this value. This is
12145 in general a good idea as it influences both Net::FTP and LWP based
12146 connections. The same effect can be achieved by starting the cpan
12147 shell with this environment variable set. For Net::FTP alone, one can
12148 also always set passive mode by running libnetcfg.
12150 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12152 Populating a freshly installed perl with my favorite modules is pretty
12153 easy if you maintain a private bundle definition file. To get a useful
12154 blueprint of a bundle definition file, the command autobundle can be used
12155 on the CPAN shell command line. This command writes a bundle definition
12156 file for all modules that are installed for the currently running perl
12157 interpreter. It's recommended to run this command only once and from then
12158 on maintain the file manually under a private name, say
12159 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12161 cpan> install Bundle::my_bundle
12163 then answer a few questions and then go out for a coffee.
12165 Maintaining a bundle definition file means keeping track of two
12166 things: dependencies and interactivity. CPAN.pm sometimes fails on
12167 calculating dependencies because not all modules define all MakeMaker
12168 attributes correctly, so a bundle definition file should specify
12169 prerequisites as early as possible. On the other hand, it's a bit
12170 annoying that many distributions need some interactive configuring. So
12171 what I try to accomplish in my private bundle file is to have the
12172 packages that need to be configured early in the file and the gentle
12173 ones later, so I can go out after a few minutes and leave CPAN.pm
12176 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12178 Thanks to Graham Barr for contributing the following paragraphs about
12179 the interaction between perl, and various firewall configurations. For
12180 further information on firewalls, it is recommended to consult the
12181 documentation that comes with the ncftp program. If you are unable to
12182 go through the firewall with a simple Perl setup, it is very likely
12183 that you can configure ncftp so that it works for your firewall.
12185 =head2 Three basic types of firewalls
12187 Firewalls can be categorized into three basic types.
12191 =item http firewall
12193 This is where the firewall machine runs a web server and to access the
12194 outside world you must do it via the web server. If you set environment
12195 variables like http_proxy or ftp_proxy to a values beginning with http://
12196 or in your web browser you have to set proxy information then you know
12197 you are running an http firewall.
12199 To access servers outside these types of firewalls with perl (even for
12200 ftp) you will need to use LWP.
12204 This where the firewall machine runs an ftp server. This kind of
12205 firewall will only let you access ftp servers outside the firewall.
12206 This is usually done by connecting to the firewall with ftp, then
12207 entering a username like "user@outside.host.com"
12209 To access servers outside these type of firewalls with perl you
12210 will need to use Net::FTP.
12212 =item One way visibility
12214 I say one way visibility as these firewalls try to make themselves look
12215 invisible to the users inside the firewall. An FTP data connection is
12216 normally created by sending the remote server your IP address and then
12217 listening for the connection. But the remote server will not be able to
12218 connect to you because of the firewall. So for these types of firewall
12219 FTP connections need to be done in a passive mode.
12221 There are two that I can think off.
12227 If you are using a SOCKS firewall you will need to compile perl and link
12228 it with the SOCKS library, this is what is normally called a 'socksified'
12229 perl. With this executable you will be able to connect to servers outside
12230 the firewall as if it is not there.
12232 =item IP Masquerade
12234 This is the firewall implemented in the Linux kernel, it allows you to
12235 hide a complete network behind one IP address. With this firewall no
12236 special compiling is needed as you can access hosts directly.
12238 For accessing ftp servers behind such firewalls you usually need to
12239 set the environment variable C<FTP_PASSIVE> or the config variable
12240 ftp_passive to a true value.
12246 =head2 Configuring lynx or ncftp for going through a firewall
12248 If you can go through your firewall with e.g. lynx, presumably with a
12251 /usr/local/bin/lynx -pscott:tiger
12253 then you would configure CPAN.pm with the command
12255 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12257 That's all. Similarly for ncftp or ftp, you would configure something
12260 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12262 Your mileage may vary...
12270 I installed a new version of module X but CPAN keeps saying,
12271 I have the old version installed
12273 Most probably you B<do> have the old version installed. This can
12274 happen if a module installs itself into a different directory in the
12275 @INC path than it was previously installed. This is not really a
12276 CPAN.pm problem, you would have the same problem when installing the
12277 module manually. The easiest way to prevent this behaviour is to add
12278 the argument C<UNINST=1> to the C<make install> call, and that is why
12279 many people add this argument permanently by configuring
12281 o conf make_install_arg UNINST=1
12285 So why is UNINST=1 not the default?
12287 Because there are people who have their precise expectations about who
12288 may install where in the @INC path and who uses which @INC array. In
12289 fine tuned environments C<UNINST=1> can cause damage.
12293 I want to clean up my mess, and install a new perl along with
12294 all modules I have. How do I go about it?
12296 Run the autobundle command for your old perl and optionally rename the
12297 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12298 with the Configure option prefix, e.g.
12300 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12302 Install the bundle file you produced in the first step with something like
12304 cpan> install Bundle::mybundle
12310 When I install bundles or multiple modules with one command
12311 there is too much output to keep track of.
12313 You may want to configure something like
12315 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12316 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12318 so that STDOUT is captured in a file for later inspection.
12323 I am not root, how can I install a module in a personal directory?
12325 First of all, you will want to use your own configuration, not the one
12326 that your root user installed. If you do not have permission to write
12327 in the cpan directory that root has configured, you will be asked if
12328 you want to create your own config. Answering "yes" will bring you into
12329 CPAN's configuration stage, using the system config for all defaults except
12330 things that have to do with CPAN's work directory, saving your choices to
12331 your MyConfig.pm file.
12333 You can also manually initiate this process with the following command:
12335 % perl -MCPAN -e 'mkmyconfig'
12341 from the CPAN shell.
12343 You will most probably also want to configure something like this:
12345 o conf makepl_arg "LIB=~/myperl/lib \
12346 INSTALLMAN1DIR=~/myperl/man/man1 \
12347 INSTALLMAN3DIR=~/myperl/man/man3 \
12348 INSTALLSCRIPT=~/myperl/bin \
12349 INSTALLBIN=~/myperl/bin"
12351 and then (oh joy) the equivalent command for Module::Build. That would
12354 o conf mbuildpl_arg "--lib=~/myperl/lib \
12355 --installman1dir=~/myperl/man/man1 \
12356 --installman3dir=~/myperl/man/man3 \
12357 --installscript=~/myperl/bin \
12358 --installbin=~/myperl/bin"
12360 You can make this setting permanent like all C<o conf> settings with
12361 C<o conf commit> or by setting C<auto_commit> beforehand.
12363 You will have to add ~/myperl/man to the MANPATH environment variable
12364 and also tell your perl programs to look into ~/myperl/lib, e.g. by
12367 use lib "$ENV{HOME}/myperl/lib";
12369 or setting the PERL5LIB environment variable.
12371 While we're speaking about $ENV{HOME}, it might be worth mentioning,
12372 that for Windows we use the File::HomeDir module that provides an
12373 equivalent to the concept of the home directory on Unix.
12375 Another thing you should bear in mind is that the UNINST parameter can
12376 be dangerous when you are installing into a private area because you
12377 might accidentally remove modules that other people depend on that are
12378 not using the private area.
12382 How to get a package, unwrap it, and make a change before building it?
12384 Have a look at the C<look> (!) command.
12388 I installed a Bundle and had a couple of fails. When I
12389 retried, everything resolved nicely. Can this be fixed to work
12392 The reason for this is that CPAN does not know the dependencies of all
12393 modules when it starts out. To decide about the additional items to
12394 install, it just uses data found in the META.yml file or the generated
12395 Makefile. An undetected missing piece breaks the process. But it may
12396 well be that your Bundle installs some prerequisite later than some
12397 depending item and thus your second try is able to resolve everything.
12398 Please note, CPAN.pm does not know the dependency tree in advance and
12399 cannot sort the queue of things to install in a topologically correct
12400 order. It resolves perfectly well IF all modules declare the
12401 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12402 the C<requires> stanza of Module::Build. For bundles which fail and
12403 you need to install often, it is recommended to sort the Bundle
12404 definition file manually.
12408 In our intranet we have many modules for internal use. How
12409 can I integrate these modules with CPAN.pm but without uploading
12410 the modules to CPAN?
12412 Have a look at the CPAN::Site module.
12416 When I run CPAN's shell, I get an error message about things in my
12417 /etc/inputrc (or ~/.inputrc) file.
12419 These are readline issues and can only be fixed by studying readline
12420 configuration on your architecture and adjusting the referenced file
12421 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12422 and edit them. Quite often harmless changes like uppercasing or
12423 lowercasing some arguments solves the problem.
12427 Some authors have strange characters in their names.
12429 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
12430 expecting ISO-8859-1 charset, a converter can be activated by setting
12431 term_is_latin to a true value in your config file. One way of doing so
12434 cpan> o conf term_is_latin 1
12436 If other charset support is needed, please file a bugreport against
12437 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
12438 the support or maybe UTF-8 terminals become widely available.
12440 Note: this config variable is deprecated and will be removed in a
12441 future version of CPAN.pm. It will be replaced with the conventions
12442 around the family of $LANG and $LC_* environment variables.
12446 When an install fails for some reason and then I correct the error
12447 condition and retry, CPAN.pm refuses to install the module, saying
12448 C<Already tried without success>.
12450 Use the force pragma like so
12452 force install Foo::Bar
12458 and then 'make install' directly in the subshell.
12462 How do I install a "DEVELOPER RELEASE" of a module?
12464 By default, CPAN will install the latest non-developer release of a
12465 module. If you want to install a dev release, you have to specify the
12466 partial path starting with the author id to the tarball you wish to
12469 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
12471 Note that you can use the C<ls> command to get this path listed.
12475 How do I install a module and all its dependencies from the commandline,
12476 without being prompted for anything, despite my CPAN configuration
12479 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
12480 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
12481 asked any questions at all (assuming the modules you are installing are
12482 nice about obeying that variable as well):
12484 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
12488 How do I create a Module::Build based Build.PL derived from an
12489 ExtUtils::MakeMaker focused Makefile.PL?
12491 http://search.cpan.org/search?query=Module::Build::Convert
12493 http://www.refcnt.org/papers/module-build-convert
12497 What's the best CPAN site for me?
12499 The urllist config parameter is yours. You can add and remove sites at
12500 will. You should find out which sites have the best uptodateness,
12501 bandwidth, reliability, etc. and are topologically close to you. Some
12502 people prefer fast downloads, others uptodateness, others reliability.
12503 You decide which to try in which order.
12505 Henk P. Penning maintains a site that collects data about CPAN sites:
12507 http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
12511 Why do I get asked the same questions every time I start the shell?
12513 You can make your configuration changes permanent by calling the
12514 command C<o conf commit>. Alternatively set the C<auto_commit>
12515 variable to true by running C<o conf init auto_commit> and answering
12516 the following question with yes.
12520 =head1 COMPATIBILITY
12522 =head2 OLD PERL VERSIONS
12524 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
12525 newer versions. It is getting more and more difficult to get the
12526 minimal prerequisites working on older perls. It is close to
12527 impossible to get the whole Bundle::CPAN working there. If you're in
12528 the position to have only these old versions, be advised that CPAN is
12529 designed to work fine without the Bundle::CPAN installed.
12531 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
12532 compatible with ancient perls and that File::Temp is listed as a
12533 prerequisite but CPAN has reasonable workarounds if it is missing.
12537 This module and its competitor, the CPANPLUS module, are both much
12538 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
12539 more modular but it was never tried to make it compatible with CPAN.pm.
12541 =head1 SECURITY ADVICE
12543 This software enables you to upgrade software on your computer and so
12544 is inherently dangerous because the newly installed software may
12545 contain bugs and may alter the way your computer works or even make it
12546 unusable. Please consider backing up your data before every upgrade.
12550 Please report bugs via L<http://rt.cpan.org/>
12552 Before submitting a bug, please make sure that the traditional method
12553 of building a Perl module package from a shell by following the
12554 installation instructions of that package still works in your
12559 Andreas Koenig C<< <andk@cpan.org> >>
12563 This program is free software; you can redistribute it and/or
12564 modify it under the same terms as Perl itself.
12566 See L<http://www.perl.com/perl/misc/Artistic.html>
12568 =head1 TRANSLATIONS
12570 Kawai,Takanori provides a Japanese translation of this manpage at
12571 L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
12575 L<cpan>, L<CPAN::Nox>, L<CPAN::Version>