1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $CPAN::VERSION = '1.88_79';
5 $CPAN::VERSION = eval $CPAN::VERSION;
7 use CPAN::HandleConfig;
17 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
18 # 5.005_04 does not work without
20 use File::Basename ();
28 use Sys::Hostname qw(hostname);
29 use Text::ParseWords ();
32 # we need to run chdir all over and we would get at wrong libraries
35 if (File::Spec->can("rel2abs")) {
37 $inc = File::Spec->rel2abs($inc) unless ref $inc;
43 require Mac::BuildTools if $^O eq 'MacOS';
44 $ENV{PERL5_CPAN_IS_RUNNING}=1;
45 $ENV{PERL5_CPANPLUS_IS_RUNNING}=1; # https://rt.cpan.org/Ticket/Display.html?id=23735
47 END { $CPAN::End++; &cleanup; }
50 $CPAN::Frontend ||= "CPAN::Shell";
51 unless (@CPAN::Defaultsites){
52 @CPAN::Defaultsites = map {
53 CPAN::URL->new(TEXT => $_, FROM => "DEF")
55 "http://www.perl.org/CPAN/",
56 "ftp://ftp.perl.org/pub/CPAN/";
58 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
59 $CPAN::Perl ||= CPAN::find_perl();
60 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
61 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
63 # our globals are getting a mess
90 @CPAN::ISA = qw(CPAN::Debug Exporter);
92 # note that these functions live in CPAN::Shell and get executed via
93 # AUTOLOAD when called directly
119 sub soft_chdir_with_alternatives ($);
122 $autoload_recursion ||= 0;
124 #-> sub CPAN::AUTOLOAD ;
126 $autoload_recursion++;
130 warn "Refusing to autoload '$l' while signal pending";
131 $autoload_recursion--;
134 if ($autoload_recursion > 1) {
135 my $fullcommand = join " ", map { "'$_'" } $l, @_;
136 warn "Refusing to autoload $fullcommand in recursion\n";
137 $autoload_recursion--;
141 @export{@EXPORT} = '';
142 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
143 if (exists $export{$l}){
146 die(qq{Unknown CPAN command "$AUTOLOAD". }.
147 qq{Type ? for help.\n});
149 $autoload_recursion--;
153 #-> sub CPAN::shell ;
156 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
157 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
159 my $oprompt = shift || CPAN::Prompt->new;
160 my $prompt = $oprompt;
161 my $commandline = shift || "";
162 $CPAN::CurrentCommandId ||= 1;
165 unless ($Suppress_readline) {
166 require Term::ReadLine;
169 $term->ReadLine eq "Term::ReadLine::Stub"
171 $term = Term::ReadLine->new('CPAN Monitor');
173 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
174 my $attribs = $term->Attribs;
175 $attribs->{attempted_completion_function} = sub {
176 &CPAN::Complete::gnu_cpl;
179 $readline::rl_completion_function =
180 $readline::rl_completion_function = 'CPAN::Complete::cpl';
182 if (my $histfile = $CPAN::Config->{'histfile'}) {{
183 unless ($term->can("AddHistory")) {
184 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
187 $META->readhist($term,$histfile);
189 for ($CPAN::Config->{term_ornaments}) { # alias
190 local $Term::ReadLine::termcap_nowarn = 1;
191 $term->ornaments($_) if defined;
193 # $term->OUT is autoflushed anyway
194 my $odef = select STDERR;
202 my @cwd = grep { defined $_ and length $_ }
204 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
205 File::Spec->rootdir();
206 my $try_detect_readline;
207 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
208 my $rl_avail = $Suppress_readline ? "suppressed" :
209 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
210 "available (try 'install Bundle::CPAN')";
212 unless ($CPAN::Config->{'inhibit_startup_message'}){
213 $CPAN::Frontend->myprint(
215 cpan shell -- CPAN exploration and modules installation (v%s)
223 my($continuation) = "";
224 my $last_term_ornaments;
225 SHELLCOMMAND: while () {
226 if ($Suppress_readline) {
227 if ($Echo_readline) {
231 last SHELLCOMMAND unless defined ($_ = <> );
232 if ($Echo_readline) {
233 # backdoor: I could not find a way to record sessions
238 last SHELLCOMMAND unless
239 defined ($_ = $term->readline($prompt, $commandline));
241 $_ = "$continuation$_" if $continuation;
243 next SHELLCOMMAND if /^$/;
244 $_ = 'h' if /^\s*\?/;
245 if (/^(?:q(?:uit)?|bye|exit)$/i) {
256 use vars qw($import_done);
257 CPAN->import(':DEFAULT') unless $import_done++;
258 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
265 eval { @line = Text::ParseWords::shellwords($_) };
266 warn($@), next SHELLCOMMAND if $@;
267 warn("Text::Parsewords could not parse the line [$_]"),
268 next SHELLCOMMAND unless @line;
269 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
270 my $command = shift @line;
271 eval { CPAN::Shell->$command(@line) };
272 if ($@ && "$@" =~ /\S/){
274 Carp::cluck("Catching error: '$@'");
276 if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
277 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
279 soft_chdir_with_alternatives(\@cwd);
280 $CPAN::Frontend->myprint("\n");
282 $CPAN::CurrentCommandId++;
286 $commandline = ""; # I do want to be able to pass a default to
287 # shell, but on the second command I see no
290 CPAN::Queue->nullify_queue;
291 if ($try_detect_readline) {
292 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
294 $CPAN::META->has_inst("Term::ReadLine::Perl")
296 delete $INC{"Term/ReadLine.pm"};
298 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
299 require Term::ReadLine;
300 $CPAN::Frontend->myprint("\n$redef subroutines in ".
301 "Term::ReadLine redefined\n");
305 if ($term and $term->can("ornaments")) {
306 for ($CPAN::Config->{term_ornaments}) { # alias
308 if (not defined $last_term_ornaments
309 or $_ != $last_term_ornaments
311 local $Term::ReadLine::termcap_nowarn = 1;
312 $term->ornaments($_);
313 $last_term_ornaments = $_;
316 undef $last_term_ornaments;
320 for my $class (qw(Module Distribution)) {
321 # again unsafe meta access?
322 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
323 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
324 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
325 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
329 $GOTOSHELL = 0; # not too often
330 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
335 soft_chdir_with_alternatives(\@cwd);
338 sub soft_chdir_with_alternatives ($) {
341 my $root = File::Spec->rootdir();
342 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
343 Trying '$root' as temporary haven.
348 if (chdir $cwd->[0]) {
352 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
353 Trying to chdir to "$cwd->[1]" instead.
357 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
363 sub _yaml_module () {
364 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
366 $yaml_module ne "YAML"
368 !$CPAN::META->has_inst($yaml_module)
370 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
371 $yaml_module = "YAML";
373 if ($yaml_module eq "YAML"
375 $CPAN::META->has_inst($yaml_module)
377 $YAML::VERSION < 0.60
379 !$Have_warned->{"YAML"}++
381 $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
382 "I'll continue but problems are *very* likely to happen.\n"
384 $CPAN::Frontend->mysleep(5);
389 # CPAN::_yaml_loadfile
391 my($self,$local_file) = @_;
392 return +[] unless -s $local_file;
393 my $yaml_module = _yaml_module;
394 if ($CPAN::META->has_inst($yaml_module)) {
396 if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
398 eval { @yaml = $code->($local_file); };
400 # this shall not be done by the frontend
401 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
404 } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
406 open FH, $local_file or die "Could not open '$local_file': $!";
410 eval { @yaml = $code->($ystream); };
412 # this shall not be done by the frontend
413 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
418 # this shall not be done by the frontend
419 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
424 # CPAN::_yaml_dumpfile
426 my($self,$local_file,@what) = @_;
427 my $yaml_module = _yaml_module;
428 if ($CPAN::META->has_inst($yaml_module)) {
430 if (UNIVERSAL::isa($local_file, "FileHandle")) {
431 $code = UNIVERSAL::can($yaml_module, "Dump");
432 eval { print $local_file $code->(@what) };
433 } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
434 eval { $code->($local_file,@what); };
435 } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
437 open FH, ">$local_file" or die "Could not open '$local_file': $!";
438 print FH $code->(@what);
441 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
444 if (UNIVERSAL::isa($local_file, "FileHandle")) {
445 # I think this case does not justify a warning at all
447 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
452 sub _init_sqlite () {
453 unless ($CPAN::META->has_inst("CPAN::SQLite")) {
454 $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
455 unless $Have_warned->{"CPAN::SQLite"}++;
458 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
459 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
463 my $negative_cache = {};
464 sub _sqlite_running {
465 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
466 # need to cache the result, otherwise too slow
467 return $negative_cache->{fact};
469 $negative_cache = {}; # reset
471 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
472 return $ret if $ret; # fast anyway
473 $negative_cache->{time} = time;
474 return $negative_cache->{fact} = $ret;
478 package CPAN::CacheMgr;
480 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
485 use Fcntl qw(:flock);
486 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
487 @CPAN::FTP::ISA = qw(CPAN::Debug);
489 package CPAN::LWP::UserAgent;
491 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
492 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
494 package CPAN::Complete;
496 @CPAN::Complete::ISA = qw(CPAN::Debug);
497 # Q: where is the "How do I add a new command" HOWTO?
498 # A: svn diff -r 1048:1049 where andk added the report command
499 @CPAN::Complete::COMMANDS = sort qw(
500 ! a b d h i m o q r u
530 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
531 @CPAN::Index::ISA = qw(CPAN::Debug);
534 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
537 package CPAN::InfoObj;
539 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
541 package CPAN::Author;
543 @CPAN::Author::ISA = qw(CPAN::InfoObj);
545 package CPAN::Distribution;
547 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
549 package CPAN::Bundle;
551 @CPAN::Bundle::ISA = qw(CPAN::Module);
553 package CPAN::Module;
555 @CPAN::Module::ISA = qw(CPAN::InfoObj);
557 package CPAN::Exception::RecursiveDependency;
559 use overload '""' => "as_string";
561 # a module sees its distribution (no version)
562 # a distribution sees its prereqs (which are module names) (usually with versions)
563 # a bundle sees its module names and/or its distributions (no version)
568 my (@deps,%seen,$loop_starts_with);
569 DCHAIN: for my $dep (@$deps) {
570 push @deps, {name => $dep, display_as => $dep};
572 $loop_starts_with = $dep;
577 for my $i (0..$#deps) {
578 my $x = $deps[$i]{name};
579 $in_loop ||= $x eq $loop_starts_with;
580 my $xo = CPAN::Shell->expandany($x) or next;
581 if ($xo->isa("CPAN::Module")) {
582 my $have = $xo->inst_version || "N/A";
583 my($want,$d,$want_type);
584 if ($i>0 and $d = $deps[$i-1]{name}) {
585 my $do = CPAN::Shell->expandany($d);
586 $want = $do->{prereq_pm}{requires}{$x};
588 $want_type = "requires: ";
590 $want = $do->{prereq_pm}{build_requires}{$x};
592 $want_type = "build_requires: ";
594 $want_type = "unknown status";
599 $want = $xo->cpan_version;
600 $want_type = "want: ";
602 $deps[$i]{have} = $have;
603 $deps[$i]{want_type} = $want_type;
604 $deps[$i]{want} = $want;
605 $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
606 } elsif ($xo->isa("CPAN::Distribution")) {
607 $deps[$i]{display_as} = $xo->pretty_id;
609 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
611 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
613 $xo->store_persistent_state; # otherwise I will not reach
614 # all involved parties for
618 bless { deps => \@deps }, $class;
623 my $ret = "\nRecursive dependency detected:\n ";
624 $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
625 $ret .= ".\nCannot resolve.\n";
629 package CPAN::Exception::yaml_not_installed;
631 use overload '""' => "as_string";
634 my($class,$module,$file,$during) = @_;
635 bless { module => $module, file => $file, during => $during }, $class;
640 "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
643 package CPAN::Exception::yaml_process_error;
645 use overload '""' => "as_string";
648 my($class,$module,$file,$during,$error) = shift;
649 bless { module => $module,
652 error => $error }, $class;
657 "Alert: While trying to $self->{during} YAML file\n".
659 "with '$self->{module}' the following error was encountered:\n".
663 package CPAN::Prompt; use overload '""' => "as_string";
664 use vars qw($prompt);
666 $CPAN::CurrentCommandId ||= 0;
672 unless ($CPAN::META->{LOCK}) {
673 $word = "nolock_cpan";
675 if ($CPAN::Config->{commandnumber_in_prompt}) {
676 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
682 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
683 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
684 # planned are things like age or quality
686 my($class,%args) = @_;
698 $self->{TEXT} = $set;
703 package CPAN::Distrostatus;
704 use overload '""' => "as_string",
707 my($class,$arg) = @_;
710 FAILED => substr($arg,0,2) eq "NO",
711 COMMANDID => $CPAN::CurrentCommandId,
715 sub commandid { shift->{COMMANDID} }
716 sub failed { shift->{FAILED} }
720 $self->{TEXT} = $set;
739 @CPAN::Shell::ISA = qw(CPAN::Debug);
740 $COLOR_REGISTERED ||= 0;
743 $autoload_recursion ||= 0;
745 #-> sub CPAN::Shell::AUTOLOAD ;
747 $autoload_recursion++;
749 my $class = shift(@_);
750 # warn "autoload[$l] class[$class]";
753 warn "Refusing to autoload '$l' while signal pending";
754 $autoload_recursion--;
757 if ($autoload_recursion > 1) {
758 my $fullcommand = join " ", map { "'$_'" } $l, @_;
759 warn "Refusing to autoload $fullcommand in recursion\n";
760 $autoload_recursion--;
764 # XXX needs to be reconsidered
765 if ($CPAN::META->has_inst('CPAN::WAIT')) {
768 $CPAN::Frontend->mywarn(qq{
769 Commands starting with "w" require CPAN::WAIT to be installed.
770 Please consider installing CPAN::WAIT to use the fulltext index.
771 For this you just need to type
776 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
780 $autoload_recursion--;
787 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
789 # from here on only subs.
790 ################################################################################
792 sub _perl_fingerprint {
793 my($self,$other_fingerprint) = @_;
794 my $dll = eval {OS2::DLLname()};
797 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
799 my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
800 my $this_fingerprint = {
802 sitearchexp => $Config::Config{sitearchexp},
803 'mtime_$^X' => $mtime_perl,
804 'mtime_dll' => $mtime_dll,
806 if ($other_fingerprint) {
807 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
808 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
810 # mandatory keys since 1.88_57
811 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
812 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
816 return $this_fingerprint;
820 sub suggest_myconfig () {
821 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
822 $CPAN::Frontend->myprint("You don't seem to have a user ".
823 "configuration (MyConfig.pm) yet.\n");
824 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
825 "user configuration now? (Y/n)",
828 CPAN::Shell->mkmyconfig();
831 $CPAN::Frontend->mydie("OK, giving up.");
836 #-> sub CPAN::all_objects ;
838 my($mgr,$class) = @_;
839 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
840 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
842 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
845 # Called by shell, not in batch mode. In batch mode I see no risk in
846 # having many processes updating something as installations are
847 # continually checked at runtime. In shell mode I suspect it is
848 # unintentional to open more than one shell at a time
850 #-> sub CPAN::checklock ;
853 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
854 if (-f $lockfile && -M _ > 0) {
855 my $fh = FileHandle->new($lockfile) or
856 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
857 my $otherpid = <$fh>;
858 my $otherhost = <$fh>;
860 if (defined $otherpid && $otherpid) {
863 if (defined $otherhost && $otherhost) {
866 my $thishost = hostname();
867 if (defined $otherhost && defined $thishost &&
868 $otherhost ne '' && $thishost ne '' &&
869 $otherhost ne $thishost) {
870 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
871 "reports other host $otherhost and other ".
872 "process $otherpid.\n".
873 "Cannot proceed.\n"));
874 } elsif ($RUN_DEGRADED) {
875 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
876 } elsif (defined $otherpid && $otherpid) {
877 return if $$ == $otherpid; # should never happen
878 $CPAN::Frontend->mywarn(
880 There seems to be running another CPAN process (pid $otherpid). Contacting...
882 if (kill 0, $otherpid) {
883 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
885 CPAN::Shell::colorable_makemaker_prompt
886 (qq{Shall I try to run in degraded }.
887 qq{mode? (Y/n)},"y");
889 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
890 Please report if something unexpected happens\n");
892 for ($CPAN::Config) {
894 # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
895 $_->{commandnumber_in_prompt} = 0; # visibility
896 $_->{histfile} = ""; # who should win otherwise?
897 $_->{cache_metadata} = 0; # better would be a lock?
898 $_->{use_sqlite} = 0; # better would be a write lock!
901 $CPAN::Frontend->mydie("
902 You may want to kill the other job and delete the lockfile. On UNIX try:
907 } elsif (-w $lockfile) {
909 CPAN::Shell::colorable_makemaker_prompt
910 (qq{Other job not responding. Shall I overwrite }.
911 qq{the lockfile '$lockfile'? (Y/n)},"y");
912 $CPAN::Frontend->myexit("Ok, bye\n")
913 unless $ans =~ /^y/i;
916 qq{Lockfile '$lockfile' not writeable by you. }.
917 qq{Cannot proceed.\n}.
919 qq{ rm '$lockfile'\n}.
920 qq{ and then rerun us.\n}
924 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
925 "'$lockfile', please remove. Cannot proceed.\n"));
928 my $dotcpan = $CPAN::Config->{cpan_home};
929 eval { File::Path::mkpath($dotcpan);};
931 # A special case at least for Jarkko.
936 $symlinkcpan = readlink $dotcpan;
937 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
938 eval { File::Path::mkpath($symlinkcpan); };
942 $CPAN::Frontend->mywarn(qq{
943 Working directory $symlinkcpan created.
947 unless (-d $dotcpan) {
949 Your configuration suggests "$dotcpan" as your
950 CPAN.pm working directory. I could not create this directory due
951 to this error: $firsterror\n};
953 As "$dotcpan" is a symlink to "$symlinkcpan",
954 I tried to create that, but I failed with this error: $seconderror
957 Please make sure the directory exists and is writable.
959 $CPAN::Frontend->myprint($mess);
960 return suggest_myconfig;
962 } # $@ after eval mkpath $dotcpan
963 if (0) { # to test what happens when a race condition occurs
964 for (reverse 1..10) {
970 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
972 unless ($fh = FileHandle->new("+>>$lockfile")) {
973 if ($! =~ /Permission/) {
974 $CPAN::Frontend->myprint(qq{
976 Your configuration suggests that CPAN.pm should use a working
978 $CPAN::Config->{cpan_home}
979 Unfortunately we could not create the lock file
981 due to permission problems.
983 Please make sure that the configuration variable
984 \$CPAN::Config->{cpan_home}
985 points to a directory where you can write a .lock file. You can set
986 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
989 return suggest_myconfig;
993 while (!flock $fh, LOCK_EX|LOCK_NB) {
995 $CPAN::Frontend->mydie("Giving up\n");
997 $CPAN::Frontend->mysleep($sleep++);
998 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1003 $fh->print($$, "\n");
1004 $fh->print(hostname(), "\n");
1005 $self->{LOCK} = $lockfile;
1006 $self->{LOCKFH} = $fh;
1011 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1016 &cleanup if $Signal;
1017 die "Got yet another signal" if $Signal > 1;
1018 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1019 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1023 # From: Larry Wall <larry@wall.org>
1024 # Subject: Re: deprecating SIGDIE
1025 # To: perl5-porters@perl.org
1026 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1028 # The original intent of __DIE__ was only to allow you to substitute one
1029 # kind of death for another on an application-wide basis without respect
1030 # to whether you were in an eval or not. As a global backstop, it should
1031 # not be used any more lightly (or any more heavily :-) than class
1032 # UNIVERSAL. Any attempt to build a general exception model on it should
1033 # be politely squashed. Any bug that causes every eval {} to have to be
1034 # modified should be not so politely squashed.
1036 # Those are my current opinions. It is also my optinion that polite
1037 # arguments degenerate to personal arguments far too frequently, and that
1038 # when they do, it's because both people wanted it to, or at least didn't
1039 # sufficiently want it not to.
1043 # global backstop to cleanup if we should really die
1044 $SIG{__DIE__} = \&cleanup;
1045 $self->debug("Signal handler set.") if $CPAN::DEBUG;
1048 #-> sub CPAN::DESTROY ;
1050 &cleanup; # need an eval?
1053 #-> sub CPAN::anycwd ;
1056 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1061 sub cwd {Cwd::cwd();}
1063 #-> sub CPAN::getcwd ;
1064 sub getcwd {Cwd::getcwd();}
1066 #-> sub CPAN::fastcwd ;
1067 sub fastcwd {Cwd::fastcwd();}
1069 #-> sub CPAN::backtickcwd ;
1070 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1072 #-> sub CPAN::find_perl ;
1074 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1075 my $pwd = $CPAN::iCwd = CPAN::anycwd();
1076 my $candidate = File::Spec->catfile($pwd,$^X);
1077 $perl ||= $candidate if MM->maybe_command($candidate);
1080 my ($component,$perl_name);
1081 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1082 PATH_COMPONENT: foreach $component (File::Spec->path(),
1083 $Config::Config{'binexp'}) {
1084 next unless defined($component) && $component;
1085 my($abs) = File::Spec->catfile($component,$perl_name);
1086 if (MM->maybe_command($abs)) {
1098 #-> sub CPAN::exists ;
1100 my($mgr,$class,$id) = @_;
1101 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1102 CPAN::Index->reload;
1103 ### Carp::croak "exists called without class argument" unless $class;
1105 $id =~ s/:+/::/g if $class eq "CPAN::Module";
1107 if (CPAN::_sqlite_running) {
1108 $exists = (exists $META->{readonly}{$class}{$id} or
1109 $CPAN::SQLite->set($class, $id));
1111 $exists = exists $META->{readonly}{$class}{$id};
1113 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1116 #-> sub CPAN::delete ;
1118 my($mgr,$class,$id) = @_;
1119 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1120 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1123 #-> sub CPAN::has_usable
1124 # has_inst is sometimes too optimistic, we should replace it with this
1125 # has_usable whenever a case is given
1127 my($self,$mod,$message) = @_;
1128 return 1 if $HAS_USABLE->{$mod};
1129 my $has_inst = $self->has_inst($mod,$message);
1130 return unless $has_inst;
1133 LWP => [ # we frequently had "Can't locate object
1134 # method "new" via package "LWP::UserAgent" at
1135 # (eval 69) line 2006
1137 sub {require LWP::UserAgent},
1138 sub {require HTTP::Request},
1139 sub {require URI::URL},
1142 sub {require Net::FTP},
1143 sub {require Net::Config},
1145 'File::HomeDir' => [
1146 sub {require File::HomeDir;
1147 unless (File::HomeDir::->VERSION >= 0.52){
1148 for ("Will not use File::HomeDir, need 0.52\n") {
1149 $CPAN::Frontend->mywarn($_);
1156 sub {require Archive::Tar;
1157 unless (Archive::Tar::->VERSION >= 1.00) {
1158 for ("Will not use Archive::Tar, need 1.00\n") {
1159 $CPAN::Frontend->mywarn($_);
1166 if ($usable->{$mod}) {
1167 for my $c (0..$#{$usable->{$mod}}) {
1168 my $code = $usable->{$mod}[$c];
1169 my $ret = eval { &$code() };
1170 $ret = "" unless defined $ret;
1172 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1177 return $HAS_USABLE->{$mod} = 1;
1180 #-> sub CPAN::has_inst
1182 my($self,$mod,$message) = @_;
1183 Carp::croak("CPAN->has_inst() called without an argument")
1184 unless defined $mod;
1185 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1186 keys %{$CPAN::Config->{dontload_hash}||{}},
1187 @{$CPAN::Config->{dontload_list}||[]};
1188 if (defined $message && $message eq "no" # afair only used by Nox
1192 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1200 # checking %INC is wrong, because $INC{LWP} may be true
1201 # although $INC{"URI/URL.pm"} may have failed. But as
1202 # I really want to say "bla loaded OK", I have to somehow
1204 ### warn "$file in %INC"; #debug
1206 } elsif (eval { require $file }) {
1207 # eval is good: if we haven't yet read the database it's
1208 # perfect and if we have installed the module in the meantime,
1209 # it tries again. The second require is only a NOOP returning
1210 # 1 if we had success, otherwise it's retrying
1212 my $v = eval "\$$mod\::VERSION";
1213 $v = $v ? " (v$v)" : "";
1214 $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1215 if ($mod eq "CPAN::WAIT") {
1216 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1219 } elsif ($mod eq "Net::FTP") {
1220 $CPAN::Frontend->mywarn(qq{
1221 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1223 install Bundle::libnet
1225 }) unless $Have_warned->{"Net::FTP"}++;
1226 $CPAN::Frontend->mysleep(3);
1227 } elsif ($mod eq "Digest::SHA"){
1228 if ($Have_warned->{"Digest::SHA"}++) {
1229 $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled }.
1230 qq{because Digest::SHA not installed.\n});
1232 $CPAN::Frontend->mywarn(qq{
1233 CPAN: checksum security checks disabled because Digest::SHA not installed.
1234 Please consider installing the Digest::SHA module.
1237 $CPAN::Frontend->mysleep(2);
1239 } elsif ($mod eq "Module::Signature"){
1240 # NOT prefs_lookup, we are not a distro
1241 my $check_sigs = $CPAN::Config->{check_sigs};
1242 if (not $check_sigs) {
1243 # they do not want us:-(
1244 } elsif (not $Have_warned->{"Module::Signature"}++) {
1245 # No point in complaining unless the user can
1246 # reasonably install and use it.
1247 if (eval { require Crypt::OpenPGP; 1 } ||
1249 defined $CPAN::Config->{'gpg'}
1251 $CPAN::Config->{'gpg'} =~ /\S/
1254 $CPAN::Frontend->mywarn(qq{
1255 CPAN: Module::Signature security checks disabled because Module::Signature
1256 not installed. Please consider installing the Module::Signature module.
1257 You may also need to be able to connect over the Internet to the public
1258 keyservers like pgp.mit.edu (port 11371).
1261 $CPAN::Frontend->mysleep(2);
1265 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1270 #-> sub CPAN::instance ;
1272 my($mgr,$class,$id) = @_;
1273 CPAN::Index->reload;
1275 # unsafe meta access, ok?
1276 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1277 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1285 #-> sub CPAN::cleanup ;
1287 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1288 local $SIG{__DIE__} = '';
1293 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1294 $ineval = 1, last if
1295 $subroutine eq '(eval)';
1297 return if $ineval && !$CPAN::End;
1298 return unless defined $META->{LOCK};
1299 return unless -f $META->{LOCK};
1301 close $META->{LOCKFH};
1302 unlink $META->{LOCK};
1304 # Carp::cluck("DEBUGGING");
1305 if ( $CPAN::CONFIG_DIRTY ) {
1306 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1308 $CPAN::Frontend->myprint("Lockfile removed.\n");
1311 #-> sub CPAN::readhist
1313 my($self,$term,$histfile) = @_;
1314 my($fh) = FileHandle->new;
1315 open $fh, "<$histfile" or last;
1319 $term->AddHistory($_);
1324 #-> sub CPAN::savehist
1327 my($histfile,$histsize);
1328 unless ($histfile = $CPAN::Config->{'histfile'}){
1329 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1332 $histsize = $CPAN::Config->{'histsize'} || 100;
1334 unless ($CPAN::term->can("GetHistory")) {
1335 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1341 my @h = $CPAN::term->GetHistory;
1342 splice @h, 0, @h-$histsize if @h>$histsize;
1343 my($fh) = FileHandle->new;
1344 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1345 local $\ = local $, = "\n";
1350 #-> sub CPAN::is_tested
1352 my($self,$what,$when) = @_;
1354 Carp::cluck("DEBUG: empty what");
1357 $self->{is_tested}{$what} = $when;
1360 #-> sub CPAN::is_installed
1361 # unsets the is_tested flag: as soon as the thing is installed, it is
1362 # not needed in set_perl5lib anymore
1364 my($self,$what) = @_;
1365 delete $self->{is_tested}{$what};
1368 sub _list_sorted_descending_is_tested {
1371 { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1372 keys %{$self->{is_tested}}
1375 #-> sub CPAN::set_perl5lib
1377 my($self,$for) = @_;
1379 (undef,undef,undef,$for) = caller(1);
1382 $self->{is_tested} ||= {};
1383 return unless %{$self->{is_tested}};
1384 my $env = $ENV{PERL5LIB};
1385 $env = $ENV{PERLLIB} unless defined $env;
1387 push @env, $env if defined $env and length $env;
1388 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1389 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1391 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1393 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1394 } elsif (@dirs < 24) {
1395 my @d = map {my $cp = $_;
1396 $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1399 $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1400 "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1404 my $cnt = keys %{$self->{is_tested}};
1405 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1406 "$cnt build dirs to PERL5LIB; ".
1411 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1414 package CPAN::CacheMgr;
1417 #-> sub CPAN::CacheMgr::as_string ;
1419 eval { require Data::Dumper };
1421 return shift->SUPER::as_string;
1423 return Data::Dumper::Dumper(shift);
1427 #-> sub CPAN::CacheMgr::cachesize ;
1432 #-> sub CPAN::CacheMgr::tidyup ;
1435 return unless $CPAN::META->{LOCK};
1436 return unless -d $self->{ID};
1437 while ($self->{DU} > $self->{'MAX'} ) {
1438 my($toremove) = shift @{$self->{FIFO}};
1439 unless ($toremove =~ /\.yml$/) {
1440 $CPAN::Frontend->myprint(sprintf(
1441 "DEL(%.1f>%.1fMB): %s \n",
1448 return if $CPAN::Signal;
1449 $self->_clean_cache($toremove);
1450 return if $CPAN::Signal;
1454 #-> sub CPAN::CacheMgr::dir ;
1459 #-> sub CPAN::CacheMgr::entries ;
1461 my($self,$dir) = @_;
1462 return unless defined $dir;
1463 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1464 $dir ||= $self->{ID};
1465 my($cwd) = CPAN::anycwd();
1466 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1467 my $dh = DirHandle->new(File::Spec->curdir)
1468 or Carp::croak("Couldn't opendir $dir: $!");
1471 next if $_ eq "." || $_ eq "..";
1473 push @entries, File::Spec->catfile($dir,$_);
1475 push @entries, File::Spec->catdir($dir,$_);
1477 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1480 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1481 sort { -M $b <=> -M $a} @entries;
1484 #-> sub CPAN::CacheMgr::disk_usage ;
1486 my($self,$dir) = @_;
1487 return if exists $self->{SIZE}{$dir};
1488 return if $CPAN::Signal;
1493 unless (chmod 0755, $dir) {
1494 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1495 "permission to change the permission; cannot ".
1496 "estimate disk usage of '$dir'\n");
1497 $CPAN::Frontend->mysleep(5);
1502 # nothing to say, no matter what the permissions
1505 $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1510 $File::Find::prune++ if $CPAN::Signal;
1512 if ($^O eq 'MacOS') {
1514 my $cat = Mac::Files::FSpGetCatInfo($_);
1515 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1519 unless (chmod 0755, $_) {
1520 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1521 "the permission to change the permission; ".
1522 "can only partially estimate disk usage ".
1524 $CPAN::Frontend->mysleep(5);
1535 return if $CPAN::Signal;
1536 $self->{SIZE}{$dir} = $Du/1024/1024;
1537 push @{$self->{FIFO}}, $dir;
1538 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1539 $self->{DU} += $Du/1024/1024;
1543 #-> sub CPAN::CacheMgr::_clean_cache ;
1545 my($self,$dir) = @_;
1546 return unless -e $dir;
1547 unless (File::Spec->canonpath(File::Basename::dirname($dir))
1548 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1549 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1550 "will not remove\n");
1551 $CPAN::Frontend->mysleep(5);
1554 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1556 File::Path::rmtree($dir);
1558 if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1559 my $yaml_module = CPAN::_yaml_module;
1560 if ($CPAN::META->has_inst($yaml_module)) {
1561 my($peek_yaml) = CPAN->_yaml_loadfile("$dir.yml");
1562 if (my $id = $peek_yaml->[0]{distribution}{ID}) {
1563 $CPAN::META->delete("CPAN::Distribution", $id);
1564 # $CPAN::Frontend->mywarn (" +++\n");
1568 unlink "$dir.yml"; # may fail
1569 unless ($id_deleted) {
1570 CPAN->debug("no distro found associated with '$dir'");
1573 $self->{DU} -= $self->{SIZE}{$dir};
1574 delete $self->{SIZE}{$dir};
1577 #-> sub CPAN::CacheMgr::new ;
1584 ID => $CPAN::Config->{build_dir},
1585 MAX => $CPAN::Config->{'build_cache'},
1586 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1589 File::Path::mkpath($self->{ID});
1590 my $dh = DirHandle->new($self->{ID});
1591 bless $self, $class;
1594 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1596 CPAN->debug($debug) if $CPAN::DEBUG;
1600 #-> sub CPAN::CacheMgr::scan_cache ;
1603 return if $self->{SCAN} eq 'never';
1604 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1605 unless $self->{SCAN} eq 'atstart';
1606 return unless $CPAN::META->{LOCK};
1607 $CPAN::Frontend->myprint(
1608 sprintf("Scanning cache %s for sizes\n",
1611 my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
1615 # next if $e eq ".." || $e eq ".";
1616 $self->disk_usage($e);
1618 while (($painted/76) < ($i/@entries)) {
1619 $CPAN::Frontend->myprint(".");
1622 return if $CPAN::Signal;
1624 $CPAN::Frontend->myprint("DONE\n");
1628 package CPAN::Shell;
1631 #-> sub CPAN::Shell::h ;
1633 my($class,$about) = @_;
1634 if (defined $about) {
1635 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1637 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1638 $CPAN::Frontend->myprint(qq{
1639 Display Information $filler (ver $CPAN::VERSION)
1640 command argument description
1641 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1642 i WORD or /REGEXP/ about any of the above
1643 ls AUTHOR or GLOB about files in the author's directory
1644 (with WORD being a module, bundle or author name or a distribution
1645 name of the form AUTHOR/DISTRIBUTION)
1647 Download, Test, Make, Install...
1648 get download clean make clean
1649 make make (implies get) look open subshell in dist directory
1650 test make test (implies make) readme display these README files
1651 install make install (implies test) perldoc display POD documentation
1654 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1655 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1658 force CMD try hard to do command fforce CMD try harder
1659 notest CMD skip testing
1662 h,? display this menu ! perl-code eval a perl command
1663 o conf [opt] set and query options q quit the cpan shell
1664 reload cpan load CPAN.pm again reload index load newer indices
1665 autobundle Snapshot recent latest CPAN uploads});
1671 #-> sub CPAN::Shell::a ;
1673 my($self,@arg) = @_;
1674 # authors are always UPPERCASE
1676 $_ = uc $_ unless /=/;
1678 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1681 #-> sub CPAN::Shell::globls ;
1683 my($self,$s,$pragmas) = @_;
1684 # ls is really very different, but we had it once as an ordinary
1685 # command in the Shell (upto rev. 321) and we could not handle
1687 my(@accept,@preexpand);
1688 if ($s =~ /[\*\?\/]/) {
1689 if ($CPAN::META->has_inst("Text::Glob")) {
1690 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1691 my $rau = Text::Glob::glob_to_regex(uc $au);
1692 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1694 push @preexpand, map { $_->id . "/" . $pathglob }
1695 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1697 my $rau = Text::Glob::glob_to_regex(uc $s);
1698 push @preexpand, map { $_->id }
1699 CPAN::Shell->expand_by_method('CPAN::Author',
1704 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1707 push @preexpand, uc $s;
1710 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1711 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1716 my $silent = @accept>1;
1717 my $last_alpha = "";
1719 for my $a (@accept){
1720 my($author,$pathglob);
1721 if ($a =~ m|(.*?)/(.*)|) {
1724 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1727 or $CPAN::Frontend->mydie("No author found for $a2\n");
1729 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1732 or $CPAN::Frontend->mydie("No author found for $a\n");
1735 my $alpha = substr $author->id, 0, 1;
1737 if ($alpha eq $last_alpha) {
1741 $last_alpha = $alpha;
1743 $CPAN::Frontend->myprint($ad);
1745 for my $pragma (@$pragmas) {
1746 if ($author->can($pragma)) {
1750 push @results, $author->ls($pathglob,$silent); # silent if
1753 for my $pragma (@$pragmas) {
1754 my $unpragma = "un$pragma";
1755 if ($author->can($unpragma)) {
1756 $author->$unpragma();
1763 #-> sub CPAN::Shell::local_bundles ;
1765 my($self,@which) = @_;
1766 my($incdir,$bdir,$dh);
1767 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1768 my @bbase = "Bundle";
1769 while (my $bbase = shift @bbase) {
1770 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1771 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1772 if ($dh = DirHandle->new($bdir)) { # may fail
1774 for $entry ($dh->read) {
1775 next if $entry =~ /^\./;
1776 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1777 if (-d File::Spec->catdir($bdir,$entry)){
1778 push @bbase, "$bbase\::$entry";
1780 next unless $entry =~ s/\.pm(?!\n)\Z//;
1781 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1789 #-> sub CPAN::Shell::b ;
1791 my($self,@which) = @_;
1792 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1793 $self->local_bundles;
1794 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1797 #-> sub CPAN::Shell::d ;
1798 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1800 #-> sub CPAN::Shell::m ;
1801 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1803 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1806 #-> sub CPAN::Shell::i ;
1810 @args = '/./' unless @args;
1812 for my $type (qw/Bundle Distribution Module/) {
1813 push @result, $self->expand($type,@args);
1815 # Authors are always uppercase.
1816 push @result, $self->expand("Author", map { uc $_ } @args);
1818 my $result = @result == 1 ?
1819 $result[0]->as_string :
1821 "No objects found of any type for argument @args\n" :
1823 (map {$_->as_glimpse} @result),
1824 scalar @result, " items found\n",
1826 $CPAN::Frontend->myprint($result);
1829 #-> sub CPAN::Shell::o ;
1831 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1832 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1833 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1834 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1836 my($self,$o_type,@o_what) = @_;
1838 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1839 if ($o_type eq 'conf') {
1840 if (!@o_what) { # print all things, "o conf"
1842 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1844 if (exists $INC{'CPAN/Config.pm'}) {
1845 push @from, $INC{'CPAN/Config.pm'};
1847 if (exists $INC{'CPAN/MyConfig.pm'}) {
1848 push @from, $INC{'CPAN/MyConfig.pm'};
1850 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1851 $CPAN::Frontend->myprint(":\n");
1852 for $k (sort keys %CPAN::HandleConfig::can) {
1853 $v = $CPAN::HandleConfig::can{$k};
1854 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1856 $CPAN::Frontend->myprint("\n");
1857 for $k (sort keys %$CPAN::Config) {
1858 CPAN::HandleConfig->prettyprint($k);
1860 $CPAN::Frontend->myprint("\n");
1862 if (CPAN::HandleConfig->edit(@o_what)) {
1864 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1868 } elsif ($o_type eq 'debug') {
1870 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1873 my($what) = shift @o_what;
1874 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1875 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1878 if ( exists $CPAN::DEBUG{$what} ) {
1879 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1880 } elsif ($what =~ /^\d/) {
1881 $CPAN::DEBUG = $what;
1882 } elsif (lc $what eq 'all') {
1884 for (values %CPAN::DEBUG) {
1887 $CPAN::DEBUG = $max;
1890 for (keys %CPAN::DEBUG) {
1891 next unless lc($_) eq lc($what);
1892 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1895 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1900 my $raw = "Valid options for debug are ".
1901 join(", ",sort(keys %CPAN::DEBUG), 'all').
1902 qq{ or a number. Completion works on the options. }.
1903 qq{Case is ignored.};
1905 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1906 $CPAN::Frontend->myprint("\n\n");
1909 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1911 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1912 $v = $CPAN::DEBUG{$k};
1913 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1914 if $v & $CPAN::DEBUG;
1917 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1920 $CPAN::Frontend->myprint(qq{
1922 conf set or get configuration variables
1923 debug set or get debugging options
1928 # CPAN::Shell::paintdots_onreload
1929 sub paintdots_onreload {
1932 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1936 # $CPAN::Frontend->myprint(".($subr)");
1937 $CPAN::Frontend->myprint(".");
1938 if ($subr =~ /\bshell\b/i) {
1939 # warn "debug[$_[0]]";
1941 # It would be nice if we could detect that a
1942 # subroutine has actually changed, but for now we
1943 # practically always set the GOTOSHELL global
1953 #-> sub CPAN::Shell::hosts ;
1956 my $fullstats = CPAN::FTP->_ftp_statistics();
1957 my $history = $fullstats->{history} || [];
1959 while (my $last = pop @$history) {
1960 my $attempts = $last->{attempts} or next;
1963 $start = $attempts->[-1]{start};
1964 if ($#$attempts > 0) {
1965 for my $i (0..$#$attempts-1) {
1966 my $url = $attempts->[$i]{url} or next;
1971 $start = $last->{start};
1973 next unless $last->{thesiteurl}; # C-C? bad filenames?
1975 $S{end} ||= $last->{end};
1976 my $dltime = $last->{end} - $start;
1977 my $dlsize = $last->{filesize} || 0;
1978 my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
1979 my $s = $S{ok}{$url} ||= {};
1982 $s->{dlsize} += $dlsize/1024;
1984 $s->{dltime} += $dltime;
1987 for my $url (keys %{$S{ok}}) {
1988 next if $S{ok}{$url}{dltime} == 0; # div by zero
1989 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1990 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1994 for my $url (keys %{$S{no}}) {
1995 push @{$res->{no}}, [$S{no}{$url},
1999 my $R = ""; # report
2000 if ($S{start} && $S{end}) {
2001 $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2002 $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
2004 if ($res->{ok} && @{$res->{ok}}) {
2005 $R .= sprintf "\nSuccessful downloads:
2006 N kB secs kB/s url\n";
2008 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2009 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2013 if ($res->{no} && @{$res->{no}}) {
2014 $R .= sprintf "\nUnsuccessful downloads:\n";
2016 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2017 $R .= sprintf "%4d %s\n", @$_;
2021 $CPAN::Frontend->myprint($R);
2024 #-> sub CPAN::Shell::reload ;
2026 my($self,$command,@arg) = @_;
2028 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2029 if ($command =~ /^cpan$/i) {
2031 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2036 "CPAN/FirstTime.pm",
2037 "CPAN/HandleConfig.pm",
2045 MFILE: for my $f (@relo) {
2046 next unless exists $INC{$f};
2050 $CPAN::Frontend->myprint("($p");
2051 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2052 $self->_reload_this($f) or $failed++;
2053 my $v = eval "$p\::->VERSION";
2054 $CPAN::Frontend->myprint("v$v)");
2056 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2058 my $errors = $failed == 1 ? "error" : "errors";
2059 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2062 } elsif ($command =~ /^index$/i) {
2063 CPAN::Index->force_reload;
2065 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
2066 index re-reads the index files\n});
2070 # reload means only load again what we have loaded before
2071 #-> sub CPAN::Shell::_reload_this ;
2073 my($self,$f,$args) = @_;
2074 CPAN->debug("f[$f]") if $CPAN::DEBUG;
2075 return 1 unless $INC{$f}; # we never loaded this, so we do not
2077 my $pwd = CPAN::anycwd();
2078 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2080 for my $inc (@INC) {
2081 $file = File::Spec->catfile($inc,split /\//, $f);
2085 CPAN->debug("file[$file]") if $CPAN::DEBUG;
2087 unless ($file && -f $file) {
2088 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2090 unless (CPAN->has_inst("File::Basename")) {
2091 @inc = File::Basename::dirname($file);
2093 # do we ever need this?
2094 @inc = substr($file,0,-length($f)-1); # bring in back to me!
2097 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2099 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2102 my $mtime = (stat $file)[9];
2103 $reload->{$f} ||= $^T;
2104 my $must_reload = $mtime > $reload->{$f};
2106 $must_reload ||= $args->{reloforce};
2108 my $fh = FileHandle->new($file) or
2109 $CPAN::Frontend->mydie("Could not open $file: $!");
2112 my $content = <$fh>;
2113 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2117 eval "require '$f'";
2122 $reload->{$f} = time;
2124 $CPAN::Frontend->myprint("__unchanged__");
2129 #-> sub CPAN::Shell::mkmyconfig ;
2131 my($self, $cpanpm, %args) = @_;
2132 require CPAN::FirstTime;
2133 my $home = CPAN::HandleConfig::home;
2134 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2135 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2136 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2137 CPAN::HandleConfig::require_myconfig_or_config;
2138 $CPAN::Config ||= {};
2143 keep_source_where => undef,
2146 CPAN::FirstTime::init($cpanpm, %args);
2149 #-> sub CPAN::Shell::_binary_extensions ;
2150 sub _binary_extensions {
2151 my($self) = shift @_;
2152 my(@result,$module,%seen,%need,$headerdone);
2153 for $module ($self->expand('Module','/./')) {
2154 my $file = $module->cpan_file;
2155 next if $file eq "N/A";
2156 next if $file =~ /^Contact Author/;
2157 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2158 next if $dist->isa_perl;
2159 next unless $module->xs_file;
2161 $CPAN::Frontend->myprint(".");
2162 push @result, $module;
2164 # print join " | ", @result;
2165 $CPAN::Frontend->myprint("\n");
2169 #-> sub CPAN::Shell::recompile ;
2171 my($self) = shift @_;
2172 my($module,@module,$cpan_file,%dist);
2173 @module = $self->_binary_extensions();
2174 for $module (@module){ # we force now and compile later, so we
2176 $cpan_file = $module->cpan_file;
2177 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2179 $dist{$cpan_file}++;
2181 for $cpan_file (sort keys %dist) {
2182 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
2183 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2185 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2186 # stop a package from recompiling,
2187 # e.g. IO-1.12 when we have perl5.003_10
2191 #-> sub CPAN::Shell::scripts ;
2193 my($self, $arg) = @_;
2194 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2196 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2197 unless ($CPAN::META->has_inst($req)) {
2198 $CPAN::Frontend->mywarn(" $req not available\n");
2201 my $p = HTML::LinkExtor->new();
2202 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2203 unless (-f $indexfile) {
2204 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2206 $p->parse_file($indexfile);
2209 if ($arg =~ s|^/(.+)/$|$1|) {
2210 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2212 for my $l ($p->links) {
2213 my $tag = shift @$l;
2214 next unless $tag eq "a";
2216 my $href = $att{href};
2217 next unless $href =~ s|^\.\./authors/id/./../||;
2220 if ($href =~ $qrarg) {
2224 if ($href =~ /\Q$arg\E/) {
2232 # now filter for the latest version if there is more than one of a name
2238 $stems{$stem} ||= [];
2239 push @{$stems{$stem}}, $href;
2241 for (sort keys %stems) {
2243 if (@{$stems{$_}} > 1) {
2244 $highest = List::Util::reduce {
2245 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2248 $highest = $stems{$_}[0];
2250 $CPAN::Frontend->myprint("$highest\n");
2254 #-> sub CPAN::Shell::report ;
2256 my($self,@args) = @_;
2257 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2258 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2260 local $CPAN::Config->{test_report} = 1;
2261 $self->force("test",@args); # force is there so that the test be
2262 # re-run (as documented)
2265 # compare with is_tested
2266 #-> sub CPAN::Shell::install_tested
2267 sub install_tested {
2268 my($self,@some) = @_;
2269 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2271 CPAN::Index->reload;
2273 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2274 my $yaml = "$b.yml";
2276 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2279 my $yaml_content = CPAN->_yaml_loadfile($yaml);
2280 my $id = $yaml_content->[0]{distribution}{ID};
2282 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2285 my $do = CPAN::Shell->expandany($id);
2287 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2290 unless ($do->{build_dir}) {
2291 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2294 unless ($do->{build_dir} eq $b) {
2295 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2301 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2302 return unless @some;
2304 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2305 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2306 return unless @some;
2308 # @some = grep { not $_->uptodate } @some;
2309 # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2310 # return unless @some;
2312 CPAN->debug("some[@some]");
2314 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2315 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2316 $CPAN::Frontend->mysleep(1);
2321 #-> sub CPAN::Shell::upgrade ;
2323 my($self,@args) = @_;
2324 $self->install($self->r(@args));
2327 #-> sub CPAN::Shell::_u_r_common ;
2329 my($self) = shift @_;
2330 my($what) = shift @_;
2331 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2332 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2333 $what && $what =~ /^[aru]$/;
2335 @args = '/./' unless @args;
2336 my(@result,$module,%seen,%need,$headerdone,
2337 $version_undefs,$version_zeroes);
2338 $version_undefs = $version_zeroes = 0;
2339 my $sprintf = "%s%-25s%s %9s %9s %s\n";
2340 my @expand = $self->expand('Module',@args);
2341 my $expand = scalar @expand;
2342 if (0) { # Looks like noise to me, was very useful for debugging
2343 # for metadata cache
2344 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2346 MODULE: for $module (@expand) {
2347 my $file = $module->cpan_file;
2348 next MODULE unless defined $file; # ??
2349 $file =~ s|^./../||;
2350 my($latest) = $module->cpan_version;
2351 my($inst_file) = $module->inst_file;
2353 return if $CPAN::Signal;
2356 $have = $module->inst_version;
2357 } elsif ($what eq "r") {
2358 $have = $module->inst_version;
2360 if ($have eq "undef"){
2362 } elsif ($have == 0){
2365 next MODULE unless CPAN::Version->vgt($latest, $have);
2366 # to be pedantic we should probably say:
2367 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2368 # to catch the case where CPAN has a version 0 and we have a version undef
2369 } elsif ($what eq "u") {
2375 } elsif ($what eq "r") {
2377 } elsif ($what eq "u") {
2381 return if $CPAN::Signal; # this is sometimes lengthy
2384 push @result, sprintf "%s %s\n", $module->id, $have;
2385 } elsif ($what eq "r") {
2386 push @result, $module->id;
2387 next MODULE if $seen{$file}++;
2388 } elsif ($what eq "u") {
2389 push @result, $module->id;
2390 next MODULE if $seen{$file}++;
2391 next MODULE if $file =~ /^Contact/;
2393 unless ($headerdone++){
2394 $CPAN::Frontend->myprint("\n");
2395 $CPAN::Frontend->myprint(sprintf(
2398 "Package namespace",
2410 $CPAN::META->has_inst("Term::ANSIColor")
2412 $module->description
2414 $color_on = Term::ANSIColor::color("green");
2415 $color_off = Term::ANSIColor::color("reset");
2417 $CPAN::Frontend->myprint(sprintf $sprintf,
2424 $need{$module->id}++;
2428 $CPAN::Frontend->myprint("No modules found for @args\n");
2429 } elsif ($what eq "r") {
2430 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2434 if ($version_zeroes) {
2435 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2436 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2437 qq{a version number of 0\n});
2439 if ($version_undefs) {
2440 my $s_has = $version_undefs > 1 ? "s have" : " has";
2441 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2442 qq{parseable version number\n});
2448 #-> sub CPAN::Shell::r ;
2450 shift->_u_r_common("r",@_);
2453 #-> sub CPAN::Shell::u ;
2455 shift->_u_r_common("u",@_);
2458 #-> sub CPAN::Shell::failed ;
2460 my($self,$only_id,$silent) = @_;
2462 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2464 NAY: for my $nosayer ( # order matters!
2473 next unless exists $d->{$nosayer};
2474 next unless defined $d->{$nosayer};
2476 UNIVERSAL::can($d->{$nosayer},"failed") ?
2477 $d->{$nosayer}->failed :
2478 $d->{$nosayer} =~ /^NO/
2480 next NAY if $only_id && $only_id != (
2481 UNIVERSAL::can($d->{$nosayer},"commandid")
2483 $d->{$nosayer}->commandid
2485 $CPAN::CurrentCommandId
2490 next DIST unless $failed;
2494 # " %-45s: %s %s\n",
2497 UNIVERSAL::can($d->{$failed},"failed") ?
2499 $d->{$failed}->commandid,
2502 $d->{$failed}->text,
2503 $d->{$failed}{TIME}||0,
2516 $scope = "this command";
2517 } elsif ($CPAN::Index::HAVE_REANIMATED) {
2518 $scope = "this or a previous session";
2519 # it might be nice to have a section for previous session and
2522 $scope = "this session";
2529 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2530 sort { $a->[0] <=> $b->[0] } @failed;
2533 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2540 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2541 } elsif (!$only_id || !$silent) {
2542 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2546 # XXX intentionally undocumented because completely bogus, unportable,
2549 #-> sub CPAN::Shell::status ;
2552 require Devel::Size;
2553 my $ps = FileHandle->new;
2554 open $ps, "/proc/$$/status";
2557 next unless /VmSize:\s+(\d+)/;
2561 $CPAN::Frontend->mywarn(sprintf(
2562 "%-27s %6d\n%-27s %6d\n",
2566 Devel::Size::total_size($CPAN::META)/1024,
2568 for my $k (sort keys %$CPAN::META) {
2569 next unless substr($k,0,4) eq "read";
2570 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2571 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2572 warn sprintf " %-25s %6d (keys: %6d)\n",
2574 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2575 scalar keys %{$CPAN::META->{$k}{$k2}};
2580 # compare with install_tested
2581 #-> sub CPAN::Shell::is_tested
2584 CPAN::Index->reload;
2585 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2587 if ($CPAN::META->{is_tested}{$b}) {
2588 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2590 $time = scalar localtime;
2593 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2597 #-> sub CPAN::Shell::autobundle ;
2600 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2601 my(@bundle) = $self->_u_r_common("a",@_);
2602 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2603 File::Path::mkpath($todir);
2604 unless (-d $todir) {
2605 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2608 my($y,$m,$d) = (localtime)[5,4,3];
2612 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2613 my($to) = File::Spec->catfile($todir,"$me.pm");
2615 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2616 $to = File::Spec->catfile($todir,"$me.pm");
2618 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2620 "package Bundle::$me;\n\n",
2621 "\$VERSION = '0.01';\n\n",
2625 "Bundle::$me - Snapshot of installation on ",
2626 $Config::Config{'myhostname'},
2629 "\n\n=head1 SYNOPSIS\n\n",
2630 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2631 "=head1 CONTENTS\n\n",
2632 join("\n", @bundle),
2633 "\n\n=head1 CONFIGURATION\n\n",
2635 "\n\n=head1 AUTHOR\n\n",
2636 "This Bundle has been generated automatically ",
2637 "by the autobundle routine in CPAN.pm.\n",
2640 $CPAN::Frontend->myprint("\nWrote bundle file
2644 #-> sub CPAN::Shell::expandany ;
2647 CPAN->debug("s[$s]") if $CPAN::DEBUG;
2648 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2649 $s = CPAN::Distribution->normalize($s);
2650 return $CPAN::META->instance('CPAN::Distribution',$s);
2651 # Distributions spring into existence, not expand
2652 } elsif ($s =~ m|^Bundle::|) {
2653 $self->local_bundles; # scanning so late for bundles seems
2654 # both attractive and crumpy: always
2655 # current state but easy to forget
2657 return $self->expand('Bundle',$s);
2659 return $self->expand('Module',$s)
2660 if $CPAN::META->exists('CPAN::Module',$s);
2665 #-> sub CPAN::Shell::expand ;
2668 my($type,@args) = @_;
2669 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2670 my $class = "CPAN::$type";
2671 my $methods = ['id'];
2672 for my $meth (qw(name)) {
2673 next unless $class->can($meth);
2674 push @$methods, $meth;
2676 $self->expand_by_method($class,$methods,@args);
2679 #-> sub CPAN::Shell::expand_by_method ;
2680 sub expand_by_method {
2682 my($class,$methods,@args) = @_;
2685 my($regex,$command);
2686 if ($arg =~ m|^/(.*)/$|) {
2688 } elsif ($arg =~ m/=/) {
2692 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2694 defined $regex ? $regex : "UNDEFINED",
2695 defined $command ? $command : "UNDEFINED",
2697 if (defined $regex) {
2698 if (CPAN::_sqlite_running) {
2699 $CPAN::SQLite->search($class, $regex);
2702 $CPAN::META->all_objects($class)
2704 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2705 # BUG, we got an empty object somewhere
2706 require Data::Dumper;
2707 CPAN->debug(sprintf(
2708 "Bug in CPAN: Empty id on obj[%s][%s]",
2710 Data::Dumper::Dumper($obj)
2714 for my $method (@$methods) {
2715 my $match = eval {$obj->$method() =~ /$regex/i};
2717 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2718 $err ||= $@; # if we were too restrictive above
2719 $CPAN::Frontend->mydie("$err\n");
2726 } elsif ($command) {
2727 die "equal sign in command disabled (immature interface), ".
2729 ! \$CPAN::Shell::ADVANCED_QUERY=1
2730 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2731 that may go away anytime.\n"
2732 unless $ADVANCED_QUERY;
2733 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2734 my($matchcrit) = $criterion =~ m/^~(.+)/;
2738 $CPAN::META->all_objects($class)
2740 my $lhs = $self->$method() or next; # () for 5.00503
2742 push @m, $self if $lhs =~ m/$matchcrit/;
2744 push @m, $self if $lhs eq $criterion;
2749 if ( $class eq 'CPAN::Bundle' ) {
2750 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2751 } elsif ($class eq "CPAN::Distribution") {
2752 $xarg = CPAN::Distribution->normalize($arg);
2756 if ($CPAN::META->exists($class,$xarg)) {
2757 $obj = $CPAN::META->instance($class,$xarg);
2758 } elsif ($CPAN::META->exists($class,$arg)) {
2759 $obj = $CPAN::META->instance($class,$arg);
2766 @m = sort {$a->id cmp $b->id} @m;
2767 if ( $CPAN::DEBUG ) {
2768 my $wantarray = wantarray;
2769 my $join_m = join ",", map {$_->id} @m;
2770 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2772 return wantarray ? @m : $m[0];
2775 #-> sub CPAN::Shell::format_result ;
2778 my($type,@args) = @_;
2779 @args = '/./' unless @args;
2780 my(@result) = $self->expand($type,@args);
2781 my $result = @result == 1 ?
2782 $result[0]->as_string :
2784 "No objects of type $type found for argument @args\n" :
2786 (map {$_->as_glimpse} @result),
2787 scalar @result, " items found\n",
2792 #-> sub CPAN::Shell::report_fh ;
2794 my $installation_report_fh;
2795 my $previously_noticed = 0;
2798 return $installation_report_fh if $installation_report_fh;
2799 if ($CPAN::META->has_inst("File::Temp")) {
2800 $installation_report_fh
2802 template => 'cpan_install_XXXX',
2807 unless ( $installation_report_fh ) {
2808 warn("Couldn't open installation report file; " .
2809 "no report file will be generated."
2810 ) unless $previously_noticed++;
2816 # The only reason for this method is currently to have a reliable
2817 # debugging utility that reveals which output is going through which
2818 # channel. No, I don't like the colors ;-)
2820 # to turn colordebugging on, write
2821 # cpan> o conf colorize_output 1
2823 #-> sub CPAN::Shell::print_ornamented ;
2825 my $print_ornamented_have_warned = 0;
2826 sub colorize_output {
2827 my $colorize_output = $CPAN::Config->{colorize_output};
2828 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2829 unless ($print_ornamented_have_warned++) {
2830 # no myprint/mywarn within myprint/mywarn!
2831 warn "Colorize_output is set to true but Term::ANSIColor is not
2832 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2834 $colorize_output = 0;
2836 return $colorize_output;
2841 #-> sub CPAN::Shell::print_ornamented ;
2842 sub print_ornamented {
2843 my($self,$what,$ornament) = @_;
2844 return unless defined $what;
2846 local $| = 1; # Flush immediately
2847 if ( $CPAN::Be_Silent ) {
2848 print {report_fh()} $what;
2851 my $swhat = "$what"; # stringify if it is an object
2852 if ($CPAN::Config->{term_is_latin}){
2855 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2857 if ($self->colorize_output) {
2858 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2859 # if you want to have this configurable, please file a bugreport
2860 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2862 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2864 print "Term::ANSIColor rejects color[$ornament]: $@\n
2865 Please choose a different color (Hint: try 'o conf init /color/')\n";
2869 Term::ANSIColor::color("reset");
2875 #-> sub CPAN::Shell::myprint ;
2877 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2878 # where to use what! I think, we send everything to STDOUT and use
2879 # print for normal/good news and warn for news that need more
2880 # attention. Yes, this is our working contract for now.
2882 my($self,$what) = @_;
2884 $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2887 #-> sub CPAN::Shell::myexit ;
2889 my($self,$what) = @_;
2890 $self->myprint($what);
2894 #-> sub CPAN::Shell::mywarn ;
2896 my($self,$what) = @_;
2897 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2900 # only to be used for shell commands
2901 #-> sub CPAN::Shell::mydie ;
2903 my($self,$what) = @_;
2904 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2906 # If it is the shell, we want that the following die to be silent,
2907 # but if it is not the shell, we would need a 'die $what'. We need
2908 # to take care that only shell commands use mydie. Is this
2914 # sub CPAN::Shell::colorable_makemaker_prompt ;
2915 sub colorable_makemaker_prompt {
2917 if (CPAN::Shell->colorize_output) {
2918 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2919 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2922 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2923 if (CPAN::Shell->colorize_output) {
2924 print Term::ANSIColor::color('reset');
2929 # use this only for unrecoverable errors!
2930 #-> sub CPAN::Shell::unrecoverable_error ;
2931 sub unrecoverable_error {
2932 my($self,$what) = @_;
2933 my @lines = split /\n/, $what;
2935 for my $l (@lines) {
2936 $longest = length $l if length $l > $longest;
2938 $longest = 62 if $longest > 62;
2939 for my $l (@lines) {
2945 if (length $l < 66) {
2946 $l = pack "A66 A*", $l, "<==";
2950 unshift @lines, "\n";
2951 $self->mydie(join "", @lines);
2954 #-> sub CPAN::Shell::mysleep ;
2956 my($self, $sleep) = @_;
2957 use Time::HiRes qw(sleep);
2961 #-> sub CPAN::Shell::setup_output ;
2963 return if -t STDOUT;
2964 my $odef = select STDERR;
2971 #-> sub CPAN::Shell::rematein ;
2972 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
2975 my($meth,@some) = @_;
2977 while($meth =~ /^(ff?orce|notest)$/) {
2978 push @pragma, $meth;
2979 $meth = shift @some or
2980 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2984 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2986 # Here is the place to set "test_count" on all involved parties to
2987 # 0. We then can pass this counter on to the involved
2988 # distributions and those can refuse to test if test_count > X. In
2989 # the first stab at it we could use a 1 for "X".
2991 # But when do I reset the distributions to start with 0 again?
2992 # Jost suggested to have a random or cycling interaction ID that
2993 # we pass through. But the ID is something that is just left lying
2994 # around in addition to the counter, so I'd prefer to set the
2995 # counter to 0 now, and repeat at the end of the loop. But what
2996 # about dependencies? They appear later and are not reset, they
2997 # enter the queue but not its copy. How do they get a sensible
3000 my $needs_recursion_protection = "make|test|install";
3002 # construct the queue
3004 STHING: foreach $s (@some) {
3007 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3009 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3010 } elsif ($s =~ m|^/|) { # looks like a regexp
3011 if (substr($s,-1,1) eq ".") {
3012 $obj = CPAN::Shell->expandany($s);
3014 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3015 "not supported.\nRejecting argument '$s'\n");
3016 $CPAN::Frontend->mysleep(2);
3019 } elsif ($meth eq "ls") {
3020 $self->globls($s,\@pragma);
3023 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3024 $obj = CPAN::Shell->expandany($s);
3027 } elsif (ref $obj) {
3028 if ($meth =~ /^($needs_recursion_protection)$/) {
3029 # it would be silly to check for recursion for look or dump
3030 # (we are in CPAN::Shell::rematein)
3031 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3032 eval { $obj->color_cmd_tmps(0,1); };
3035 and $@->isa("CPAN::Exception::RecursiveDependency")) {
3036 $CPAN::Frontend->mywarn($@);
3040 Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3046 CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
3048 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3049 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3050 if ($meth =~ /^(dump|ls)$/) {
3053 $CPAN::Frontend->mywarn(
3055 "Don't be silly, you can't $meth ",
3059 $CPAN::Frontend->mysleep(2);
3061 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3062 CPAN::InfoObj->dump($s);
3065 ->mywarn(qq{Warning: Cannot $meth $s, }.
3066 qq{don't know what it is.
3071 to find objects with matching identifiers.
3073 $CPAN::Frontend->mysleep(2);
3077 # queuerunner (please be warned: when I started to change the
3078 # queue to hold objects instead of names, I made one or two
3079 # mistakes and never found which. I reverted back instead)
3080 while (my $q = CPAN::Queue->first) {
3082 my $s = $q->as_string;
3083 my $reqtype = $q->reqtype || "";
3084 $obj = CPAN::Shell->expandany($s);
3086 # don't know how this can happen, maybe we should panic,
3087 # but maybe we get a solution from the first user who hits
3088 # this unfortunate exception?
3089 $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3090 "to an object. Skipping.\n");
3091 $CPAN::Frontend->mysleep(5);
3092 CPAN::Queue->delete_first($s);
3095 $obj->{reqtype} ||= "";
3097 # force debugging because CPAN::SQLite somehow delivers us
3100 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3102 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3103 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3105 if ($obj->{reqtype}) {
3106 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3107 $obj->{reqtype} = $reqtype;
3109 exists $obj->{install}
3112 UNIVERSAL::can($obj->{install},"failed") ?
3113 $obj->{install}->failed :
3114 $obj->{install} =~ /^NO/
3117 delete $obj->{install};
3118 $CPAN::Frontend->mywarn
3119 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3123 $obj->{reqtype} = $reqtype;
3126 for my $pragma (@pragma) {
3129 $obj->can($pragma)){
3130 $obj->$pragma($meth);
3133 if (UNIVERSAL::can($obj, 'called_for')) {
3134 $obj->called_for($s);
3136 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3137 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3140 if (! UNIVERSAL::can($obj,$meth)) {
3142 my $serialized = "";
3144 } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3145 $serialized = YAML::Syck::Dump($obj);
3146 } elsif ($CPAN::META->has_inst("YAML")) {
3147 $serialized = YAML::Dump($obj);
3148 } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3149 $serialized = Data::Dumper::Dumper($obj);
3152 $serialized = overload::StrVal($obj);
3154 $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3155 } elsif ($obj->$meth()){
3156 CPAN::Queue->delete($s);
3158 CPAN->debug("failed");
3162 for my $pragma (@pragma) {
3163 my $unpragma = "un$pragma";
3164 if ($obj->can($unpragma)) {
3168 CPAN::Queue->delete_first($s);
3170 if ($meth =~ /^($needs_recursion_protection)$/) {
3171 for my $obj (@qcopy) {
3172 $obj->color_cmd_tmps(0,0);
3177 #-> sub CPAN::Shell::recent ;
3181 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3186 # set up the dispatching methods
3188 for my $command (qw(
3204 *$command = sub { shift->rematein($command, @_); };
3208 package CPAN::LWP::UserAgent;
3212 return if $SETUPDONE;
3213 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3214 require LWP::UserAgent;
3215 @ISA = qw(Exporter LWP::UserAgent);
3218 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
3222 sub get_basic_credentials {
3223 my($self, $realm, $uri, $proxy) = @_;
3224 if ($USER && $PASSWD) {
3225 return ($USER, $PASSWD);
3228 ($USER,$PASSWD) = $self->get_proxy_credentials();
3230 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3232 return($USER,$PASSWD);
3235 sub get_proxy_credentials {
3237 my ($user, $password);
3238 if ( defined $CPAN::Config->{proxy_user} &&
3239 defined $CPAN::Config->{proxy_pass}) {
3240 $user = $CPAN::Config->{proxy_user};
3241 $password = $CPAN::Config->{proxy_pass};
3242 return ($user, $password);
3244 my $username_prompt = "\nProxy authentication needed!
3245 (Note: to permanently configure username and password run
3246 o conf proxy_user your_username
3247 o conf proxy_pass your_password
3249 ($user, $password) =
3250 _get_username_and_password_from_user($username_prompt);
3251 return ($user,$password);
3254 sub get_non_proxy_credentials {
3256 my ($user,$password);
3257 if ( defined $CPAN::Config->{username} &&
3258 defined $CPAN::Config->{password}) {
3259 $user = $CPAN::Config->{username};
3260 $password = $CPAN::Config->{password};
3261 return ($user, $password);
3263 my $username_prompt = "\nAuthentication needed!
3264 (Note: to permanently configure username and password run
3265 o conf username your_username
3266 o conf password your_password
3269 ($user, $password) =
3270 _get_username_and_password_from_user($username_prompt);
3271 return ($user,$password);
3274 sub _get_username_and_password_from_user {
3275 my $username_message = shift;
3276 my ($username,$password);
3278 ExtUtils::MakeMaker->import(qw(prompt));
3279 $username = prompt($username_message);
3280 if ($CPAN::META->has_inst("Term::ReadKey")) {
3281 Term::ReadKey::ReadMode("noecho");
3284 $CPAN::Frontend->mywarn(
3285 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3288 $password = prompt("Password:");
3290 if ($CPAN::META->has_inst("Term::ReadKey")) {
3291 Term::ReadKey::ReadMode("restore");
3293 $CPAN::Frontend->myprint("\n\n");
3294 return ($username,$password);
3297 # mirror(): Its purpose is to deal with proxy authentication. When we
3298 # call SUPER::mirror, we relly call the mirror method in
3299 # LWP::UserAgent. LWP::UserAgent will then call
3300 # $self->get_basic_credentials or some equivalent and this will be
3301 # $self->dispatched to our own get_basic_credentials method.
3303 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3305 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3306 # although we have gone through our get_basic_credentials, the proxy
3307 # server refuses to connect. This could be a case where the username or
3308 # password has changed in the meantime, so I'm trying once again without
3309 # $USER and $PASSWD to give the get_basic_credentials routine another
3310 # chance to set $USER and $PASSWD.
3312 # mirror(): Its purpose is to deal with proxy authentication. When we
3313 # call SUPER::mirror, we relly call the mirror method in
3314 # LWP::UserAgent. LWP::UserAgent will then call
3315 # $self->get_basic_credentials or some equivalent and this will be
3316 # $self->dispatched to our own get_basic_credentials method.
3318 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3320 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3321 # although we have gone through our get_basic_credentials, the proxy
3322 # server refuses to connect. This could be a case where the username or
3323 # password has changed in the meantime, so I'm trying once again without
3324 # $USER and $PASSWD to give the get_basic_credentials routine another
3325 # chance to set $USER and $PASSWD.
3328 my($self,$url,$aslocal) = @_;
3329 my $result = $self->SUPER::mirror($url,$aslocal);
3330 if ($result->code == 407) {
3333 $result = $self->SUPER::mirror($url,$aslocal);
3341 #-> sub CPAN::FTP::ftp_statistics
3342 # if they want to rewrite, they need to pass in a filehandle
3343 sub _ftp_statistics {
3345 my $locktype = $fh ? LOCK_EX : LOCK_SH;
3346 $fh ||= FileHandle->new;
3347 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3348 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3351 while (!flock $fh, $locktype|LOCK_NB) {
3352 $waitstart ||= localtime();
3354 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3356 $CPAN::Frontend->mysleep($sleep);
3359 } elsif ($sleep <=6) {
3363 my $stats = eval { CPAN->_yaml_loadfile($file); };
3366 if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3367 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3369 } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3370 $CPAN::Frontend->mydie($@);
3373 $CPAN::Frontend->mydie($@);
3379 #-> sub CPAN::FTP::_mytime
3381 if (CPAN->has_inst("Time::HiRes")) {
3382 return Time::HiRes::time();
3388 #-> sub CPAN::FTP::_new_stats
3390 my($self,$file) = @_;
3399 #-> sub CPAN::FTP::_add_to_statistics
3400 sub _add_to_statistics {
3401 my($self,$stats) = @_;
3402 my $yaml_module = CPAN::_yaml_module;
3403 $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3404 if ($CPAN::META->has_inst($yaml_module)) {
3405 $stats->{thesiteurl} = $ThesiteURL;
3406 if (CPAN->has_inst("Time::HiRes")) {
3407 $stats->{end} = Time::HiRes::time();
3409 $stats->{end} = time;
3411 my $fh = FileHandle->new;
3415 @debug = $time if $sdebug;
3416 my $fullstats = $self->_ftp_statistics($fh);
3418 $fullstats->{history} ||= [];
3419 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3420 push @debug, time if $sdebug;
3421 push @{$fullstats->{history}}, $stats;
3422 # arbitrary hardcoded constants until somebody demands to have
3423 # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3424 # YAML::Syck 0.82 has no noticable performance problem with 999;
3426 @{$fullstats->{history}} > 99
3427 || $time - $fullstats->{history}[0]{start} > 14*86400
3429 shift @{$fullstats->{history}}
3431 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3432 push @debug, time if $sdebug;
3433 push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3434 # need no eval because if this fails, it is serious
3435 my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3436 CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3438 local $CPAN::DEBUG = 512; # FTP
3440 CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3441 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3445 # Win32 cannot rename a file to an existing filename
3446 unlink($sfile) if ($^O eq 'MSWin32');
3447 rename "$sfile.$$", $sfile
3448 or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3452 # if file is CHECKSUMS, suggest the place where we got the file to be
3453 # checked from, maybe only for young files?
3454 #-> sub CPAN::FTP::_recommend_url_for
3455 sub _recommend_url_for {
3456 my($self, $file) = @_;
3457 my $urllist = $self->_get_urllist;
3458 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3459 my $fullstats = $self->_ftp_statistics();
3460 my $history = $fullstats->{history} || [];
3461 while (my $last = pop @$history) {
3462 last if $last->{end} - time > 3600; # only young results are interesting
3463 next unless $last->{file}; # dirname of nothing dies!
3464 next unless $file eq File::Basename::dirname($last->{file});
3465 return $last->{thesiteurl};
3468 if ($CPAN::Config->{randomize_urllist}
3470 rand(1) < $CPAN::Config->{randomize_urllist}
3472 $urllist->[int rand scalar @$urllist];
3478 #-> sub CPAN::FTP::_get_urllist
3481 $CPAN::Config->{urllist} ||= [];
3482 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3483 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
3484 $CPAN::Config->{urllist} = [];
3486 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3487 for my $u (@urllist) {
3488 CPAN->debug("u[$u]") if $CPAN::DEBUG;
3489 if (UNIVERSAL::can($u,"text")) {
3490 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3492 $u .= "/" unless substr($u,-1) eq "/";
3493 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3499 #-> sub CPAN::FTP::ftp_get ;
3501 my($class,$host,$dir,$file,$target) = @_;
3503 qq[Going to fetch file [$file] from dir [$dir]
3504 on host [$host] as local [$target]\n]
3506 my $ftp = Net::FTP->new($host);
3508 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
3511 return 0 unless defined $ftp;
3512 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3513 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3514 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3515 my $msg = $ftp->message;
3516 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
3519 unless ( $ftp->cwd($dir) ){
3520 my $msg = $ftp->message;
3521 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
3525 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3526 unless ( $ftp->get($file,$target) ){
3527 my $msg = $ftp->message;
3528 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
3531 $ftp->quit; # it's ok if this fails
3535 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3537 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
3538 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
3540 # > *** 1562,1567 ****
3541 # > --- 1562,1580 ----
3542 # > return 1 if substr($url,0,4) eq "file";
3543 # > return 1 unless $url =~ m|://([^/]+)|;
3545 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3547 # > + $proxy =~ m|://([^/:]+)|;
3549 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3550 # > + if ($noproxy) {
3551 # > + if ($host !~ /$noproxy$/) {
3552 # > + $host = $proxy;
3555 # > + $host = $proxy;
3558 # > require Net::Ping;
3559 # > return 1 unless $Net::Ping::VERSION >= 2;
3563 #-> sub CPAN::FTP::localize ;
3565 my($self,$file,$aslocal,$force) = @_;
3567 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3568 unless defined $aslocal;
3569 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3572 if ($^O eq 'MacOS') {
3573 # Comment by AK on 2000-09-03: Uniq short filenames would be
3574 # available in CHECKSUMS file
3575 my($name, $path) = File::Basename::fileparse($aslocal, '');
3576 if (length($name) > 31) {
3587 my $size = 31 - length($suf);
3588 while (length($name) > $size) {
3592 $aslocal = File::Spec->catfile($path, $name);
3596 if (-f $aslocal && -r _ && !($force & 1)){
3598 if ($size = -s $aslocal) {
3599 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3602 # empty file from a previous unsuccessful attempt to download it
3604 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3605 "could not remove.");
3608 my($maybe_restore) = 0;
3610 rename $aslocal, "$aslocal.bak$$";
3614 my($aslocal_dir) = File::Basename::dirname($aslocal);
3615 File::Path::mkpath($aslocal_dir);
3616 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3617 qq{directory "$aslocal_dir".
3618 I\'ll continue, but if you encounter problems, they may be due
3619 to insufficient permissions.\n}) unless -w $aslocal_dir;
3621 # Inheritance is not easier to manage than a few if/else branches
3622 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3624 CPAN::LWP::UserAgent->config;
3625 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3627 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3631 $Ua->proxy('ftp', $var)
3632 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3633 $Ua->proxy('http', $var)
3634 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3637 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3639 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3640 # > use ones that require basic autorization.
3642 # > Example of when I use it manually in my own stuff:
3644 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3645 # > $req->proxy_authorization_basic("username","password");
3646 # > $res = $ua->request($req);
3650 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3654 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3655 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3658 # Try the list of urls for each single object. We keep a record
3659 # where we did get a file from
3660 my(@reordered,$last);
3661 my $ccurllist = $self->_get_urllist;
3662 $last = $#$ccurllist;
3663 if ($force & 2) { # local cpans probably out of date, don't reorder
3664 @reordered = (0..$last);
3668 (substr($ccurllist->[$b],0,4) eq "file")
3670 (substr($ccurllist->[$a],0,4) eq "file")
3672 defined($ThesiteURL)
3674 ($ccurllist->[$b] eq $ThesiteURL)
3676 ($ccurllist->[$a] eq $ThesiteURL)
3681 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3683 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3685 @levels = qw/easy hard hardest/;
3687 @levels = qw/easy/ if $^O eq 'MacOS';
3689 local $ENV{FTP_PASSIVE} =
3690 exists $CPAN::Config->{ftp_passive} ?
3691 $CPAN::Config->{ftp_passive} : 1;
3693 my $stats = $self->_new_stats($file);
3694 LEVEL: for $levelno (0..$#levels) {
3695 my $level = $levels[$levelno];
3696 my $method = "host$level";
3697 my @host_seq = $level eq "easy" ?
3698 @reordered : 0..$last; # reordered has CDROM up front
3699 my @urllist = map { $ccurllist->[$_] } @host_seq;
3700 for my $u (@CPAN::Defaultsites) {
3701 push @urllist, $u unless grep { $_ eq $u } @urllist;
3703 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3704 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3705 if (my $recommend = $self->_recommend_url_for($file)) {
3706 @urllist = grep { $_ ne $recommend } @urllist;
3707 unshift @urllist, $recommend;
3709 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3710 $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3712 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3713 if ($ret eq $aslocal_tempfile) {
3714 # if we got it exactly as we asked for, only then we
3716 rename $aslocal_tempfile, $aslocal
3717 or $CPAN::Frontend->mydie("Error while trying to rename ".
3718 "'$ret' to '$aslocal': $!");
3721 $Themethod = $level;
3723 # utime $now, $now, $aslocal; # too bad, if we do that, we
3724 # might alter a local mirror
3725 $self->debug("level[$level]") if $CPAN::DEBUG;
3728 unlink $aslocal_tempfile;
3729 last if $CPAN::Signal; # need to cleanup
3733 $stats->{filesize} = -s $ret;
3735 $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
3736 $self->_add_to_statistics($stats);
3737 $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
3739 unlink "$aslocal.bak$$";
3742 unless ($CPAN::Signal) {
3745 if (@{$CPAN::Config->{urllist}}) {
3747 qq{Please check, if the URLs I found in your configuration file \(}.
3748 join(", ", @{$CPAN::Config->{urllist}}).
3751 push @mess, qq{Your urllist is empty!};
3753 push @mess, qq{The urllist can be edited.},
3754 qq{E.g. with 'o conf urllist push ftp://myurl/'};
3755 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3756 $CPAN::Frontend->mywarn("Could not fetch $file\n");
3757 $CPAN::Frontend->mysleep(2);
3759 if ($maybe_restore) {
3760 rename "$aslocal.bak$$", $aslocal;
3761 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3762 $self->ls($aslocal));
3769 my($self,$stats,$method,$url) = @_;
3770 push @{$stats->{attempts}}, {
3777 # package CPAN::FTP;
3779 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3781 HOSTEASY: for $ro_url (@$host_seq) {
3782 $self->_set_attempt($stats,"easy",$ro_url);
3783 my $url .= "$ro_url$file";
3784 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3785 if ($url =~ /^file:/) {
3787 if ($CPAN::META->has_inst('URI::URL')) {
3788 my $u = URI::URL->new($url);
3790 } else { # works only on Unix, is poorly constructed, but
3791 # hopefully better than nothing.
3792 # RFC 1738 says fileurl BNF is
3793 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3794 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3796 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3797 $l =~ s|^file:||; # assume they
3801 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
3803 $self->debug("local file[$l]") if $CPAN::DEBUG;
3804 if ( -f $l && -r _) {
3805 $ThesiteURL = $ro_url;
3808 if ($l =~ /(.+)\.gz$/) {
3810 if ( -f $ungz && -r _) {
3811 $ThesiteURL = $ro_url;
3815 # Maybe mirror has compressed it?
3817 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3818 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3820 $ThesiteURL = $ro_url;
3825 $self->debug("it was not a file URL") if $CPAN::DEBUG;
3826 if ($CPAN::META->has_usable('LWP')) {
3827 $CPAN::Frontend->myprint("Fetching with LWP:
3831 CPAN::LWP::UserAgent->config;
3832 eval { $Ua = CPAN::LWP::UserAgent->new; };
3834 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3837 my $res = $Ua->mirror($url, $aslocal);
3838 if ($res->is_success) {
3839 $ThesiteURL = $ro_url;
3841 utime $now, $now, $aslocal; # download time is more
3842 # important than upload
3845 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3846 my $gzurl = "$url.gz";
3847 $CPAN::Frontend->myprint("Fetching with LWP:
3850 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3851 if ($res->is_success) {
3852 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3853 $ThesiteURL = $ro_url;
3858 $CPAN::Frontend->myprint(sprintf(
3859 "LWP failed with code[%s] message[%s]\n",
3863 # Alan Burlison informed me that in firewall environments
3864 # Net::FTP can still succeed where LWP fails. So we do not
3865 # skip Net::FTP anymore when LWP is available.
3868 $CPAN::Frontend->mywarn(" LWP not available\n");
3870 return if $CPAN::Signal;
3871 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3872 # that's the nice and easy way thanks to Graham
3873 $self->debug("recognized ftp") if $CPAN::DEBUG;
3874 my($host,$dir,$getfile) = ($1,$2,$3);
3875 if ($CPAN::META->has_usable('Net::FTP')) {
3877 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3880 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3881 "aslocal[$aslocal]") if $CPAN::DEBUG;
3882 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3883 $ThesiteURL = $ro_url;
3886 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3887 my $gz = "$aslocal.gz";
3888 $CPAN::Frontend->myprint("Fetching with Net::FTP
3891 if (CPAN::FTP->ftp_get($host,
3895 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3897 $ThesiteURL = $ro_url;
3903 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3907 UNIVERSAL::can($ro_url,"text")
3909 $ro_url->{FROM} eq "USER"
3911 ##address #17973: default URLs should not try to override
3912 ##user-defined URLs just because LWP is not available
3913 my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3914 return $ret if $ret;
3916 return if $CPAN::Signal;
3920 # package CPAN::FTP;
3922 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3924 # Came back if Net::FTP couldn't establish connection (or
3925 # failed otherwise) Maybe they are behind a firewall, but they
3926 # gave us a socksified (or other) ftp program...
3929 my($devnull) = $CPAN::Config->{devnull} || "";
3931 my($aslocal_dir) = File::Basename::dirname($aslocal);
3932 File::Path::mkpath($aslocal_dir);
3933 HOSTHARD: for $ro_url (@$host_seq) {
3934 $self->_set_attempt($stats,"hard",$ro_url);
3935 my $url = "$ro_url$file";
3936 my($proto,$host,$dir,$getfile);
3938 # Courtesy Mark Conty mark_conty@cargill.com change from
3939 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3941 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3942 # proto not yet used
3943 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3945 next HOSTHARD; # who said, we could ftp anything except ftp?
3947 next HOSTHARD if $proto eq "file"; # file URLs would have had
3948 # success above. Likely a bogus URL
3950 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3952 # Try the most capable first and leave ncftp* for last as it only
3954 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3955 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3956 next unless defined $funkyftp;
3957 next if $funkyftp =~ /^\s*$/;
3959 my($asl_ungz, $asl_gz);
3960 ($asl_ungz = $aslocal) =~ s/\.gz//;
3961 $asl_gz = "$asl_ungz.gz";
3963 my($src_switch) = "";
3965 my($stdout_redir) = " > $asl_ungz";
3967 $src_switch = " -source";
3968 } elsif ($f eq "ncftp"){
3969 $src_switch = " -c";
3970 } elsif ($f eq "wget"){
3971 $src_switch = " -O $asl_ungz";
3973 } elsif ($f eq 'curl'){
3974 $src_switch = ' -L -f -s -S --netrc-optional';
3977 if ($f eq "ncftpget"){
3978 $chdir = "cd $aslocal_dir && ";
3981 $CPAN::Frontend->myprint(
3983 Trying with "$funkyftp$src_switch" to get
3987 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3988 $self->debug("system[$system]") if $CPAN::DEBUG;
3989 my($wstatus) = system($system);
3991 # lynx returns 0 when it fails somewhere
3993 my $content = do { local *FH;
3994 open FH, $asl_ungz or die;
3997 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3998 $CPAN::Frontend->mywarn(qq{
3999 No success, the file that lynx has has downloaded looks like an error message:
4002 $CPAN::Frontend->mysleep(1);
4006 $CPAN::Frontend->myprint(qq{
4007 No success, the file that lynx has has downloaded is an empty file.
4012 if ($wstatus == 0) {
4015 } elsif ($asl_ungz ne $aslocal) {
4016 # test gzip integrity
4017 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4018 # e.g. foo.tar is gzipped --> foo.tar.gz
4019 rename $asl_ungz, $aslocal;
4021 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4024 $ThesiteURL = $ro_url;
4026 } elsif ($url !~ /\.gz(?!\n)\Z/) {
4028 -f $asl_ungz && -s _ == 0;
4029 my $gz = "$aslocal.gz";
4030 my $gzurl = "$url.gz";
4031 $CPAN::Frontend->myprint(
4033 Trying with "$funkyftp$src_switch" to get
4036 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4037 $self->debug("system[$system]") if $CPAN::DEBUG;
4039 if (($wstatus = system($system)) == 0
4043 # test gzip integrity
4044 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4045 if ($ct && $ct->gtest) {
4046 $ct->gunzip($aslocal);
4048 # somebody uncompressed file for us?
4049 rename $asl_ungz, $aslocal;
4051 $ThesiteURL = $ro_url;
4054 unlink $asl_gz if -f $asl_gz;
4057 my $estatus = $wstatus >> 8;
4058 my $size = -f $aslocal ?
4059 ", left\n$aslocal with size ".-s _ :
4060 "\nWarning: expected file [$aslocal] doesn't exist";
4061 $CPAN::Frontend->myprint(qq{
4062 System call "$system"
4063 returned status $estatus (wstat $wstatus)$size
4066 return if $CPAN::Signal;
4067 } # transfer programs
4071 # package CPAN::FTP;
4073 my($self,$host_seq,$file,$aslocal,$stats) = @_;
4076 my($aslocal_dir) = File::Basename::dirname($aslocal);
4077 File::Path::mkpath($aslocal_dir);
4078 my $ftpbin = $CPAN::Config->{ftp};
4079 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4080 $CPAN::Frontend->myprint("No external ftp command available\n\n");
4083 $CPAN::Frontend->mywarn(qq{
4084 As a last ressort we now switch to the external ftp command '$ftpbin'
4087 Doing so often leads to problems that are hard to diagnose.
4089 If you're victim of such problems, please consider unsetting the ftp
4090 config variable with
4096 $CPAN::Frontend->mysleep(2);
4097 HOSTHARDEST: for $ro_url (@$host_seq) {
4098 $self->_set_attempt($stats,"hardest",$ro_url);
4099 my $url = "$ro_url$file";
4100 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4101 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4104 my($host,$dir,$getfile) = ($1,$2,$3);
4106 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4107 $ctime,$blksize,$blocks) = stat($aslocal);
4108 $timestamp = $mtime ||= 0;
4109 my($netrc) = CPAN::FTP::netrc->new;
4110 my($netrcfile) = $netrc->netrc;
4111 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4112 my $targetfile = File::Basename::basename($aslocal);
4118 map("cd $_", split /\//, $dir), # RFC 1738
4120 "get $getfile $targetfile",
4124 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4125 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4126 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4128 $netrc->contains($host))) if $CPAN::DEBUG;
4129 if ($netrc->protected) {
4130 my $dialog = join "", map { " $_\n" } @dialog;
4132 if ($netrc->contains($host)) {
4133 $netrc_explain = "Relying that your .netrc entry for '$host' ".
4134 "manages the login";
4136 $netrc_explain = "Relying that your default .netrc entry ".
4137 "manages the login";
4139 $CPAN::Frontend->myprint(qq{
4140 Trying with external ftp to get
4143 Going to send the dialog
4147 $self->talk_ftp("$ftpbin$verbose $host",
4149 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4150 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4152 if ($mtime > $timestamp) {
4153 $CPAN::Frontend->myprint("GOT $aslocal\n");
4154 $ThesiteURL = $ro_url;
4157 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4159 return if $CPAN::Signal;
4161 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4162 qq{correctly protected.\n});
4165 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4166 nor does it have a default entry\n");
4169 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4170 # then and login manually to host, using e-mail as
4172 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4176 "user anonymous $Config::Config{'cf_email'}"
4178 my $dialog = join "", map { " $_\n" } @dialog;
4179 $CPAN::Frontend->myprint(qq{
4180 Trying with external ftp to get
4182 Going to send the dialog
4186 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4187 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4188 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4190 if ($mtime > $timestamp) {
4191 $CPAN::Frontend->myprint("GOT $aslocal\n");
4192 $ThesiteURL = $ro_url;
4195 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4197 return if $CPAN::Signal;
4198 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4199 $CPAN::Frontend->mysleep(2);
4203 # package CPAN::FTP;
4205 my($self,$command,@dialog) = @_;
4206 my $fh = FileHandle->new;
4207 $fh->open("|$command") or die "Couldn't open ftp: $!";
4208 foreach (@dialog) { $fh->print("$_\n") }
4209 $fh->close; # Wait for process to complete
4211 my $estatus = $wstatus >> 8;
4212 $CPAN::Frontend->myprint(qq{
4213 Subprocess "|$command"
4214 returned status $estatus (wstat $wstatus)
4218 # find2perl needs modularization, too, all the following is stolen
4222 my($self,$name) = @_;
4223 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4224 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4226 my($perms,%user,%group);
4230 $blocks = int(($blocks + 1) / 2);
4233 $blocks = int(($sizemm + 1023) / 1024);
4236 if (-f _) { $perms = '-'; }
4237 elsif (-d _) { $perms = 'd'; }
4238 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4239 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4240 elsif (-p _) { $perms = 'p'; }
4241 elsif (-S _) { $perms = 's'; }
4242 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4244 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4245 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4246 my $tmpmode = $mode;
4247 my $tmp = $rwx[$tmpmode & 7];
4249 $tmp = $rwx[$tmpmode & 7] . $tmp;
4251 $tmp = $rwx[$tmpmode & 7] . $tmp;
4252 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4253 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4254 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4257 my $user = $user{$uid} || $uid; # too lazy to implement lookup
4258 my $group = $group{$gid} || $gid;
4260 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4262 my($moname) = $moname[$mon];
4263 if (-M _ > 365.25 / 2) {
4264 $timeyear = $year + 1900;
4267 $timeyear = sprintf("%02d:%02d", $hour, $min);
4270 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4284 package CPAN::FTP::netrc;
4287 # package CPAN::FTP::netrc;
4290 my $home = CPAN::HandleConfig::home;
4291 my $file = File::Spec->catfile($home,".netrc");
4293 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4294 $atime,$mtime,$ctime,$blksize,$blocks)
4299 my($fh,@machines,$hasdefault);
4301 $fh = FileHandle->new or die "Could not create a filehandle";
4303 if($fh->open($file)){
4304 $protected = ($mode & 077) == 0;
4306 NETRC: while (<$fh>) {
4307 my(@tokens) = split " ", $_;
4308 TOKEN: while (@tokens) {
4309 my($t) = shift @tokens;
4310 if ($t eq "default"){
4314 last TOKEN if $t eq "macdef";
4315 if ($t eq "machine") {
4316 push @machines, shift @tokens;
4321 $file = $hasdefault = $protected = "";
4325 'mach' => [@machines],
4327 'hasdefault' => $hasdefault,
4328 'protected' => $protected,
4332 # CPAN::FTP::netrc::hasdefault;
4333 sub hasdefault { shift->{'hasdefault'} }
4334 sub netrc { shift->{'netrc'} }
4335 sub protected { shift->{'protected'} }
4337 my($self,$mach) = @_;
4338 for ( @{$self->{'mach'}} ) {
4339 return 1 if $_ eq $mach;
4344 package CPAN::Complete;
4348 my($text, $line, $start, $end) = @_;
4349 my(@perlret) = cpl($text, $line, $start);
4350 # find longest common match. Can anybody show me how to peruse
4351 # T::R::Gnu to have this done automatically? Seems expensive.
4352 return () unless @perlret;
4353 my($newtext) = $text;
4354 for (my $i = length($text)+1;;$i++) {
4355 last unless length($perlret[0]) && length($perlret[0]) >= $i;
4356 my $try = substr($perlret[0],0,$i);
4357 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4358 # warn "try[$try]tries[@tries]";
4359 if (@tries == @perlret) {
4365 ($newtext,@perlret);
4368 #-> sub CPAN::Complete::cpl ;
4370 my($word,$line,$pos) = @_;
4374 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4376 if ($line =~ s/^((?:notest|f?force)\s*)//) {
4381 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4382 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4384 } elsif ($line =~ /^(a|ls)\s/) {
4385 @return = cplx('CPAN::Author',uc($word));
4386 } elsif ($line =~ /^b\s/) {
4387 CPAN::Shell->local_bundles;
4388 @return = cplx('CPAN::Bundle',$word);
4389 } elsif ($line =~ /^d\s/) {
4390 @return = cplx('CPAN::Distribution',$word);
4391 } elsif ($line =~ m/^(
4392 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4394 if ($word =~ /^Bundle::/) {
4395 CPAN::Shell->local_bundles;
4397 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4398 } elsif ($line =~ /^i\s/) {
4399 @return = cpl_any($word);
4400 } elsif ($line =~ /^reload\s/) {
4401 @return = cpl_reload($word,$line,$pos);
4402 } elsif ($line =~ /^o\s/) {
4403 @return = cpl_option($word,$line,$pos);
4404 } elsif ($line =~ m/^\S+\s/ ) {
4405 # fallback for future commands and what we have forgotten above
4406 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4413 #-> sub CPAN::Complete::cplx ;
4415 my($class, $word) = @_;
4416 if (CPAN::_sqlite_running) {
4417 $CPAN::SQLite->search($class, "^\Q$word\E");
4419 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4422 #-> sub CPAN::Complete::cpl_any ;
4426 cplx('CPAN::Author',$word),
4427 cplx('CPAN::Bundle',$word),
4428 cplx('CPAN::Distribution',$word),
4429 cplx('CPAN::Module',$word),
4433 #-> sub CPAN::Complete::cpl_reload ;
4435 my($word,$line,$pos) = @_;
4437 my(@words) = split " ", $line;
4438 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4439 my(@ok) = qw(cpan index);
4440 return @ok if @words == 1;
4441 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4444 #-> sub CPAN::Complete::cpl_option ;
4446 my($word,$line,$pos) = @_;
4448 my(@words) = split " ", $line;
4449 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4450 my(@ok) = qw(conf debug);
4451 return @ok if @words == 1;
4452 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4454 } elsif ($words[1] eq 'index') {
4456 } elsif ($words[1] eq 'conf') {
4457 return CPAN::HandleConfig::cpl(@_);
4458 } elsif ($words[1] eq 'debug') {
4459 return sort grep /^\Q$word\E/i,
4460 sort keys %CPAN::DEBUG, 'all';
4464 package CPAN::Index;
4467 #-> sub CPAN::Index::force_reload ;
4470 $CPAN::Index::LAST_TIME = 0;
4474 #-> sub CPAN::Index::reload ;
4476 my($self,$force) = @_;
4479 # XXX check if a newer one is available. (We currently read it
4480 # from time to time)
4481 for ($CPAN::Config->{index_expire}) {
4482 $_ = 0.001 unless $_ && $_ > 0.001;
4484 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4485 # debug here when CPAN doesn't seem to read the Metadata
4487 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4489 unless ($CPAN::META->{PROTOCOL}) {
4490 $self->read_metadata_cache;
4491 $CPAN::META->{PROTOCOL} ||= "1.0";
4493 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
4494 # warn "Setting last_time to 0";
4495 $LAST_TIME = 0; # No warning necessary
4497 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4500 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4502 # IFF we are developing, it helps to wipe out the memory
4503 # between reloads, otherwise it is not what a user expects.
4504 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4505 $CPAN::META = CPAN->new;
4508 local $LAST_TIME = $time;
4509 local $CPAN::META->{PROTOCOL} = PROTOCOL;
4511 my $needshort = $^O eq "dos";
4513 $self->rd_authindex($self
4515 "authors/01mailrc.txt.gz",
4517 File::Spec->catfile('authors', '01mailrc.gz') :
4518 File::Spec->catfile('authors', '01mailrc.txt.gz'),
4521 $debug = "timing reading 01[".($t2 - $time)."]";
4523 return if $CPAN::Signal; # this is sometimes lengthy
4524 $self->rd_modpacks($self
4526 "modules/02packages.details.txt.gz",
4528 File::Spec->catfile('modules', '02packag.gz') :
4529 File::Spec->catfile('modules', '02packages.details.txt.gz'),
4532 $debug .= "02[".($t2 - $time)."]";
4534 return if $CPAN::Signal; # this is sometimes lengthy
4535 $self->rd_modlist($self
4537 "modules/03modlist.data.gz",
4539 File::Spec->catfile('modules', '03mlist.gz') :
4540 File::Spec->catfile('modules', '03modlist.data.gz'),
4542 $self->write_metadata_cache;
4544 $debug .= "03[".($t2 - $time)."]";
4546 CPAN->debug($debug) if $CPAN::DEBUG;
4548 if ($CPAN::Config->{build_dir_reuse}) {
4549 $self->reanimate_build_dir;
4551 if (CPAN::_sqlite_running) {
4552 $CPAN::SQLite->reload(time => $time, force => $force)
4556 $CPAN::META->{PROTOCOL} = PROTOCOL;
4559 #-> sub CPAN::Index::reanimate_build_dir ;
4560 sub reanimate_build_dir {
4562 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4565 return if $HAVE_REANIMATED++;
4566 my $d = $CPAN::Config->{build_dir};
4567 my $dh = DirHandle->new;
4568 opendir $dh, $d or return; # does not exist
4573 $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4574 my @candidates = map { $_->[0] }
4575 sort { $b->[1] <=> $a->[1] }
4576 map { [ $_, -M File::Spec->catfile($d,$_) ] }
4577 grep {/\.yml$/} readdir $dh;
4578 DISTRO: for $dirent (@candidates) {
4579 my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4582 if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4583 my $key = $c->{distribution}{ID};
4584 for my $k (keys %{$c->{distribution}}) {
4585 if ($c->{distribution}{$k}
4586 && ref $c->{distribution}{$k}
4587 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4588 $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4592 #we tried to restore only if element already
4593 #exists; but then we do not work with metadata
4596 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4597 = $c->{distribution};
4598 delete $do->{badtestcnt};
4600 if ($do->{make_test}
4602 && !$do->{make_test}->failed
4606 $do->{install}->failed
4609 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4614 while (($painted/76) < ($i/@candidates)) {
4615 $CPAN::Frontend->myprint(".");
4619 $CPAN::Frontend->myprint(sprintf(
4620 "DONE\nFound %s old builds, restored the state of %s\n",
4621 @candidates ? sprintf("%d",scalar @candidates) : "no",
4622 $restored || "none",
4627 #-> sub CPAN::Index::reload_x ;
4629 my($cl,$wanted,$localname,$force) = @_;
4630 $force |= 2; # means we're dealing with an index here
4631 CPAN::HandleConfig->load; # we should guarantee loading wherever
4632 # we rely on Config XXX
4633 $localname ||= $wanted;
4634 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4638 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4641 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4642 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4643 qq{day$s. I\'ll use that.});
4646 $force |= 1; # means we're quite serious about it.
4648 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4651 #-> sub CPAN::Index::rd_authindex ;
4653 my($cl, $index_target) = @_;
4654 return unless defined $index_target;
4655 return if CPAN::_sqlite_running;
4657 $CPAN::Frontend->myprint("Going to read $index_target\n");
4659 tie *FH, 'CPAN::Tarzip', $index_target;
4662 push @lines, split /\012/ while <FH>;
4666 my($userid,$fullname,$email) =
4667 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4668 $fullname ||= $email;
4669 if ($userid && $fullname && $email){
4670 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4671 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4673 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4676 while (($painted/76) < ($i/@lines)) {
4677 $CPAN::Frontend->myprint(".");
4680 return if $CPAN::Signal;
4682 $CPAN::Frontend->myprint("DONE\n");
4686 my($self,$dist) = @_;
4687 $dist = $self->{'id'} unless defined $dist;
4688 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4692 #-> sub CPAN::Index::rd_modpacks ;
4694 my($self, $index_target) = @_;
4695 return unless defined $index_target;
4696 return if CPAN::_sqlite_running;
4697 $CPAN::Frontend->myprint("Going to read $index_target\n");
4698 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4700 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4703 while (my $bytes = $fh->READ(\$chunk,8192)) {
4706 my @lines = split /\012/, $slurp;
4707 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4710 my($line_count,$last_updated);
4712 my $shift = shift(@lines);
4713 last if $shift =~ /^\s*$/;
4714 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4715 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4717 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4718 if (not defined $line_count) {
4720 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4721 Please check the validity of the index file by comparing it to more
4722 than one CPAN mirror. I'll continue but problems seem likely to
4726 $CPAN::Frontend->mysleep(5);
4727 } elsif ($line_count != scalar @lines) {
4729 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4730 contains a Line-Count header of %d but I see %d lines there. Please
4731 check the validity of the index file by comparing it to more than one
4732 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4733 $index_target, $line_count, scalar(@lines));
4736 if (not defined $last_updated) {
4738 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4739 Please check the validity of the index file by comparing it to more
4740 than one CPAN mirror. I'll continue but problems seem likely to
4744 $CPAN::Frontend->mysleep(5);
4748 ->myprint(sprintf qq{ Database was generated on %s\n},
4750 $DATE_OF_02 = $last_updated;
4753 if ($CPAN::META->has_inst('HTTP::Date')) {
4755 $age -= HTTP::Date::str2time($last_updated);
4757 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
4758 require Time::Local;
4759 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4760 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4761 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4768 qq{Warning: This index file is %d days old.
4769 Please check the host you chose as your CPAN mirror for staleness.
4770 I'll continue but problems seem likely to happen.\a\n},
4773 } elsif ($age < -1) {
4777 qq{Warning: Your system date is %d days behind this index file!
4779 Timestamp index file: %s
4780 Please fix your system time, problems with the make command expected.\n},
4790 # A necessity since we have metadata_cache: delete what isn't
4792 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4793 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4798 # before 1.56 we split into 3 and discarded the rest. From
4799 # 1.57 we assign remaining text to $comment thus allowing to
4800 # influence isa_perl
4801 my($mod,$version,$dist,$comment) = split " ", $_, 4;
4802 my($bundle,$id,$userid);
4804 if ($mod eq 'CPAN' &&
4806 CPAN::Queue->exists('Bundle::CPAN') ||
4807 CPAN::Queue->exists('CPAN')
4811 if ($version > $CPAN::VERSION){
4812 $CPAN::Frontend->mywarn(qq{
4813 New CPAN.pm version (v$version) available.
4814 [Currently running version is v$CPAN::VERSION]
4815 You might want to try
4818 to both upgrade CPAN.pm and run the new version without leaving
4819 the current session.
4822 $CPAN::Frontend->mysleep(2);
4823 $CPAN::Frontend->myprint(qq{\n});
4825 last if $CPAN::Signal;
4826 } elsif ($mod =~ /^Bundle::(.*)/) {
4831 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
4832 # Let's make it a module too, because bundles have so much
4833 # in common with modules.
4835 # Changed in 1.57_63: seems like memory bloat now without
4836 # any value, so commented out
4838 # $CPAN::META->instance('CPAN::Module',$mod);
4842 # instantiate a module object
4843 $id = $CPAN::META->instance('CPAN::Module',$mod);
4847 # Although CPAN prohibits same name with different version the
4848 # indexer may have changed the version for the same distro
4849 # since the last time ("Force Reindexing" feature)
4850 if ($id->cpan_file ne $dist
4852 $id->cpan_version ne $version
4854 $userid = $id->userid || $self->userid($dist);
4856 'CPAN_USERID' => $userid,
4857 'CPAN_VERSION' => $version,
4858 'CPAN_FILE' => $dist,
4862 # instantiate a distribution object
4863 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4864 # we do not need CONTAINSMODS unless we do something with
4865 # this dist, so we better produce it on demand.
4867 ## my $obj = $CPAN::META->instance(
4868 ## 'CPAN::Distribution' => $dist
4870 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4872 $CPAN::META->instance(
4873 'CPAN::Distribution' => $dist
4875 'CPAN_USERID' => $userid,
4876 'CPAN_COMMENT' => $comment,
4880 for my $name ($mod,$dist) {
4881 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4882 $exists{$name} = undef;
4886 while (($painted/76) < ($i/@lines)) {
4887 $CPAN::Frontend->myprint(".");
4890 return if $CPAN::Signal;
4892 $CPAN::Frontend->myprint("DONE\n");
4894 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4895 for my $o ($CPAN::META->all_objects($class)) {
4896 next if exists $exists{$o->{ID}};
4897 $CPAN::META->delete($class,$o->{ID});
4898 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4905 #-> sub CPAN::Index::rd_modlist ;
4907 my($cl,$index_target) = @_;
4908 return unless defined $index_target;
4909 return if CPAN::_sqlite_running;
4910 $CPAN::Frontend->myprint("Going to read $index_target\n");
4911 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4915 while (my $bytes = $fh->READ(\$chunk,8192)) {
4918 my @eval2 = split /\012/, $slurp;
4921 my $shift = shift(@eval2);
4922 if ($shift =~ /^Date:\s+(.*)/){
4923 if ($DATE_OF_03 eq $1){
4924 $CPAN::Frontend->myprint("Unchanged.\n");
4929 last if $shift =~ /^\s*$/;
4931 push @eval2, q{CPAN::Modulelist->data;};
4933 my($comp) = Safe->new("CPAN::Safe1");
4934 my($eval2) = join("\n", @eval2);
4935 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4936 my $ret = $comp->reval($eval2);
4937 Carp::confess($@) if $@;
4938 return if $CPAN::Signal;
4940 my $until = keys(%$ret);
4942 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4944 my $obj = $CPAN::META->instance("CPAN::Module",$_);
4945 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4946 $obj->set(%{$ret->{$_}});
4948 while (($painted/76) < ($i/$until)) {
4949 $CPAN::Frontend->myprint(".");
4952 return if $CPAN::Signal;
4954 $CPAN::Frontend->myprint("DONE\n");
4957 #-> sub CPAN::Index::write_metadata_cache ;
4958 sub write_metadata_cache {
4960 return unless $CPAN::Config->{'cache_metadata'};
4961 return if CPAN::_sqlite_running;
4962 return unless $CPAN::META->has_usable("Storable");
4964 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4965 CPAN::Distribution)) {
4966 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4968 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4969 $cache->{last_time} = $LAST_TIME;
4970 $cache->{DATE_OF_02} = $DATE_OF_02;
4971 $cache->{PROTOCOL} = PROTOCOL;
4972 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4973 eval { Storable::nstore($cache, $metadata_file) };
4974 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4977 #-> sub CPAN::Index::read_metadata_cache ;
4978 sub read_metadata_cache {
4980 return unless $CPAN::Config->{'cache_metadata'};
4981 return if CPAN::_sqlite_running;
4982 return unless $CPAN::META->has_usable("Storable");
4983 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4984 return unless -r $metadata_file and -f $metadata_file;
4985 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4987 eval { $cache = Storable::retrieve($metadata_file) };
4988 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4989 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4993 if (exists $cache->{PROTOCOL}) {
4994 if (PROTOCOL > $cache->{PROTOCOL}) {
4995 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4996 "with protocol v%s, requiring v%s\n",
5003 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5004 "with protocol v1.0\n");
5009 while(my($class,$v) = each %$cache) {
5010 next unless $class =~ /^CPAN::/;
5011 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5012 while (my($id,$ro) = each %$v) {
5013 $CPAN::META->{readwrite}{$class}{$id} ||=
5014 $class->new(ID=>$id, RO=>$ro);
5019 unless ($clcnt) { # sanity check
5020 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5023 if ($idcnt < 1000) {
5024 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5025 "in $metadata_file\n");
5028 $CPAN::META->{PROTOCOL} ||=
5029 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5030 # does initialize to some protocol
5031 $LAST_TIME = $cache->{last_time};
5032 $DATE_OF_02 = $cache->{DATE_OF_02};
5033 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
5034 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5038 package CPAN::InfoObj;
5043 exists $self->{RO} and return $self->{RO};
5046 #-> sub CPAN::InfoObj::cpan_userid
5051 return $ro->{CPAN_USERID} || "N/A";
5053 $self->debug("ID[$self->{ID}]");
5054 # N/A for bundles found locally
5059 sub id { shift->{ID}; }
5061 #-> sub CPAN::InfoObj::new ;
5063 my $this = bless {}, shift;
5068 # The set method may only be used by code that reads index data or
5069 # otherwise "objective" data from the outside world. All session
5070 # related material may do anything else with instance variables but
5071 # must not touch the hash under the RO attribute. The reason is that
5072 # the RO hash gets written to Metadata file and is thus persistent.
5074 #-> sub CPAN::InfoObj::safe_chdir ;
5076 my($self,$todir) = @_;
5077 # we die if we cannot chdir and we are debuggable
5078 Carp::confess("safe_chdir called without todir argument")
5079 unless defined $todir and length $todir;
5081 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5085 unless (-x $todir) {
5086 unless (chmod 0755, $todir) {
5087 my $cwd = CPAN::anycwd();
5088 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5089 "permission to change the permission; cannot ".
5090 "chdir to '$todir'\n");
5091 $CPAN::Frontend->mysleep(5);
5092 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5093 qq{to todir[$todir]: $!});
5097 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5100 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5103 my $cwd = CPAN::anycwd();
5104 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5105 qq{to todir[$todir] (a chmod has been issued): $!});
5110 #-> sub CPAN::InfoObj::set ;
5112 my($self,%att) = @_;
5113 my $class = ref $self;
5115 # This must be ||=, not ||, because only if we write an empty
5116 # reference, only then the set method will write into the readonly
5117 # area. But for Distributions that spring into existence, maybe
5118 # because of a typo, we do not like it that they are written into
5119 # the readonly area and made permanent (at least for a while) and
5120 # that is why we do not "allow" other places to call ->set.
5121 unless ($self->id) {
5122 CPAN->debug("Bug? Empty ID, rejecting");
5125 my $ro = $self->{RO} =
5126 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5128 while (my($k,$v) = each %att) {
5133 #-> sub CPAN::InfoObj::as_glimpse ;
5137 my $class = ref($self);
5138 $class =~ s/^CPAN:://;
5139 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5140 push @m, sprintf "%-15s %s\n", $class, $id;
5144 #-> sub CPAN::InfoObj::as_string ;
5148 my $class = ref($self);
5149 $class =~ s/^CPAN:://;
5150 push @m, $class, " id = $self->{ID}\n";
5152 unless ($ro = $self->ro) {
5153 if (substr($self->{ID},-1,1) eq ".") { # directory
5156 $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5159 for (sort keys %$ro) {
5160 # next if m/^(ID|RO)$/;
5162 if ($_ eq "CPAN_USERID") {
5164 $extra .= $self->fullname;
5165 my $email; # old perls!
5166 if ($email = $CPAN::META->instance("CPAN::Author",
5169 $extra .= " <$email>";
5171 $extra .= " <no email>";
5174 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5175 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
5178 next unless defined $ro->{$_};
5179 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
5181 KEY: for (sort keys %$self) {
5182 next if m/^(ID|RO)$/;
5183 unless (defined $self->{$_}) {
5187 if (ref($self->{$_}) eq "ARRAY") {
5188 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
5189 } elsif (ref($self->{$_}) eq "HASH") {
5191 if (/^CONTAINSMODS$/) {
5192 $value = join(" ",sort keys %{$self->{$_}});
5193 } elsif (/^prereq_pm$/) {
5195 my $v = $self->{$_};
5196 for my $x (sort keys %$v) {
5198 for my $y (sort keys %{$v->{$x}}) {
5199 push @svalue, "$y=>$v->{$x}{$y}";
5201 push @value, "$x\:" . join ",", @svalue if @svalue;
5203 $value = join ";", @value;
5205 $value = $self->{$_};
5213 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
5219 #-> sub CPAN::InfoObj::fullname ;
5222 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5225 #-> sub CPAN::InfoObj::dump ;
5227 my($self, $what) = @_;
5228 unless ($CPAN::META->has_inst("Data::Dumper")) {
5229 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5231 local $Data::Dumper::Sortkeys;
5232 $Data::Dumper::Sortkeys = 1;
5233 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5234 if (length $out > 100000) {
5235 my $fh_pager = FileHandle->new;
5236 local($SIG{PIPE}) = "IGNORE";
5237 my $pager = $CPAN::Config->{'pager'} || "cat";
5238 $fh_pager->open("|$pager")
5239 or die "Could not open pager $pager\: $!";
5240 $fh_pager->print($out);
5243 $CPAN::Frontend->myprint($out);
5247 package CPAN::Author;
5250 #-> sub CPAN::Author::force
5256 #-> sub CPAN::Author::force
5259 delete $self->{force};
5262 #-> sub CPAN::Author::id
5265 my $id = $self->{ID};
5266 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5270 #-> sub CPAN::Author::as_glimpse ;
5274 my $class = ref($self);
5275 $class =~ s/^CPAN:://;
5276 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5284 #-> sub CPAN::Author::fullname ;
5286 shift->ro->{FULLNAME};
5290 #-> sub CPAN::Author::email ;
5291 sub email { shift->ro->{EMAIL}; }
5293 #-> sub CPAN::Author::ls ;
5296 my $glob = shift || "";
5297 my $silent = shift || 0;
5300 # adapted from CPAN::Distribution::verifyCHECKSUM ;
5301 my(@csf); # chksumfile
5302 @csf = $self->id =~ /(.)(.)(.*)/;
5303 $csf[1] = join "", @csf[0,1];
5304 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5306 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5307 unless (grep {$_->[2] eq $csf[1]} @dl) {
5308 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5311 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5312 unless (grep {$_->[2] eq $csf[2]} @dl) {
5313 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5316 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5318 if ($CPAN::META->has_inst("Text::Glob")) {
5319 my $rglob = Text::Glob::glob_to_regex($glob);
5320 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5322 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5325 $CPAN::Frontend->myprint(join "", map {
5326 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5327 } sort { $a->[2] cmp $b->[2] } @dl);
5331 # returns an array of arrays, the latter contain (size,mtime,filename)
5332 #-> sub CPAN::Author::dir_listing ;
5335 my $chksumfile = shift;
5336 my $recursive = shift;
5337 my $may_ftp = shift;
5340 File::Spec->catfile($CPAN::Config->{keep_source_where},
5341 "authors", "id", @$chksumfile);
5345 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5346 # hazard. (Without GPG installed they are not that much better,
5348 $fh = FileHandle->new;
5349 if (open($fh, $lc_want)) {
5350 my $line = <$fh>; close $fh;
5351 unlink($lc_want) unless $line =~ /PGP/;
5355 # connect "force" argument with "index_expire".
5356 my $force = $self->{force};
5357 if (my @stat = stat $lc_want) {
5358 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5362 $lc_file = CPAN::FTP->localize(
5363 "authors/id/@$chksumfile",
5368 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5369 $chksumfile->[-1] .= ".gz";
5370 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5373 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5374 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5380 $lc_file = $lc_want;
5381 # we *could* second-guess and if the user has a file: URL,
5382 # then we could look there. But on the other hand, if they do
5383 # have a file: URL, wy did they choose to set
5384 # $CPAN::Config->{show_upload_date} to false?
5387 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5388 $fh = FileHandle->new;
5390 if (open $fh, $lc_file){
5393 $eval =~ s/\015?\012/\n/g;
5395 my($comp) = Safe->new();
5396 $cksum = $comp->reval($eval);
5398 rename $lc_file, "$lc_file.bad";
5399 Carp::confess($@) if $@;
5401 } elsif ($may_ftp) {
5402 Carp::carp "Could not open '$lc_file' for reading.";
5404 # Maybe should warn: "You may want to set show_upload_date to a true value"
5408 for $f (sort keys %$cksum) {
5409 if (exists $cksum->{$f}{isdir}) {
5411 my(@dir) = @$chksumfile;
5413 push @dir, $f, "CHECKSUMS";
5415 [$_->[0], $_->[1], "$f/$_->[2]"]
5416 } $self->dir_listing(\@dir,1,$may_ftp);
5418 push @result, [ 0, "-", $f ];
5422 ($cksum->{$f}{"size"}||0),
5423 $cksum->{$f}{"mtime"}||"---",
5431 package CPAN::Distribution;
5437 my $ro = $self->ro or return;
5441 # CPAN::Distribution::undelay
5444 delete $self->{later};
5447 # add the A/AN/ stuff
5448 # CPAN::Distribution::normalize
5451 $s = $self->id unless defined $s;
5452 if (substr($s,-1,1) eq ".") {
5453 # using a global because we are sometimes called as static method
5454 if (!$CPAN::META->{LOCK}
5455 && !$CPAN::Have_warned->{"$s is unlocked"}++
5457 $CPAN::Frontend->mywarn("You are visiting the local directory
5459 without lock, take care that concurrent processes do not do likewise.\n");
5460 $CPAN::Frontend->mysleep(1);
5463 $s = "$CPAN::iCwd/.";
5464 } elsif (File::Spec->file_name_is_absolute($s)) {
5465 } elsif (File::Spec->can("rel2abs")) {
5466 $s = File::Spec->rel2abs($s);
5468 $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5470 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5471 unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5472 for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5473 $_->{build_dir} = $s;
5474 $_->{archived} = "local_directory";
5475 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5481 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5483 return $s if $s =~ m:^N/A|^Contact Author: ;
5484 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5485 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5486 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5491 #-> sub CPAN::Distribution::author ;
5495 if (substr($self->id,-1,1) eq ".") {
5496 $authorid = "LOCAL";
5498 ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5500 CPAN::Shell->expand("Author",$authorid);
5503 # tries to get the yaml from CPAN instead of the distro itself:
5504 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5507 my $meta = $self->pretty_id;
5508 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5509 my(@ls) = CPAN::Shell->globls($meta);
5510 my $norm = $self->normalize($meta);
5514 File::Spec->catfile(
5515 $CPAN::Config->{keep_source_where},
5520 $self->debug("Doing localize") if $CPAN::DEBUG;
5521 unless ($local_file =
5522 CPAN::FTP->localize("authors/id/$norm",
5524 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5526 my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5529 #-> sub CPAN::Distribution::cpan_userid
5532 if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5535 return $self->SUPER::cpan_userid;
5538 #-> sub CPAN::Distribution::pretty_id
5542 return $id unless $id =~ m|^./../|;
5546 # mark as dirty/clean for the sake of recursion detection. $color=1
5547 # means "in use", $color=0 means "not in use anymore". $color=2 means
5548 # we have determined prereqs now and thus insist on passing this
5549 # through (at least) once again.
5551 #-> sub CPAN::Distribution::color_cmd_tmps ;
5552 sub color_cmd_tmps {
5554 my($depth) = shift || 0;
5555 my($color) = shift || 0;
5556 my($ancestors) = shift || [];
5557 # a distribution needs to recurse into its prereq_pms
5559 return if exists $self->{incommandcolor}
5561 && $self->{incommandcolor}==$color;
5562 if ($depth>=$CPAN::MAX_RECURSION){
5563 die(CPAN::Exception::RecursiveDependency->new($ancestors));
5565 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5566 my $prereq_pm = $self->prereq_pm;
5567 if (defined $prereq_pm) {
5568 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5569 keys %{$prereq_pm->{build_requires}||{}}) {
5570 next PREREQ if $pre eq "perl";
5572 unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5573 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5574 $CPAN::Frontend->mysleep(2);
5577 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5581 delete $self->{sponsored_mods};
5583 # as we are at the end of a command, we'll give up this
5584 # reminder of a broken test. Other commands may test this guy
5585 # again. Maybe 'badtestcnt' should be renamed to
5586 # 'make_test_failed_within_command'?
5587 delete $self->{badtestcnt};
5589 $self->{incommandcolor} = $color;
5592 #-> sub CPAN::Distribution::as_string ;
5595 $self->containsmods;
5597 $self->SUPER::as_string(@_);
5600 #-> sub CPAN::Distribution::containsmods ;
5603 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5604 my $dist_id = $self->{ID};
5605 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5606 my $mod_file = $mod->cpan_file or next;
5607 my $mod_id = $mod->{ID} or next;
5608 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5610 if ($CPAN::Signal) {
5611 delete $self->{CONTAINSMODS};
5614 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5616 keys %{$self->{CONTAINSMODS}||{}};
5619 #-> sub CPAN::Distribution::upload_date ;
5622 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5623 my(@local_wanted) = split(/\//,$self->id);
5624 my $filename = pop @local_wanted;
5625 push @local_wanted, "CHECKSUMS";
5626 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5627 return unless $author;
5628 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5630 my($dirent) = grep { $_->[2] eq $filename } @dl;
5631 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5632 return unless $dirent->[1];
5633 return $self->{UPLOAD_DATE} = $dirent->[1];
5636 #-> sub CPAN::Distribution::uptodate ;
5640 foreach $c ($self->containsmods) {
5641 my $obj = CPAN::Shell->expandany($c);
5642 unless ($obj->uptodate){
5643 my $id = $self->pretty_id;
5644 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5651 #-> sub CPAN::Distribution::called_for ;
5654 $self->{CALLED_FOR} = $id if defined $id;
5655 return $self->{CALLED_FOR};
5658 #-> sub CPAN::Distribution::get ;
5661 $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5662 if (my $goto = $self->prefs->{goto}) {
5663 $CPAN::Frontend->mywarn
5665 "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5667 $self->{prefs_file},
5668 $self->{prefs_file_doc},
5670 return $self->goto($goto);
5672 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5674 : ($ENV{PERLLIB} || "");
5676 $CPAN::META->set_perl5lib;
5677 local $ENV{MAKEFLAGS}; # protect us from outer make calls
5681 $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5682 if ($self->prefs->{disabled}) {
5684 "Disabled via prefs file '%s' doc %d",
5685 $self->{prefs_file},
5686 $self->{prefs_file_doc},
5689 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5690 # note: not intended to be persistent but at least visible
5691 # during this session
5693 if (exists $self->{build_dir} && -d $self->{build_dir}) {
5694 # this deserves print, not warn:
5695 $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
5696 "$self->{build_dir}\n"
5701 # although we talk about 'force' we shall not test on
5702 # force directly. New model of force tries to refrain from
5703 # direct checking of force.
5704 exists $self->{unwrapped} and (
5705 UNIVERSAL::can($self->{unwrapped},"failed") ?
5706 $self->{unwrapped}->failed :
5707 $self->{unwrapped} =~ /^NO/
5709 and push @e, "Unwrapping had some problem, won't try again without force";
5712 $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5714 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5717 # Get the file on local disk
5722 File::Spec->catfile(
5723 $CPAN::Config->{keep_source_where},
5726 split(/\//,$self->id)
5729 $self->debug("Doing localize") if $CPAN::DEBUG;
5730 unless ($local_file =
5731 CPAN::FTP->localize("authors/id/$self->{ID}",
5734 if ($CPAN::Index::DATE_OF_02) {
5735 $note = "Note: Current database in memory was generated ".
5736 "on $CPAN::Index::DATE_OF_02\n";
5738 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5741 $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5742 $self->{localfile} = $local_file;
5743 return if $CPAN::Signal;
5748 if ($CPAN::META->has_inst("Digest::SHA")) {
5749 $self->debug("Digest::SHA is installed, verifying");
5750 $self->verifyCHECKSUM;
5752 $self->debug("Digest::SHA is NOT installed");
5754 return if $CPAN::Signal;
5757 # Create a clean room and go there
5759 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5760 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5761 $self->safe_chdir($builddir);
5762 $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5763 File::Path::rmtree("tmp-$$");
5764 unless (mkdir "tmp-$$", 0755) {
5765 $CPAN::Frontend->unrecoverable_error(<<EOF);
5766 Couldn't mkdir '$builddir/tmp-$$': $!
5768 Cannot continue: Please find the reason why I cannot make the
5771 and fix the problem, then retry.
5776 $self->safe_chdir($sub_wd);
5779 $self->safe_chdir("tmp-$$");
5784 my $ct = eval{CPAN::Tarzip->new($local_file)};
5786 $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5787 delete $self->{build_dir};
5790 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5791 $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5792 $self->untar_me($ct);
5793 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5794 $self->unzip_me($ct);
5796 $self->{was_uncompressed}++ unless $ct->gtest();
5797 $local_file = $self->handle_singlefile($local_file);
5800 # we are still in the tmp directory!
5801 # Let's check if the package has its own directory.
5802 my $dh = DirHandle->new(File::Spec->curdir)
5803 or Carp::croak("Couldn't opendir .: $!");
5804 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5807 # XXX here we want in each branch File::Temp to protect all build_dir directories
5808 if (CPAN->has_inst("File::Temp")) {
5812 if (@readdir == 1 && -d $readdir[0]) {
5813 $tdir_base = $readdir[0];
5814 $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5815 my $dh2 = DirHandle->new($from_dir)
5816 or Carp::croak("Couldn't opendir $from_dir: $!");
5817 @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5819 my $userid = $self->cpan_userid;
5820 CPAN->debug("userid[$userid]");
5821 if (!$userid or $userid eq "N/A") {
5824 $tdir_base = $userid;
5825 $from_dir = File::Spec->curdir;
5826 @dirents = @readdir;
5828 $packagedir = File::Temp::tempdir(
5829 "$tdir_base-XXXXXX",
5834 for $f (@dirents) { # is already without "." and ".."
5835 my $from = File::Spec->catdir($from_dir,$f);
5836 my $to = File::Spec->catdir($packagedir,$f);
5837 unless (File::Copy::move($from,$to)) {
5839 $from = File::Spec->rel2abs($from);
5840 Carp::confess("Couldn't move $from to $to: $err");
5843 } else { # older code below, still better than nothing when there is no File::Temp
5845 if (@readdir == 1 && -d $readdir[0]) {
5846 $distdir = $readdir[0];
5847 $packagedir = File::Spec->catdir($builddir,$distdir);
5848 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5850 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5852 File::Path::rmtree($packagedir);
5853 unless (File::Copy::move($distdir,$packagedir)) {
5854 $CPAN::Frontend->unrecoverable_error(<<EOF);
5855 Couldn't move '$distdir' to '$packagedir': $!
5857 Cannot continue: Please find the reason why I cannot move
5858 $builddir/tmp-$$/$distdir
5861 and fix the problem, then retry
5865 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5872 my $userid = $self->cpan_userid;
5873 CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5874 if (!$userid or $userid eq "N/A") {
5877 my $pragmatic_dir = $userid . '000';
5878 $pragmatic_dir =~ s/\W_//g;
5879 $pragmatic_dir++ while -d "../$pragmatic_dir";
5880 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5881 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5882 File::Path::mkpath($packagedir);
5884 for $f (@readdir) { # is already without "." and ".."
5885 my $to = File::Spec->catdir($packagedir,$f);
5886 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5891 $self->safe_chdir($sub_wd);
5895 $self->{build_dir} = $packagedir;
5896 $self->safe_chdir($builddir);
5897 File::Path::rmtree("tmp-$$");
5899 $self->safe_chdir($packagedir);
5900 $self->_signature_business();
5901 $self->safe_chdir($builddir);
5902 return if $CPAN::Signal;
5905 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5906 my($mpl_exists) = -f $mpl;
5907 unless ($mpl_exists) {
5908 # NFS has been reported to have racing problems after the
5909 # renaming of a directory in some environments.
5911 $CPAN::Frontend->mysleep(1);
5912 my $mpldh = DirHandle->new($packagedir)
5913 or Carp::croak("Couldn't opendir $packagedir: $!");
5914 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5917 my $prefer_installer = "eumm"; # eumm|mb
5918 if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5919 if ($mpl_exists) { # they *can* choose
5920 if ($CPAN::META->has_inst("Module::Build")) {
5921 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5922 q{prefer_installer});
5925 $prefer_installer = "mb";
5928 return unless $self->patch;
5929 if (lc($prefer_installer) eq "mb") {
5930 $self->{modulebuild} = 1;
5931 } elsif ($self->{archived} eq "patch") {
5932 # not an edge case, nothing to install for sure
5933 my $why = "A patch file cannot be installed";
5934 $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
5935 $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
5936 } elsif (! $mpl_exists) {
5937 $self->_edge_cases($mpl,$packagedir,$local_file);
5939 if ($self->{build_dir}
5941 $CPAN::Config->{build_dir_reuse}
5943 $self->store_persistent_state;
5949 #-> CPAN::Distribution::store_persistent_state
5950 sub store_persistent_state {
5952 my $dir = $self->{build_dir};
5953 unless (File::Spec->canonpath(File::Basename::dirname($dir))
5954 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5955 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5956 "will not store persistent state\n");
5959 my $file = sprintf "%s.yml", $dir;
5960 my $yaml_module = CPAN::_yaml_module;
5961 if ($CPAN::META->has_inst($yaml_module)) {
5962 CPAN->_yaml_dumpfile(
5966 perl => CPAN::_perl_fingerprint,
5967 distribution => $self,
5971 $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
5972 "will not store persistent state\n");
5976 #-> CPAN::Distribution::patch
5978 my($self,$patch) = @_;
5979 my $norm = $self->normalize($patch);
5981 File::Spec->catfile(
5982 $CPAN::Config->{keep_source_where},
5987 $self->debug("Doing localize") if $CPAN::DEBUG;
5988 return CPAN::FTP->localize("authors/id/$norm",
5992 #-> CPAN::Distribution::patch
5995 $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
5996 my $patches = $self->prefs->{patches};
5998 $self->debug("patches[$patches]") if $CPAN::DEBUG;
6000 return unless @$patches;
6001 $self->safe_chdir($self->{build_dir});
6002 CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6003 my $patchbin = $CPAN::Config->{patch};
6004 unless ($patchbin && length $patchbin) {
6005 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6006 "Please run 'o conf init /patch/'\n\n");
6008 unless (MM->maybe_command($patchbin)) {
6009 $CPAN::Frontend->mydie("No external patch command available\n\n".
6010 "Please run 'o conf init /patch/'\n\n");
6012 $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6013 local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
6014 # supported everywhere (and then,
6015 # not ever necessary there)
6016 my $stdpatchargs = "-N --fuzz=3";
6017 my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6018 $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6019 for my $patch (@$patches) {
6020 unless (-f $patch) {
6021 if (my $trydl = $self->try_download($patch)) {
6024 my $fail = "Could not find patch '$patch'";
6025 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6026 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6027 delete $self->{build_dir};
6031 $CPAN::Frontend->myprint(" $patch\n");
6032 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6035 my $ppp = $self->_patch_p_parameter($readfh);
6036 if ($ppp eq "applypatch") {
6037 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6039 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6040 $pcommand = "$patchbin $thispatchargs";
6043 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6044 my $writefh = FileHandle->new;
6045 $CPAN::Frontend->myprint(" $pcommand\n");
6046 unless (open $writefh, "|$pcommand") {
6047 my $fail = "Could not fork '$pcommand'";
6048 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6049 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6050 delete $self->{build_dir};
6053 while (my $x = $readfh->READLINE) {
6056 unless (close $writefh) {
6057 my $fail = "Could not apply patch '$patch'";
6058 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6059 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6060 delete $self->{build_dir};
6069 sub _patch_p_parameter {
6072 my $cnt_p0files = 0;
6074 while ($_ = $fh->READLINE) {
6076 $CPAN::Config->{applypatch}
6078 /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6082 next unless /^[\*\+]{3}\s(\S+)/;
6085 $cnt_p0files++ if -f $file;
6086 CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6089 return "-p1" unless $cnt_files;
6090 return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6093 #-> sub CPAN::Distribution::_edge_cases
6094 # with "configure" or "Makefile" or single file scripts
6096 my($self,$mpl,$packagedir,$local_file) = @_;
6097 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6101 my($configure) = File::Spec->catfile($packagedir,"Configure");
6102 if (-f $configure) {
6103 # do we have anything to do?
6104 $self->{configure} = $configure;
6105 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6106 $CPAN::Frontend->mywarn(qq{
6107 Package comes with a Makefile and without a Makefile.PL.
6108 We\'ll try to build it with that Makefile then.
6110 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6111 $CPAN::Frontend->mysleep(2);
6113 my $cf = $self->called_for || "unknown";
6118 $cf =~ s|[/\\:]||g; # risk of filesystem damage
6119 $cf = "unknown" unless length($cf);
6120 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6121 (The test -f "$mpl" returned false.)
6122 Writing one on our own (setting NAME to $cf)\a\n});
6123 $self->{had_no_makefile_pl}++;
6124 $CPAN::Frontend->mysleep(3);
6126 # Writing our own Makefile.PL
6129 if ($self->{archived} eq "maybe_pl") {
6130 my $fh = FileHandle->new;
6131 my $script_file = File::Spec->catfile($packagedir,$local_file);
6132 $fh->open($script_file)
6133 or Carp::croak("Could not open $script_file: $!");
6135 # name parsen und prereq
6136 my($state) = "poddir";
6137 my($name, $prereq) = ("", "");
6139 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6142 } elsif ($1 eq 'PREREQUISITES') {
6145 } elsif ($state =~ m{^(name|prereq)$}) {
6150 } elsif ($state eq "name") {
6155 } elsif ($state eq "prereq") {
6158 } elsif (/^=cut\b/) {
6165 s{.*<}{}; # strip X<...>
6169 $prereq = join " ", split /\s+/, $prereq;
6170 my($PREREQ_PM) = join("\n", map {
6171 s{.*<}{}; # strip X<...>
6173 if (/[\s\'\"]/) { # prose?
6175 s/[^\w:]$//; # period?
6176 " "x28 . "'$_' => 0,";
6178 } split /\s*,\s*/, $prereq);
6181 EXE_FILES => ['$name'],
6187 my $to_file = File::Spec->catfile($packagedir, $name);
6188 rename $script_file, $to_file
6189 or die "Can't rename $script_file to $to_file: $!";
6193 my $fh = FileHandle->new;
6195 or Carp::croak("Could not open >$mpl: $!");
6197 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6198 # because there was no Makefile.PL supplied.
6199 # Autogenerated on: }.scalar localtime().qq{
6201 use ExtUtils::MakeMaker;
6203 NAME => q[$cf],$script
6210 #-> CPAN::Distribution::_signature_business
6211 sub _signature_business {
6213 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6216 if ($CPAN::META->has_inst("Module::Signature")) {
6217 if (-f "SIGNATURE") {
6218 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6219 my $rv = Module::Signature::verify();
6220 if ($rv != Module::Signature::SIGNATURE_OK() and
6221 $rv != Module::Signature::SIGNATURE_MISSING()) {
6222 $CPAN::Frontend->mywarn(
6223 qq{\nSignature invalid for }.
6224 qq{distribution file. }.
6225 qq{Please investigate.\n\n}
6229 sprintf(qq{I'd recommend removing %s. Its signature
6230 is invalid. Maybe you have configured your 'urllist' with
6231 a bad URL. Please check this array with 'o conf urllist', and
6232 retry. For more information, try opening a subshell with
6240 $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6241 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6242 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6244 $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6245 $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6248 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6251 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6256 #-> CPAN::Distribution::untar_me ;
6259 $self->{archived} = "tar";
6261 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6263 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6267 # CPAN::Distribution::unzip_me ;
6270 $self->{archived} = "zip";
6272 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6274 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6279 sub handle_singlefile {
6280 my($self,$local_file) = @_;
6282 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6283 $self->{archived} = "pm";
6284 } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6285 $self->{archived} = "patch";
6287 $self->{archived} = "maybe_pl";
6290 my $to = File::Basename::basename($local_file);
6291 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6292 if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6293 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6295 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6298 if (File::Copy::cp($local_file,".")) {
6299 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6301 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6307 #-> sub CPAN::Distribution::new ;
6309 my($class,%att) = @_;
6311 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6313 my $this = { %att };
6314 return bless $this, $class;
6317 #-> sub CPAN::Distribution::look ;
6321 if ($^O eq 'MacOS') {
6322 $self->Mac::BuildTools::look;
6326 if ( $CPAN::Config->{'shell'} ) {
6327 $CPAN::Frontend->myprint(qq{
6328 Trying to open a subshell in the build directory...
6331 $CPAN::Frontend->myprint(qq{
6332 Your configuration does not define a value for subshells.
6333 Please define it with "o conf shell <your shell>"
6337 my $dist = $self->id;
6339 unless ($dir = $self->dir) {
6342 unless ($dir ||= $self->dir) {
6343 $CPAN::Frontend->mywarn(qq{
6344 Could not determine which directory to use for looking at $dist.
6348 my $pwd = CPAN::anycwd();
6349 $self->safe_chdir($dir);
6350 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6352 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6353 $ENV{CPAN_SHELL_LEVEL} += 1;
6354 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6355 unless (system($shell) == 0) {
6357 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6360 $self->safe_chdir($pwd);
6363 # CPAN::Distribution::cvs_import ;
6367 my $dir = $self->dir;
6369 my $package = $self->called_for;
6370 my $module = $CPAN::META->instance('CPAN::Module', $package);
6371 my $version = $module->cpan_version;
6373 my $userid = $self->cpan_userid;
6375 my $cvs_dir = (split /\//, $dir)[-1];
6376 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6378 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6380 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6381 if ($cvs_site_perl) {
6382 $cvs_dir = "$cvs_site_perl/$cvs_dir";
6384 my $cvs_log = qq{"imported $package $version sources"};
6385 $version =~ s/\./_/g;
6386 # XXX cvs: undocumented and unclear how it was meant to work
6387 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6388 "$cvs_dir", $userid, "v$version");
6390 my $pwd = CPAN::anycwd();
6391 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6393 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6395 $CPAN::Frontend->myprint(qq{@cmd\n});
6396 system(@cmd) == 0 or
6398 $CPAN::Frontend->mydie("cvs import failed");
6399 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6402 #-> sub CPAN::Distribution::readme ;
6405 my($dist) = $self->id;
6406 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6407 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6410 File::Spec->catfile(
6411 $CPAN::Config->{keep_source_where},
6414 split(/\//,"$sans.readme"),
6416 $self->debug("Doing localize") if $CPAN::DEBUG;
6417 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6419 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6421 if ($^O eq 'MacOS') {
6422 Mac::BuildTools::launch_file($local_file);
6426 my $fh_pager = FileHandle->new;
6427 local($SIG{PIPE}) = "IGNORE";
6428 my $pager = $CPAN::Config->{'pager'} || "cat";
6429 $fh_pager->open("|$pager")
6430 or die "Could not open pager $pager\: $!";
6431 my $fh_readme = FileHandle->new;
6432 $fh_readme->open($local_file)
6433 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6434 $CPAN::Frontend->myprint(qq{
6439 $fh_pager->print(<$fh_readme>);
6443 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6444 sub verifyCHECKSUM {
6448 $self->{CHECKSUM_STATUS} ||= "";
6449 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6450 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6452 my($lc_want,$lc_file,@local,$basename);
6453 @local = split(/\//,$self->id);
6455 push @local, "CHECKSUMS";
6457 File::Spec->catfile($CPAN::Config->{keep_source_where},
6458 "authors", "id", @local);
6460 if (my $size = -s $lc_want) {
6461 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6462 if ($self->CHECKSUM_check_file($lc_want,1)) {
6463 return $self->{CHECKSUM_STATUS} = "OK";
6466 $lc_file = CPAN::FTP->localize("authors/id/@local",
6469 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6470 $local[-1] .= ".gz";
6471 $lc_file = CPAN::FTP->localize("authors/id/@local",
6474 $lc_file =~ s/\.gz(?!\n)\Z//;
6475 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6480 if ($self->CHECKSUM_check_file($lc_file)) {
6481 return $self->{CHECKSUM_STATUS} = "OK";
6485 #-> sub CPAN::Distribution::SIG_check_file ;
6486 sub SIG_check_file {
6487 my($self,$chk_file) = @_;
6488 my $rv = eval { Module::Signature::_verify($chk_file) };
6490 if ($rv == Module::Signature::SIGNATURE_OK()) {
6491 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6492 return $self->{SIG_STATUS} = "OK";
6494 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6495 qq{distribution file. }.
6496 qq{Please investigate.\n\n}.
6498 $CPAN::META->instance(
6503 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6504 is invalid. Maybe you have configured your 'urllist' with
6505 a bad URL. Please check this array with 'o conf urllist', and
6508 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6512 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6514 # sloppy is 1 when we have an old checksums file that maybe is good
6517 sub CHECKSUM_check_file {
6518 my($self,$chk_file,$sloppy) = @_;
6519 my($cksum,$file,$basename);
6522 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6523 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6526 if ($CPAN::META->has_inst("Module::Signature")) {
6527 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6528 $self->SIG_check_file($chk_file);
6530 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6534 $file = $self->{localfile};
6535 $basename = File::Basename::basename($file);
6536 my $fh = FileHandle->new;
6537 if (open $fh, $chk_file){
6540 $eval =~ s/\015?\012/\n/g;
6542 my($comp) = Safe->new();
6543 $cksum = $comp->reval($eval);
6545 rename $chk_file, "$chk_file.bad";
6546 Carp::confess($@) if $@;
6549 Carp::carp "Could not open $chk_file for reading";
6552 if (! ref $cksum or ref $cksum ne "HASH") {
6553 $CPAN::Frontend->mywarn(qq{
6554 Warning: checksum file '$chk_file' broken.
6556 When trying to read that file I expected to get a hash reference
6557 for further processing, but got garbage instead.
6559 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6560 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6561 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6563 } elsif (exists $cksum->{$basename}{sha256}) {
6564 $self->debug("Found checksum for $basename:" .
6565 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6569 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6571 $fh = CPAN::Tarzip->TIEHANDLE($file);
6574 my $dg = Digest::SHA->new(256);
6577 while ($fh->READ($ref, 4096) > 0){
6580 my $hexdigest = $dg->hexdigest;
6581 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6585 $CPAN::Frontend->myprint("Checksum for $file ok\n");
6586 return $self->{CHECKSUM_STATUS} = "OK";
6588 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6589 qq{distribution file. }.
6590 qq{Please investigate.\n\n}.
6592 $CPAN::META->instance(
6597 my $wrap = qq{I\'d recommend removing $file. Its
6598 checksum is incorrect. Maybe you have configured your 'urllist' with
6599 a bad URL. Please check this array with 'o conf urllist', and
6602 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6604 # former versions just returned here but this seems a
6605 # serious threat that deserves a die
6607 # $CPAN::Frontend->myprint("\n\n");
6611 # close $fh if fileno($fh);
6614 unless ($self->{CHECKSUM_STATUS}) {
6615 $CPAN::Frontend->mywarn(qq{
6616 Warning: No checksum for $basename in $chk_file.
6618 The cause for this may be that the file is very new and the checksum
6619 has not yet been calculated, but it may also be that something is
6620 going awry right now.
6622 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6623 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6625 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6630 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6632 my($self,$fh,$expect) = @_;
6633 if ($CPAN::META->has_inst("Digest::SHA")) {
6634 my $dg = Digest::SHA->new(256);
6636 while (read($fh, $data, 4096)){
6639 my $hexdigest = $dg->hexdigest;
6640 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6641 return $hexdigest eq $expect;
6646 #-> sub CPAN::Distribution::force ;
6648 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6649 # effect by autoinspection, not by inspecting a global variable. One
6650 # of the reason why this was chosen to work that way was the treatment
6651 # of dependencies. They should not automatically inherit the force
6652 # status. But this has the downside that ^C and die() will return to
6653 # the prompt but will not be able to reset the force_update
6654 # attributes. We try to correct for it currently in the read_metadata
6655 # routine, and immediately before we check for a Signal. I hope this
6656 # works out in one of v1.57_53ff
6658 # "Force get forgets previous error conditions"
6660 #-> sub CPAN::Distribution::fforce ;
6662 my($self, $method) = @_;
6663 $self->force($method,1);
6666 #-> sub CPAN::Distribution::force ;
6668 my($self, $method,$fforce) = @_;
6686 "prereq_pm_detected",
6700 my $methodmatch = 0;
6702 PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6703 $methodmatch = 1 if $fforce || $phase eq $method;
6704 next unless $methodmatch;
6705 ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6706 if ($phase eq "get") {
6707 if (substr($self->id,-1,1) eq "."
6708 && $att =~ /(unwrapped|build_dir|archived)/ ) {
6709 # cannot be undone for local distros
6712 if ($att eq "build_dir"
6713 && $self->{build_dir}
6714 && $CPAN::META->{is_tested}
6716 delete $CPAN::META->{is_tested}{$self->{build_dir}};
6718 } elsif ($phase eq "test") {
6719 if ($att eq "make_test"
6720 && $self->{make_test}
6721 && $self->{make_test}{COMMANDID}
6722 && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6724 # endless loop too likely
6728 delete $self->{$att};
6729 if ($ldebug || $CPAN::DEBUG) {
6730 # local $CPAN::DEBUG = 16; # Distribution
6731 CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6735 if ($method && $method =~ /make|test|install/) {
6736 $self->{force_update} = 1; # name should probably have been force_install
6740 #-> sub CPAN::Distribution::notest ;
6742 my($self, $method) = @_;
6743 # warn "XDEBUG: set notest for $self $method";
6744 $self->{"notest"}++; # name should probably have been force_install
6747 #-> sub CPAN::Distribution::unnotest ;
6750 # warn "XDEBUG: deleting notest";
6751 delete $self->{'notest'};
6754 #-> sub CPAN::Distribution::unforce ;
6757 delete $self->{force_update};
6760 #-> sub CPAN::Distribution::isa_perl ;
6763 my $file = File::Basename::basename($self->id);
6764 if ($file =~ m{ ^ perl
6773 \.tar[._-](?:gz|bz2)
6777 } elsif ($self->cpan_comment
6779 $self->cpan_comment =~ /isa_perl\(.+?\)/){
6785 #-> sub CPAN::Distribution::perl ;
6790 carp __PACKAGE__ . "::perl was called without parameters.";
6792 return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6796 #-> sub CPAN::Distribution::make ;
6799 if (my $goto = $self->prefs->{goto}) {
6800 return $self->goto($goto);
6802 my $make = $self->{modulebuild} ? "Build" : "make";
6803 # Emergency brake if they said install Pippi and get newest perl
6804 if ($self->isa_perl) {
6806 $self->called_for ne $self->id &&
6807 ! $self->{force_update}
6809 # if we die here, we break bundles
6812 qq{The most recent version "%s" of the module "%s"
6813 is part of the perl-%s distribution. To install that, you need to run
6814 force install %s --or--
6817 $CPAN::META->instance(
6826 $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6827 $CPAN::Frontend->mysleep(1);
6831 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6833 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6835 : ($ENV{PERLLIB} || "");
6836 $CPAN::META->set_perl5lib;
6837 local $ENV{MAKEFLAGS}; # protect us from outer make calls
6840 delete $self->{force_update};
6847 if (!$self->{archived} || $self->{archived} eq "NO") {
6848 push @e, "Is neither a tar nor a zip archive.";
6851 if (!$self->{unwrapped}
6853 UNIVERSAL::can($self->{unwrapped},"failed") ?
6854 $self->{unwrapped}->failed :
6855 $self->{unwrapped} =~ /^NO/
6857 push @e, "Had problems unarchiving. Please build manually";
6860 unless ($self->{force_update}) {
6861 exists $self->{signature_verify} and
6863 UNIVERSAL::can($self->{signature_verify},"failed") ?
6864 $self->{signature_verify}->failed :
6865 $self->{signature_verify} =~ /^NO/
6867 and push @e, "Did not pass the signature test.";
6870 if (exists $self->{writemakefile} &&
6872 UNIVERSAL::can($self->{writemakefile},"failed") ?
6873 $self->{writemakefile}->failed :
6874 $self->{writemakefile} =~ /^NO/
6876 # XXX maybe a retry would be in order?
6877 my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6878 $self->{writemakefile}->text :
6879 $self->{writemakefile};
6881 $err ||= "Had some problem writing Makefile";
6882 $err .= ", won't make";
6886 if (defined $self->{make}) {
6887 if ($self->{make}->failed) {
6888 if ($self->{force_update}) {
6889 # Trying an already failed 'make' (unless somebody else blocks)
6891 # introduced for turning recursion detection into a distrostatus
6892 $CPAN::Frontend->mywarn("Could not make: ".substr($self->{make},3)."\n");
6893 $self->store_persistent_state;
6897 push @e, "Has already been made";
6901 if (exists $self->{later} and length($self->{later})) {
6902 if ($self->unsat_prereq) {
6903 push @e, $self->{later};
6904 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6905 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6906 # are not sufficient to be sure if we really must/may do the delete
6907 # here. SO I accept the suggested patch for now. If we trigger a bug
6908 # again, I must go into deep contemplation about the {later} flag.
6911 # delete $self->{later};
6915 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6916 $builddir = $self->dir or
6917 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6918 unless (chdir $builddir) {
6919 push @e, "Couldn't chdir to '$builddir': $!";
6921 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
6924 delete $self->{force_update};
6927 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
6928 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6930 if ($^O eq 'MacOS') {
6931 Mac::BuildTools::make($self);
6936 while (my($k,$v) = each %ENV) {
6937 next unless defined $v;
6942 if (my $commandline = $self->prefs->{pl}{commandline}) {
6943 $system = $commandline;
6945 } elsif ($self->{'configure'}) {
6946 $system = $self->{'configure'};
6947 } elsif ($self->{modulebuild}) {
6948 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6949 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6951 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6953 # This needs a handler that can be turned on or off:
6954 # $switch = "-MExtUtils::MakeMaker ".
6955 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6957 my $makepl_arg = $self->make_x_arg("pl");
6958 $system = sprintf("%s%s Makefile.PL%s",
6960 $switch ? " $switch" : "",
6961 $makepl_arg ? " $makepl_arg" : "",
6964 if (my $env = $self->prefs->{pl}{env}) {
6965 for my $e (keys %$env) {
6966 $ENV{$e} = $env->{$e};
6969 if (exists $self->{writemakefile}) {
6971 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6975 if ($CPAN::Config->{inactivity_timeout}) {
6977 if ($Config::Config{d_alarm}
6979 $Config::Config{d_alarm} eq "define"
6983 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6984 "variable 'inactivity_timeout' to ".
6985 "'$CPAN::Config->{inactivity_timeout}'. But ".
6986 "on this machine the system call 'alarm' ".
6987 "isn't available. This means that we cannot ".
6988 "provide the feature of intercepting long ".
6989 "waiting code and will turn this feature off.\n"
6991 $CPAN::Config->{inactivity_timeout} = 0;
6994 if ($go_via_alarm) {
6996 alarm $CPAN::Config->{inactivity_timeout};
6997 local $SIG{CHLD}; # = sub { wait };
6998 if (defined($pid = fork)) {
7003 # note, this exec isn't necessary if
7004 # inactivity_timeout is 0. On the Mac I'd
7005 # suggest, we set it always to 0.
7009 $CPAN::Frontend->myprint("Cannot fork: $!");
7018 $CPAN::Frontend->myprint($err);
7019 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7024 if (my $expect_model = $self->_prefs_with_expect("pl")) {
7025 $ret = $self->_run_via_expect($system,$expect_model);
7027 && $self->{writemakefile}
7028 && $self->{writemakefile}->failed) {
7033 $ret = system($system);
7036 $self->{writemakefile} = CPAN::Distrostatus
7037 ->new("NO '$system' returned status $ret");
7038 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7039 $self->store_persistent_state;
7043 if (-f "Makefile" || -f "Build") {
7044 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7045 delete $self->{make_clean}; # if cleaned before, enable next
7047 $self->{writemakefile} = CPAN::Distrostatus
7048 ->new(qq{NO -- Unknown reason});
7052 delete $self->{force_update};
7055 if (my @prereq = $self->unsat_prereq){
7056 if ($prereq[0][0] eq "perl") {
7057 my $need = "requires perl '$prereq[0][1]'";
7058 my $id = $self->pretty_id;
7059 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7060 $self->{make} = CPAN::Distrostatus->new("NO $need");
7061 $self->store_persistent_state;
7064 my $follow = eval { $self->follow_prereqs(@prereq); };
7067 # signal success to the queuerunner
7069 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7070 $CPAN::Frontend->mywarn($@);
7076 delete $self->{force_update};
7079 if (my $commandline = $self->prefs->{make}{commandline}) {
7080 $system = $commandline;
7083 if ($self->{modulebuild}) {
7084 unless (-f "Build") {
7085 my $cwd = CPAN::anycwd();
7086 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7087 " in cwd[$cwd]. Danger, Will Robinson!");
7088 $CPAN::Frontend->mysleep(5);
7090 $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7092 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
7094 $system =~ s/\s+$//;
7095 my $make_arg = $self->make_x_arg("make");
7096 $system = sprintf("%s%s",
7098 $make_arg ? " $make_arg" : "",
7101 if (my $env = $self->prefs->{make}{env}) { # overriding the local
7102 # ENV of PL, not the
7104 # unlikely to be a risk
7105 for my $e (keys %$env) {
7106 $ENV{$e} = $env->{$e};
7109 my $expect_model = $self->_prefs_with_expect("make");
7110 my $want_expect = 0;
7111 if ( $expect_model && @{$expect_model->{talk}} ) {
7112 my $can_expect = $CPAN::META->has_inst("Expect");
7116 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7122 $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7124 $system_ok = system($system) == 0;
7126 $self->introduce_myself;
7128 $CPAN::Frontend->myprint(" $system -- OK\n");
7129 $self->{make} = CPAN::Distrostatus->new("YES");
7131 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7132 $self->{make} = CPAN::Distrostatus->new("NO");
7133 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
7135 $self->store_persistent_state;
7138 # CPAN::Distribution::_run_via_expect
7139 sub _run_via_expect {
7140 my($self,$system,$expect_model) = @_;
7141 CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7142 if ($CPAN::META->has_inst("Expect")) {
7143 my $expo = Expect->new; # expo Expect object;
7144 $expo->spawn($system);
7145 $expect_model->{mode} ||= "deterministic";
7146 if ($expect_model->{mode} eq "deterministic") {
7147 return $self->_run_via_expect_deterministic($expo,$expect_model);
7148 } elsif ($expect_model->{mode} eq "anyorder") {
7149 return $self->_run_via_expect_anyorder($expo,$expect_model);
7151 die "Panic: Illegal expect mode: $expect_model->{mode}";
7154 $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7155 return system($system);
7159 sub _run_via_expect_anyorder {
7160 my($self,$expo,$expect_model) = @_;
7161 my $timeout = $expect_model->{timeout} || 5;
7162 my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7165 my($eof,$ran_into_timeout);
7166 my @match = $expo->expect($timeout,
7171 $ran_into_timeout++;
7178 $but .= $expo->clear_accum;
7181 return $expo->exitstatus();
7182 } elsif ($ran_into_timeout) {
7183 # warn "DEBUG: they are asking a question, but[$but]";
7184 for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7185 my($next,$send) = @expectacopy[$i,$i+1];
7186 my $regex = eval "qr{$next}";
7187 # warn "DEBUG: will compare with regex[$regex].";
7188 if ($but =~ /$regex/) {
7189 # warn "DEBUG: will send send[$send]";
7191 splice @expectacopy, $i, 2; # never allow reusing an QA pair
7195 my $why = "could not answer a question during the dialog";
7196 $CPAN::Frontend->mywarn("Failing: $why\n");
7197 $self->{writemakefile} =
7198 CPAN::Distrostatus->new("NO $why");
7204 sub _run_via_expect_deterministic {
7205 my($self,$expo,$expect_model) = @_;
7206 my $ran_into_timeout;
7207 my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7208 my $expecta = $expect_model->{talk};
7209 EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7210 my($re,$send) = @$expecta[$i,$i+1];
7211 CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7212 my $regex = eval "qr{$re}";
7213 $expo->expect($timeout,
7215 my $but = $expo->clear_accum;
7216 $CPAN::Frontend->mywarn("EOF (maybe harmless)
7217 expected[$regex]\nbut[$but]\n\n");
7221 my $but = $expo->clear_accum;
7222 $CPAN::Frontend->mywarn("TIMEOUT
7223 expected[$regex]\nbut[$but]\n\n");
7224 $ran_into_timeout++;
7227 if ($ran_into_timeout){
7228 # note that the caller expects 0 for success
7229 $self->{writemakefile} =
7230 CPAN::Distrostatus->new("NO timeout during expect dialog");
7236 return $expo->exitstatus();
7239 #-> CPAN::Distribution::_validate_distropref
7240 sub _validate_distropref {
7241 my($self,@args) = @_;
7243 $CPAN::META->has_inst("CPAN::Kwalify")
7245 $CPAN::META->has_inst("Kwalify")
7247 eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7249 $CPAN::Frontend->mywarn($@);
7252 CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7256 #-> CPAN::Distribution::_find_prefs
7259 my $distroid = $self->pretty_id;
7260 #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7261 my $prefs_dir = $CPAN::Config->{prefs_dir};
7262 eval { File::Path::mkpath($prefs_dir); };
7264 $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7266 my $yaml_module = CPAN::_yaml_module;
7268 if ($CPAN::META->has_inst($yaml_module)) {
7269 push @extensions, "yml";
7272 if ($CPAN::META->has_inst("Data::Dumper")) {
7273 push @extensions, "dd";
7274 push @fallbacks, "Data::Dumper";
7276 if ($CPAN::META->has_inst("Storable")) {
7277 push @extensions, "st";
7278 push @fallbacks, "Storable";
7282 unless ($self->{have_complained_about_missing_yaml}++) {
7283 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7284 "to @fallbacks to read prefs '$prefs_dir'\n");
7287 unless ($self->{have_complained_about_missing_yaml}++) {
7288 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7289 "read prefs '$prefs_dir'\n");
7294 my $dh = DirHandle->new($prefs_dir)
7295 or die Carp::croak("Couldn't open '$prefs_dir': $!");
7296 DIRENT: for (sort $dh->read) {
7297 next if $_ eq "." || $_ eq "..";
7298 my $exte = join "|", @extensions;
7299 next unless /\.($exte)$/;
7301 my $abs = File::Spec->catfile($prefs_dir, $_);
7303 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7305 if ($thisexte eq "yml") {
7306 # need no eval because if we have no YAML we do not try to read *.yml
7307 #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7308 @distropref = @{CPAN->_yaml_loadfile($abs)};
7309 #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7310 } elsif ($thisexte eq "dd") {
7313 open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7319 $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7322 while (${"VAR".$i}) {
7323 push @distropref, ${"VAR".$i};
7326 } elsif ($thisexte eq "st") {
7327 # eval because Storable is never forward compatible
7328 eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7330 $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7331 "$_, skipping\: $@");
7332 $CPAN::Frontend->mysleep(4);
7337 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7338 ELEMENT: for my $y (0..$#distropref) {
7339 my $distropref = $distropref[$y];
7340 $self->_validate_distropref($distropref,$abs,$y);
7341 my $match = $distropref->{match};
7343 #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7347 # do not take the order of C<keys %$match> because
7348 # "module" is by far the slowest
7349 my $saw_valid_subkeys = 0;
7350 for my $sub_attribute (qw(distribution perl perlconfig module)) {
7351 next unless exists $match->{$sub_attribute};
7352 $saw_valid_subkeys++;
7353 my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7354 if ($sub_attribute eq "module") {
7356 #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7357 my @modules = $self->containsmods;
7358 #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7359 MODULE: for my $module (@modules) {
7360 $okm ||= $module =~ /$qr/;
7361 last MODULE if $okm;
7364 } elsif ($sub_attribute eq "distribution") {
7365 my $okd = $distroid =~ /$qr/;
7367 } elsif ($sub_attribute eq "perl") {
7368 my $okp = $^X =~ /$qr/;
7370 } elsif ($sub_attribute eq "perlconfig") {
7371 for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7372 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7373 # XXX should probably warn if Config does not exist
7374 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7379 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7380 "unknown sub_attribut '$sub_attribute'. ".
7382 "remove, cannot continue.");
7384 last if $ok == 0; # short circuit
7386 unless ($saw_valid_subkeys) {
7387 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7388 "missing match/* subattribute. ".
7390 "remove, cannot continue.");
7392 #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7395 prefs => $distropref,
7397 prefs_file_doc => $y,
7409 # CPAN::Distribution::prefs
7412 if (exists $self->{negative_prefs_cache}
7414 $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7416 delete $self->{negative_prefs_cache};
7417 delete $self->{prefs};
7419 if (exists $self->{prefs}) {
7420 return $self->{prefs}; # XXX comment out during debugging
7422 if ($CPAN::Config->{prefs_dir}) {
7423 CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7424 my $prefs = $self->_find_prefs();
7425 $prefs ||= ""; # avoid warning next line
7426 CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7428 for my $x (qw(prefs prefs_file prefs_file_doc)) {
7429 $self->{$x} = $prefs->{$x};
7433 File::Basename::basename($self->{prefs_file}),
7434 $self->{prefs_file_doc},
7436 my $filler1 = "_" x 22;
7437 my $filler2 = int(66 - length($bs))/2;
7438 $filler2 = 0 if $filler2 < 0;
7439 $filler2 = " " x $filler2;
7440 $CPAN::Frontend->myprint("
7441 $filler1 D i s t r o P r e f s $filler1
7442 $filler2 $bs $filler2
7444 $CPAN::Frontend->mysleep(1);
7445 return $self->{prefs};
7448 $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7449 return $self->{prefs} = +{};
7452 # CPAN::Distribution::make_x_arg
7454 my($self, $whixh) = @_;
7456 my $prefs = $self->prefs;
7459 && exists $prefs->{$whixh}
7460 && exists $prefs->{$whixh}{args}
7461 && $prefs->{$whixh}{args}
7463 $make_x_arg = join(" ",
7464 map {CPAN::HandleConfig
7465 ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7468 my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7469 $make_x_arg ||= $CPAN::Config->{$what};
7473 # CPAN::Distribution::_make_command
7480 CPAN::HandleConfig->prefs_lookup($self,
7482 || $Config::Config{make}
7486 # Old style call, without object. Deprecated
7487 Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7490 CPAN::HandleConfig->prefs_lookup($self,q{make})
7491 || $CPAN::Config->{make}
7492 || $Config::Config{make}
7497 #-> sub CPAN::Distribution::follow_prereqs ;
7498 sub follow_prereqs {
7500 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7501 return unless @prereq_tuples;
7502 my @prereq = map { $_->[0] } @prereq_tuples;
7503 my $pretty_id = $self->pretty_id;
7505 b => "build_requires",
7509 my($filler1,$filler2,$filler3,$filler4);
7511 my $unsat = "Unsatisfied dependencies detected during";
7512 my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7514 my $r = int(($w - length($unsat))/2);
7515 my $l = $w - length($unsat) - $r;
7516 $filler1 = "-"x4 . " "x$l;
7517 $filler2 = " "x$r . "-"x4 . "\n";
7520 my $r = int(($w - length($pretty_id))/2);
7521 my $l = $w - length($pretty_id) - $r;
7522 $filler3 = "-"x4 . " "x$l;
7523 $filler4 = " "x$r . "-"x4 . "\n";
7526 myprint("$filler1 $unsat $filler2".
7527 "$filler3 $pretty_id $filler4".
7528 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7531 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7533 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7534 my $answer = CPAN::Shell::colorable_makemaker_prompt(
7535 "Shall I follow them and prepend them to the queue
7536 of modules we are processing right now?", "yes");
7537 $follow = $answer =~ /^\s*y/i;
7541 myprint(" Ignoring dependencies on modules @prereq\n");
7545 # color them as dirty
7546 for my $p (@prereq) {
7547 # warn "calling color_cmd_tmps(0,1)";
7548 my $any = CPAN::Shell->expandany($p);
7550 $any->color_cmd_tmps(0,2);
7552 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7553 $CPAN::Frontend->mysleep(2);
7556 # queue them and re-queue yourself
7557 CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7558 reverse @prereq_tuples);
7559 $self->{later} = "Delayed until after prerequisites";
7560 return 1; # signal success to the queuerunner
7564 #-> sub CPAN::Distribution::unsat_prereq ;
7565 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7566 # return ([perl=>5.008]) if we need a newer perl than we are running under
7569 my $prereq_pm = $self->prereq_pm or return;
7571 my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7572 my @merged = %merged;
7573 CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7574 NEED: while (my($need_module, $need_version) = each %merged) {
7575 my($available_version,$available_file,$nmo);
7576 if ($need_module eq "perl") {
7577 $available_version = $];
7578 $available_file = $^X;
7580 $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7581 next if $nmo->uptodate;
7582 $available_file = $nmo->available_file;
7584 # if they have not specified a version, we accept any installed one
7585 if (defined $available_file
7586 and ( # a few quick shortcurcuits
7587 not defined $need_version
7588 or $need_version eq '0' # "==" would trigger warning when not numeric
7589 or $need_version eq "undef"
7594 $available_version = $nmo->available_version;
7597 # We only want to install prereqs if either they're not installed
7598 # or if the installed version is too old. We cannot omit this
7599 # check, because if 'force' is in effect, nobody else will check.
7600 if (defined $available_file) {
7601 my(@all_requirements) = split /\s*,\s*/, $need_version;
7604 RQ: for my $rq (@all_requirements) {
7605 if ($rq =~ s|>=\s*||) {
7606 } elsif ($rq =~ s|>\s*||) {
7608 if (CPAN::Version->vgt($available_version,$rq)){
7612 } elsif ($rq =~ s|!=\s*||) {
7614 if (CPAN::Version->vcmp($available_version,$rq)){
7620 } elsif ($rq =~ m|<=?\s*|) {
7622 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7626 if (! CPAN::Version->vgt($rq, $available_version)){
7629 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7630 "available_version[%s]rq[%s]ok[%d]",
7634 CPAN::Version->readable($rq),
7638 next NEED if $ok == @all_requirements;
7641 if ($need_module eq "perl") {
7642 return ["perl", $need_version];
7644 if ($self->{sponsored_mods}{$need_module}++){
7645 # We have already sponsored it and for some reason it's still
7646 # not available. So we do ... what??
7648 # if we push it again, we have a potential infinite loop
7650 # The following "next" was a very problematic construct.
7651 # It helped a lot but broke some day and must be replaced.
7653 # We must be able to deal with modules that come again and
7654 # again as a prereq and have themselves prereqs and the
7655 # queue becomes long but finally we would find the correct
7656 # order. The RecursiveDependency check should trigger a
7657 # die when it's becoming too weird. Unfortunately removing
7658 # this next breaks many other things.
7660 # The bug that brought this up is described in Todo under
7661 # "5.8.9 cannot install Compress::Zlib"
7663 # next; # this is the next that must go away
7665 # The following "next NEED" are fine and the error message
7666 # explains well what is going on. For example when the DBI
7667 # fails and consequently DBD::SQLite fails and now we are
7668 # processing CPAN::SQLite. Then we must have a "next" for
7669 # DBD::SQLite. How can we get it and how can we identify
7670 # all other cases we must identify?
7672 my $do = $nmo->distribution;
7673 next NEED unless $do; # not on CPAN
7674 NOSAYER: for my $nosayer (
7685 &&(UNIVERSAL::can($do->{$nosayer},"failed") ?
7686 $do->{$nosayer}->failed :
7687 $do->{$nosayer} =~ /^NO/)
7689 if ($nosayer eq "make_test"
7691 $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7695 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7696 "'$need_module => $need_version' ".
7697 "for '$self->{ID}' failed when ".
7698 "processing '$do->{ID}' with ".
7699 "'$nosayer => $do->{$nosayer}'. Continuing, ".
7700 "but chances to succeed are limited.\n"
7706 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7707 push @need, [$need_module,$needed_as];
7709 my @unfolded = map { "[".join(",",@$_)."]" } @need;
7710 CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7714 #-> sub CPAN::Distribution::read_yaml ;
7717 return $self->{yaml_content} if exists $self->{yaml_content};
7718 my $build_dir = $self->{build_dir};
7719 my $yaml = File::Spec->catfile($build_dir,"META.yml");
7720 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7721 return unless -f $yaml;
7722 eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7724 $CPAN::Frontend->mywarn("Could not read ".
7725 "'$yaml'. Falling back to other ".
7726 "methods to determine prerequisites\n");
7727 return $self->{yaml_content} = undef; # if we die, then we
7728 # cannot read YAML's own
7731 # not "authoritative"
7732 if (not exists $self->{yaml_content}{dynamic_config}
7733 or $self->{yaml_content}{dynamic_config}
7735 $self->{yaml_content} = undef;
7737 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7739 return $self->{yaml_content};
7742 #-> sub CPAN::Distribution::prereq_pm ;
7745 $self->{prereq_pm_detected} ||= 0;
7746 CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7747 return $self->{prereq_pm} if $self->{prereq_pm_detected};
7748 return unless $self->{writemakefile} # no need to have succeeded
7749 # but we must have run it
7750 || $self->{modulebuild};
7751 CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7752 $self->{writemakefile}||"",
7753 $self->{modulebuild}||"",
7756 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7757 $req = $yaml->{requires} || {};
7758 $breq = $yaml->{build_requires} || {};
7759 undef $req unless ref $req eq "HASH" && %$req;
7761 if ($yaml->{generated_by} &&
7762 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7763 my $eummv = do { local $^W = 0; $1+0; };
7764 if ($eummv < 6.2501) {
7765 # thanks to Slaven for digging that out: MM before
7766 # that could be wrong because it could reflect a
7773 while (my($k,$v) = each %{$req||{}}) {
7776 } elsif ($k =~ /[A-Za-z]/ &&
7778 $CPAN::META->exists("Module",$v)
7780 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7781 "requires hash: $k => $v; I'll take both ".
7782 "key and value as a module name\n");
7783 $CPAN::Frontend->mysleep(1);
7789 $req = $areq if $do_replace;
7792 unless ($req || $breq) {
7793 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7794 my $makefile = File::Spec->catfile($build_dir,"Makefile");
7798 $fh = FileHandle->new("<$makefile\0")) {
7799 CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7802 last if /MakeMaker post_initialize section/;
7804 \s+PREREQ_PM\s+=>\s+(.+)
7807 # warn "Found prereq expr[$p]";
7809 # Regexp modified by A.Speer to remember actual version of file
7810 # PREREQ_PM hash key wants, then add to
7811 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7812 # In case a prereq is mentioned twice, complain.
7813 if ( defined $req->{$1} ) {
7814 warn "Warning: PREREQ_PM mentions $1 more than once, ".
7815 "last mention wins";
7817 my($m,$n) = ($1,$2);
7818 if ($n =~ /^q\[(.*?)\]$/) {
7827 unless ($req || $breq) {
7828 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7829 my $buildfile = File::Spec->catfile($build_dir,"Build");
7830 if (-f $buildfile) {
7831 CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7832 my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7833 if (-f $build_prereqs) {
7834 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7835 my $content = do { local *FH;
7836 open FH, $build_prereqs
7837 or $CPAN::Frontend->mydie("Could not open ".
7838 "'$build_prereqs': $!");
7842 my $bphash = eval $content;
7845 $req = $bphash->{requires} || +{};
7846 $breq = $bphash->{build_requires} || +{};
7852 && ! -f "Makefile.PL"
7853 && ! exists $req->{"Module::Build"}
7854 && ! $CPAN::META->has_inst("Module::Build")) {
7855 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
7856 "undeclared prerequisite.\n".
7857 " Adding it now as such.\n"
7859 $CPAN::Frontend->mysleep(5);
7860 $req->{"Module::Build"} = 0;
7861 delete $self->{writemakefile};
7863 if ($req || $breq) {
7864 $self->{prereq_pm_detected}++;
7865 return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7869 #-> sub CPAN::Distribution::test ;
7872 if (my $goto = $self->prefs->{goto}) {
7873 return $self->goto($goto);
7877 delete $self->{force_update};
7880 # warn "XDEBUG: checking for notest: $self->{notest} $self";
7881 if ($self->{notest}) {
7882 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7886 my $make = $self->{modulebuild} ? "Build" : "make";
7888 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7890 : ($ENV{PERLLIB} || "");
7892 $CPAN::META->set_perl5lib;
7893 local $ENV{MAKEFLAGS}; # protect us from outer make calls
7895 $CPAN::Frontend->myprint("Running $make test\n");
7897 # if (my @prereq = $self->unsat_prereq){
7898 # if ( $CPAN::DEBUG ) {
7899 # require Data::Dumper;
7900 # CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7902 # unless ($prereq[0][0] eq "perl") {
7903 # return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7909 unless (exists $self->{make} or exists $self->{later}) {
7911 "Make had some problems, won't test";
7914 exists $self->{make} and
7916 UNIVERSAL::can($self->{make},"failed") ?
7917 $self->{make}->failed :
7918 $self->{make} =~ /^NO/
7919 ) and push @e, "Can't test without successful make";
7921 $self->{badtestcnt} ||= 0;
7922 if ($self->{badtestcnt} > 0) {
7923 require Data::Dumper;
7924 CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
7925 push @e, "Won't repeat unsuccessful test during this command";
7928 exists $self->{later} and length($self->{later}) and
7929 push @e, $self->{later};
7931 if (exists $self->{build_dir}) {
7932 if ($CPAN::META->{is_tested}{$self->{build_dir}}
7934 exists $self->{make_test}
7937 UNIVERSAL::can($self->{make_test},"failed") ?
7938 $self->{make_test}->failed :
7939 $self->{make_test} =~ /^NO/
7942 push @e, "Has already been tested successfully";
7945 push @e, "Has no own directory";
7947 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7948 unless (chdir $self->{build_dir}) {
7949 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7951 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
7953 $self->debug("Changed directory to $self->{build_dir}")
7956 if ($^O eq 'MacOS') {
7957 Mac::BuildTools::make_test($self);
7961 if ($self->{modulebuild}) {
7962 my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7963 if (CPAN::Version->vlt($v,2.62)) {
7964 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7965 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7966 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7972 if (my $commandline = $self->prefs->{test}{commandline}) {
7973 $system = $commandline;
7975 } elsif ($self->{modulebuild}) {
7976 $system = sprintf "%s test", $self->_build_command();
7978 $system = join " ", $self->_make_command(), "test";
7980 my $make_test_arg = $self->make_x_arg("test");
7981 $system = sprintf("%s%s",
7983 $make_test_arg ? " $make_test_arg" : "",
7987 while (my($k,$v) = each %ENV) {
7988 next unless defined $v;
7992 if (my $env = $self->prefs->{test}{env}) {
7993 for my $e (keys %$env) {
7994 $ENV{$e} = $env->{$e};
7997 my $expect_model = $self->_prefs_with_expect("test");
7998 my $want_expect = 0;
7999 if ( $expect_model && @{$expect_model->{talk}} ) {
8000 my $can_expect = $CPAN::META->has_inst("Expect");
8004 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8005 "testing without\n");
8008 my $test_report = CPAN::HandleConfig->prefs_lookup($self,
8012 my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
8016 $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
8017 "testing without\n");
8020 my $ready_to_report = $want_report;
8021 if ($ready_to_report
8023 substr($self->id,-1,1) eq "."
8025 $self->author->id eq "LOCAL"
8028 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8029 "for local directories\n");
8030 $ready_to_report = 0;
8032 if ($ready_to_report
8034 $self->prefs->{patches}
8036 @{$self->prefs->{patches}}
8040 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8041 "when the source has been patched\n");
8042 $ready_to_report = 0;
8045 if ($ready_to_report) {
8046 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8047 "not supported when distroprefs specify ".
8048 "an interactive test\n");
8050 $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8051 } elsif ( $ready_to_report ) {
8052 $tests_ok = CPAN::Reporter::test($self, $system);
8054 $tests_ok = system($system) == 0;
8056 $self->introduce_myself;
8061 # local $CPAN::DEBUG = 16; # Distribution
8062 for my $m (keys %{$self->{sponsored_mods}}) {
8063 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8064 # XXX we need available_version which reflects
8065 # $ENV{PERL5LIB} so that already tested but not yet
8066 # installed modules are counted.
8067 my $available_version = $m_obj->available_version;
8068 my $available_file = $m_obj->available_file;
8069 if ($available_version &&
8070 !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8072 CPAN->debug("m[$m] good enough available_version[$available_version]")
8074 } elsif ($available_file
8076 !$self->{prereq_pm}{$m}
8078 $self->{prereq_pm}{$m} == 0
8081 # lex Class::Accessor::Chained::Fast which has no $VERSION
8082 CPAN->debug("m[$m] have available_file[$available_file]")
8090 my $which = join ",", @prereq;
8091 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8092 "$cnt dependencies missing ($which)";
8093 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8094 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8095 $self->store_persistent_state;
8100 $CPAN::Frontend->myprint(" $system -- OK\n");
8101 $self->{make_test} = CPAN::Distrostatus->new("YES");
8102 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8103 # probably impossible to need the next line because badtestcnt
8104 # has a lifespan of one command
8105 delete $self->{badtestcnt};
8107 $self->{make_test} = CPAN::Distrostatus->new("NO");
8108 $self->{badtestcnt}++;
8109 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
8111 $self->store_persistent_state;
8114 sub _prefs_with_expect {
8115 my($self,$where) = @_;
8116 return unless my $prefs = $self->prefs;
8117 return unless my $where_prefs = $prefs->{$where};
8118 if ($where_prefs->{expect}) {
8120 mode => "deterministic",
8122 talk => $where_prefs->{expect},
8124 } elsif ($where_prefs->{"eexpect"}) {
8125 return $where_prefs->{"eexpect"};
8130 #-> sub CPAN::Distribution::clean ;
8133 my $make = $self->{modulebuild} ? "Build" : "make";
8134 $CPAN::Frontend->myprint("Running $make clean\n");
8135 unless (exists $self->{archived}) {
8136 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8137 "/untarred, nothing done\n");
8140 unless (exists $self->{build_dir}) {
8141 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8144 if (exists $self->{writemakefile}
8145 and $self->{writemakefile}->failed
8147 $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8152 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8153 push @e, "make clean already called once";
8154 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
8156 chdir $self->{build_dir} or
8157 Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8158 $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8160 if ($^O eq 'MacOS') {
8161 Mac::BuildTools::make_clean($self);
8166 if ($self->{modulebuild}) {
8167 unless (-f "Build") {
8168 my $cwd = CPAN::anycwd();
8169 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8170 " in cwd[$cwd]. Danger, Will Robinson!");
8171 $CPAN::Frontend->mysleep(5);
8173 $system = sprintf "%s clean", $self->_build_command();
8175 $system = join " ", $self->_make_command(), "clean";
8177 my $system_ok = system($system) == 0;
8178 $self->introduce_myself;
8180 $CPAN::Frontend->myprint(" $system -- OK\n");
8184 # Jost Krieger pointed out that this "force" was wrong because
8185 # it has the effect that the next "install" on this distribution
8186 # will untar everything again. Instead we should bring the
8187 # object's state back to where it is after untarring.
8198 $self->{make_clean} = CPAN::Distrostatus->new("YES");
8201 # Hmmm, what to do if make clean failed?
8203 $self->{make_clean} = CPAN::Distrostatus->new("NO");
8204 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
8206 # 2006-02-27: seems silly to me to force a make now
8207 # $self->force("make"); # so that this directory won't be used again
8210 $self->store_persistent_state;
8213 #-> sub CPAN::Distribution::goto ;
8215 my($self,$goto) = @_;
8216 $goto = $self->normalize($goto);
8218 # inject into the queue
8220 CPAN::Queue->delete($self->id);
8221 CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8223 # and run where we left off
8225 my($method) = (caller(1))[3];
8226 CPAN->instance("CPAN::Distribution",$goto)->$method;
8227 CPAN::Queue->delete_first($goto);
8230 #-> sub CPAN::Distribution::install ;
8233 if (my $goto = $self->prefs->{goto}) {
8234 return $self->goto($goto);
8237 unless ($self->{badtestcnt}) {
8241 delete $self->{force_update};
8244 my $make = $self->{modulebuild} ? "Build" : "make";
8245 $CPAN::Frontend->myprint("Running $make install\n");
8248 unless (exists $self->{make} or exists $self->{later}) {
8250 "Make had some problems, won't install";
8253 exists $self->{make} and
8255 UNIVERSAL::can($self->{make},"failed") ?
8256 $self->{make}->failed :
8257 $self->{make} =~ /^NO/
8259 push @e, "Make had returned bad status, install seems impossible";
8261 if (exists $self->{build_dir}) {
8263 push @e, "Has no own directory";
8266 if (exists $self->{make_test} and
8268 UNIVERSAL::can($self->{make_test},"failed") ?
8269 $self->{make_test}->failed :
8270 $self->{make_test} =~ /^NO/
8272 if ($self->{force_update}) {
8273 $self->{make_test}->text("FAILED but failure ignored because ".
8274 "'force' in effect");
8276 push @e, "make test had returned bad status, ".
8277 "won't install without force"
8280 if (exists $self->{install}) {
8281 if (UNIVERSAL::can($self->{install},"text") ?
8282 $self->{install}->text eq "YES" :
8283 $self->{install} =~ /^YES/
8285 push @e, "Already done";
8287 # comment in Todo on 2006-02-11; maybe retry?
8288 push @e, "Already tried without success";
8292 exists $self->{later} and length($self->{later}) and
8293 push @e, $self->{later};
8295 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
8296 unless (chdir $self->{build_dir}) {
8297 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8299 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
8301 $self->debug("Changed directory to $self->{build_dir}")
8304 if ($^O eq 'MacOS') {
8305 Mac::BuildTools::make_install($self);
8310 if (my $commandline = $self->prefs->{install}{commandline}) {
8311 $system = $commandline;
8313 } elsif ($self->{modulebuild}) {
8314 my($mbuild_install_build_command) =
8315 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8316 $CPAN::Config->{mbuild_install_build_command} ?
8317 $CPAN::Config->{mbuild_install_build_command} :
8318 $self->_build_command();
8319 $system = sprintf("%s install %s",
8320 $mbuild_install_build_command,
8321 $CPAN::Config->{mbuild_install_arg},
8324 my($make_install_make_command) =
8325 CPAN::HandleConfig->prefs_lookup($self,
8326 q{make_install_make_command})
8327 || $self->_make_command();
8328 $system = sprintf("%s install %s",
8329 $make_install_make_command,
8330 $CPAN::Config->{make_install_arg},
8334 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8335 my $brip = CPAN::HandleConfig->prefs_lookup($self,
8336 q{build_requires_install_policy});
8339 my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8340 my $want_install = "yes";
8341 if ($reqtype eq "b") {
8342 if ($brip eq "no") {
8343 $want_install = "no";
8344 } elsif ($brip =~ m|^ask/(.+)|) {
8346 $default = "yes" unless $default =~ /^(y|n)/i;
8348 CPAN::Shell::colorable_makemaker_prompt
8349 ("$id is just needed temporarily during building or testing. ".
8350 "Do you want to install it permanently? (Y/n)",
8354 unless ($want_install =~ /^y/i) {
8355 my $is_only = "is only 'build_requires'";
8356 $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8357 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8358 delete $self->{force_update};
8361 my($pipe) = FileHandle->new("$system $stderr |");
8364 print $_; # intentionally NOT use Frontend->myprint because it
8365 # looks irritating when we markup in color what we
8366 # just pass through from an external program
8370 my $close_ok = $? == 0;
8371 $self->introduce_myself;
8373 $CPAN::Frontend->myprint(" $system -- OK\n");
8374 $CPAN::META->is_installed($self->{build_dir});
8375 $self->{install} = CPAN::Distrostatus->new("YES");
8377 $self->{install} = CPAN::Distrostatus->new("NO");
8378 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
8380 CPAN::HandleConfig->prefs_lookup($self,
8381 q{make_install_make_command});
8383 $makeout =~ /permission/s
8387 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8391 $CPAN::Frontend->myprint(
8393 qq{ You may have to su }.
8394 qq{to root to install the package\n}.
8395 qq{ (Or you may want to run something like\n}.
8396 qq{ o conf make_install_make_command 'sudo make'\n}.
8397 qq{ to raise your permissions.}
8401 delete $self->{force_update};
8403 $self->store_persistent_state;
8406 sub introduce_myself {
8408 $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
8411 #-> sub CPAN::Distribution::dir ;
8416 #-> sub CPAN::Distribution::perldoc ;
8420 my($dist) = $self->id;
8421 my $package = $self->called_for;
8423 $self->_display_url( $CPAN::Defaultdocs . $package );
8426 #-> sub CPAN::Distribution::_check_binary ;
8428 my ($dist,$shell,$binary) = @_;
8431 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8434 if ($CPAN::META->has_inst("File::Which")) {
8435 return File::Which::which($binary);
8438 $pid = open README, "which $binary|"
8439 or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8445 or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8449 $CPAN::Frontend->myprint(qq{ + $out \n})
8450 if $CPAN::DEBUG && $out;
8455 #-> sub CPAN::Distribution::_display_url ;
8457 my($self,$url) = @_;
8458 my($res,$saved_file,$pid,$out);
8460 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8463 # should we define it in the config instead?
8464 my $html_converter = "html2text";
8466 my $web_browser = $CPAN::Config->{'lynx'} || undef;
8467 my $web_browser_out = $web_browser
8468 ? CPAN::Distribution->_check_binary($self,$web_browser)
8471 if ($web_browser_out) {
8472 # web browser found, run the action
8473 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8474 $CPAN::Frontend->myprint(qq{system[$browser $url]})
8476 $CPAN::Frontend->myprint(qq{
8479 with browser $browser
8481 $CPAN::Frontend->mysleep(1);
8482 system("$browser $url");
8483 if ($saved_file) { 1 while unlink($saved_file) }
8485 # web browser not found, let's try text only
8486 my $html_converter_out =
8487 CPAN::Distribution->_check_binary($self,$html_converter);
8488 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8490 if ($html_converter_out ) {
8491 # html2text found, run it
8492 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8493 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8494 unless defined($saved_file);
8497 $pid = open README, "$html_converter $saved_file |"
8498 or $CPAN::Frontend->mydie(qq{
8499 Could not fork '$html_converter $saved_file': $!});
8501 if ($CPAN::META->has_inst("File::Temp")) {
8502 $fh = File::Temp->new(
8503 template => 'cpan_htmlconvert_XXXX',
8507 $filename = $fh->filename;
8509 $filename = "cpan_htmlconvert_$$.txt";
8510 $fh = FileHandle->new();
8511 open $fh, ">$filename" or die;
8517 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8518 my $tmpin = $fh->filename;
8519 $CPAN::Frontend->myprint(sprintf(qq{
8521 saved output to %s\n},
8529 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8530 my $fh_pager = FileHandle->new;
8531 local($SIG{PIPE}) = "IGNORE";
8532 my $pager = $CPAN::Config->{'pager'} || "cat";
8533 $fh_pager->open("|$pager")
8534 or $CPAN::Frontend->mydie(qq{
8535 Could not open pager '$pager': $!});
8536 $CPAN::Frontend->myprint(qq{
8541 $CPAN::Frontend->mysleep(1);
8542 $fh_pager->print(<FH>);
8545 # coldn't find the web browser or html converter
8546 $CPAN::Frontend->myprint(qq{
8547 You need to install lynx or $html_converter to use this feature.});
8552 #-> sub CPAN::Distribution::_getsave_url ;
8554 my($dist, $shell, $url) = @_;
8556 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8560 if ($CPAN::META->has_inst("File::Temp")) {
8561 $fh = File::Temp->new(
8562 template => "cpan_getsave_url_XXXX",
8566 $filename = $fh->filename;
8568 $fh = FileHandle->new;
8569 $filename = "cpan_getsave_url_$$.html";
8571 my $tmpin = $filename;
8572 if ($CPAN::META->has_usable('LWP')) {
8573 $CPAN::Frontend->myprint("Fetching with LWP:
8577 CPAN::LWP::UserAgent->config;
8578 eval { $Ua = CPAN::LWP::UserAgent->new; };
8580 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8584 $Ua->proxy('http', $var)
8585 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8587 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8590 my $req = HTTP::Request->new(GET => $url);
8591 $req->header('Accept' => 'text/html');
8592 my $res = $Ua->request($req);
8593 if ($res->is_success) {
8594 $CPAN::Frontend->myprint(" + request successful.\n")
8596 print $fh $res->content;
8598 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8602 $CPAN::Frontend->myprint(sprintf(
8603 "LWP failed with code[%s], message[%s]\n",
8610 $CPAN::Frontend->mywarn(" LWP not available\n");
8615 # sub CPAN::Distribution::_build_command
8616 sub _build_command {
8618 if ($^O eq "MSWin32") { # special code needed at least up to
8619 # Module::Build 0.2611 and 0.2706; a fix
8620 # in M:B has been promised 2006-01-30
8621 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8622 return "$perl ./Build";
8627 package CPAN::Bundle;
8632 $CPAN::Frontend->myprint($self->as_string);
8637 delete $self->{later};
8638 for my $c ( $self->contains ) {
8639 my $obj = CPAN::Shell->expandany($c) or next;
8644 # mark as dirty/clean
8645 #-> sub CPAN::Bundle::color_cmd_tmps ;
8646 sub color_cmd_tmps {
8648 my($depth) = shift || 0;
8649 my($color) = shift || 0;
8650 my($ancestors) = shift || [];
8651 # a module needs to recurse to its cpan_file, a distribution needs
8652 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8654 return if exists $self->{incommandcolor}
8656 && $self->{incommandcolor}==$color;
8657 if ($depth>=$CPAN::MAX_RECURSION){
8658 die(CPAN::Exception::RecursiveDependency->new($ancestors));
8660 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8662 for my $c ( $self->contains ) {
8663 my $obj = CPAN::Shell->expandany($c) or next;
8664 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8665 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8667 # never reached code?
8669 #delete $self->{badtestcnt};
8671 $self->{incommandcolor} = $color;
8674 #-> sub CPAN::Bundle::as_string ;
8678 # following line must be "=", not "||=" because we have a moving target
8679 $self->{INST_VERSION} = $self->inst_version;
8680 return $self->SUPER::as_string;
8683 #-> sub CPAN::Bundle::contains ;
8686 my($inst_file) = $self->inst_file || "";
8687 my($id) = $self->id;
8688 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8689 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8692 unless ($inst_file) {
8693 # Try to get at it in the cpan directory
8694 $self->debug("no inst_file") if $CPAN::DEBUG;
8696 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8697 $cpan_file = $self->cpan_file;
8698 if ($cpan_file eq "N/A") {
8699 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8700 Maybe stale symlink? Maybe removed during session? Giving up.\n");
8702 my $dist = $CPAN::META->instance('CPAN::Distribution',
8704 $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8706 $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8707 my($todir) = $CPAN::Config->{'cpan_home'};
8708 my(@me,$from,$to,$me);
8709 @me = split /::/, $self->id;
8711 $me = File::Spec->catfile(@me);
8712 $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8713 $to = File::Spec->catfile($todir,$me);
8714 File::Path::mkpath(File::Basename::dirname($to));
8715 File::Copy::copy($from, $to)
8716 or Carp::confess("Couldn't copy $from to $to: $!");
8720 my $fh = FileHandle->new;
8722 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8724 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8726 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8727 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8728 next unless $in_cont;
8733 push @result, (split " ", $_, 2)[0];
8736 delete $self->{STATUS};
8737 $self->{CONTAINS} = \@result;
8738 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8740 $CPAN::Frontend->mywarn(qq{
8741 The bundle file "$inst_file" may be a broken
8742 bundlefile. It seems not to contain any bundle definition.
8743 Please check the file and if it is bogus, please delete it.
8744 Sorry for the inconvenience.
8750 #-> sub CPAN::Bundle::find_bundle_file
8751 # $where is in local format, $what is in unix format
8752 sub find_bundle_file {
8753 my($self,$where,$what) = @_;
8754 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8755 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8756 ### my $bu = File::Spec->catfile($where,$what);
8757 ### return $bu if -f $bu;
8758 my $manifest = File::Spec->catfile($where,"MANIFEST");
8759 unless (-f $manifest) {
8760 require ExtUtils::Manifest;
8761 my $cwd = CPAN::anycwd();
8762 $self->safe_chdir($where);
8763 ExtUtils::Manifest::mkmanifest();
8764 $self->safe_chdir($cwd);
8766 my $fh = FileHandle->new($manifest)
8767 or Carp::croak("Couldn't open $manifest: $!");
8769 my $bundle_filename = $what;
8770 $bundle_filename =~ s|Bundle.*/||;
8771 my $bundle_unixpath;
8774 my($file) = /(\S+)/;
8775 if ($file =~ m|\Q$what\E$|) {
8776 $bundle_unixpath = $file;
8777 # return File::Spec->catfile($where,$bundle_unixpath); # bad
8780 # retry if she managed to have no Bundle directory
8781 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8783 return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8784 if $bundle_unixpath;
8785 Carp::croak("Couldn't find a Bundle file in $where");
8788 # needs to work quite differently from Module::inst_file because of
8789 # cpan_home/Bundle/ directory and the possibility that we have
8790 # shadowing effect. As it makes no sense to take the first in @INC for
8791 # Bundles, we parse them all for $VERSION and take the newest.
8793 #-> sub CPAN::Bundle::inst_file ;
8798 @me = split /::/, $self->id;
8801 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8802 my $bfile = File::Spec->catfile($incdir, @me);
8803 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8804 next unless -f $bfile;
8805 my $foundv = MM->parse_version($bfile);
8806 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8807 $self->{INST_FILE} = $bfile;
8808 $self->{INST_VERSION} = $bestv = $foundv;
8814 #-> sub CPAN::Bundle::inst_version ;
8817 $self->inst_file; # finds INST_VERSION as side effect
8818 $self->{INST_VERSION};
8821 #-> sub CPAN::Bundle::rematein ;
8823 my($self,$meth) = @_;
8824 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8825 my($id) = $self->id;
8826 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8827 unless $self->inst_file || $self->cpan_file;
8829 for $s ($self->contains) {
8830 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8831 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8832 if ($type eq 'CPAN::Distribution') {
8833 $CPAN::Frontend->mywarn(qq{
8834 The Bundle }.$self->id.qq{ contains
8835 explicitly a file '$s'.
8836 Going to $meth that.
8838 $CPAN::Frontend->mysleep(5);
8840 # possibly noisy action:
8841 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8842 my $obj = $CPAN::META->instance($type,$s);
8843 $obj->{reqtype} = $self->{reqtype};
8848 # If a bundle contains another that contains an xs_file we have here,
8849 # we just don't bother I suppose
8850 #-> sub CPAN::Bundle::xs_file
8855 #-> sub CPAN::Bundle::force ;
8856 sub fforce { shift->rematein('fforce',@_); }
8857 #-> sub CPAN::Bundle::force ;
8858 sub force { shift->rematein('force',@_); }
8859 #-> sub CPAN::Bundle::notest ;
8860 sub notest { shift->rematein('notest',@_); }
8861 #-> sub CPAN::Bundle::get ;
8862 sub get { shift->rematein('get',@_); }
8863 #-> sub CPAN::Bundle::make ;
8864 sub make { shift->rematein('make',@_); }
8865 #-> sub CPAN::Bundle::test ;
8868 # $self->{badtestcnt} ||= 0;
8869 $self->rematein('test',@_);
8871 #-> sub CPAN::Bundle::install ;
8874 $self->rematein('install',@_);
8876 #-> sub CPAN::Bundle::clean ;
8877 sub clean { shift->rematein('clean',@_); }
8879 #-> sub CPAN::Bundle::uptodate ;
8882 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8884 foreach $c ($self->contains) {
8885 my $obj = CPAN::Shell->expandany($c);
8886 return 0 unless $obj->uptodate;
8891 #-> sub CPAN::Bundle::readme ;
8894 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8895 No File found for bundle } . $self->id . qq{\n}), return;
8896 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8897 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8900 package CPAN::Module;
8904 # sub CPAN::Module::userid
8909 return $ro->{userid} || $ro->{CPAN_USERID};
8911 # sub CPAN::Module::description
8914 my $ro = $self->ro or return "";
8920 CPAN::Shell->expand("Distribution",$self->cpan_file);
8923 # sub CPAN::Module::undelay
8926 delete $self->{later};
8927 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8932 # mark as dirty/clean
8933 #-> sub CPAN::Module::color_cmd_tmps ;
8934 sub color_cmd_tmps {
8936 my($depth) = shift || 0;
8937 my($color) = shift || 0;
8938 my($ancestors) = shift || [];
8939 # a module needs to recurse to its cpan_file
8941 return if exists $self->{incommandcolor}
8943 && $self->{incommandcolor}==$color;
8944 return if $color==0 && !$self->{incommandcolor};
8946 if ( $self->uptodate ) {
8947 $self->{incommandcolor} = $color;
8949 } elsif (my $have_version = $self->available_version) {
8950 # maybe what we have is good enough
8952 my $who_asked_for_me = $ancestors->[-1];
8953 my $obj = CPAN::Shell->expandany($who_asked_for_me);
8955 } elsif ($obj->isa("CPAN::Bundle")) {
8956 # bundles cannot specify a minimum version
8958 } elsif ($obj->isa("CPAN::Distribution")) {
8959 if (my $prereq_pm = $obj->prereq_pm) {
8960 for my $k (keys %$prereq_pm) {
8961 if (my $want_version = $prereq_pm->{$k}{$self->id}) {
8962 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
8963 $self->{incommandcolor} = $color;
8973 $self->{incommandcolor} = $color; # set me before recursion,
8974 # so we can break it
8976 if ($depth>=$CPAN::MAX_RECURSION){
8977 die(CPAN::Exception::RecursiveDependency->new($ancestors));
8979 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8981 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8982 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8986 # delete $self->{badtestcnt};
8988 $self->{incommandcolor} = $color;
8991 #-> sub CPAN::Module::as_glimpse ;
8995 my $class = ref($self);
8996 $class =~ s/^CPAN:://;
9000 $CPAN::Shell::COLOR_REGISTERED
9002 $CPAN::META->has_inst("Term::ANSIColor")
9006 $color_on = Term::ANSIColor::color("green");
9007 $color_off = Term::ANSIColor::color("reset");
9009 my $uptodateness = " ";
9010 if ($class eq "Bundle") {
9011 } elsif ($self->uptodate) {
9012 $uptodateness = "=";
9013 } elsif ($self->inst_version) {
9014 $uptodateness = "<";
9016 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9022 ($self->distribution ?
9023 $self->distribution->pretty_id :
9030 #-> sub CPAN::Module::dslip_status
9034 # development status
9035 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
9036 pre-alpha alpha beta released
9039 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
9040 developer comp.lang.perl.*
9043 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
9045 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
9047 object-oriented pragma
9050 @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
9054 distribution_allowed
9055 restricted_distribution
9057 for my $x (qw(d s l i p)) {
9058 $stat->{$x}{' '} = 'unknown';
9059 $stat->{$x}{'?'} = 'unknown';
9062 return +{} unless $ro && $ro->{statd};
9069 DV => $stat->{D}{$ro->{statd}},
9070 SV => $stat->{S}{$ro->{stats}},
9071 LV => $stat->{L}{$ro->{statl}},
9072 IV => $stat->{I}{$ro->{stati}},
9073 PV => $stat->{P}{$ro->{statp}},
9077 #-> sub CPAN::Module::as_string ;
9081 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9082 my $class = ref($self);
9083 $class =~ s/^CPAN:://;
9085 push @m, $class, " id = $self->{ID}\n";
9086 my $sprintf = " %-12s %s\n";
9087 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9088 if $self->description;
9089 my $sprintf2 = " %-12s %s (%s)\n";
9091 $userid = $self->userid;
9094 if ($author = CPAN::Shell->expand('Author',$userid)) {
9097 if ($m = $author->email) {
9104 $author->fullname . $email
9108 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9109 if $self->cpan_version;
9110 if (my $cpan_file = $self->cpan_file){
9111 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9112 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9113 my $upload_date = $dist->upload_date;
9115 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9119 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9120 my $dslip = $self->dslip_status;
9124 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9126 my $local_file = $self->inst_file;
9127 unless ($self->{MANPAGE}) {
9130 $manpage = $self->manpage_headline($local_file);
9132 # If we have already untarred it, we should look there
9133 my $dist = $CPAN::META->instance('CPAN::Distribution',
9135 # warn "dist[$dist]";
9136 # mff=manifest file; mfh=manifest handle
9141 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9143 $mfh = FileHandle->new($mff)
9145 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9146 my $lfre = $self->id; # local file RE
9149 my($lfl); # local file file
9151 my(@mflines) = <$mfh>;
9156 while (length($lfre)>5 and !$lfl) {
9157 ($lfl) = grep /$lfre/, @mflines;
9158 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9161 $lfl =~ s/\s.*//; # remove comments
9162 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9163 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9164 # warn "lfl_abs[$lfl_abs]";
9166 $manpage = $self->manpage_headline($lfl_abs);
9170 $self->{MANPAGE} = $manpage if $manpage;
9173 for $item (qw/MANPAGE/) {
9174 push @m, sprintf($sprintf, $item, $self->{$item})
9175 if exists $self->{$item};
9177 for $item (qw/CONTAINS/) {
9178 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9179 if exists $self->{$item} && @{$self->{$item}};
9181 push @m, sprintf($sprintf, 'INST_FILE',
9182 $local_file || "(not installed)");
9183 push @m, sprintf($sprintf, 'INST_VERSION',
9184 $self->inst_version) if $local_file;
9188 sub manpage_headline {
9189 my($self,$local_file) = @_;
9190 my(@local_file) = $local_file;
9191 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9192 push @local_file, $local_file;
9194 for $locf (@local_file) {
9195 next unless -f $locf;
9196 my $fh = FileHandle->new($locf)
9197 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9201 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9202 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9219 #-> sub CPAN::Module::cpan_file ;
9220 # Note: also inherited by CPAN::Bundle
9223 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9224 unless ($self->ro) {
9225 CPAN::Index->reload;
9228 if ($ro && defined $ro->{CPAN_FILE}){
9229 return $ro->{CPAN_FILE};
9231 my $userid = $self->userid;
9233 if ($CPAN::META->exists("CPAN::Author",$userid)) {
9234 my $author = $CPAN::META->instance("CPAN::Author",
9236 my $fullname = $author->fullname;
9237 my $email = $author->email;
9238 unless (defined $fullname && defined $email) {
9239 return sprintf("Contact Author %s",
9243 return "Contact Author $fullname <$email>";
9245 return "Contact Author $userid (Email address not available)";
9253 #-> sub CPAN::Module::cpan_version ;
9259 # Can happen with modules that are not on CPAN
9262 $ro->{CPAN_VERSION} = 'undef'
9263 unless defined $ro->{CPAN_VERSION};
9264 $ro->{CPAN_VERSION};
9267 #-> sub CPAN::Module::force ;
9270 $self->{force_update} = 1;
9273 #-> sub CPAN::Module::fforce ;
9276 $self->{force_update} = 2;
9281 # warn "XDEBUG: set notest for Module";
9282 $self->{'notest'}++;
9285 #-> sub CPAN::Module::rematein ;
9287 my($self,$meth) = @_;
9288 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9291 my $cpan_file = $self->cpan_file;
9292 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9293 $CPAN::Frontend->mywarn(sprintf qq{
9294 The module %s isn\'t available on CPAN.
9296 Either the module has not yet been uploaded to CPAN, or it is
9297 temporary unavailable. Please contact the author to find out
9298 more about the status. Try 'i %s'.
9305 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9306 $pack->called_for($self->id);
9307 if (exists $self->{force_update}){
9308 if ($self->{force_update} == 2) {
9309 $pack->fforce($meth);
9311 $pack->force($meth);
9314 $pack->notest($meth) if exists $self->{'notest'};
9316 $pack->{reqtype} ||= "";
9317 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9318 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9319 if ($pack->{reqtype}) {
9320 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9321 $pack->{reqtype} = $self->{reqtype};
9323 exists $pack->{install}
9326 UNIVERSAL::can($pack->{install},"failed") ?
9327 $pack->{install}->failed :
9328 $pack->{install} =~ /^NO/
9331 delete $pack->{install};
9332 $CPAN::Frontend->mywarn
9333 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9337 $pack->{reqtype} = $self->{reqtype};
9344 $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9345 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
9346 delete $self->{force_update};
9347 delete $self->{'notest'};
9353 #-> sub CPAN::Module::perldoc ;
9354 sub perldoc { shift->rematein('perldoc') }
9355 #-> sub CPAN::Module::readme ;
9356 sub readme { shift->rematein('readme') }
9357 #-> sub CPAN::Module::look ;
9358 sub look { shift->rematein('look') }
9359 #-> sub CPAN::Module::cvs_import ;
9360 sub cvs_import { shift->rematein('cvs_import') }
9361 #-> sub CPAN::Module::get ;
9362 sub get { shift->rematein('get',@_) }
9363 #-> sub CPAN::Module::make ;
9364 sub make { shift->rematein('make') }
9365 #-> sub CPAN::Module::test ;
9368 # $self->{badtestcnt} ||= 0;
9369 $self->rematein('test',@_);
9371 #-> sub CPAN::Module::uptodate ;
9374 local($_); # protect against a bug in MakeMaker 6.17
9375 my($latest) = $self->cpan_version;
9377 my($inst_file) = $self->inst_file;
9379 if (defined $inst_file) {
9380 $have = $self->inst_version;
9385 ! CPAN::Version->vgt($latest, $have)
9387 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9388 "latest[$latest] have[$have]") if $CPAN::DEBUG;
9393 #-> sub CPAN::Module::install ;
9399 not exists $self->{force_update}
9401 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9403 $self->inst_version,
9409 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9410 $CPAN::Frontend->mywarn(qq{
9411 \n\n\n ***WARNING***
9412 The module $self->{ID} has no active maintainer.\n\n\n
9414 $CPAN::Frontend->mysleep(5);
9416 $self->rematein('install') if $doit;
9418 #-> sub CPAN::Module::clean ;
9419 sub clean { shift->rematein('clean') }
9421 #-> sub CPAN::Module::inst_file ;
9424 $self->_file_in_path([@INC]);
9427 #-> sub CPAN::Module::available_file ;
9428 sub available_file {
9430 my $sep = $Config::Config{path_sep};
9431 my $perllib = $ENV{PERL5LIB};
9432 $perllib = $ENV{PERLLIB} unless defined $perllib;
9433 my @perllib = split(/$sep/,$perllib) if defined $perllib;
9434 $self->_file_in_path([@perllib,@INC]);
9437 #-> sub CPAN::Module::file_in_path ;
9439 my($self,$path) = @_;
9441 @packpath = split /::/, $self->{ID};
9442 $packpath[-1] .= ".pm";
9443 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9444 unshift @packpath, "Term", "ReadLine"; # historical reasons
9446 foreach $dir (@$path) {
9447 my $pmfile = File::Spec->catfile($dir,@packpath);
9455 #-> sub CPAN::Module::xs_file ;
9459 @packpath = split /::/, $self->{ID};
9460 push @packpath, $packpath[-1];
9461 $packpath[-1] .= "." . $Config::Config{'dlext'};
9462 foreach $dir (@INC) {
9463 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9471 #-> sub CPAN::Module::inst_version ;
9474 my $parsefile = $self->inst_file or return;
9475 my $have = $self->parse_version($parsefile);
9479 #-> sub CPAN::Module::inst_version ;
9480 sub available_version {
9482 my $parsefile = $self->available_file or return;
9483 my $have = $self->parse_version($parsefile);
9487 #-> sub CPAN::Module::parse_version ;
9489 my($self,$parsefile) = @_;
9490 my $have = MM->parse_version($parsefile);
9491 $have = "undef" unless defined $have && length $have;
9492 $have =~ s/^ //; # since the %vd hack these two lines here are needed
9493 $have =~ s/ $//; # trailing whitespace happens all the time
9495 $have = CPAN::Version->readable($have);
9497 $have =~ s/\s*//g; # stringify to float around floating point issues
9498 $have; # no stringify needed, \s* above matches always
9511 CPAN - query, download and build perl modules from CPAN sites
9517 perl -MCPAN -e shell
9527 cpan> install Acme::Meta # in the shell
9529 CPAN::Shell->install("Acme::Meta"); # in perl
9533 cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
9536 install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
9540 $mo = CPAN::Shell->expandany($mod);
9541 $mo = CPAN::Shell->expand("Module",$mod); # same thing
9543 # distribution objects:
9545 $do = CPAN::Shell->expand("Module",$mod)->distribution;
9546 $do = CPAN::Shell->expandany($distro); # same thing
9547 $do = CPAN::Shell->expand("Distribution",
9548 $distro); # same thing
9552 The CPAN module automates or at least simplifies the make and install
9553 of perl modules and extensions. It includes some primitive searching
9554 capabilities and knows how to use Net::FTP or LWP or some external
9555 download clients to fetch the distributions from the net.
9557 These are fetched from one or more of the mirrored CPAN (Comprehensive
9558 Perl Archive Network) sites and unpacked in a dedicated directory.
9560 The CPAN module also supports the concept of named and versioned
9561 I<bundles> of modules. Bundles simplify the handling of sets of
9562 related modules. See Bundles below.
9564 The package contains a session manager and a cache manager. The
9565 session manager keeps track of what has been fetched, built and
9566 installed in the current session. The cache manager keeps track of the
9567 disk space occupied by the make processes and deletes excess space
9568 according to a simple FIFO mechanism.
9570 All methods provided are accessible in a programmer style and in an
9571 interactive shell style.
9573 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9575 The interactive mode is entered by running
9577 perl -MCPAN -e shell
9583 which puts you into a readline interface. If C<Term::ReadKey> and
9584 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9585 it supports both history and command completion.
9587 Once you are on the command line, type C<h> to get a one page help
9588 screen and the rest should be self-explanatory.
9590 The function call C<shell> takes two optional arguments, one is the
9591 prompt, the second is the default initial command line (the latter
9592 only works if a real ReadLine interface module is installed).
9594 The most common uses of the interactive modes are
9598 =item Searching for authors, bundles, distribution files and modules
9600 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9601 for each of the four categories and another, C<i> for any of the
9602 mentioned four. Each of the four entities is implemented as a class
9603 with slightly differing methods for displaying an object.
9605 Arguments you pass to these commands are either strings exactly matching
9606 the identification string of an object or regular expressions that are
9607 then matched case-insensitively against various attributes of the
9608 objects. The parser recognizes a regular expression only if you
9609 enclose it between two slashes.
9611 The principle is that the number of found objects influences how an
9612 item is displayed. If the search finds one item, the result is
9613 displayed with the rather verbose method C<as_string>, but if we find
9614 more than one, we display each object with the terse method
9617 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9619 These commands take any number of arguments and investigate what is
9620 necessary to perform the action. If the argument is a distribution
9621 file name (recognized by embedded slashes), it is processed. If it is
9622 a module, CPAN determines the distribution file in which this module
9623 is included and processes that, following any dependencies named in
9624 the module's META.yml or Makefile.PL (this behavior is controlled by
9625 the configuration parameter C<prerequisites_policy>.)
9627 C<get> downloads a distribution file and untars or unzips it, C<make>
9628 builds it, C<test> runs the test suite, and C<install> installs it.
9630 Any C<make> or C<test> are run unconditionally. An
9632 install <distribution_file>
9634 also is run unconditionally. But for
9638 CPAN checks if an install is actually needed for it and prints
9639 I<module up to date> in the case that the distribution file containing
9640 the module doesn't need to be updated.
9642 CPAN also keeps track of what it has done within the current session
9643 and doesn't try to build a package a second time regardless if it
9644 succeeded or not. It does not repeat a test run if the test
9645 has been run successfully before. Same for install runs.
9647 The C<force> pragma may precede another command (currently: C<get>,
9648 C<make>, C<test>, or C<install>) and executes the command from scratch
9649 and tries to continue in case of some errors. See the section below on
9650 the C<force> and the C<fforce> pragma.
9652 The C<notest> pragma may be used to skip the test part in the build
9657 cpan> notest install Tk
9659 A C<clean> command results in a
9663 being executed within the distribution file's working directory.
9665 =item C<readme>, C<perldoc>, C<look> module or distribution
9667 C<readme> displays the README file of the associated distribution.
9668 C<Look> gets and untars (if not yet done) the distribution file,
9669 changes to the appropriate directory and opens a subshell process in
9670 that directory. C<perldoc> displays the pod documentation of the
9671 module in html or plain text format.
9675 =item C<ls> globbing_expression
9677 The first form lists all distribution files in and below an author's
9678 CPAN directory as they are stored in the CHECKUMS files distributed on
9679 CPAN. The listing goes recursive into all subdirectories.
9681 The second form allows to limit or expand the output with shell
9682 globbing as in the following examples:
9688 The last example is very slow and outputs extra progress indicators
9689 that break the alignment of the result.
9691 Note that globbing only lists directories explicitly asked for, for
9692 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9693 regarded as a bug and may be changed in future versions.
9697 The C<failed> command reports all distributions that failed on one of
9698 C<make>, C<test> or C<install> for some reason in the currently
9699 running shell session.
9701 =item Persistence between sessions
9703 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9704 the internal state of all modules is written to disk after each step.
9705 The files contain a signature of the currently running perl version
9708 If the configurations variable C<build_dir_reuse> is set to a true
9709 value, then CPAN.pm reads the collected YAML files. If the stored
9710 signature matches the currently running perl the stored state is
9711 loaded into memory such that effectively persistence between sessions
9714 =item The C<force> and the C<fforce> pragma
9716 To speed things up in complex installation scenarios, CPAN.pm keeps
9717 track of what it has already done and refuses to do some things a
9718 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9719 A C<test> is only repeated if the previous test was unsuccessful. The
9720 diagnostic message when CPAN.pm refuses to do something a second time
9721 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9722 something similar. Another situation where CPAN refuses to act is an
9723 C<install> if the according C<test> was not successful.
9725 In all these cases, the user can override the goatish behaviour by
9726 prepending the command with the word force, for example:
9729 cpan> force make AUTHOR/Bar-3.14.tar.gz
9730 cpan> force test Baz
9731 cpan> force install Acme::Meta
9733 Each I<forced> command is executed with the according part of its
9736 The C<fforce> pragma is a variant that emulates a C<force get> which
9737 erases the entire memory followed by the action specified, effectively
9738 restarting the whole get/make/test/install procedure from scratch.
9742 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9743 Batch jobs can run without a lockfile and do not disturb each other.
9745 The shell offers to run in I<degraded mode> when another process is
9746 holding the lockfile. This is an experimental feature that is not yet
9747 tested very well. This second shell then does not write the history
9748 file, does not use the metadata file and has a different prompt.
9752 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9753 in the cpan-shell it is intended that you can press C<^C> anytime and
9754 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9755 to clean up and leave the shell loop. You can emulate the effect of a
9756 SIGTERM by sending two consecutive SIGINTs, which usually means by
9757 pressing C<^C> twice.
9759 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9760 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9761 Build.PL> subprocess.
9767 The commands that are available in the shell interface are methods in
9768 the package CPAN::Shell. If you enter the shell command, all your
9769 input is split by the Text::ParseWords::shellwords() routine which
9770 acts like most shells do. The first word is being interpreted as the
9771 method to be called and the rest of the words are treated as arguments
9772 to this method. Continuation lines are supported if a line ends with a
9777 C<autobundle> writes a bundle file into the
9778 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9779 a list of all modules that are both available from CPAN and currently
9780 installed within @INC. The name of the bundle file is based on the
9781 current date and a counter.
9785 Note: this feature is still in alpha state and may change in future
9788 This commands provides a statistical overview over recent download
9789 activities. The data for this is collected in the YAML file
9790 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9791 configured or YAML not installed, then no stats are provided.
9795 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9796 directory so that you can save your own preferences instead of the
9801 recompile() is a very special command in that it takes no argument and
9802 runs the make/test/install cycle with brute force over all installed
9803 dynamically loadable extensions (aka XS modules) with 'force' in
9804 effect. The primary purpose of this command is to finish a network
9805 installation. Imagine, you have a common source tree for two different
9806 architectures. You decide to do a completely independent fresh
9807 installation. You start on one architecture with the help of a Bundle
9808 file produced earlier. CPAN installs the whole Bundle for you, but
9809 when you try to repeat the job on the second architecture, CPAN
9810 responds with a C<"Foo up to date"> message for all modules. So you
9811 invoke CPAN's recompile on the second architecture and you're done.
9813 Another popular use for C<recompile> is to act as a rescue in case your
9814 perl breaks binary compatibility. If one of the modules that CPAN uses
9815 is in turn depending on binary compatibility (so you cannot run CPAN
9816 commands), then you should try the CPAN::Nox module for recovery.
9818 =head2 report Bundle|Distribution|Module
9820 The C<report> command temporarily turns on the C<test_report> config
9821 variable, then runs the C<force test> command with the given
9822 arguments. The C<force> pragma is used to re-run the tests and repeat
9823 every step that might have failed before.
9825 =head2 upgrade [Module|/Regex/]...
9827 The C<upgrade> command first runs an C<r> command with the given
9828 arguments and then installs the newest versions of all modules that
9829 were listed by that.
9831 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9833 Although it may be considered internal, the class hierarchy does matter
9834 for both users and programmer. CPAN.pm deals with above mentioned four
9835 classes, and all those classes share a set of methods. A classical
9836 single polymorphism is in effect. A metaclass object registers all
9837 objects of all kinds and indexes them with a string. The strings
9838 referencing objects have a separated namespace (well, not completely
9843 words containing a "/" (slash) Distribution
9844 words starting with Bundle:: Bundle
9845 everything else Module or Author
9847 Modules know their associated Distribution objects. They always refer
9848 to the most recent official release. Developers may mark their releases
9849 as unstable development versions (by inserting an underbar into the
9850 module version number which will also be reflected in the distribution
9851 name when you run 'make dist'), so the really hottest and newest
9852 distribution is not always the default. If a module Foo circulates
9853 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9854 way to install version 1.23 by saying
9858 This would install the complete distribution file (say
9859 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9860 like to install version 1.23_90, you need to know where the
9861 distribution file resides on CPAN relative to the authors/id/
9862 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9863 so you would have to say
9865 install BAR/Foo-1.23_90.tar.gz
9867 The first example will be driven by an object of the class
9868 CPAN::Module, the second by an object of class CPAN::Distribution.
9870 =head2 Integrating local directories
9872 Note: this feature is still in alpha state and may change in future
9875 Distribution objects are normally distributions from the CPAN, but
9876 there is a slightly degenerate case for Distribution objects, too, of
9877 projects held on the local disk. These distribution objects have the
9878 same name as the local directory and end with a dot. A dot by itself
9879 is also allowed for the current directory at the time CPAN.pm was
9880 used. All actions such as C<make>, C<test>, and C<install> are applied
9881 directly to that directory. This gives the command C<cpan .> an
9882 interesting touch: while the normal mantra of installing a CPAN module
9883 without CPAN.pm is one of
9885 perl Makefile.PL perl Build.PL
9886 ( go and get prerequisites )
9888 make test ./Build test
9889 make install ./Build install
9891 the command C<cpan .> does all of this at once. It figures out which
9892 of the two mantras is appropriate, fetches and installs all
9893 prerequisites, cares for them recursively and finally finishes the
9894 installation of the module in the current directory, be it a CPAN
9897 The typical usage case is for private modules or working copies of
9898 projects from remote repositories on the local disk.
9900 =head1 CONFIGURATION
9902 When the CPAN module is used for the first time, a configuration
9903 dialog tries to determine a couple of site specific options. The
9904 result of the dialog is stored in a hash reference C< $CPAN::Config >
9905 in a file CPAN/Config.pm.
9907 The default values defined in the CPAN/Config.pm file can be
9908 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9909 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9910 added to the search path of the CPAN module before the use() or
9911 require() statements. The mkmyconfig command writes this file for you.
9913 The C<o conf> command has various bells and whistles:
9917 =item completion support
9919 If you have a ReadLine module installed, you can hit TAB at any point
9920 of the commandline and C<o conf> will offer you completion for the
9921 built-in subcommands and/or config variable names.
9923 =item displaying some help: o conf help
9925 Displays a short help
9927 =item displaying current values: o conf [KEY]
9929 Displays the current value(s) for this config variable. Without KEY
9930 displays all subcommands and config variables.
9936 =item changing of scalar values: o conf KEY VALUE
9938 Sets the config variable KEY to VALUE. The empty string can be
9939 specified as usual in shells, with C<''> or C<"">
9943 o conf wget /usr/bin/wget
9945 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9947 If a config variable name ends with C<list>, it is a list. C<o conf
9948 KEY shift> removes the first element of the list, C<o conf KEY pop>
9949 removes the last element of the list. C<o conf KEYS unshift LIST>
9950 prepends a list of values to the list, C<o conf KEYS push LIST>
9951 appends a list of valued to the list.
9953 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9956 Finally, any other list of arguments is taken as a new list value for
9957 the KEY variable discarding the previous value.
9961 o conf urllist unshift http://cpan.dev.local/CPAN
9962 o conf urllist splice 3 1
9963 o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9965 =item reverting to saved: o conf defaults
9967 Reverts all config variables to the state in the saved config file.
9969 =item saving the config: o conf commit
9971 Saves all config variables to the current config file (CPAN/Config.pm
9972 or CPAN/MyConfig.pm that was loaded at start).
9976 The configuration dialog can be started any time later again by
9977 issuing the command C< o conf init > in the CPAN shell. A subset of
9978 the configuration dialog can be run by issuing C<o conf init WORD>
9979 where WORD is any valid config variable or a regular expression.
9981 =head2 Config Variables
9983 Currently the following keys in the hash reference $CPAN::Config are
9986 applypatch path to external prg
9987 auto_commit commit all changes to config variables to disk
9988 build_cache size of cache for directories to build modules
9989 build_dir locally accessible directory to build modules
9990 build_dir_reuse boolean if distros in build_dir are persistent
9991 build_requires_install_policy
9992 to install or not to install when a module is
9993 only needed for building. yes|no|ask/yes|ask/no
9994 bzip2 path to external prg
9995 cache_metadata use serializer to cache metadata
9996 commands_quote prefered character to use for quoting external
9997 commands when running them. Defaults to double
9998 quote on Windows, single tick everywhere else;
9999 can be set to space to disable quoting
10000 check_sigs if signatures should be verified
10001 colorize_debug Term::ANSIColor attributes for debugging output
10002 colorize_output boolean if Term::ANSIColor should colorize output
10003 colorize_print Term::ANSIColor attributes for normal output
10004 colorize_warn Term::ANSIColor attributes for warnings
10005 commandnumber_in_prompt
10006 boolean if you want to see current command number
10007 cpan_home local directory reserved for this package
10008 curl path to external prg
10009 dontload_hash DEPRECATED
10010 dontload_list arrayref: modules in the list will not be
10011 loaded by the CPAN::has_inst() routine
10012 ftp path to external prg
10013 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
10014 ftp_proxy proxy host for ftp requests
10016 gpg path to external prg
10017 gzip location of external program gzip
10018 histfile file to maintain history between sessions
10019 histsize maximum number of lines to keep in histfile
10020 http_proxy proxy host for http requests
10021 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10022 after this many seconds inactivity. Set to 0 to
10024 index_expire after this many days refetch index files
10025 inhibit_startup_message
10026 if true, does not print the startup message
10027 keep_source_where directory in which to keep the source (if we do)
10028 lynx path to external prg
10029 make location of external make program
10030 make_arg arguments that should always be passed to 'make'
10031 make_install_make_command
10032 the make command for running 'make install', for
10033 example 'sudo make'
10034 make_install_arg same as make_arg for 'make install'
10035 makepl_arg arguments passed to 'perl Makefile.PL'
10036 mbuild_arg arguments passed to './Build'
10037 mbuild_install_arg arguments passed to './Build install'
10038 mbuild_install_build_command
10039 command to use instead of './Build' when we are
10040 in the install stage, for example 'sudo ./Build'
10041 mbuildpl_arg arguments passed to 'perl Build.PL'
10042 ncftp path to external prg
10043 ncftpget path to external prg
10044 no_proxy don't proxy to these hosts/domains (comma separated list)
10045 pager location of external program more (or any pager)
10046 password your password if you CPAN server wants one
10047 patch path to external prg
10048 prefer_installer legal values are MB and EUMM: if a module comes
10049 with both a Makefile.PL and a Build.PL, use the
10050 former (EUMM) or the latter (MB); if the module
10051 comes with only one of the two, that one will be
10053 prerequisites_policy
10054 what to do if you are missing module prerequisites
10055 ('follow' automatically, 'ask' me, or 'ignore')
10056 prefs_dir local directory to store per-distro build options
10057 proxy_user username for accessing an authenticating proxy
10058 proxy_pass password for accessing an authenticating proxy
10059 randomize_urllist add some randomness to the sequence of the urllist
10060 scan_cache controls scanning of cache ('atstart' or 'never')
10061 shell your favorite shell
10062 show_upload_date boolean if commands should try to determine upload date
10063 tar location of external program tar
10064 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
10065 (and nonsense for characters outside latin range)
10066 term_ornaments boolean to turn ReadLine ornamenting on/off
10067 test_report email test reports (if CPAN::Reporter is installed)
10068 unzip location of external program unzip
10069 urllist arrayref to nearby CPAN sites (or equivalent locations)
10070 use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
10071 username your username if you CPAN server wants one
10072 wait_list arrayref to a wait server to try (See CPAN::WAIT)
10073 wget path to external prg
10074 yaml_module which module to use to read/write YAML files
10076 You can set and query each of these options interactively in the cpan
10077 shell with the C<o conf> or the C<o conf init> command as specified below.
10081 =item C<o conf E<lt>scalar optionE<gt>>
10083 prints the current value of the I<scalar option>
10085 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10087 Sets the value of the I<scalar option> to I<value>
10089 =item C<o conf E<lt>list optionE<gt>>
10091 prints the current value of the I<list option> in MakeMaker's
10094 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10096 shifts or pops the array in the I<list option> variable
10098 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10100 works like the corresponding perl commands.
10102 =item interactive editing: o conf init [MATCH|LIST]
10104 Runs an interactive configuration dialog for matching variables.
10105 Without argument runs the dialog over all supported config variables.
10106 To specify a MATCH the argument must be enclosed by slashes.
10110 o conf init ftp_passive ftp_proxy
10111 o conf init /color/
10113 Note: this method of setting config variables often provides more
10114 explanation about the functioning of a variable than the manpage.
10118 =head2 CPAN::anycwd($path): Note on config variable getcwd
10120 CPAN.pm changes the current working directory often and needs to
10121 determine its own current working directory. Per default it uses
10122 Cwd::cwd but if this doesn't work on your system for some reason,
10123 alternatives can be configured according to the following table:
10141 Calls the external command cwd.
10145 =head2 Note on the format of the urllist parameter
10147 urllist parameters are URLs according to RFC 1738. We do a little
10148 guessing if your URL is not compliant, but if you have problems with
10149 C<file> URLs, please try the correct format. Either:
10151 file://localhost/whatever/ftp/pub/CPAN/
10155 file:///home/ftp/pub/CPAN/
10157 =head2 The urllist parameter has CD-ROM support
10159 The C<urllist> parameter of the configuration table contains a list of
10160 URLs that are to be used for downloading. If the list contains any
10161 C<file> URLs, CPAN always tries to get files from there first. This
10162 feature is disabled for index files. So the recommendation for the
10163 owner of a CD-ROM with CPAN contents is: include your local, possibly
10164 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10166 o conf urllist push file://localhost/CDROM/CPAN
10168 CPAN.pm will then fetch the index files from one of the CPAN sites
10169 that come at the beginning of urllist. It will later check for each
10170 module if there is a local copy of the most recent version.
10172 Another peculiarity of urllist is that the site that we could
10173 successfully fetch the last file from automatically gets a preference
10174 token and is tried as the first site for the next request. So if you
10175 add a new site at runtime it may happen that the previously preferred
10176 site will be tried another time. This means that if you want to disallow
10177 a site for the next transfer, it must be explicitly removed from
10180 =head2 Maintaining the urllist parameter
10182 If you have YAML.pm (or some other YAML module configured in
10183 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10184 about recent downloads. You can view the statistics with the C<hosts>
10185 command or inspect them directly by looking into the C<FTPstats.yml>
10186 file in your C<cpan_home> directory.
10188 To get some interesting statistics it is recommended to set the
10189 C<randomize_urllist> parameter that introduces some amount of
10190 randomness into the URL selection.
10192 =head2 The C<requires> and C<build_requires> dependency declarations
10194 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10195 a distribution are treated differently depending on the config
10196 variable C<build_requires_install_policy>. By setting
10197 C<build_requires_install_policy> to C<no> such a module is not being
10198 installed. It is only built and tested and then kept in the list of
10199 tested but uninstalled modules. As such it is available during the
10200 build of the dependent module by integrating the path to the
10201 C<blib/arch> and C<blib/lib> directories in the environment variable
10202 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10203 both modules declared as C<requires> and those declared as
10204 C<build_requires> are treated alike. By setting to C<ask/yes> or
10205 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10207 =head2 Configuration for individual distributions (I<Distroprefs>)
10209 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10210 still considered beta quality)
10212 Distributions on the CPAN usually behave according to what we call the
10213 CPAN mantra. Or since the event of Module::Build we should talk about
10216 perl Makefile.PL perl Build.PL
10218 make test ./Build test
10219 make install ./Build install
10221 But some modules cannot be built with this mantra. They try to get
10222 some extra data from the user via the environment, extra arguments or
10223 interactively thus disturbing the installation of large bundles like
10224 Phalanx100 or modules with many dependencies like Plagger.
10226 The distroprefs system of C<CPAN.pm> addresses this problem by
10227 allowing the user to specify extra informations and recipes in YAML
10234 pass additional arguments to one of the four commands,
10238 set environment variables
10242 instantiate an Expect object that reads from the console, waits for
10243 some regular expressions and enters some answers
10247 temporarily override assorted C<CPAN.pm> configuration variables
10251 disable the installation of an object altogether
10255 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10256 distribution in the C<distroprefs/> directory for examples.
10260 The YAML files themselves must have the C<.yml> extension, all other
10261 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10262 Storable> below). The containing directory can be specified in
10263 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10264 prefs_dir> in the CPAN shell to set and activate the distroprefs
10267 Every YAML file may contain arbitrary documents according to the YAML
10268 specification and every single document is treated as an entity that
10269 can specify the treatment of a single distribution.
10271 The names of the files can be picked freely, C<CPAN.pm> always reads
10272 all files (in alphabetical order) and takes the key C<match> (see
10273 below in I<Language Specs>) as a hashref containing match criteria
10274 that determine if the current distribution matches the YAML document
10277 =head2 Fallback Data::Dumper and Storable
10279 If neither your configured C<yaml_module> nor YAML.pm is installed
10280 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10281 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10282 directory. These files are expected to contain one or more hashrefs.
10283 For Data::Dumper generated files, this is expected to be done with by
10284 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10287 ysh < somefile.yml > somefile.dd
10289 For Storable files the rule is that they must be constructed such that
10290 C<Storable::retrieve(file)> returns an array reference and the array
10291 elements represent one distropref object each. The conversion from
10292 YAML would look like so:
10294 perl -MYAML=LoadFile -MStorable=nstore -e '
10295 @y=LoadFile(shift);
10296 nstore(\@y, shift)' somefile.yml somefile.st
10298 In bootstrapping situations it is usually sufficient to translate only
10299 a few YAML files to Data::Dumper for the crucial modules like
10300 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10301 over Data::Dumper, remember to pull out a Storable version that writes
10302 an older format than all the other Storable versions that will need to
10307 The following example contains all supported keywords and structures
10308 with the exception of C<eexpect> which can be used instead of
10314 module: "Dancing::Queen"
10315 distribution: "^CHACHACHA/Dancing-"
10316 perl: "/usr/local/cariba-perl/bin/perl"
10318 archname: "freebsd"
10324 - "--somearg=specialcase"
10329 - "Which is your favorite fruit"
10341 commendline: "echo SKIPPING make"
10354 WANT_TO_INSTALL: YES
10357 - "Do you really want to install"
10361 - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10364 =head2 Language Specs
10366 Every YAML document represents a single hash reference. The valid keys
10367 in this hash are as follows:
10371 =item comment [scalar]
10375 =item cpanconfig [hash]
10377 Temporarily override assorted C<CPAN.pm> configuration variables.
10379 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10380 C<make>, C<make_install_make_command>, C<prefer_installer>,
10381 C<test_report>. Please report as a bug when you need another one
10384 =item disabled [boolean]
10386 Specifies that this distribution shall not be processed at all.
10388 =item goto [string]
10390 The canonical name of a delegate distribution that shall be installed
10391 instead. Useful when a new version, although it tests OK itself,
10392 breaks something else or a developer release or a fork is already
10393 uploaded that is better than the last released version.
10395 =item install [hash]
10397 Processing instructions for the C<make install> or C<./Build install>
10398 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10402 Processing instructions for the C<make> or C<./Build> phase of the
10403 CPAN mantra. See below under I<Processiong Instructions>.
10407 A hashref with one or more of the keys C<distribution>, C<modules>,
10408 C<perl>, and C<perlconfig> that specify if a document is targeted at a
10409 specific CPAN distribution or installation.
10411 The corresponding values are interpreted as regular expressions. The
10412 C<distribution> related one will be matched against the canonical
10413 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10415 The C<module> related one will be matched against I<all> modules
10416 contained in the distribution until one module matches.
10418 The C<perl> related one will be matched against C<$^X>.
10420 The value associated with C<perlconfig> is itself a hashref that is
10421 matched against corresponding values in the C<%Config::Config> hash
10422 living in the C< Config.pm > module.
10424 If more than one restriction of C<module>, C<distribution>, and
10425 C<perl> is specified, the results of the separately computed match
10426 values must all match. If this is the case then the hashref
10427 represented by the YAML document is returned as the preference
10428 structure for the current distribution.
10430 =item patches [array]
10432 An array of patches on CPAN or on the local disk to be applied in
10433 order via the external patch program. If the value for the C<-p>
10434 parameter is C<0> or C<1> is determined by reading the patch
10437 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10438 knows about it B<and> a patch is written by the C<makepatch> program,
10439 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10440 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10445 Processing instructions for the C<perl Makefile.PL> or C<perl
10446 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10451 Processing instructions for the C<make test> or C<./Build test> phase
10452 of the CPAN mantra. See below under I<Processiong Instructions>.
10456 =head2 Processing Instructions
10462 Arguments to be added to the command line
10466 A full commandline that will be executed as it stands by a system
10467 call. During the execution the environment variable PERL will is set
10468 to $^X. If C<commandline> is specified, the content of C<args> is not
10471 =item eexpect [hash]
10473 Extended C<expect>. This is a hash reference with three allowed keys,
10474 C<mode>, C<timeout>, and C<talk>.
10476 C<mode> may have the values C<deterministic> for the case where all
10477 questions come in the order written down and C<anyorder> for the case
10478 where the questions may come in any order. The default mode is
10481 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10482 OK. In the case of a C<mode=deterministic> the timeout denotes the
10483 timeout per question, in the case of C<mode=anyorder> it denotes the
10484 timeout per byte received from the stream or questions.
10486 C<talk> is a reference to an array that contains alternating questions
10487 and answers. Questions are regular expressions and answers are literal
10488 strings. The Expect module will then watch the stream coming from the
10489 execution of the external program (C<perl Makefile.PL>, C<perl
10490 Build.PL>, C<make>, etc.).
10492 In the case of C<mode=deterministic> the CPAN.pm will inject the
10493 according answer as soon as the stream matches the regular expression.
10494 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10495 soon as the timeout is reached for the next byte in the input stream.
10496 In the latter case it removes the according question/answer pair from
10497 the array, so if you want to answer the question C<Do you really want
10498 to do that> several times, then it must be included in the array at
10499 least as often as you want this answer to be given.
10503 Environment variables to be set during the command
10505 =item expect [array]
10507 C<< expect: <array> >> is a short notation for
10510 mode: deterministic
10516 =head2 Schema verification with C<Kwalify>
10518 If you have the C<Kwalify> module installed (which is part of the
10519 Bundle::CPANxxl), then all your distroprefs files are checked for
10520 syntactical correctness.
10522 =head2 Example Distroprefs Files
10524 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10525 are really just examples and should not be used without care because
10526 they cannot fit everybody's purpose. After all the authors of the
10527 packages that ask questions had a need to ask, so you should watch
10528 their questions and adjust the examples to your environment and your
10529 needs. You have beend warned:-)
10531 =head1 PROGRAMMER'S INTERFACE
10533 If you do not enter the shell, the available shell commands are both
10534 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10535 functions in the calling package (C<install(...)>). Before calling low-level
10536 commands it makes sense to initialize components of CPAN you need, e.g.:
10538 CPAN::HandleConfig->load;
10539 CPAN::Shell::setup_output;
10540 CPAN::Index->reload;
10542 High-level commands do such initializations automatically.
10544 There's currently only one class that has a stable interface -
10545 CPAN::Shell. All commands that are available in the CPAN shell are
10546 methods of the class CPAN::Shell. Each of the commands that produce
10547 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10548 the IDs of all modules within the list.
10552 =item expand($type,@things)
10554 The IDs of all objects available within a program are strings that can
10555 be expanded to the corresponding real objects with the
10556 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10557 list of CPAN::Module objects according to the C<@things> arguments
10558 given. In scalar context it only returns the first element of the
10561 =item expandany(@things)
10563 Like expand, but returns objects of the appropriate type, i.e.
10564 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10565 CPAN::Distribution objects for distributions. Note: it does not expand
10566 to CPAN::Author objects.
10568 =item Programming Examples
10570 This enables the programmer to do operations that combine
10571 functionalities that are available in the shell.
10573 # install everything that is outdated on my disk:
10574 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10576 # install my favorite programs if necessary:
10577 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10578 CPAN::Shell->install($mod);
10581 # list all modules on my disk that have no VERSION number
10582 for $mod (CPAN::Shell->expand("Module","/./")){
10583 next unless $mod->inst_file;
10584 # MakeMaker convention for undefined $VERSION:
10585 next unless $mod->inst_version eq "undef";
10586 print "No VERSION in ", $mod->id, "\n";
10589 # find out which distribution on CPAN contains a module:
10590 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10592 Or if you want to write a cronjob to watch The CPAN, you could list
10593 all modules that need updating. First a quick and dirty way:
10595 perl -e 'use CPAN; CPAN::Shell->r;'
10597 If you don't want to get any output in the case that all modules are
10598 up to date, you can parse the output of above command for the regular
10599 expression //modules are up to date// and decide to mail the output
10600 only if it doesn't match. Ick?
10602 If you prefer to do it more in a programmer style in one single
10603 process, maybe something like this suits you better:
10605 # list all modules on my disk that have newer versions on CPAN
10606 for $mod (CPAN::Shell->expand("Module","/./")){
10607 next unless $mod->inst_file;
10608 next if $mod->uptodate;
10609 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10610 $mod->id, $mod->inst_version, $mod->cpan_version;
10613 If that gives you too much output every day, you maybe only want to
10614 watch for three modules. You can write
10616 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10618 as the first line instead. Or you can combine some of the above
10621 # watch only for a new mod_perl module
10622 $mod = CPAN::Shell->expand("Module","mod_perl");
10623 exit if $mod->uptodate;
10624 # new mod_perl arrived, let me know all update recommendations
10629 =head2 Methods in the other Classes
10633 =item CPAN::Author::as_glimpse()
10635 Returns a one-line description of the author
10637 =item CPAN::Author::as_string()
10639 Returns a multi-line description of the author
10641 =item CPAN::Author::email()
10643 Returns the author's email address
10645 =item CPAN::Author::fullname()
10647 Returns the author's name
10649 =item CPAN::Author::name()
10651 An alias for fullname
10653 =item CPAN::Bundle::as_glimpse()
10655 Returns a one-line description of the bundle
10657 =item CPAN::Bundle::as_string()
10659 Returns a multi-line description of the bundle
10661 =item CPAN::Bundle::clean()
10663 Recursively runs the C<clean> method on all items contained in the bundle.
10665 =item CPAN::Bundle::contains()
10667 Returns a list of objects' IDs contained in a bundle. The associated
10668 objects may be bundles, modules or distributions.
10670 =item CPAN::Bundle::force($method,@args)
10672 Forces CPAN to perform a task that it normally would have refused to
10673 do. Force takes as arguments a method name to be called and any number
10674 of additional arguments that should be passed to the called method.
10675 The internals of the object get the needed changes so that CPAN.pm
10676 does not refuse to take the action. The C<force> is passed recursively
10677 to all contained objects. See also the section above on the C<force>
10678 and the C<fforce> pragma.
10680 =item CPAN::Bundle::get()
10682 Recursively runs the C<get> method on all items contained in the bundle
10684 =item CPAN::Bundle::inst_file()
10686 Returns the highest installed version of the bundle in either @INC or
10687 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10688 CPAN::Module::inst_file.
10690 =item CPAN::Bundle::inst_version()
10692 Like CPAN::Bundle::inst_file, but returns the $VERSION
10694 =item CPAN::Bundle::uptodate()
10696 Returns 1 if the bundle itself and all its members are uptodate.
10698 =item CPAN::Bundle::install()
10700 Recursively runs the C<install> method on all items contained in the bundle
10702 =item CPAN::Bundle::make()
10704 Recursively runs the C<make> method on all items contained in the bundle
10706 =item CPAN::Bundle::readme()
10708 Recursively runs the C<readme> method on all items contained in the bundle
10710 =item CPAN::Bundle::test()
10712 Recursively runs the C<test> method on all items contained in the bundle
10714 =item CPAN::Distribution::as_glimpse()
10716 Returns a one-line description of the distribution
10718 =item CPAN::Distribution::as_string()
10720 Returns a multi-line description of the distribution
10722 =item CPAN::Distribution::author
10724 Returns the CPAN::Author object of the maintainer who uploaded this
10727 =item CPAN::Distribution::clean()
10729 Changes to the directory where the distribution has been unpacked and
10730 runs C<make clean> there.
10732 =item CPAN::Distribution::containsmods()
10734 Returns a list of IDs of modules contained in a distribution file.
10735 Only works for distributions listed in the 02packages.details.txt.gz
10736 file. This typically means that only the most recent version of a
10737 distribution is covered.
10739 =item CPAN::Distribution::cvs_import()
10741 Changes to the directory where the distribution has been unpacked and
10742 runs something like
10744 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10748 =item CPAN::Distribution::dir()
10750 Returns the directory into which this distribution has been unpacked.
10752 =item CPAN::Distribution::force($method,@args)
10754 Forces CPAN to perform a task that it normally would have refused to
10755 do. Force takes as arguments a method name to be called and any number
10756 of additional arguments that should be passed to the called method.
10757 The internals of the object get the needed changes so that CPAN.pm
10758 does not refuse to take the action. See also the section above on the
10759 C<force> and the C<fforce> pragma.
10761 =item CPAN::Distribution::get()
10763 Downloads the distribution from CPAN and unpacks it. Does nothing if
10764 the distribution has already been downloaded and unpacked within the
10767 =item CPAN::Distribution::install()
10769 Changes to the directory where the distribution has been unpacked and
10770 runs the external command C<make install> there. If C<make> has not
10771 yet been run, it will be run first. A C<make test> will be issued in
10772 any case and if this fails, the install will be canceled. The
10773 cancellation can be avoided by letting C<force> run the C<install> for
10776 This install method has only the power to install the distribution if
10777 there are no dependencies in the way. To install an object and all of
10778 its dependencies, use CPAN::Shell->install.
10780 Note that install() gives no meaningful return value. See uptodate().
10782 =item CPAN::Distribution::install_tested()
10784 Install all the distributions that have been tested sucessfully but
10785 not yet installed. See also C<is_tested>.
10787 =item CPAN::Distribution::isa_perl()
10789 Returns 1 if this distribution file seems to be a perl distribution.
10790 Normally this is derived from the file name only, but the index from
10791 CPAN can contain a hint to achieve a return value of true for other
10794 =item CPAN::Distribution::is_tested()
10796 List all the distributions that have been tested sucessfully but not
10797 yet installed. See also C<install_tested>.
10799 =item CPAN::Distribution::look()
10801 Changes to the directory where the distribution has been unpacked and
10802 opens a subshell there. Exiting the subshell returns.
10804 =item CPAN::Distribution::make()
10806 First runs the C<get> method to make sure the distribution is
10807 downloaded and unpacked. Changes to the directory where the
10808 distribution has been unpacked and runs the external commands C<perl
10809 Makefile.PL> or C<perl Build.PL> and C<make> there.
10811 =item CPAN::Distribution::perldoc()
10813 Downloads the pod documentation of the file associated with a
10814 distribution (in html format) and runs it through the external
10815 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
10816 isn't available, it converts it to plain text with external
10817 command html2text and runs it through the pager specified
10818 in C<$CPAN::Config->{pager}>
10820 =item CPAN::Distribution::prefs()
10822 Returns the hash reference from the first matching YAML file that the
10823 user has deposited in the C<prefs_dir/> directory. The first
10824 succeeding match wins. The files in the C<prefs_dir/> are processed
10825 alphabetically and the canonical distroname (e.g.
10826 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
10827 stored in the $root->{match}{distribution} attribute value.
10828 Additionally all module names contained in a distribution are matched
10829 agains the regular expressions in the $root->{match}{module} attribute
10830 value. The two match values are ANDed together. Each of the two
10831 attributes are optional.
10833 =item CPAN::Distribution::prereq_pm()
10835 Returns the hash reference that has been announced by a distribution
10836 as the the C<requires> and C<build_requires> elements. These can be
10837 declared either by the C<META.yml> (if authoritative) or can be
10838 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
10839 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
10840 a comment in the produced C<Makefile>. I<Note>: this method only works
10841 after an attempt has been made to C<make> the distribution. Returns
10844 =item CPAN::Distribution::readme()
10846 Downloads the README file associated with a distribution and runs it
10847 through the pager specified in C<$CPAN::Config->{pager}>.
10849 =item CPAN::Distribution::read_yaml()
10851 Returns the content of the META.yml of this distro as a hashref. Note:
10852 works only after an attempt has been made to C<make> the distribution.
10853 Returns undef otherwise. Also returns undef if the content of META.yml
10854 is not authoritative. (The rules about what exactly makes the content
10855 authoritative are still in flux.)
10857 =item CPAN::Distribution::test()
10859 Changes to the directory where the distribution has been unpacked and
10860 runs C<make test> there.
10862 =item CPAN::Distribution::uptodate()
10864 Returns 1 if all the modules contained in the distribution are
10865 uptodate. Relies on containsmods.
10867 =item CPAN::Index::force_reload()
10869 Forces a reload of all indices.
10871 =item CPAN::Index::reload()
10873 Reloads all indices if they have not been read for more than
10874 C<$CPAN::Config->{index_expire}> days.
10876 =item CPAN::InfoObj::dump()
10878 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
10879 inherit this method. It prints the data structure associated with an
10880 object. Useful for debugging. Note: the data structure is considered
10881 internal and thus subject to change without notice.
10883 =item CPAN::Module::as_glimpse()
10885 Returns a one-line description of the module in four columns: The
10886 first column contains the word C<Module>, the second column consists
10887 of one character: an equals sign if this module is already installed
10888 and uptodate, a less-than sign if this module is installed but can be
10889 upgraded, and a space if the module is not installed. The third column
10890 is the name of the module and the fourth column gives maintainer or
10891 distribution information.
10893 =item CPAN::Module::as_string()
10895 Returns a multi-line description of the module
10897 =item CPAN::Module::clean()
10899 Runs a clean on the distribution associated with this module.
10901 =item CPAN::Module::cpan_file()
10903 Returns the filename on CPAN that is associated with the module.
10905 =item CPAN::Module::cpan_version()
10907 Returns the latest version of this module available on CPAN.
10909 =item CPAN::Module::cvs_import()
10911 Runs a cvs_import on the distribution associated with this module.
10913 =item CPAN::Module::description()
10915 Returns a 44 character description of this module. Only available for
10916 modules listed in The Module List (CPAN/modules/00modlist.long.html
10917 or 00modlist.long.txt.gz)
10919 =item CPAN::Module::distribution()
10921 Returns the CPAN::Distribution object that contains the current
10922 version of this module.
10924 =item CPAN::Module::dslip_status()
10926 Returns a hash reference. The keys of the hash are the letters C<D>,
10927 C<S>, C<L>, C<I>, and <P>, for development status, support level,
10928 language, interface and public licence respectively. The data for the
10929 DSLIP status are collected by pause.perl.org when authors register
10930 their namespaces. The values of the 5 hash elements are one-character
10931 words whose meaning is described in the table below. There are also 5
10932 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
10933 verbose value of the 5 status variables.
10935 Where the 'DSLIP' characters have the following meanings:
10937 D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
10938 i - Idea, listed to gain consensus or as a placeholder
10939 c - under construction but pre-alpha (not yet released)
10940 a/b - Alpha/Beta testing
10942 M - Mature (no rigorous definition)
10943 S - Standard, supplied with Perl 5
10948 u - Usenet newsgroup comp.lang.perl.modules
10949 n - None known, try comp.lang.perl.modules
10950 a - abandoned; volunteers welcome to take over maintainance
10953 p - Perl-only, no compiler needed, should be platform independent
10954 c - C and perl, a C compiler will be needed
10955 h - Hybrid, written in perl with optional C code, no compiler needed
10956 + - C++ and perl, a C++ compiler will be needed
10957 o - perl and another language other than C or C++
10959 I - Interface Style
10960 f - plain Functions, no references used
10961 h - hybrid, object and function interfaces available
10962 n - no interface at all (huh?)
10963 r - some use of unblessed References or ties
10964 O - Object oriented using blessed references and/or inheritance
10967 p - Standard-Perl: user may choose between GPL and Artistic
10968 g - GPL: GNU General Public License
10969 l - LGPL: "GNU Lesser General Public License" (previously known as
10970 "GNU Library General Public License")
10971 b - BSD: The BSD License
10972 a - Artistic license alone
10973 o - open source: appoved by www.opensource.org
10974 d - allows distribution without restrictions
10975 r - restricted distribtion
10976 n - no license at all
10978 =item CPAN::Module::force($method,@args)
10980 Forces CPAN to perform a task that it normally would have refused to
10981 do. Force takes as arguments a method name to be called and any number
10982 of additional arguments that should be passed to the called method.
10983 The internals of the object get the needed changes so that CPAN.pm
10984 does not refuse to take the action. See also the section above on the
10985 C<force> and the C<fforce> pragma.
10987 =item CPAN::Module::get()
10989 Runs a get on the distribution associated with this module.
10991 =item CPAN::Module::inst_file()
10993 Returns the filename of the module found in @INC. The first file found
10994 is reported just like perl itself stops searching @INC when it finds a
10997 =item CPAN::Module::available_file()
10999 Returns the filename of the module found in PERL5LIB or @INC. The
11000 first file found is reported. The advantage of this method over
11001 C<inst_file> is that modules that have been tested but not yet
11002 installed are included because PERL5LIB keeps track of tested modules.
11004 =item CPAN::Module::inst_version()
11006 Returns the version number of the installed module in readable format.
11008 =item CPAN::Module::available_version()
11010 Returns the version number of the available module in readable format.
11012 =item CPAN::Module::install()
11014 Runs an C<install> on the distribution associated with this module.
11016 =item CPAN::Module::look()
11018 Changes to the directory where the distribution associated with this
11019 module has been unpacked and opens a subshell there. Exiting the
11022 =item CPAN::Module::make()
11024 Runs a C<make> on the distribution associated with this module.
11026 =item CPAN::Module::manpage_headline()
11028 If module is installed, peeks into the module's manpage, reads the
11029 headline and returns it. Moreover, if the module has been downloaded
11030 within this session, does the equivalent on the downloaded module even
11031 if it is not installed.
11033 =item CPAN::Module::perldoc()
11035 Runs a C<perldoc> on this module.
11037 =item CPAN::Module::readme()
11039 Runs a C<readme> on the distribution associated with this module.
11041 =item CPAN::Module::test()
11043 Runs a C<test> on the distribution associated with this module.
11045 =item CPAN::Module::uptodate()
11047 Returns 1 if the module is installed and up-to-date.
11049 =item CPAN::Module::userid()
11051 Returns the author's ID of the module.
11055 =head2 Cache Manager
11057 Currently the cache manager only keeps track of the build directory
11058 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11059 deletes complete directories below C<build_dir> as soon as the size of
11060 all directories there gets bigger than $CPAN::Config->{build_cache}
11061 (in MB). The contents of this cache may be used for later
11062 re-installations that you intend to do manually, but will never be
11063 trusted by CPAN itself. This is due to the fact that the user might
11064 use these directories for building modules on different architectures.
11066 There is another directory ($CPAN::Config->{keep_source_where}) where
11067 the original distribution files are kept. This directory is not
11068 covered by the cache manager and must be controlled by the user. If
11069 you choose to have the same directory as build_dir and as
11070 keep_source_where directory, then your sources will be deleted with
11071 the same fifo mechanism.
11075 A bundle is just a perl module in the namespace Bundle:: that does not
11076 define any functions or methods. It usually only contains documentation.
11078 It starts like a perl module with a package declaration and a $VERSION
11079 variable. After that the pod section looks like any other pod with the
11080 only difference being that I<one special pod section> exists starting with
11085 In this pod section each line obeys the format
11087 Module_Name [Version_String] [- optional text]
11089 The only required part is the first field, the name of a module
11090 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11091 of the line is optional. The comment part is delimited by a dash just
11092 as in the man page header.
11094 The distribution of a bundle should follow the same convention as
11095 other distributions.
11097 Bundles are treated specially in the CPAN package. If you say 'install
11098 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11099 the modules in the CONTENTS section of the pod. You can install your
11100 own Bundles locally by placing a conformant Bundle file somewhere into
11101 your @INC path. The autobundle() command which is available in the
11102 shell interface does that for you by including all currently installed
11103 modules in a snapshot bundle file.
11105 =head1 PREREQUISITES
11107 If you have a local mirror of CPAN and can access all files with
11108 "file:" URLs, then you only need a perl better than perl5.003 to run
11109 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11110 required for non-UNIX systems or if your nearest CPAN site is
11111 associated with a URL that is not C<ftp:>.
11113 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11114 implemented for an external ftp command or for an external lynx
11119 =head2 Finding packages and VERSION
11121 This module presumes that all packages on CPAN
11127 declare their $VERSION variable in an easy to parse manner. This
11128 prerequisite can hardly be relaxed because it consumes far too much
11129 memory to load all packages into the running program just to determine
11130 the $VERSION variable. Currently all programs that are dealing with
11131 version use something like this
11133 perl -MExtUtils::MakeMaker -le \
11134 'print MM->parse_version(shift)' filename
11136 If you are author of a package and wonder if your $VERSION can be
11137 parsed, please try the above method.
11141 come as compressed or gzipped tarfiles or as zip files and contain a
11142 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11143 without much enthusiasm).
11149 The debugging of this module is a bit complex, because we have
11150 interferences of the software producing the indices on CPAN, of the
11151 mirroring process on CPAN, of packaging, of configuration, of
11152 synchronicity, and of bugs within CPAN.pm.
11154 For debugging the code of CPAN.pm itself in interactive mode some more
11155 or less useful debugging aid can be turned on for most packages within
11156 CPAN.pm with one of
11160 =item o debug package...
11162 sets debug mode for packages.
11164 =item o debug -package...
11166 unsets debug mode for packages.
11170 turns debugging on for all packages.
11172 =item o debug number
11176 which sets the debugging packages directly. Note that C<o debug 0>
11177 turns debugging off.
11179 What seems quite a successful strategy is the combination of C<reload
11180 cpan> and the debugging switches. Add a new debug statement while
11181 running in the shell and then issue a C<reload cpan> and see the new
11182 debugging messages immediately without losing the current context.
11184 C<o debug> without an argument lists the valid package names and the
11185 current set of packages in debugging mode. C<o debug> has built-in
11186 completion support.
11188 For debugging of CPAN data there is the C<dump> command which takes
11189 the same arguments as make/test/install and outputs each object's
11190 Data::Dumper dump. If an argument looks like a perl variable and
11191 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11192 Data::Dumper directly.
11194 =head2 Floppy, Zip, Offline Mode
11196 CPAN.pm works nicely without network too. If you maintain machines
11197 that are not networked at all, you should consider working with file:
11198 URLs. Of course, you have to collect your modules somewhere first. So
11199 you might use CPAN.pm to put together all you need on a networked
11200 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11201 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11202 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11203 with this floppy. See also below the paragraph about CD-ROM support.
11205 =head2 Basic Utilities for Programmers
11209 =item has_inst($module)
11211 Returns true if the module is installed. Used to load all modules into
11212 the running CPAN.pm which are considered optional. The config variable
11213 C<dontload_list> can be used to intercept the C<has_inst()> call such
11214 that an optional module is not loaded despite being available. For
11215 example the following command will prevent that C<YAML.pm> is being
11218 cpan> o conf dontload_list push YAML
11220 See the source for details.
11222 =item has_usable($module)
11224 Returns true if the module is installed and is in a usable state. Only
11225 useful for a handful of modules that are used internally. See the
11226 source for details.
11228 =item instance($module)
11230 The constructor for all the singletons used to represent modules,
11231 distributions, authors and bundles. If the object already exists, this
11232 method returns the object, otherwise it calls the constructor.
11238 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11239 install foreign, unmasked, unsigned code on your machine. We compare
11240 to a checksum that comes from the net just as the distribution file
11241 itself. But we try to make it easy to add security on demand:
11243 =head2 Cryptographically signed modules
11245 Since release 1.77 CPAN.pm has been able to verify cryptographically
11246 signed module distributions using Module::Signature. The CPAN modules
11247 can be signed by their authors, thus giving more security. The simple
11248 unsigned MD5 checksums that were used before by CPAN protect mainly
11249 against accidental file corruption.
11251 You will need to have Module::Signature installed, which in turn
11252 requires that you have at least one of Crypt::OpenPGP module or the
11253 command-line F<gpg> tool installed.
11255 You will also need to be able to connect over the Internet to the public
11256 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11258 The configuration parameter check_sigs is there to turn signature
11259 checking on or off.
11263 Most functions in package CPAN are exported per default. The reason
11264 for this is that the primary use is intended for the cpan shell or for
11269 When the CPAN shell enters a subshell via the look command, it sets
11270 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11273 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11275 When the config variable ftp_passive is set, all downloads will be run
11276 with the environment variable FTP_PASSIVE set to this value. This is
11277 in general a good idea as it influences both Net::FTP and LWP based
11278 connections. The same effect can be achieved by starting the cpan
11279 shell with this environment variable set. For Net::FTP alone, one can
11280 also always set passive mode by running libnetcfg.
11282 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11284 Populating a freshly installed perl with my favorite modules is pretty
11285 easy if you maintain a private bundle definition file. To get a useful
11286 blueprint of a bundle definition file, the command autobundle can be used
11287 on the CPAN shell command line. This command writes a bundle definition
11288 file for all modules that are installed for the currently running perl
11289 interpreter. It's recommended to run this command only once and from then
11290 on maintain the file manually under a private name, say
11291 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11293 cpan> install Bundle::my_bundle
11295 then answer a few questions and then go out for a coffee.
11297 Maintaining a bundle definition file means keeping track of two
11298 things: dependencies and interactivity. CPAN.pm sometimes fails on
11299 calculating dependencies because not all modules define all MakeMaker
11300 attributes correctly, so a bundle definition file should specify
11301 prerequisites as early as possible. On the other hand, it's a bit
11302 annoying that many distributions need some interactive configuring. So
11303 what I try to accomplish in my private bundle file is to have the
11304 packages that need to be configured early in the file and the gentle
11305 ones later, so I can go out after a few minutes and leave CPAN.pm
11308 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11310 Thanks to Graham Barr for contributing the following paragraphs about
11311 the interaction between perl, and various firewall configurations. For
11312 further information on firewalls, it is recommended to consult the
11313 documentation that comes with the ncftp program. If you are unable to
11314 go through the firewall with a simple Perl setup, it is very likely
11315 that you can configure ncftp so that it works for your firewall.
11317 =head2 Three basic types of firewalls
11319 Firewalls can be categorized into three basic types.
11323 =item http firewall
11325 This is where the firewall machine runs a web server and to access the
11326 outside world you must do it via the web server. If you set environment
11327 variables like http_proxy or ftp_proxy to a values beginning with http://
11328 or in your web browser you have to set proxy information then you know
11329 you are running an http firewall.
11331 To access servers outside these types of firewalls with perl (even for
11332 ftp) you will need to use LWP.
11336 This where the firewall machine runs an ftp server. This kind of
11337 firewall will only let you access ftp servers outside the firewall.
11338 This is usually done by connecting to the firewall with ftp, then
11339 entering a username like "user@outside.host.com"
11341 To access servers outside these type of firewalls with perl you
11342 will need to use Net::FTP.
11344 =item One way visibility
11346 I say one way visibility as these firewalls try to make themselves look
11347 invisible to the users inside the firewall. An FTP data connection is
11348 normally created by sending the remote server your IP address and then
11349 listening for the connection. But the remote server will not be able to
11350 connect to you because of the firewall. So for these types of firewall
11351 FTP connections need to be done in a passive mode.
11353 There are two that I can think off.
11359 If you are using a SOCKS firewall you will need to compile perl and link
11360 it with the SOCKS library, this is what is normally called a 'socksified'
11361 perl. With this executable you will be able to connect to servers outside
11362 the firewall as if it is not there.
11364 =item IP Masquerade
11366 This is the firewall implemented in the Linux kernel, it allows you to
11367 hide a complete network behind one IP address. With this firewall no
11368 special compiling is needed as you can access hosts directly.
11370 For accessing ftp servers behind such firewalls you usually need to
11371 set the environment variable C<FTP_PASSIVE> or the config variable
11372 ftp_passive to a true value.
11378 =head2 Configuring lynx or ncftp for going through a firewall
11380 If you can go through your firewall with e.g. lynx, presumably with a
11383 /usr/local/bin/lynx -pscott:tiger
11385 then you would configure CPAN.pm with the command
11387 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11389 That's all. Similarly for ncftp or ftp, you would configure something
11392 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11394 Your mileage may vary...
11402 I installed a new version of module X but CPAN keeps saying,
11403 I have the old version installed
11405 Most probably you B<do> have the old version installed. This can
11406 happen if a module installs itself into a different directory in the
11407 @INC path than it was previously installed. This is not really a
11408 CPAN.pm problem, you would have the same problem when installing the
11409 module manually. The easiest way to prevent this behaviour is to add
11410 the argument C<UNINST=1> to the C<make install> call, and that is why
11411 many people add this argument permanently by configuring
11413 o conf make_install_arg UNINST=1
11417 So why is UNINST=1 not the default?
11419 Because there are people who have their precise expectations about who
11420 may install where in the @INC path and who uses which @INC array. In
11421 fine tuned environments C<UNINST=1> can cause damage.
11425 I want to clean up my mess, and install a new perl along with
11426 all modules I have. How do I go about it?
11428 Run the autobundle command for your old perl and optionally rename the
11429 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11430 with the Configure option prefix, e.g.
11432 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11434 Install the bundle file you produced in the first step with something like
11436 cpan> install Bundle::mybundle
11442 When I install bundles or multiple modules with one command
11443 there is too much output to keep track of.
11445 You may want to configure something like
11447 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11448 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11450 so that STDOUT is captured in a file for later inspection.
11455 I am not root, how can I install a module in a personal directory?
11457 First of all, you will want to use your own configuration, not the one
11458 that your root user installed. If you do not have permission to write
11459 in the cpan directory that root has configured, you will be asked if
11460 you want to create your own config. Answering "yes" will bring you into
11461 CPAN's configuration stage, using the system config for all defaults except
11462 things that have to do with CPAN's work directory, saving your choices to
11463 your MyConfig.pm file.
11465 You can also manually initiate this process with the following command:
11467 % perl -MCPAN -e 'mkmyconfig'
11473 from the CPAN shell.
11475 You will most probably also want to configure something like this:
11477 o conf makepl_arg "LIB=~/myperl/lib \
11478 INSTALLMAN1DIR=~/myperl/man/man1 \
11479 INSTALLMAN3DIR=~/myperl/man/man3 \
11480 INSTALLSCRIPT=~/myperl/bin \
11481 INSTALLBIN=~/myperl/bin"
11483 and then (oh joy) the equivalent command for Module::Build.
11485 You can make this setting permanent like all C<o conf> settings with
11486 C<o conf commit> or by setting C<auto_commit> beforehand.
11488 You will have to add ~/myperl/man to the MANPATH environment variable
11489 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11492 use lib "$ENV{HOME}/myperl/lib";
11494 or setting the PERL5LIB environment variable.
11496 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11497 that for Windows we use the File::HomeDir module that provides an
11498 equivalent to the concept of the home directory on Unix.
11500 Another thing you should bear in mind is that the UNINST parameter can
11501 be dnagerous when you are installing into a private area because you
11502 might accidentally remove modules that other people depend on that are
11503 not using the private area.
11507 How to get a package, unwrap it, and make a change before building it?
11509 Have a look at the C<look> (!) command.
11513 I installed a Bundle and had a couple of fails. When I
11514 retried, everything resolved nicely. Can this be fixed to work
11517 The reason for this is that CPAN does not know the dependencies of all
11518 modules when it starts out. To decide about the additional items to
11519 install, it just uses data found in the META.yml file or the generated
11520 Makefile. An undetected missing piece breaks the process. But it may
11521 well be that your Bundle installs some prerequisite later than some
11522 depending item and thus your second try is able to resolve everything.
11523 Please note, CPAN.pm does not know the dependency tree in advance and
11524 cannot sort the queue of things to install in a topologically correct
11525 order. It resolves perfectly well IF all modules declare the
11526 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11527 the C<requires> stanza of Module::Build. For bundles which fail and
11528 you need to install often, it is recommended to sort the Bundle
11529 definition file manually.
11533 In our intranet we have many modules for internal use. How
11534 can I integrate these modules with CPAN.pm but without uploading
11535 the modules to CPAN?
11537 Have a look at the CPAN::Site module.
11541 When I run CPAN's shell, I get an error message about things in my
11542 /etc/inputrc (or ~/.inputrc) file.
11544 These are readline issues and can only be fixed by studying readline
11545 configuration on your architecture and adjusting the referenced file
11546 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11547 and edit them. Quite often harmless changes like uppercasing or
11548 lowercasing some arguments solves the problem.
11552 Some authors have strange characters in their names.
11554 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11555 expecting ISO-8859-1 charset, a converter can be activated by setting
11556 term_is_latin to a true value in your config file. One way of doing so
11559 cpan> o conf term_is_latin 1
11561 If other charset support is needed, please file a bugreport against
11562 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11563 the support or maybe UTF-8 terminals become widely available.
11567 When an install fails for some reason and then I correct the error
11568 condition and retry, CPAN.pm refuses to install the module, saying
11569 C<Already tried without success>.
11571 Use the force pragma like so
11573 force install Foo::Bar
11579 and then 'make install' directly in the subshell.
11583 How do I install a "DEVELOPER RELEASE" of a module?
11585 By default, CPAN will install the latest non-developer release of a
11586 module. If you want to install a dev release, you have to specify the
11587 partial path starting with the author id to the tarball you wish to
11590 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11592 Note that you can use the C<ls> command to get this path listed.
11596 How do I install a module and all its dependencies from the commandline,
11597 without being prompted for anything, despite my CPAN configuration
11600 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11601 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11602 asked any questions at all (assuming the modules you are installing are
11603 nice about obeying that variable as well):
11605 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11609 How do I create a Module::Build based Build.PL derived from an
11610 ExtUtils::MakeMaker focused Makefile.PL?
11612 http://search.cpan.org/search?query=Module::Build::Convert
11614 http://www.refcnt.org/papers/module-build-convert
11618 What's the best CPAN site for me?
11620 The urllist config parameter is yours. You can add and remove sites at
11621 will. You should find out which sites have the best uptodateness,
11622 bandwidth, reliability, etc. and are topologically close to you. Some
11623 people prefer fast downloads, others uptodateness, others reliability.
11624 You decide which to try in which order.
11626 Henk P. Penning maintains a site that collects data about CPAN sites:
11628 http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11632 =head1 COMPATIBILITY
11634 =head2 OLD PERL VERSIONS
11636 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11637 newer versions. It is getting more and more difficult to get the
11638 minimal prerequisites working on older perls. It is close to
11639 impossible to get the whole Bundle::CPAN working there. If you're in
11640 the position to have only these old versions, be advised that CPAN is
11641 designed to work fine without the Bundle::CPAN installed.
11643 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11644 compatible with ancient perls and that File::Temp is listed as a
11645 prerequisite but CPAN has reasonable workarounds if it is missing.
11649 This module and its competitor, the CPANPLUS module, are both much
11650 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11651 more modular but it was never tried to make it compatible with CPAN.pm.
11653 =head1 SECURITY ADVICE
11655 This software enables you to upgrade software on your computer and so
11656 is inherently dangerous because the newly installed software may
11657 contain bugs and may alter the way your computer works or even make it
11658 unusable. Please consider backing up your data before every upgrade.
11662 Please report bugs via http://rt.cpan.org/
11664 Before submitting a bug, please make sure that the traditional method
11665 of building a Perl module package from a shell by following the
11666 installation instructions of that package still works in your
11671 Andreas Koenig C<< <andk@cpan.org> >>
11675 This program is free software; you can redistribute it and/or
11676 modify it under the same terms as Perl itself.
11678 See L<http://www.perl.com/perl/misc/Artistic.html>
11680 =head1 TRANSLATIONS
11682 Kawai,Takanori provides a Japanese translation of this manpage at
11683 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11687 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)