1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $CPAN::VERSION = '1.88_69';
5 $CPAN::VERSION = eval $CPAN::VERSION;
7 use CPAN::HandleConfig;
17 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
18 # 5.005_04 does not work without
20 use File::Basename ();
28 use Sys::Hostname qw(hostname);
29 use Text::ParseWords ();
32 # we need to run chdir all over and we would get at wrong libraries
35 if (File::Spec->can("rel2abs")) {
37 $inc = File::Spec->rel2abs($inc);
43 require Mac::BuildTools if $^O eq 'MacOS';
44 $ENV{PERL5_CPAN_IS_RUNNING}=1;
46 END { $CPAN::End++; &cleanup; }
49 $CPAN::Frontend ||= "CPAN::Shell";
50 unless (@CPAN::Defaultsites){
51 @CPAN::Defaultsites = map {
52 CPAN::URL->new(TEXT => $_, FROM => "DEF")
54 "http://www.perl.org/CPAN/",
55 "ftp://ftp.perl.org/pub/CPAN/";
57 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
58 $CPAN::Perl ||= CPAN::find_perl();
59 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
60 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
62 # our globals are getting a mess
86 @CPAN::ISA = qw(CPAN::Debug Exporter);
88 # note that these functions live in CPAN::Shell and get executed via
89 # AUTOLOAD when called directly
114 sub soft_chdir_with_alternatives ($);
117 $autoload_recursion ||= 0;
119 #-> sub CPAN::AUTOLOAD ;
121 $autoload_recursion++;
125 warn "Refusing to autoload '$l' while signal pending";
126 $autoload_recursion--;
129 if ($autoload_recursion > 1) {
130 my $fullcommand = join " ", map { "'$_'" } $l, @_;
131 warn "Refusing to autoload $fullcommand in recursion\n";
132 $autoload_recursion--;
136 @export{@EXPORT} = '';
137 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
138 if (exists $export{$l}){
141 die(qq{Unknown CPAN command "$AUTOLOAD". }.
142 qq{Type ? for help.\n});
144 $autoload_recursion--;
148 #-> sub CPAN::shell ;
151 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
152 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
154 my $oprompt = shift || CPAN::Prompt->new;
155 my $prompt = $oprompt;
156 my $commandline = shift || "";
157 $CPAN::CurrentCommandId ||= 1;
160 unless ($Suppress_readline) {
161 require Term::ReadLine;
164 $term->ReadLine eq "Term::ReadLine::Stub"
166 $term = Term::ReadLine->new('CPAN Monitor');
168 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
169 my $attribs = $term->Attribs;
170 $attribs->{attempted_completion_function} = sub {
171 &CPAN::Complete::gnu_cpl;
174 $readline::rl_completion_function =
175 $readline::rl_completion_function = 'CPAN::Complete::cpl';
177 if (my $histfile = $CPAN::Config->{'histfile'}) {{
178 unless ($term->can("AddHistory")) {
179 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
182 my($fh) = FileHandle->new;
183 open $fh, "<$histfile" or last;
187 $term->AddHistory($_);
191 for ($CPAN::Config->{term_ornaments}) { # alias
192 local $Term::ReadLine::termcap_nowarn = 1;
193 $term->ornaments($_) if defined;
195 # $term->OUT is autoflushed anyway
196 my $odef = select STDERR;
204 my @cwd = grep { defined $_ and length $_ }
206 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
207 File::Spec->rootdir();
208 my $try_detect_readline;
209 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
210 my $rl_avail = $Suppress_readline ? "suppressed" :
211 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
212 "available (try 'install Bundle::CPAN')";
214 unless ($CPAN::Config->{'inhibit_startup_message'}){
215 $CPAN::Frontend->myprint(
217 cpan shell -- CPAN exploration and modules installation (v%s)
225 my($continuation) = "";
226 my $last_term_ornaments;
227 SHELLCOMMAND: while () {
228 if ($Suppress_readline) {
230 last SHELLCOMMAND unless defined ($_ = <> );
233 last SHELLCOMMAND unless
234 defined ($_ = $term->readline($prompt, $commandline));
236 $_ = "$continuation$_" if $continuation;
238 next SHELLCOMMAND if /^$/;
239 $_ = 'h' if /^\s*\?/;
240 if (/^(?:q(?:uit)?|bye|exit)$/i) {
251 use vars qw($import_done);
252 CPAN->import(':DEFAULT') unless $import_done++;
253 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
260 eval { @line = Text::ParseWords::shellwords($_) };
261 warn($@), next SHELLCOMMAND if $@;
262 warn("Text::Parsewords could not parse the line [$_]"),
263 next SHELLCOMMAND unless @line;
264 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
265 my $command = shift @line;
266 eval { CPAN::Shell->$command(@line) };
267 if ($@ && "$@" =~ /\S/){
269 Carp::cluck("Catching error: '$@'");
271 if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
272 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
274 soft_chdir_with_alternatives(\@cwd);
275 $CPAN::Frontend->myprint("\n");
277 $CPAN::CurrentCommandId++;
281 $commandline = ""; # I do want to be able to pass a default to
282 # shell, but on the second command I see no
285 CPAN::Queue->nullify_queue;
286 if ($try_detect_readline) {
287 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
289 $CPAN::META->has_inst("Term::ReadLine::Perl")
291 delete $INC{"Term/ReadLine.pm"};
293 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
294 require Term::ReadLine;
295 $CPAN::Frontend->myprint("\n$redef subroutines in ".
296 "Term::ReadLine redefined\n");
300 if ($term and $term->can("ornaments")) {
301 for ($CPAN::Config->{term_ornaments}) { # alias
303 if (not defined $last_term_ornaments
304 or $_ != $last_term_ornaments
306 local $Term::ReadLine::termcap_nowarn = 1;
307 $term->ornaments($_);
308 $last_term_ornaments = $_;
311 undef $last_term_ornaments;
315 for my $class (qw(Module Distribution)) {
316 # again unsafe meta access?
317 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
318 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
319 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
320 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
324 $GOTOSHELL = 0; # not too often
325 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
330 soft_chdir_with_alternatives(\@cwd);
333 sub soft_chdir_with_alternatives ($) {
336 my $root = File::Spec->rootdir();
337 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
338 Trying '$root' as temporary haven.
343 if (chdir $cwd->[0]) {
347 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
348 Trying to chdir to "$cwd->[1]" instead.
352 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
358 sub _yaml_module () {
359 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
361 $yaml_module ne "YAML"
363 !$CPAN::META->has_inst($yaml_module)
365 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
366 $yaml_module = "YAML";
371 # CPAN::_yaml_loadfile
373 my($self,$local_file) = @_;
374 return +[] unless -s $local_file;
375 my $yaml_module = _yaml_module;
376 if ($CPAN::META->has_inst($yaml_module)) {
377 my $code = UNIVERSAL::can($yaml_module, "LoadFile");
379 eval { @yaml = $code->($local_file); };
381 # this shall not be done by the frontend
382 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
386 # this shall not be done by the frontend
387 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
392 # CPAN::_yaml_dumpfile
394 my($self,$local_file,@what) = @_;
395 my $yaml_module = _yaml_module;
396 if ($CPAN::META->has_inst($yaml_module)) {
397 if (UNIVERSAL::isa($local_file, "FileHandle")) {
398 my $code = UNIVERSAL::can($yaml_module, "Dump");
399 eval { print $local_file $code->(@what) };
401 my $code = UNIVERSAL::can($yaml_module, "DumpFile");
402 eval { $code->($local_file,@what); };
405 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
408 if (UNIVERSAL::isa($local_file, "FileHandle")) {
409 # I think this case does not justify a warning at all
411 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
416 sub _init_sqlite () {
417 unless ($CPAN::META->has_inst("CPAN::SQLite")) {
418 $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
419 unless $Have_warned->{"CPAN::SQLite"}++;
422 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
423 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
427 my $negative_cache = {};
428 sub _sqlite_running {
429 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
430 # need to cache the result, otherwise too slow
431 return $negative_cache->{fact};
433 $negative_cache = {}; # reset
435 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
436 return $ret if $ret; # fast anyway
437 $negative_cache->{time} = time;
438 return $negative_cache->{fact} = $ret;
442 package CPAN::CacheMgr;
444 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
449 use Fcntl qw(:flock);
450 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
451 @CPAN::FTP::ISA = qw(CPAN::Debug);
453 package CPAN::LWP::UserAgent;
455 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
456 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
458 package CPAN::Complete;
460 @CPAN::Complete::ISA = qw(CPAN::Debug);
461 # Q: where is the "How do I add a new command" HOWTO?
462 # A: svn diff -r 1048:1049 where andk added the report command
463 @CPAN::Complete::COMMANDS = sort qw(
464 ! a b d h i m o q r u
492 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
493 @CPAN::Index::ISA = qw(CPAN::Debug);
496 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
499 package CPAN::InfoObj;
501 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
503 package CPAN::Author;
505 @CPAN::Author::ISA = qw(CPAN::InfoObj);
507 package CPAN::Distribution;
509 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
511 package CPAN::Bundle;
513 @CPAN::Bundle::ISA = qw(CPAN::Module);
515 package CPAN::Module;
517 @CPAN::Module::ISA = qw(CPAN::InfoObj);
519 package CPAN::Exception::RecursiveDependency;
521 use overload '""' => "as_string";
528 for my $dep (@$deps) {
530 last if $seen{$dep}++;
532 bless { deps => \@deps }, $class;
537 "\nRecursive dependency detected:\n " .
538 join("\n => ", @{$self->{deps}}) .
539 ".\nCannot continue.\n";
542 package CPAN::Exception::yaml_not_installed;
544 use overload '""' => "as_string";
547 my($class,$module,$file,$during) = @_;
548 bless { module => $module, file => $file, during => $during }, $class;
553 "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
556 package CPAN::Exception::yaml_process_error;
558 use overload '""' => "as_string";
561 my($class,$module,$file,$during,$error) = shift;
562 bless { module => $module,
565 error => $error }, $class;
570 "Alert: While trying to $self->{during} YAML file\n".
572 "with '$self->{module}' the following error was encountered:\n".
576 package CPAN::Prompt; use overload '""' => "as_string";
577 use vars qw($prompt);
579 $CPAN::CurrentCommandId ||= 0;
585 unless ($CPAN::META->{LOCK}) {
586 $word = "nolock_cpan";
588 if ($CPAN::Config->{commandnumber_in_prompt}) {
589 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
595 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
596 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
597 # planned are things like age or quality
599 my($class,%args) = @_;
611 $self->{TEXT} = $set;
616 package CPAN::Distrostatus;
617 use overload '""' => "as_string",
620 my($class,$arg) = @_;
623 FAILED => substr($arg,0,2) eq "NO",
624 COMMANDID => $CPAN::CurrentCommandId,
628 sub commandid { shift->{COMMANDID} }
629 sub failed { shift->{FAILED} }
633 $self->{TEXT} = $set;
652 @CPAN::Shell::ISA = qw(CPAN::Debug);
653 $COLOR_REGISTERED ||= 0;
656 $autoload_recursion ||= 0;
658 #-> sub CPAN::Shell::AUTOLOAD ;
660 $autoload_recursion++;
662 my $class = shift(@_);
663 # warn "autoload[$l] class[$class]";
666 warn "Refusing to autoload '$l' while signal pending";
667 $autoload_recursion--;
670 if ($autoload_recursion > 1) {
671 my $fullcommand = join " ", map { "'$_'" } $l, @_;
672 warn "Refusing to autoload $fullcommand in recursion\n";
673 $autoload_recursion--;
677 # XXX needs to be reconsidered
678 if ($CPAN::META->has_inst('CPAN::WAIT')) {
681 $CPAN::Frontend->mywarn(qq{
682 Commands starting with "w" require CPAN::WAIT to be installed.
683 Please consider installing CPAN::WAIT to use the fulltext index.
684 For this you just need to type
689 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
693 $autoload_recursion--;
700 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
702 # from here on only subs.
703 ################################################################################
705 sub _perl_fingerprint {
706 my($self,$other_fingerprint) = @_;
707 my $dll = eval {OS2::DLLname()};
710 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
712 my $this_fingerprint = {
714 sitearchexp => $Config::Config{sitearchexp},
715 'mtime_$^X' => (stat $^X)[9],
716 'mtime_dll' => $mtime_dll,
718 if ($other_fingerprint) {
719 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
720 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
722 # mandatory keys since 1.88_57
723 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
724 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
728 return $this_fingerprint;
732 sub suggest_myconfig () {
733 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
734 $CPAN::Frontend->myprint("You don't seem to have a user ".
735 "configuration (MyConfig.pm) yet.\n");
736 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
737 "user configuration now? (Y/n)",
740 CPAN::Shell->mkmyconfig();
743 $CPAN::Frontend->mydie("OK, giving up.");
748 #-> sub CPAN::all_objects ;
750 my($mgr,$class) = @_;
751 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
752 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
754 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
757 # Called by shell, not in batch mode. In batch mode I see no risk in
758 # having many processes updating something as installations are
759 # continually checked at runtime. In shell mode I suspect it is
760 # unintentional to open more than one shell at a time
762 #-> sub CPAN::checklock ;
765 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
766 if (-f $lockfile && -M _ > 0) {
767 my $fh = FileHandle->new($lockfile) or
768 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
769 my $otherpid = <$fh>;
770 my $otherhost = <$fh>;
772 if (defined $otherpid && $otherpid) {
775 if (defined $otherhost && $otherhost) {
778 my $thishost = hostname();
779 if (defined $otherhost && defined $thishost &&
780 $otherhost ne '' && $thishost ne '' &&
781 $otherhost ne $thishost) {
782 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
783 "reports other host $otherhost and other ".
784 "process $otherpid.\n".
785 "Cannot proceed.\n"));
786 } elsif ($RUN_DEGRADED) {
787 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
788 } elsif (defined $otherpid && $otherpid) {
789 return if $$ == $otherpid; # should never happen
790 $CPAN::Frontend->mywarn(
792 There seems to be running another CPAN process (pid $otherpid). Contacting...
794 if (kill 0, $otherpid) {
795 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
797 CPAN::Shell::colorable_makemaker_prompt
798 (qq{Shall I try to run in degraded }.
799 qq{mode? (Y/n)},"y");
801 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
802 Please report if something unexpected happens\n");
804 for ($CPAN::Config) {
806 # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
807 $_->{commandnumber_in_prompt} = 0; # visibility
808 $_->{histfile} = ""; # who should win otherwise?
809 $_->{cache_metadata} = 0; # better would be a lock?
810 $_->{use_sqlite} = 0; # better would be a write lock!
813 $CPAN::Frontend->mydie("
814 You may want to kill the other job and delete the lockfile. On UNIX try:
819 } elsif (-w $lockfile) {
821 CPAN::Shell::colorable_makemaker_prompt
822 (qq{Other job not responding. Shall I overwrite }.
823 qq{the lockfile '$lockfile'? (Y/n)},"y");
824 $CPAN::Frontend->myexit("Ok, bye\n")
825 unless $ans =~ /^y/i;
828 qq{Lockfile '$lockfile' not writeable by you. }.
829 qq{Cannot proceed.\n}.
831 qq{ rm '$lockfile'\n}.
832 qq{ and then rerun us.\n}
836 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
837 "'$lockfile', please remove. Cannot proceed.\n"));
840 my $dotcpan = $CPAN::Config->{cpan_home};
841 eval { File::Path::mkpath($dotcpan);};
843 # A special case at least for Jarkko.
848 $symlinkcpan = readlink $dotcpan;
849 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
850 eval { File::Path::mkpath($symlinkcpan); };
854 $CPAN::Frontend->mywarn(qq{
855 Working directory $symlinkcpan created.
859 unless (-d $dotcpan) {
861 Your configuration suggests "$dotcpan" as your
862 CPAN.pm working directory. I could not create this directory due
863 to this error: $firsterror\n};
865 As "$dotcpan" is a symlink to "$symlinkcpan",
866 I tried to create that, but I failed with this error: $seconderror
869 Please make sure the directory exists and is writable.
871 $CPAN::Frontend->myprint($mess);
872 return suggest_myconfig;
874 } # $@ after eval mkpath $dotcpan
875 if (0) { # to test what happens when a race condition occurs
876 for (reverse 1..10) {
882 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
884 unless ($fh = FileHandle->new("+>>$lockfile")) {
885 if ($! =~ /Permission/) {
886 $CPAN::Frontend->myprint(qq{
888 Your configuration suggests that CPAN.pm should use a working
890 $CPAN::Config->{cpan_home}
891 Unfortunately we could not create the lock file
893 due to permission problems.
895 Please make sure that the configuration variable
896 \$CPAN::Config->{cpan_home}
897 points to a directory where you can write a .lock file. You can set
898 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
901 return suggest_myconfig;
905 while (!flock $fh, LOCK_EX|LOCK_NB) {
907 $CPAN::Frontend->mydie("Giving up\n");
909 $CPAN::Frontend->mysleep($sleep++);
910 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
915 $fh->print($$, "\n");
916 $fh->print(hostname(), "\n");
917 $self->{LOCK} = $lockfile;
918 $self->{LOCKFH} = $fh;
923 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
929 die "Got yet another signal" if $Signal > 1;
930 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
931 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
935 # From: Larry Wall <larry@wall.org>
936 # Subject: Re: deprecating SIGDIE
937 # To: perl5-porters@perl.org
938 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
940 # The original intent of __DIE__ was only to allow you to substitute one
941 # kind of death for another on an application-wide basis without respect
942 # to whether you were in an eval or not. As a global backstop, it should
943 # not be used any more lightly (or any more heavily :-) than class
944 # UNIVERSAL. Any attempt to build a general exception model on it should
945 # be politely squashed. Any bug that causes every eval {} to have to be
946 # modified should be not so politely squashed.
948 # Those are my current opinions. It is also my optinion that polite
949 # arguments degenerate to personal arguments far too frequently, and that
950 # when they do, it's because both people wanted it to, or at least didn't
951 # sufficiently want it not to.
955 # global backstop to cleanup if we should really die
956 $SIG{__DIE__} = \&cleanup;
957 $self->debug("Signal handler set.") if $CPAN::DEBUG;
960 #-> sub CPAN::DESTROY ;
962 &cleanup; # need an eval?
965 #-> sub CPAN::anycwd ;
968 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
973 sub cwd {Cwd::cwd();}
975 #-> sub CPAN::getcwd ;
976 sub getcwd {Cwd::getcwd();}
978 #-> sub CPAN::fastcwd ;
979 sub fastcwd {Cwd::fastcwd();}
981 #-> sub CPAN::backtickcwd ;
982 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
984 #-> sub CPAN::find_perl ;
986 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
987 my $pwd = $CPAN::iCwd = CPAN::anycwd();
988 my $candidate = File::Spec->catfile($pwd,$^X);
989 $perl ||= $candidate if MM->maybe_command($candidate);
992 my ($component,$perl_name);
993 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
994 PATH_COMPONENT: foreach $component (File::Spec->path(),
995 $Config::Config{'binexp'}) {
996 next unless defined($component) && $component;
997 my($abs) = File::Spec->catfile($component,$perl_name);
998 if (MM->maybe_command($abs)) {
1010 #-> sub CPAN::exists ;
1012 my($mgr,$class,$id) = @_;
1013 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1014 CPAN::Index->reload;
1015 ### Carp::croak "exists called without class argument" unless $class;
1017 $id =~ s/:+/::/g if $class eq "CPAN::Module";
1019 if (CPAN::_sqlite_running) {
1020 $exists = (exists $META->{readonly}{$class}{$id} or
1021 $CPAN::SQLite->set($class, $id));
1023 $exists = exists $META->{readonly}{$class}{$id};
1025 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1028 #-> sub CPAN::delete ;
1030 my($mgr,$class,$id) = @_;
1031 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1032 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1035 #-> sub CPAN::has_usable
1036 # has_inst is sometimes too optimistic, we should replace it with this
1037 # has_usable whenever a case is given
1039 my($self,$mod,$message) = @_;
1040 return 1 if $HAS_USABLE->{$mod};
1041 my $has_inst = $self->has_inst($mod,$message);
1042 return unless $has_inst;
1045 LWP => [ # we frequently had "Can't locate object
1046 # method "new" via package "LWP::UserAgent" at
1047 # (eval 69) line 2006
1049 sub {require LWP::UserAgent},
1050 sub {require HTTP::Request},
1051 sub {require URI::URL},
1054 sub {require Net::FTP},
1055 sub {require Net::Config},
1057 'File::HomeDir' => [
1058 sub {require File::HomeDir;
1059 unless (File::HomeDir::->VERSION >= 0.52){
1060 for ("Will not use File::HomeDir, need 0.52\n") {
1061 $CPAN::Frontend->mywarn($_);
1068 if ($usable->{$mod}) {
1069 for my $c (0..$#{$usable->{$mod}}) {
1070 my $code = $usable->{$mod}[$c];
1071 my $ret = eval { &$code() };
1072 $ret = "" unless defined $ret;
1074 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1079 return $HAS_USABLE->{$mod} = 1;
1082 #-> sub CPAN::has_inst
1084 my($self,$mod,$message) = @_;
1085 Carp::croak("CPAN->has_inst() called without an argument")
1086 unless defined $mod;
1087 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1088 keys %{$CPAN::Config->{dontload_hash}||{}},
1089 @{$CPAN::Config->{dontload_list}||[]};
1090 if (defined $message && $message eq "no" # afair only used by Nox
1094 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1102 # checking %INC is wrong, because $INC{LWP} may be true
1103 # although $INC{"URI/URL.pm"} may have failed. But as
1104 # I really want to say "bla loaded OK", I have to somehow
1106 ### warn "$file in %INC"; #debug
1108 } elsif (eval { require $file }) {
1109 # eval is good: if we haven't yet read the database it's
1110 # perfect and if we have installed the module in the meantime,
1111 # it tries again. The second require is only a NOOP returning
1112 # 1 if we had success, otherwise it's retrying
1114 my $v = eval "\$$mod\::VERSION";
1115 $v = $v ? " (v$v)" : "";
1116 $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1117 if ($mod eq "CPAN::WAIT") {
1118 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1121 } elsif ($mod eq "Net::FTP") {
1122 $CPAN::Frontend->mywarn(qq{
1123 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1125 install Bundle::libnet
1127 }) unless $Have_warned->{"Net::FTP"}++;
1128 $CPAN::Frontend->mysleep(3);
1129 } elsif ($mod eq "Digest::SHA"){
1130 if ($Have_warned->{"Digest::SHA"}++) {
1131 $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
1132 qq{because Digest::SHA not installed.\n});
1134 $CPAN::Frontend->mywarn(qq{
1135 CPAN: checksum security checks disabled because Digest::SHA not installed.
1136 Please consider installing the Digest::SHA module.
1139 $CPAN::Frontend->mysleep(2);
1141 } elsif ($mod eq "Module::Signature"){
1142 # NOT prefs_lookup, we are not a distro
1143 my $check_sigs = $CPAN::Config->{check_sigs};
1144 if (not $check_sigs) {
1145 # they do not want us:-(
1146 } elsif (not $Have_warned->{"Module::Signature"}++) {
1147 # No point in complaining unless the user can
1148 # reasonably install and use it.
1149 if (eval { require Crypt::OpenPGP; 1 } ||
1151 defined $CPAN::Config->{'gpg'}
1153 $CPAN::Config->{'gpg'} =~ /\S/
1156 $CPAN::Frontend->mywarn(qq{
1157 CPAN: Module::Signature security checks disabled because Module::Signature
1158 not installed. Please consider installing the Module::Signature module.
1159 You may also need to be able to connect over the Internet to the public
1160 keyservers like pgp.mit.edu (port 11371).
1163 $CPAN::Frontend->mysleep(2);
1167 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1172 #-> sub CPAN::instance ;
1174 my($mgr,$class,$id) = @_;
1175 CPAN::Index->reload;
1177 # unsafe meta access, ok?
1178 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1179 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1187 #-> sub CPAN::cleanup ;
1189 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1190 local $SIG{__DIE__} = '';
1195 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1196 $ineval = 1, last if
1197 $subroutine eq '(eval)';
1199 return if $ineval && !$CPAN::End;
1200 return unless defined $META->{LOCK};
1201 return unless -f $META->{LOCK};
1203 close $META->{LOCKFH};
1204 unlink $META->{LOCK};
1206 # Carp::cluck("DEBUGGING");
1207 if ( $CPAN::CONFIG_DIRTY ) {
1208 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1210 $CPAN::Frontend->myprint("Lockfile removed.\n");
1213 #-> sub CPAN::savehist
1216 my($histfile,$histsize);
1217 unless ($histfile = $CPAN::Config->{'histfile'}){
1218 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1221 $histsize = $CPAN::Config->{'histsize'} || 100;
1223 unless ($CPAN::term->can("GetHistory")) {
1224 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1230 my @h = $CPAN::term->GetHistory;
1231 splice @h, 0, @h-$histsize if @h>$histsize;
1232 my($fh) = FileHandle->new;
1233 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1234 local $\ = local $, = "\n";
1239 #-> sub CPAN::is_tested
1241 my($self,$what,$when) = @_;
1243 Carp::cluck("DEBUG: empty what");
1246 $self->{is_tested}{$what} = $when;
1249 #-> sub CPAN::is_installed
1250 # unsets the is_tested flag: as soon as the thing is installed, it is
1251 # not needed in set_perl5lib anymore
1253 my($self,$what) = @_;
1254 delete $self->{is_tested}{$what};
1257 sub _list_sorted_descending_is_tested {
1260 { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1261 keys %{$self->{is_tested}}
1264 #-> sub CPAN::set_perl5lib
1266 my($self,$for) = @_;
1268 (undef,undef,undef,$for) = caller(1);
1271 $self->{is_tested} ||= {};
1272 return unless %{$self->{is_tested}};
1273 my $env = $ENV{PERL5LIB};
1274 $env = $ENV{PERLLIB} unless defined $env;
1276 push @env, $env if defined $env and length $env;
1277 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1278 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1280 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1282 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1283 } elsif (@dirs < 24) {
1284 my @d = map {my $cp = $_;
1285 $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1288 $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1289 "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1293 my $cnt = keys %{$self->{is_tested}};
1294 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1295 "$cnt build dirs to PERL5LIB; ".
1300 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1303 package CPAN::CacheMgr;
1306 #-> sub CPAN::CacheMgr::as_string ;
1308 eval { require Data::Dumper };
1310 return shift->SUPER::as_string;
1312 return Data::Dumper::Dumper(shift);
1316 #-> sub CPAN::CacheMgr::cachesize ;
1321 #-> sub CPAN::CacheMgr::tidyup ;
1324 return unless $CPAN::META->{LOCK};
1325 return unless -d $self->{ID};
1326 while ($self->{DU} > $self->{'MAX'} ) {
1327 my($toremove) = shift @{$self->{FIFO}};
1328 unless ($toremove =~ /\.yml$/) {
1329 $CPAN::Frontend->myprint(sprintf(
1330 "DEL: $toremove (%.1f>%.1f MB)\n",
1331 $self->{DU}, $self->{'MAX'})
1334 return if $CPAN::Signal;
1335 $self->_clean_cache($toremove);
1336 return if $CPAN::Signal;
1340 #-> sub CPAN::CacheMgr::dir ;
1345 #-> sub CPAN::CacheMgr::entries ;
1347 my($self,$dir) = @_;
1348 return unless defined $dir;
1349 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1350 $dir ||= $self->{ID};
1351 my($cwd) = CPAN::anycwd();
1352 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1353 my $dh = DirHandle->new(File::Spec->curdir)
1354 or Carp::croak("Couldn't opendir $dir: $!");
1357 next if $_ eq "." || $_ eq "..";
1359 push @entries, File::Spec->catfile($dir,$_);
1361 push @entries, File::Spec->catdir($dir,$_);
1363 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1366 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1367 sort { -M $b <=> -M $a} @entries;
1370 #-> sub CPAN::CacheMgr::disk_usage ;
1372 my($self,$dir) = @_;
1373 return if exists $self->{SIZE}{$dir};
1374 return if $CPAN::Signal;
1378 unless (chmod 0755, $dir) {
1379 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1380 "permission to change the permission; cannot ".
1381 "estimate disk usage of '$dir'\n");
1382 $CPAN::Frontend->mysleep(5);
1387 $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1392 $File::Find::prune++ if $CPAN::Signal;
1394 if ($^O eq 'MacOS') {
1396 my $cat = Mac::Files::FSpGetCatInfo($_);
1397 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1401 unless (chmod 0755, $_) {
1402 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1403 "the permission to change the permission; ".
1404 "can only partially estimate disk usage ".
1406 $CPAN::Frontend->mysleep(5);
1417 return if $CPAN::Signal;
1418 $self->{SIZE}{$dir} = $Du/1024/1024;
1419 push @{$self->{FIFO}}, $dir;
1420 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1421 $self->{DU} += $Du/1024/1024;
1425 #-> sub CPAN::CacheMgr::_clean_cache ;
1427 my($self,$dir) = @_;
1428 return unless -e $dir;
1429 unless (File::Spec->canonpath(File::Basename::dirname($dir))
1430 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1431 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1432 "will not remove\n");
1433 $CPAN::Frontend->mysleep(5);
1436 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1438 File::Path::rmtree($dir);
1439 unlink "$dir.yml"; # may fail
1440 $self->{DU} -= $self->{SIZE}{$dir};
1441 delete $self->{SIZE}{$dir};
1444 #-> sub CPAN::CacheMgr::new ;
1451 ID => $CPAN::Config->{build_dir},
1452 MAX => $CPAN::Config->{'build_cache'},
1453 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1456 File::Path::mkpath($self->{ID});
1457 my $dh = DirHandle->new($self->{ID});
1458 bless $self, $class;
1461 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1463 CPAN->debug($debug) if $CPAN::DEBUG;
1467 #-> sub CPAN::CacheMgr::scan_cache ;
1470 return if $self->{SCAN} eq 'never';
1471 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1472 unless $self->{SCAN} eq 'atstart';
1473 $CPAN::Frontend->myprint(
1474 sprintf("Scanning cache %s for sizes\n",
1477 my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
1481 # next if $e eq ".." || $e eq ".";
1482 $self->disk_usage($e);
1484 while (($painted/76) < ($i/@entries)) {
1485 $CPAN::Frontend->myprint(".");
1488 return if $CPAN::Signal;
1490 $CPAN::Frontend->myprint("DONE\n");
1494 package CPAN::Shell;
1497 #-> sub CPAN::Shell::h ;
1499 my($class,$about) = @_;
1500 if (defined $about) {
1501 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1503 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1504 $CPAN::Frontend->myprint(qq{
1505 Display Information $filler (ver $CPAN::VERSION)
1506 command argument description
1507 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1508 i WORD or /REGEXP/ about any of the above
1509 ls AUTHOR or GLOB about files in the author's directory
1510 (with WORD being a module, bundle or author name or a distribution
1511 name of the form AUTHOR/DISTRIBUTION)
1513 Download, Test, Make, Install...
1514 get download clean make clean
1515 make make (implies get) look open subshell in dist directory
1516 test make test (implies make) readme display these README files
1517 install make install (implies test) perldoc display POD documentation
1520 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1521 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1524 force CMD try hard to do command fforce CMD try harder
1525 notest CMD skip testing
1528 h,? display this menu ! perl-code eval a perl command
1529 o conf [opt] set and query options q quit the cpan shell
1530 reload cpan load CPAN.pm again reload index load newer indices
1531 autobundle Snapshot recent latest CPAN uploads});
1537 #-> sub CPAN::Shell::a ;
1539 my($self,@arg) = @_;
1540 # authors are always UPPERCASE
1542 $_ = uc $_ unless /=/;
1544 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1547 #-> sub CPAN::Shell::globls ;
1549 my($self,$s,$pragmas) = @_;
1550 # ls is really very different, but we had it once as an ordinary
1551 # command in the Shell (upto rev. 321) and we could not handle
1553 my(@accept,@preexpand);
1554 if ($s =~ /[\*\?\/]/) {
1555 if ($CPAN::META->has_inst("Text::Glob")) {
1556 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1557 my $rau = Text::Glob::glob_to_regex(uc $au);
1558 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1560 push @preexpand, map { $_->id . "/" . $pathglob }
1561 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1563 my $rau = Text::Glob::glob_to_regex(uc $s);
1564 push @preexpand, map { $_->id }
1565 CPAN::Shell->expand_by_method('CPAN::Author',
1570 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1573 push @preexpand, uc $s;
1576 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1577 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1582 my $silent = @accept>1;
1583 my $last_alpha = "";
1585 for my $a (@accept){
1586 my($author,$pathglob);
1587 if ($a =~ m|(.*?)/(.*)|) {
1590 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1593 or $CPAN::Frontend->mydie("No author found for $a2\n");
1595 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1598 or $CPAN::Frontend->mydie("No author found for $a\n");
1601 my $alpha = substr $author->id, 0, 1;
1603 if ($alpha eq $last_alpha) {
1607 $last_alpha = $alpha;
1609 $CPAN::Frontend->myprint($ad);
1611 for my $pragma (@$pragmas) {
1612 if ($author->can($pragma)) {
1616 push @results, $author->ls($pathglob,$silent); # silent if
1619 for my $pragma (@$pragmas) {
1620 my $unpragma = "un$pragma";
1621 if ($author->can($unpragma)) {
1622 $author->$unpragma();
1629 #-> sub CPAN::Shell::local_bundles ;
1631 my($self,@which) = @_;
1632 my($incdir,$bdir,$dh);
1633 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1634 my @bbase = "Bundle";
1635 while (my $bbase = shift @bbase) {
1636 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1637 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1638 if ($dh = DirHandle->new($bdir)) { # may fail
1640 for $entry ($dh->read) {
1641 next if $entry =~ /^\./;
1642 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1643 if (-d File::Spec->catdir($bdir,$entry)){
1644 push @bbase, "$bbase\::$entry";
1646 next unless $entry =~ s/\.pm(?!\n)\Z//;
1647 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1655 #-> sub CPAN::Shell::b ;
1657 my($self,@which) = @_;
1658 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1659 $self->local_bundles;
1660 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1663 #-> sub CPAN::Shell::d ;
1664 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1666 #-> sub CPAN::Shell::m ;
1667 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1669 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1672 #-> sub CPAN::Shell::i ;
1676 @args = '/./' unless @args;
1678 for my $type (qw/Bundle Distribution Module/) {
1679 push @result, $self->expand($type,@args);
1681 # Authors are always uppercase.
1682 push @result, $self->expand("Author", map { uc $_ } @args);
1684 my $result = @result == 1 ?
1685 $result[0]->as_string :
1687 "No objects found of any type for argument @args\n" :
1689 (map {$_->as_glimpse} @result),
1690 scalar @result, " items found\n",
1692 $CPAN::Frontend->myprint($result);
1695 #-> sub CPAN::Shell::o ;
1697 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1698 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1699 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1700 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1702 my($self,$o_type,@o_what) = @_;
1704 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1705 if ($o_type eq 'conf') {
1706 if (!@o_what) { # print all things, "o conf"
1708 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1710 if (exists $INC{'CPAN/Config.pm'}) {
1711 push @from, $INC{'CPAN/Config.pm'};
1713 if (exists $INC{'CPAN/MyConfig.pm'}) {
1714 push @from, $INC{'CPAN/MyConfig.pm'};
1716 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1717 $CPAN::Frontend->myprint(":\n");
1718 for $k (sort keys %CPAN::HandleConfig::can) {
1719 $v = $CPAN::HandleConfig::can{$k};
1720 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1722 $CPAN::Frontend->myprint("\n");
1723 for $k (sort keys %$CPAN::Config) {
1724 CPAN::HandleConfig->prettyprint($k);
1726 $CPAN::Frontend->myprint("\n");
1728 if (CPAN::HandleConfig->edit(@o_what)) {
1730 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1734 } elsif ($o_type eq 'debug') {
1736 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1739 my($what) = shift @o_what;
1740 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1741 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1744 if ( exists $CPAN::DEBUG{$what} ) {
1745 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1746 } elsif ($what =~ /^\d/) {
1747 $CPAN::DEBUG = $what;
1748 } elsif (lc $what eq 'all') {
1750 for (values %CPAN::DEBUG) {
1753 $CPAN::DEBUG = $max;
1756 for (keys %CPAN::DEBUG) {
1757 next unless lc($_) eq lc($what);
1758 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1761 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1766 my $raw = "Valid options for debug are ".
1767 join(", ",sort(keys %CPAN::DEBUG), 'all').
1768 qq{ or a number. Completion works on the options. }.
1769 qq{Case is ignored.};
1771 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1772 $CPAN::Frontend->myprint("\n\n");
1775 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1777 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1778 $v = $CPAN::DEBUG{$k};
1779 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1780 if $v & $CPAN::DEBUG;
1783 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1786 $CPAN::Frontend->myprint(qq{
1788 conf set or get configuration variables
1789 debug set or get debugging options
1794 # CPAN::Shell::paintdots_onreload
1795 sub paintdots_onreload {
1798 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1802 # $CPAN::Frontend->myprint(".($subr)");
1803 $CPAN::Frontend->myprint(".");
1804 if ($subr =~ /\bshell\b/i) {
1805 # warn "debug[$_[0]]";
1807 # It would be nice if we could detect that a
1808 # subroutine has actually changed, but for now we
1809 # practically always set the GOTOSHELL global
1819 #-> sub CPAN::Shell::hosts ;
1822 my $fullstats = CPAN::FTP->_ftp_statistics();
1823 my $history = $fullstats->{history} || [];
1825 while (my $last = pop @$history) {
1826 my $attempts = $last->{attempts} or next;
1829 $start = $attempts->[-1]{start};
1830 if ($#$attempts > 0) {
1831 for my $i (0..$#$attempts-1) {
1832 my $url = $attempts->[$i]{url} or next;
1837 $start = $last->{start};
1839 next unless $last->{thesiteurl}; # C-C? bad filenames?
1841 $S{end} ||= $last->{end};
1842 my $dltime = $last->{end} - $start;
1843 my $dlsize = $last->{filesize} || 0;
1844 my $url = $last->{thesiteurl}->text;
1845 my $s = $S{ok}{$url} ||= {};
1848 $s->{dlsize} += $dlsize/1024;
1850 $s->{dltime} += $dltime;
1853 for my $url (keys %{$S{ok}}) {
1854 next if $S{ok}{$url}{dltime} == 0; # div by zero
1855 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1856 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1860 for my $url (keys %{$S{no}}) {
1861 push @{$res->{no}}, [$S{no}{$url},
1865 my $R = ""; # report
1866 if ($S{start} && $S{end}) {
1867 $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
1868 $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
1870 if ($res->{ok} && @{$res->{ok}}) {
1871 $R .= sprintf "\nSuccessful downloads:
1872 N kB secs kB/s url\n";
1874 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1875 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1879 if ($res->{no} && @{$res->{no}}) {
1880 $R .= sprintf "\nUnsuccessful downloads:\n";
1882 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1883 $R .= sprintf "%4d %s\n", @$_;
1887 $CPAN::Frontend->myprint($R);
1890 #-> sub CPAN::Shell::reload ;
1892 my($self,$command,@arg) = @_;
1894 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1895 if ($command =~ /^cpan$/i) {
1897 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1902 "CPAN/FirstTime.pm",
1903 "CPAN/HandleConfig.pm",
1910 MFILE: for my $f (@relo) {
1911 next unless exists $INC{$f};
1915 $CPAN::Frontend->myprint("($p");
1916 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1917 $self->_reload_this($f) or $failed++;
1918 my $v = eval "$p\::->VERSION";
1919 $CPAN::Frontend->myprint("v$v)");
1921 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1923 my $errors = $failed == 1 ? "error" : "errors";
1924 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1927 } elsif ($command =~ /^index$/i) {
1928 CPAN::Index->force_reload;
1930 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
1931 index re-reads the index files\n});
1935 # reload means only load again what we have loaded before
1936 #-> sub CPAN::Shell::_reload_this ;
1938 my($self,$f,$args) = @_;
1939 CPAN->debug("f[$f]") if $CPAN::DEBUG;
1940 return 1 unless $INC{$f}; # we never loaded this, so we do not
1942 my $pwd = CPAN::anycwd();
1943 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1945 for my $inc (@INC) {
1946 $file = File::Spec->catfile($inc,split /\//, $f);
1950 CPAN->debug("file[$file]") if $CPAN::DEBUG;
1952 unless ($file && -f $file) {
1953 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1955 unless (CPAN->has_inst("File::Basename")) {
1956 @inc = File::Basename::dirname($file);
1958 # do we ever need this?
1959 @inc = substr($file,0,-length($f)-1); # bring in back to me!
1962 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1964 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1967 my $mtime = (stat $file)[9];
1968 $reload->{$f} ||= $^T;
1969 my $must_reload = $mtime > $reload->{$f};
1971 $must_reload ||= $args->{reloforce};
1973 my $fh = FileHandle->new($file) or
1974 $CPAN::Frontend->mydie("Could not open $file: $!");
1977 my $content = <$fh>;
1978 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1982 eval "require '$f'";
1987 $reload->{$f} = time;
1989 $CPAN::Frontend->myprint("__unchanged__");
1994 #-> sub CPAN::Shell::mkmyconfig ;
1996 my($self, $cpanpm, %args) = @_;
1997 require CPAN::FirstTime;
1998 my $home = CPAN::HandleConfig::home;
1999 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2000 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2001 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2002 CPAN::HandleConfig::require_myconfig_or_config;
2003 $CPAN::Config ||= {};
2008 keep_source_where => undef,
2011 CPAN::FirstTime::init($cpanpm, %args);
2014 #-> sub CPAN::Shell::_binary_extensions ;
2015 sub _binary_extensions {
2016 my($self) = shift @_;
2017 my(@result,$module,%seen,%need,$headerdone);
2018 for $module ($self->expand('Module','/./')) {
2019 my $file = $module->cpan_file;
2020 next if $file eq "N/A";
2021 next if $file =~ /^Contact Author/;
2022 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2023 next if $dist->isa_perl;
2024 next unless $module->xs_file;
2026 $CPAN::Frontend->myprint(".");
2027 push @result, $module;
2029 # print join " | ", @result;
2030 $CPAN::Frontend->myprint("\n");
2034 #-> sub CPAN::Shell::recompile ;
2036 my($self) = shift @_;
2037 my($module,@module,$cpan_file,%dist);
2038 @module = $self->_binary_extensions();
2039 for $module (@module){ # we force now and compile later, so we
2041 $cpan_file = $module->cpan_file;
2042 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2044 $dist{$cpan_file}++;
2046 for $cpan_file (sort keys %dist) {
2047 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
2048 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2050 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2051 # stop a package from recompiling,
2052 # e.g. IO-1.12 when we have perl5.003_10
2056 #-> sub CPAN::Shell::scripts ;
2058 my($self, $arg) = @_;
2059 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2061 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2062 unless ($CPAN::META->has_inst($req)) {
2063 $CPAN::Frontend->mywarn(" $req not available\n");
2066 my $p = HTML::LinkExtor->new();
2067 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2068 unless (-f $indexfile) {
2069 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2071 $p->parse_file($indexfile);
2074 if ($arg =~ s|^/(.+)/$|$1|) {
2075 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2077 for my $l ($p->links) {
2078 my $tag = shift @$l;
2079 next unless $tag eq "a";
2081 my $href = $att{href};
2082 next unless $href =~ s|^\.\./authors/id/./../||;
2085 if ($href =~ $qrarg) {
2089 if ($href =~ /\Q$arg\E/) {
2097 # now filter for the latest version if there is more than one of a name
2103 $stems{$stem} ||= [];
2104 push @{$stems{$stem}}, $href;
2106 for (sort keys %stems) {
2108 if (@{$stems{$_}} > 1) {
2109 $highest = List::Util::reduce {
2110 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2113 $highest = $stems{$_}[0];
2115 $CPAN::Frontend->myprint("$highest\n");
2119 #-> sub CPAN::Shell::report ;
2121 my($self,@args) = @_;
2122 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2123 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2125 local $CPAN::Config->{test_report} = 1;
2126 $self->force("test",@args); # force is there so that the test be
2127 # re-run (as documented)
2130 # experimental (compare with _is_tested)
2131 #-> sub CPAN::Shell::install_tested
2132 sub install_tested {
2133 my($self,@some) = @_;
2134 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2136 CPAN::Index->reload;
2138 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2139 my $yaml = "$b.yml";
2141 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2144 my $yaml_content = CPAN::_yaml_loadfile($yaml);
2145 my $id = $yaml_content->[0]{ID};
2147 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2150 my $do = CPAN::Shell->expandany($id);
2152 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2155 unless ($do->{build_dir}) {
2156 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2159 unless ($do->{build_dir} eq $b) {
2160 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2166 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2167 return unless @some;
2169 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2170 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2171 return unless @some;
2173 # @some = grep { not $_->uptodate } @some;
2174 # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2175 # return unless @some;
2177 CPAN->debug("some[@some]");
2179 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2180 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2181 $CPAN::Frontend->mysleep(1);
2186 #-> sub CPAN::Shell::upgrade ;
2188 my($self,@args) = @_;
2189 $self->install($self->r(@args));
2192 #-> sub CPAN::Shell::_u_r_common ;
2194 my($self) = shift @_;
2195 my($what) = shift @_;
2196 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2197 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2198 $what && $what =~ /^[aru]$/;
2200 @args = '/./' unless @args;
2201 my(@result,$module,%seen,%need,$headerdone,
2202 $version_undefs,$version_zeroes);
2203 $version_undefs = $version_zeroes = 0;
2204 my $sprintf = "%s%-25s%s %9s %9s %s\n";
2205 my @expand = $self->expand('Module',@args);
2206 my $expand = scalar @expand;
2207 if (0) { # Looks like noise to me, was very useful for debugging
2208 # for metadata cache
2209 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2211 MODULE: for $module (@expand) {
2212 my $file = $module->cpan_file;
2213 next MODULE unless defined $file; # ??
2214 $file =~ s|^./../||;
2215 my($latest) = $module->cpan_version;
2216 my($inst_file) = $module->inst_file;
2218 return if $CPAN::Signal;
2221 $have = $module->inst_version;
2222 } elsif ($what eq "r") {
2223 $have = $module->inst_version;
2225 if ($have eq "undef"){
2227 } elsif ($have == 0){
2230 next MODULE unless CPAN::Version->vgt($latest, $have);
2231 # to be pedantic we should probably say:
2232 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2233 # to catch the case where CPAN has a version 0 and we have a version undef
2234 } elsif ($what eq "u") {
2240 } elsif ($what eq "r") {
2242 } elsif ($what eq "u") {
2246 return if $CPAN::Signal; # this is sometimes lengthy
2249 push @result, sprintf "%s %s\n", $module->id, $have;
2250 } elsif ($what eq "r") {
2251 push @result, $module->id;
2252 next MODULE if $seen{$file}++;
2253 } elsif ($what eq "u") {
2254 push @result, $module->id;
2255 next MODULE if $seen{$file}++;
2256 next MODULE if $file =~ /^Contact/;
2258 unless ($headerdone++){
2259 $CPAN::Frontend->myprint("\n");
2260 $CPAN::Frontend->myprint(sprintf(
2263 "Package namespace",
2275 $CPAN::META->has_inst("Term::ANSIColor")
2277 $module->description
2279 $color_on = Term::ANSIColor::color("green");
2280 $color_off = Term::ANSIColor::color("reset");
2282 $CPAN::Frontend->myprint(sprintf $sprintf,
2289 $need{$module->id}++;
2293 $CPAN::Frontend->myprint("No modules found for @args\n");
2294 } elsif ($what eq "r") {
2295 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2299 if ($version_zeroes) {
2300 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2301 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2302 qq{a version number of 0\n});
2304 if ($version_undefs) {
2305 my $s_has = $version_undefs > 1 ? "s have" : " has";
2306 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2307 qq{parseable version number\n});
2313 #-> sub CPAN::Shell::r ;
2315 shift->_u_r_common("r",@_);
2318 #-> sub CPAN::Shell::u ;
2320 shift->_u_r_common("u",@_);
2323 #-> sub CPAN::Shell::failed ;
2325 my($self,$only_id,$silent) = @_;
2327 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2329 NAY: for my $nosayer ( # order matters!
2338 next unless exists $d->{$nosayer};
2339 next unless defined $d->{$nosayer};
2341 UNIVERSAL::can($d->{$nosayer},"failed") ?
2342 $d->{$nosayer}->failed :
2343 $d->{$nosayer} =~ /^NO/
2345 next NAY if $only_id && $only_id != (
2346 UNIVERSAL::can($d->{$nosayer},"commandid")
2348 $d->{$nosayer}->commandid
2350 $CPAN::CurrentCommandId
2355 next DIST unless $failed;
2359 # " %-45s: %s %s\n",
2362 UNIVERSAL::can($d->{$failed},"failed") ?
2364 $d->{$failed}->commandid,
2367 $d->{$failed}->text,
2368 $d->{$failed}{TIME}||0,
2381 $scope = "this command";
2382 } elsif ($CPAN::Index::HAVE_REANIMATED) {
2383 $scope = "this or a previous session";
2384 # it might be nice to have a section for previous session and
2387 $scope = "this session";
2394 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2395 sort { $a->[0] <=> $b->[0] } @failed;
2398 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2405 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2406 } elsif (!$only_id || !$silent) {
2407 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2411 # XXX intentionally undocumented because completely bogus, unportable,
2414 #-> sub CPAN::Shell::status ;
2417 require Devel::Size;
2418 my $ps = FileHandle->new;
2419 open $ps, "/proc/$$/status";
2422 next unless /VmSize:\s+(\d+)/;
2426 $CPAN::Frontend->mywarn(sprintf(
2427 "%-27s %6d\n%-27s %6d\n",
2431 Devel::Size::total_size($CPAN::META)/1024,
2433 for my $k (sort keys %$CPAN::META) {
2434 next unless substr($k,0,4) eq "read";
2435 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2436 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2437 warn sprintf " %-25s %6d (keys: %6d)\n",
2439 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2440 scalar keys %{$CPAN::META->{$k}{$k2}};
2445 # experimental (must run after failed or similar [I think])
2446 # intended as a preparation ot install_tested
2447 #-> sub CPAN::Shell::is_tested
2450 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2452 if ($CPAN::META->{is_tested}{$b}) {
2453 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2455 $time = scalar localtime;
2458 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2462 #-> sub CPAN::Shell::autobundle ;
2465 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2466 my(@bundle) = $self->_u_r_common("a",@_);
2467 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2468 File::Path::mkpath($todir);
2469 unless (-d $todir) {
2470 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2473 my($y,$m,$d) = (localtime)[5,4,3];
2477 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2478 my($to) = File::Spec->catfile($todir,"$me.pm");
2480 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2481 $to = File::Spec->catfile($todir,"$me.pm");
2483 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2485 "package Bundle::$me;\n\n",
2486 "\$VERSION = '0.01';\n\n",
2490 "Bundle::$me - Snapshot of installation on ",
2491 $Config::Config{'myhostname'},
2494 "\n\n=head1 SYNOPSIS\n\n",
2495 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2496 "=head1 CONTENTS\n\n",
2497 join("\n", @bundle),
2498 "\n\n=head1 CONFIGURATION\n\n",
2500 "\n\n=head1 AUTHOR\n\n",
2501 "This Bundle has been generated automatically ",
2502 "by the autobundle routine in CPAN.pm.\n",
2505 $CPAN::Frontend->myprint("\nWrote bundle file
2509 #-> sub CPAN::Shell::expandany ;
2512 CPAN->debug("s[$s]") if $CPAN::DEBUG;
2513 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2514 $s = CPAN::Distribution->normalize($s);
2515 return $CPAN::META->instance('CPAN::Distribution',$s);
2516 # Distributions spring into existence, not expand
2517 } elsif ($s =~ m|^Bundle::|) {
2518 $self->local_bundles; # scanning so late for bundles seems
2519 # both attractive and crumpy: always
2520 # current state but easy to forget
2522 return $self->expand('Bundle',$s);
2524 return $self->expand('Module',$s)
2525 if $CPAN::META->exists('CPAN::Module',$s);
2530 #-> sub CPAN::Shell::expand ;
2533 my($type,@args) = @_;
2534 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2535 my $class = "CPAN::$type";
2536 my $methods = ['id'];
2537 for my $meth (qw(name)) {
2538 next unless $class->can($meth);
2539 push @$methods, $meth;
2541 $self->expand_by_method($class,$methods,@args);
2544 #-> sub CPAN::Shell::expand_by_method ;
2545 sub expand_by_method {
2547 my($class,$methods,@args) = @_;
2550 my($regex,$command);
2551 if ($arg =~ m|^/(.*)/$|) {
2553 } elsif ($arg =~ m/=/) {
2557 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2559 defined $regex ? $regex : "UNDEFINED",
2560 defined $command ? $command : "UNDEFINED",
2562 if (defined $regex) {
2563 if (CPAN::_sqlite_running) {
2564 $CPAN::SQLite->search($class, $regex);
2567 $CPAN::META->all_objects($class)
2569 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2570 # BUG, we got an empty object somewhere
2571 require Data::Dumper;
2572 CPAN->debug(sprintf(
2573 "Bug in CPAN: Empty id on obj[%s][%s]",
2575 Data::Dumper::Dumper($obj)
2579 for my $method (@$methods) {
2580 my $match = eval {$obj->$method() =~ /$regex/i};
2582 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2583 $err ||= $@; # if we were too restrictive above
2584 $CPAN::Frontend->mydie("$err\n");
2591 } elsif ($command) {
2592 die "equal sign in command disabled (immature interface), ".
2594 ! \$CPAN::Shell::ADVANCED_QUERY=1
2595 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2596 that may go away anytime.\n"
2597 unless $ADVANCED_QUERY;
2598 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2599 my($matchcrit) = $criterion =~ m/^~(.+)/;
2603 $CPAN::META->all_objects($class)
2605 my $lhs = $self->$method() or next; # () for 5.00503
2607 push @m, $self if $lhs =~ m/$matchcrit/;
2609 push @m, $self if $lhs eq $criterion;
2614 if ( $class eq 'CPAN::Bundle' ) {
2615 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2616 } elsif ($class eq "CPAN::Distribution") {
2617 $xarg = CPAN::Distribution->normalize($arg);
2621 if ($CPAN::META->exists($class,$xarg)) {
2622 $obj = $CPAN::META->instance($class,$xarg);
2623 } elsif ($CPAN::META->exists($class,$arg)) {
2624 $obj = $CPAN::META->instance($class,$arg);
2631 @m = sort {$a->id cmp $b->id} @m;
2632 if ( $CPAN::DEBUG ) {
2633 my $wantarray = wantarray;
2634 my $join_m = join ",", map {$_->id} @m;
2635 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2637 return wantarray ? @m : $m[0];
2640 #-> sub CPAN::Shell::format_result ;
2643 my($type,@args) = @_;
2644 @args = '/./' unless @args;
2645 my(@result) = $self->expand($type,@args);
2646 my $result = @result == 1 ?
2647 $result[0]->as_string :
2649 "No objects of type $type found for argument @args\n" :
2651 (map {$_->as_glimpse} @result),
2652 scalar @result, " items found\n",
2657 #-> sub CPAN::Shell::report_fh ;
2659 my $installation_report_fh;
2660 my $previously_noticed = 0;
2663 return $installation_report_fh if $installation_report_fh;
2664 if ($CPAN::META->has_inst("File::Temp")) {
2665 $installation_report_fh
2667 template => 'cpan_install_XXXX',
2672 unless ( $installation_report_fh ) {
2673 warn("Couldn't open installation report file; " .
2674 "no report file will be generated."
2675 ) unless $previously_noticed++;
2681 # The only reason for this method is currently to have a reliable
2682 # debugging utility that reveals which output is going through which
2683 # channel. No, I don't like the colors ;-)
2685 # to turn colordebugging on, write
2686 # cpan> o conf colorize_output 1
2688 #-> sub CPAN::Shell::print_ornamented ;
2690 my $print_ornamented_have_warned = 0;
2691 sub colorize_output {
2692 my $colorize_output = $CPAN::Config->{colorize_output};
2693 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2694 unless ($print_ornamented_have_warned++) {
2695 # no myprint/mywarn within myprint/mywarn!
2696 warn "Colorize_output is set to true but Term::ANSIColor is not
2697 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2699 $colorize_output = 0;
2701 return $colorize_output;
2706 #-> sub CPAN::Shell::print_ornamented ;
2707 sub print_ornamented {
2708 my($self,$what,$ornament) = @_;
2709 return unless defined $what;
2711 local $| = 1; # Flush immediately
2712 if ( $CPAN::Be_Silent ) {
2713 print {report_fh()} $what;
2716 my $swhat = "$what"; # stringify if it is an object
2717 if ($CPAN::Config->{term_is_latin}){
2720 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2722 if ($self->colorize_output) {
2723 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2724 # if you want to have this configurable, please file a bugreport
2725 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2727 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2729 print "Term::ANSIColor rejects color[$ornament]: $@\n
2730 Please choose a different color (Hint: try 'o conf init color.*')\n";
2734 Term::ANSIColor::color("reset");
2740 #-> sub CPAN::Shell::myprint ;
2742 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2743 # where to use what! I think, we send everything to STDOUT and use
2744 # print for normal/good news and warn for news that need more
2745 # attention. Yes, this is our working contract for now.
2747 my($self,$what) = @_;
2749 $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2752 #-> sub CPAN::Shell::myexit ;
2754 my($self,$what) = @_;
2755 $self->myprint($what);
2759 #-> sub CPAN::Shell::mywarn ;
2761 my($self,$what) = @_;
2762 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2765 # only to be used for shell commands
2766 #-> sub CPAN::Shell::mydie ;
2768 my($self,$what) = @_;
2769 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2771 # If it is the shell, we want that the following die to be silent,
2772 # but if it is not the shell, we would need a 'die $what'. We need
2773 # to take care that only shell commands use mydie. Is this
2779 # sub CPAN::Shell::colorable_makemaker_prompt ;
2780 sub colorable_makemaker_prompt {
2782 if (CPAN::Shell->colorize_output) {
2783 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2784 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2787 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2788 if (CPAN::Shell->colorize_output) {
2789 print Term::ANSIColor::color('reset');
2794 # use this only for unrecoverable errors!
2795 #-> sub CPAN::Shell::unrecoverable_error ;
2796 sub unrecoverable_error {
2797 my($self,$what) = @_;
2798 my @lines = split /\n/, $what;
2800 for my $l (@lines) {
2801 $longest = length $l if length $l > $longest;
2803 $longest = 62 if $longest > 62;
2804 for my $l (@lines) {
2810 if (length $l < 66) {
2811 $l = pack "A66 A*", $l, "<==";
2815 unshift @lines, "\n";
2816 $self->mydie(join "", @lines);
2819 #-> sub CPAN::Shell::mysleep ;
2821 my($self, $sleep) = @_;
2825 #-> sub CPAN::Shell::setup_output ;
2827 return if -t STDOUT;
2828 my $odef = select STDERR;
2835 #-> sub CPAN::Shell::rematein ;
2836 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
2839 my($meth,@some) = @_;
2841 while($meth =~ /^(ff?orce|notest)$/) {
2842 push @pragma, $meth;
2843 $meth = shift @some or
2844 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2848 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2850 # Here is the place to set "test_count" on all involved parties to
2851 # 0. We then can pass this counter on to the involved
2852 # distributions and those can refuse to test if test_count > X. In
2853 # the first stab at it we could use a 1 for "X".
2855 # But when do I reset the distributions to start with 0 again?
2856 # Jost suggested to have a random or cycling interaction ID that
2857 # we pass through. But the ID is something that is just left lying
2858 # around in addition to the counter, so I'd prefer to set the
2859 # counter to 0 now, and repeat at the end of the loop. But what
2860 # about dependencies? They appear later and are not reset, they
2861 # enter the queue but not its copy. How do they get a sensible
2864 # construct the queue
2866 STHING: foreach $s (@some) {
2869 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2871 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2872 } elsif ($s =~ m|^/|) { # looks like a regexp
2873 if (substr($s,-1,1) eq ".") {
2874 $obj = CPAN::Shell->expandany($s);
2876 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2877 "not supported.\nRejecting argument '$s'\n");
2878 $CPAN::Frontend->mysleep(2);
2881 } elsif ($meth eq "ls") {
2882 $self->globls($s,\@pragma);
2885 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2886 $obj = CPAN::Shell->expandany($s);
2889 } elsif (ref $obj) {
2890 $obj->color_cmd_tmps(0,1);
2891 CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2893 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2894 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2895 if ($meth =~ /^(dump|ls)$/) {
2898 $CPAN::Frontend->mywarn(
2900 "Don't be silly, you can't $meth ",
2904 $CPAN::Frontend->mysleep(2);
2906 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2907 CPAN::InfoObj->dump($s);
2910 ->mywarn(qq{Warning: Cannot $meth $s, }.
2911 qq{don't know what it is.
2916 to find objects with matching identifiers.
2918 $CPAN::Frontend->mysleep(2);
2922 # queuerunner (please be warned: when I started to change the
2923 # queue to hold objects instead of names, I made one or two
2924 # mistakes and never found which. I reverted back instead)
2925 while (my $q = CPAN::Queue->first) {
2927 my $s = $q->as_string;
2928 my $reqtype = $q->reqtype || "";
2929 $obj = CPAN::Shell->expandany($s);
2930 $obj->{reqtype} ||= "";
2932 # force debugging because CPAN::SQLite somehow delivers us
2935 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
2937 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
2938 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2940 if ($obj->{reqtype}) {
2941 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2942 $obj->{reqtype} = $reqtype;
2944 exists $obj->{install}
2947 UNIVERSAL::can($obj->{install},"failed") ?
2948 $obj->{install}->failed :
2949 $obj->{install} =~ /^NO/
2952 delete $obj->{install};
2953 $CPAN::Frontend->mywarn
2954 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2958 $obj->{reqtype} = $reqtype;
2961 for my $pragma (@pragma) {
2964 $obj->can($pragma)){
2965 $obj->$pragma($meth);
2968 if (UNIVERSAL::can($obj, 'called_for')) {
2969 $obj->called_for($s);
2971 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2972 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2975 if (! UNIVERSAL::can($obj,$meth)) {
2977 my $serialized = "";
2979 } elsif ($CPAN::META->has_inst("YAML::Syck")) {
2980 $serialized = YAML::Syck::Dump($obj);
2981 } elsif ($CPAN::META->has_inst("YAML")) {
2982 $serialized = YAML::Dump($obj);
2983 } elsif ($CPAN::META->has_inst("Data::Dumper")) {
2984 $serialized = Data::Dumper::Dumper($obj);
2987 $serialized = overload::StrVal($obj);
2989 $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
2990 } elsif ($obj->$meth()){
2991 CPAN::Queue->delete($s);
2993 CPAN->debug("failed");
2997 for my $pragma (@pragma) {
2998 my $unpragma = "un$pragma";
2999 if ($obj->can($unpragma)) {
3003 CPAN::Queue->delete_first($s);
3005 for my $obj (@qcopy) {
3006 $obj->color_cmd_tmps(0,0);
3010 #-> sub CPAN::Shell::recent ;
3014 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3019 # set up the dispatching methods
3021 for my $command (qw(
3037 *$command = sub { shift->rematein($command, @_); };
3041 package CPAN::LWP::UserAgent;
3045 return if $SETUPDONE;
3046 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3047 require LWP::UserAgent;
3048 @ISA = qw(Exporter LWP::UserAgent);
3051 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
3055 sub get_basic_credentials {
3056 my($self, $realm, $uri, $proxy) = @_;
3057 if ($USER && $PASSWD) {
3058 return ($USER, $PASSWD);
3061 ($USER,$PASSWD) = $self->get_proxy_credentials();
3063 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3065 return($USER,$PASSWD);
3068 sub get_proxy_credentials {
3070 my ($user, $password);
3071 if ( defined $CPAN::Config->{proxy_user} &&
3072 defined $CPAN::Config->{proxy_pass}) {
3073 $user = $CPAN::Config->{proxy_user};
3074 $password = $CPAN::Config->{proxy_pass};
3075 return ($user, $password);
3077 my $username_prompt = "\nProxy authentication needed!
3078 (Note: to permanently configure username and password run
3079 o conf proxy_user your_username
3080 o conf proxy_pass your_password
3082 ($user, $password) =
3083 _get_username_and_password_from_user($username_prompt);
3084 return ($user,$password);
3087 sub get_non_proxy_credentials {
3089 my ($user,$password);
3090 if ( defined $CPAN::Config->{username} &&
3091 defined $CPAN::Config->{password}) {
3092 $user = $CPAN::Config->{username};
3093 $password = $CPAN::Config->{password};
3094 return ($user, $password);
3096 my $username_prompt = "\nAuthentication needed!
3097 (Note: to permanently configure username and password run
3098 o conf username your_username
3099 o conf password your_password
3102 ($user, $password) =
3103 _get_username_and_password_from_user($username_prompt);
3104 return ($user,$password);
3107 sub _get_username_and_password_from_user {
3108 my $username_message = shift;
3109 my ($username,$password);
3111 ExtUtils::MakeMaker->import(qw(prompt));
3112 $username = prompt($username_message);
3113 if ($CPAN::META->has_inst("Term::ReadKey")) {
3114 Term::ReadKey::ReadMode("noecho");
3117 $CPAN::Frontend->mywarn(
3118 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3121 $password = prompt("Password:");
3123 if ($CPAN::META->has_inst("Term::ReadKey")) {
3124 Term::ReadKey::ReadMode("restore");
3126 $CPAN::Frontend->myprint("\n\n");
3127 return ($username,$password);
3130 # mirror(): Its purpose is to deal with proxy authentication. When we
3131 # call SUPER::mirror, we relly call the mirror method in
3132 # LWP::UserAgent. LWP::UserAgent will then call
3133 # $self->get_basic_credentials or some equivalent and this will be
3134 # $self->dispatched to our own get_basic_credentials method.
3136 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3138 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3139 # although we have gone through our get_basic_credentials, the proxy
3140 # server refuses to connect. This could be a case where the username or
3141 # password has changed in the meantime, so I'm trying once again without
3142 # $USER and $PASSWD to give the get_basic_credentials routine another
3143 # chance to set $USER and $PASSWD.
3145 # mirror(): Its purpose is to deal with proxy authentication. When we
3146 # call SUPER::mirror, we relly call the mirror method in
3147 # LWP::UserAgent. LWP::UserAgent will then call
3148 # $self->get_basic_credentials or some equivalent and this will be
3149 # $self->dispatched to our own get_basic_credentials method.
3151 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3153 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3154 # although we have gone through our get_basic_credentials, the proxy
3155 # server refuses to connect. This could be a case where the username or
3156 # password has changed in the meantime, so I'm trying once again without
3157 # $USER and $PASSWD to give the get_basic_credentials routine another
3158 # chance to set $USER and $PASSWD.
3161 my($self,$url,$aslocal) = @_;
3162 my $result = $self->SUPER::mirror($url,$aslocal);
3163 if ($result->code == 407) {
3166 $result = $self->SUPER::mirror($url,$aslocal);
3174 #-> sub CPAN::FTP::ftp_statistics
3175 # if they want to rewrite, they need to pass in a filehandle
3176 sub _ftp_statistics {
3178 my $locktype = $fh ? LOCK_EX : LOCK_SH;
3179 $fh ||= FileHandle->new;
3180 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3181 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3184 while (!flock $fh, $locktype|LOCK_NB) {
3185 $waitstart ||= localtime();
3187 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3189 $CPAN::Frontend->mysleep($sleep);
3192 } elsif ($sleep <=6) {
3196 my $stats = eval { CPAN->_yaml_loadfile($file); };
3199 if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3200 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3202 } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3203 $CPAN::Frontend->mydie($@);
3206 $CPAN::Frontend->mydie($@);
3212 #-> sub CPAN::FTP::_mytime
3214 if (CPAN->has_inst("Time::HiRes")) {
3215 return Time::HiRes::time();
3221 #-> sub CPAN::FTP::_new_stats
3223 my($self,$file) = @_;
3232 #-> sub CPAN::FTP::_add_to_statistics
3233 sub _add_to_statistics {
3234 my($self,$stats) = @_;
3235 my $yaml_module = CPAN::_yaml_module;
3236 if ($CPAN::META->has_inst($yaml_module)) {
3237 $stats->{thesiteurl} = $ThesiteURL;
3238 if (CPAN->has_inst("Time::HiRes")) {
3239 $stats->{end} = Time::HiRes::time();
3241 $stats->{end} = time;
3243 my $fh = FileHandle->new;
3247 @debug = $time if $sdebug;
3248 my $fullstats = $self->_ftp_statistics($fh);
3250 $fullstats->{history} ||= [];
3251 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3252 push @debug, time if $sdebug;
3253 push @{$fullstats->{history}}, $stats;
3254 # arbitrary hardcoded constants until somebody demands to have
3257 @{$fullstats->{history}} > 9999
3258 || $time - $fullstats->{history}[0]{start} > 30*86400 # one month
3260 shift @{$fullstats->{history}}
3262 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3263 push @debug, time if $sdebug;
3264 push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3265 # need no eval because if this fails, it is serious
3266 my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3267 CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3268 if ( $sdebug||$CPAN::DEBUG ) {
3269 local $CPAN::DEBUG = 512; # FTP
3271 CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3272 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3276 # Win32 cannot rename a file to an existing filename
3277 unlink($sfile) if ($^O eq 'MSWin32');
3278 rename "$sfile.$$", $sfile
3279 or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3283 # if file is CHECKSUMS, suggest the place where we got the file to be
3284 # checked from, maybe only for young files?
3285 #-> sub CPAN::FTP::_recommend_url_for
3286 sub _recommend_url_for {
3287 my($self, $file) = @_;
3288 my $urllist = $self->_get_urllist;
3289 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3290 my $fullstats = $self->_ftp_statistics();
3291 my $history = $fullstats->{history} || [];
3292 while (my $last = pop @$history) {
3293 last if $last->{end} - time > 3600; # only young results are interesting
3294 next unless $last->{file}; # dirname of nothing dies!
3295 next unless $file eq File::Basename::dirname($last->{file});
3296 return $last->{thesiteurl};
3299 if ($CPAN::Config->{randomize_urllist}
3301 rand(1) < $CPAN::Config->{randomize_urllist}
3303 $urllist->[int rand scalar @$urllist];
3309 #-> sub CPAN::FTP::_get_urllist
3312 $CPAN::Config->{urllist} ||= [];
3313 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3314 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
3315 $CPAN::Config->{urllist} = [];
3317 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3318 for my $u (@urllist) {
3319 CPAN->debug("u[$u]") if $CPAN::DEBUG;
3320 if (UNIVERSAL::can($u,"text")) {
3321 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3323 $u .= "/" unless substr($u,-1) eq "/";
3324 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3330 #-> sub CPAN::FTP::ftp_get ;
3332 my($class,$host,$dir,$file,$target) = @_;
3334 qq[Going to fetch file [$file] from dir [$dir]
3335 on host [$host] as local [$target]\n]
3337 my $ftp = Net::FTP->new($host);
3339 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
3342 return 0 unless defined $ftp;
3343 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3344 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3345 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3346 my $msg = $ftp->message;
3347 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
3350 unless ( $ftp->cwd($dir) ){
3351 my $msg = $ftp->message;
3352 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
3356 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3357 unless ( $ftp->get($file,$target) ){
3358 my $msg = $ftp->message;
3359 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
3362 $ftp->quit; # it's ok if this fails
3366 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3368 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
3369 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
3371 # > *** 1562,1567 ****
3372 # > --- 1562,1580 ----
3373 # > return 1 if substr($url,0,4) eq "file";
3374 # > return 1 unless $url =~ m|://([^/]+)|;
3376 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3378 # > + $proxy =~ m|://([^/:]+)|;
3380 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3381 # > + if ($noproxy) {
3382 # > + if ($host !~ /$noproxy$/) {
3383 # > + $host = $proxy;
3386 # > + $host = $proxy;
3389 # > require Net::Ping;
3390 # > return 1 unless $Net::Ping::VERSION >= 2;
3394 #-> sub CPAN::FTP::localize ;
3396 my($self,$file,$aslocal,$force) = @_;
3398 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3399 unless defined $aslocal;
3400 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3403 if ($^O eq 'MacOS') {
3404 # Comment by AK on 2000-09-03: Uniq short filenames would be
3405 # available in CHECKSUMS file
3406 my($name, $path) = File::Basename::fileparse($aslocal, '');
3407 if (length($name) > 31) {
3418 my $size = 31 - length($suf);
3419 while (length($name) > $size) {
3423 $aslocal = File::Spec->catfile($path, $name);
3427 if (-f $aslocal && -r _ && !($force & 1)){
3429 if ($size = -s $aslocal) {
3430 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3433 # empty file from a previous unsuccessful attempt to download it
3435 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3436 "could not remove.");
3439 my($maybe_restore) = 0;
3441 rename $aslocal, "$aslocal.bak$$";
3445 my($aslocal_dir) = File::Basename::dirname($aslocal);
3446 File::Path::mkpath($aslocal_dir);
3447 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3448 qq{directory "$aslocal_dir".
3449 I\'ll continue, but if you encounter problems, they may be due
3450 to insufficient permissions.\n}) unless -w $aslocal_dir;
3452 # Inheritance is not easier to manage than a few if/else branches
3453 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3455 CPAN::LWP::UserAgent->config;
3456 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3458 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3462 $Ua->proxy('ftp', $var)
3463 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3464 $Ua->proxy('http', $var)
3465 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3468 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3470 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3471 # > use ones that require basic autorization.
3473 # > Example of when I use it manually in my own stuff:
3475 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3476 # > $req->proxy_authorization_basic("username","password");
3477 # > $res = $ua->request($req);
3481 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3485 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3486 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3489 # Try the list of urls for each single object. We keep a record
3490 # where we did get a file from
3491 my(@reordered,$last);
3492 my $ccurllist = $self->_get_urllist;
3493 $last = $#$ccurllist;
3494 if ($force & 2) { # local cpans probably out of date, don't reorder
3495 @reordered = (0..$last);
3499 (substr($ccurllist->[$b],0,4) eq "file")
3501 (substr($ccurllist->[$a],0,4) eq "file")
3503 defined($ThesiteURL)
3505 ($ccurllist->[$b] eq $ThesiteURL)
3507 ($ccurllist->[$a] eq $ThesiteURL)
3512 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3514 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3516 @levels = qw/easy hard hardest/;
3518 @levels = qw/easy/ if $^O eq 'MacOS';
3520 local $ENV{FTP_PASSIVE} =
3521 exists $CPAN::Config->{ftp_passive} ?
3522 $CPAN::Config->{ftp_passive} : 1;
3524 my $stats = $self->_new_stats($file);
3525 LEVEL: for $levelno (0..$#levels) {
3526 my $level = $levels[$levelno];
3527 my $method = "host$level";
3528 my @host_seq = $level eq "easy" ?
3529 @reordered : 0..$last; # reordered has CDROM up front
3530 my @urllist = map { $ccurllist->[$_] } @host_seq;
3531 for my $u (@CPAN::Defaultsites) {
3532 push @urllist, $u unless grep { $_ eq $u } @urllist;
3534 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3535 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3536 if (my $recommend = $self->_recommend_url_for($file)) {
3537 @urllist = grep { $_ ne $recommend } @urllist;
3538 unshift @urllist, $recommend;
3540 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3541 $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3543 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3544 if ($ret eq $aslocal_tempfile) {
3545 # if we got it exactly as we asked for, only then we
3547 rename $aslocal_tempfile, $aslocal
3548 or $CPAN::Frontend->mydie("Error while trying to rename ".
3549 "'$ret' to '$aslocal': $!");
3552 $Themethod = $level;
3554 # utime $now, $now, $aslocal; # too bad, if we do that, we
3555 # might alter a local mirror
3556 $self->debug("level[$level]") if $CPAN::DEBUG;
3559 unlink $aslocal_tempfile;
3560 last if $CPAN::Signal; # need to cleanup
3564 $stats->{filesize} = -s $ret;
3566 $self->_add_to_statistics($stats);
3568 unlink "$aslocal.bak$$";
3571 unless ($CPAN::Signal) {
3574 if (@{$CPAN::Config->{urllist}}) {
3576 qq{Please check, if the URLs I found in your configuration file \(}.
3577 join(", ", @{$CPAN::Config->{urllist}}).
3580 push @mess, qq{Your urllist is empty!};
3582 push @mess, qq{The urllist can be edited.},
3583 qq{E.g. with 'o conf urllist push ftp://myurl/'};
3584 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3585 $CPAN::Frontend->mywarn("Could not fetch $file\n");
3586 $CPAN::Frontend->mysleep(2);
3588 if ($maybe_restore) {
3589 rename "$aslocal.bak$$", $aslocal;
3590 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3591 $self->ls($aslocal));
3598 my($self,$stats,$method,$url) = @_;
3599 push @{$stats->{attempts}}, {
3606 # package CPAN::FTP;
3608 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3610 HOSTEASY: for $ro_url (@$host_seq) {
3611 $self->_set_attempt($stats,"easy",$ro_url);
3612 my $url .= "$ro_url$file";
3613 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3614 if ($url =~ /^file:/) {
3616 if ($CPAN::META->has_inst('URI::URL')) {
3617 my $u = URI::URL->new($url);
3619 } else { # works only on Unix, is poorly constructed, but
3620 # hopefully better than nothing.
3621 # RFC 1738 says fileurl BNF is
3622 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3623 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3625 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3626 $l =~ s|^file:||; # assume they
3630 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
3632 $self->debug("local file[$l]") if $CPAN::DEBUG;
3633 if ( -f $l && -r _) {
3634 $ThesiteURL = $ro_url;
3637 if ($l =~ /(.+)\.gz$/) {
3639 if ( -f $ungz && -r _) {
3640 $ThesiteURL = $ro_url;
3644 # Maybe mirror has compressed it?
3646 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3647 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3649 $ThesiteURL = $ro_url;
3654 $self->debug("it was not a file URL") if $CPAN::DEBUG;
3655 if ($CPAN::META->has_usable('LWP')) {
3656 $CPAN::Frontend->myprint("Fetching with LWP:
3660 CPAN::LWP::UserAgent->config;
3661 eval { $Ua = CPAN::LWP::UserAgent->new; };
3663 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3666 my $res = $Ua->mirror($url, $aslocal);
3667 if ($res->is_success) {
3668 $ThesiteURL = $ro_url;
3670 utime $now, $now, $aslocal; # download time is more
3671 # important than upload
3674 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3675 my $gzurl = "$url.gz";
3676 $CPAN::Frontend->myprint("Fetching with LWP:
3679 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3680 if ($res->is_success) {
3681 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3682 $ThesiteURL = $ro_url;
3687 $CPAN::Frontend->myprint(sprintf(
3688 "LWP failed with code[%s] message[%s]\n",
3692 # Alan Burlison informed me that in firewall environments
3693 # Net::FTP can still succeed where LWP fails. So we do not
3694 # skip Net::FTP anymore when LWP is available.
3697 $CPAN::Frontend->mywarn(" LWP not available\n");
3699 return if $CPAN::Signal;
3700 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3701 # that's the nice and easy way thanks to Graham
3702 $self->debug("recognized ftp") if $CPAN::DEBUG;
3703 my($host,$dir,$getfile) = ($1,$2,$3);
3704 if ($CPAN::META->has_usable('Net::FTP')) {
3706 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3709 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3710 "aslocal[$aslocal]") if $CPAN::DEBUG;
3711 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3712 $ThesiteURL = $ro_url;
3715 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3716 my $gz = "$aslocal.gz";
3717 $CPAN::Frontend->myprint("Fetching with Net::FTP
3720 if (CPAN::FTP->ftp_get($host,
3724 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3726 $ThesiteURL = $ro_url;
3732 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3736 UNIVERSAL::can($ro_url,"text")
3738 $ro_url->{FROM} eq "USER"
3740 ##address #17973: default URLs should not try to override
3741 ##user-defined URLs just because LWP is not available
3742 my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3743 return $ret if $ret;
3745 return if $CPAN::Signal;
3749 # package CPAN::FTP;
3751 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3753 # Came back if Net::FTP couldn't establish connection (or
3754 # failed otherwise) Maybe they are behind a firewall, but they
3755 # gave us a socksified (or other) ftp program...
3758 my($devnull) = $CPAN::Config->{devnull} || "";
3760 my($aslocal_dir) = File::Basename::dirname($aslocal);
3761 File::Path::mkpath($aslocal_dir);
3762 HOSTHARD: for $ro_url (@$host_seq) {
3763 $self->_set_attempt($stats,"hard",$ro_url);
3764 my $url = "$ro_url$file";
3765 my($proto,$host,$dir,$getfile);
3767 # Courtesy Mark Conty mark_conty@cargill.com change from
3768 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3770 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3771 # proto not yet used
3772 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3774 next HOSTHARD; # who said, we could ftp anything except ftp?
3776 next HOSTHARD if $proto eq "file"; # file URLs would have had
3777 # success above. Likely a bogus URL
3779 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3781 # Try the most capable first and leave ncftp* for last as it only
3783 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3784 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3785 next unless defined $funkyftp;
3786 next if $funkyftp =~ /^\s*$/;
3788 my($asl_ungz, $asl_gz);
3789 ($asl_ungz = $aslocal) =~ s/\.gz//;
3790 $asl_gz = "$asl_ungz.gz";
3792 my($src_switch) = "";
3794 my($stdout_redir) = " > $asl_ungz";
3796 $src_switch = " -source";
3797 } elsif ($f eq "ncftp"){
3798 $src_switch = " -c";
3799 } elsif ($f eq "wget"){
3800 $src_switch = " -O $asl_ungz";
3802 } elsif ($f eq 'curl'){
3803 $src_switch = ' -L -f -s -S --netrc-optional';
3806 if ($f eq "ncftpget"){
3807 $chdir = "cd $aslocal_dir && ";
3810 $CPAN::Frontend->myprint(
3812 Trying with "$funkyftp$src_switch" to get
3816 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3817 $self->debug("system[$system]") if $CPAN::DEBUG;
3818 my($wstatus) = system($system);
3820 # lynx returns 0 when it fails somewhere
3822 my $content = do { local *FH;
3823 open FH, $asl_ungz or die;
3826 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3827 $CPAN::Frontend->mywarn(qq{
3828 No success, the file that lynx has has downloaded looks like an error message:
3831 $CPAN::Frontend->mysleep(1);
3835 $CPAN::Frontend->myprint(qq{
3836 No success, the file that lynx has has downloaded is an empty file.
3841 if ($wstatus == 0) {
3844 } elsif ($asl_ungz ne $aslocal) {
3845 # test gzip integrity
3846 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3847 # e.g. foo.tar is gzipped --> foo.tar.gz
3848 rename $asl_ungz, $aslocal;
3850 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3853 $ThesiteURL = $ro_url;
3855 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3857 -f $asl_ungz && -s _ == 0;
3858 my $gz = "$aslocal.gz";
3859 my $gzurl = "$url.gz";
3860 $CPAN::Frontend->myprint(
3862 Trying with "$funkyftp$src_switch" to get
3865 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3866 $self->debug("system[$system]") if $CPAN::DEBUG;
3868 if (($wstatus = system($system)) == 0
3872 # test gzip integrity
3873 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3874 if ($ct && $ct->gtest) {
3875 $ct->gunzip($aslocal);
3877 # somebody uncompressed file for us?
3878 rename $asl_ungz, $aslocal;
3880 $ThesiteURL = $ro_url;
3883 unlink $asl_gz if -f $asl_gz;
3886 my $estatus = $wstatus >> 8;
3887 my $size = -f $aslocal ?
3888 ", left\n$aslocal with size ".-s _ :
3889 "\nWarning: expected file [$aslocal] doesn't exist";
3890 $CPAN::Frontend->myprint(qq{
3891 System call "$system"
3892 returned status $estatus (wstat $wstatus)$size
3895 return if $CPAN::Signal;
3896 } # transfer programs
3900 # package CPAN::FTP;
3902 my($self,$host_seq,$file,$aslocal,$stats) = @_;
3905 my($aslocal_dir) = File::Basename::dirname($aslocal);
3906 File::Path::mkpath($aslocal_dir);
3907 my $ftpbin = $CPAN::Config->{ftp};
3908 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
3909 $CPAN::Frontend->myprint("No external ftp command available\n\n");
3912 $CPAN::Frontend->mywarn(qq{
3913 As a last ressort we now switch to the external ftp command '$ftpbin'
3916 Doing so often leads to problems that are hard to diagnose.
3918 If you're victim of such problems, please consider unsetting the ftp
3919 config variable with
3925 $CPAN::Frontend->mysleep(2);
3926 HOSTHARDEST: for $ro_url (@$host_seq) {
3927 $self->_set_attempt($stats,"hardest",$ro_url);
3928 my $url = "$ro_url$file";
3929 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3930 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3933 my($host,$dir,$getfile) = ($1,$2,$3);
3935 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3936 $ctime,$blksize,$blocks) = stat($aslocal);
3937 $timestamp = $mtime ||= 0;
3938 my($netrc) = CPAN::FTP::netrc->new;
3939 my($netrcfile) = $netrc->netrc;
3940 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3941 my $targetfile = File::Basename::basename($aslocal);
3947 map("cd $_", split /\//, $dir), # RFC 1738
3949 "get $getfile $targetfile",
3953 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3954 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3955 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3957 $netrc->contains($host))) if $CPAN::DEBUG;
3958 if ($netrc->protected) {
3959 my $dialog = join "", map { " $_\n" } @dialog;
3961 if ($netrc->contains($host)) {
3962 $netrc_explain = "Relying that your .netrc entry for '$host' ".
3963 "manages the login";
3965 $netrc_explain = "Relying that your default .netrc entry ".
3966 "manages the login";
3968 $CPAN::Frontend->myprint(qq{
3969 Trying with external ftp to get
3972 Going to send the dialog
3976 $self->talk_ftp("$ftpbin$verbose $host",
3978 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3979 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3981 if ($mtime > $timestamp) {
3982 $CPAN::Frontend->myprint("GOT $aslocal\n");
3983 $ThesiteURL = $ro_url;
3986 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3988 return if $CPAN::Signal;
3990 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3991 qq{correctly protected.\n});
3994 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3995 nor does it have a default entry\n");
3998 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3999 # then and login manually to host, using e-mail as
4001 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4005 "user anonymous $Config::Config{'cf_email'}"
4007 my $dialog = join "", map { " $_\n" } @dialog;
4008 $CPAN::Frontend->myprint(qq{
4009 Trying with external ftp to get
4011 Going to send the dialog
4015 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4016 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4017 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4019 if ($mtime > $timestamp) {
4020 $CPAN::Frontend->myprint("GOT $aslocal\n");
4021 $ThesiteURL = $ro_url;
4024 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4026 return if $CPAN::Signal;
4027 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4028 $CPAN::Frontend->mysleep(2);
4032 # package CPAN::FTP;
4034 my($self,$command,@dialog) = @_;
4035 my $fh = FileHandle->new;
4036 $fh->open("|$command") or die "Couldn't open ftp: $!";
4037 foreach (@dialog) { $fh->print("$_\n") }
4038 $fh->close; # Wait for process to complete
4040 my $estatus = $wstatus >> 8;
4041 $CPAN::Frontend->myprint(qq{
4042 Subprocess "|$command"
4043 returned status $estatus (wstat $wstatus)
4047 # find2perl needs modularization, too, all the following is stolen
4051 my($self,$name) = @_;
4052 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4053 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4055 my($perms,%user,%group);
4059 $blocks = int(($blocks + 1) / 2);
4062 $blocks = int(($sizemm + 1023) / 1024);
4065 if (-f _) { $perms = '-'; }
4066 elsif (-d _) { $perms = 'd'; }
4067 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4068 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4069 elsif (-p _) { $perms = 'p'; }
4070 elsif (-S _) { $perms = 's'; }
4071 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4073 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4074 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4075 my $tmpmode = $mode;
4076 my $tmp = $rwx[$tmpmode & 7];
4078 $tmp = $rwx[$tmpmode & 7] . $tmp;
4080 $tmp = $rwx[$tmpmode & 7] . $tmp;
4081 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4082 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4083 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4086 my $user = $user{$uid} || $uid; # too lazy to implement lookup
4087 my $group = $group{$gid} || $gid;
4089 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4091 my($moname) = $moname[$mon];
4092 if (-M _ > 365.25 / 2) {
4093 $timeyear = $year + 1900;
4096 $timeyear = sprintf("%02d:%02d", $hour, $min);
4099 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4113 package CPAN::FTP::netrc;
4116 # package CPAN::FTP::netrc;
4119 my $home = CPAN::HandleConfig::home;
4120 my $file = File::Spec->catfile($home,".netrc");
4122 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4123 $atime,$mtime,$ctime,$blksize,$blocks)
4128 my($fh,@machines,$hasdefault);
4130 $fh = FileHandle->new or die "Could not create a filehandle";
4132 if($fh->open($file)){
4133 $protected = ($mode & 077) == 0;
4135 NETRC: while (<$fh>) {
4136 my(@tokens) = split " ", $_;
4137 TOKEN: while (@tokens) {
4138 my($t) = shift @tokens;
4139 if ($t eq "default"){
4143 last TOKEN if $t eq "macdef";
4144 if ($t eq "machine") {
4145 push @machines, shift @tokens;
4150 $file = $hasdefault = $protected = "";
4154 'mach' => [@machines],
4156 'hasdefault' => $hasdefault,
4157 'protected' => $protected,
4161 # CPAN::FTP::netrc::hasdefault;
4162 sub hasdefault { shift->{'hasdefault'} }
4163 sub netrc { shift->{'netrc'} }
4164 sub protected { shift->{'protected'} }
4166 my($self,$mach) = @_;
4167 for ( @{$self->{'mach'}} ) {
4168 return 1 if $_ eq $mach;
4173 package CPAN::Complete;
4177 my($text, $line, $start, $end) = @_;
4178 my(@perlret) = cpl($text, $line, $start);
4179 # find longest common match. Can anybody show me how to peruse
4180 # T::R::Gnu to have this done automatically? Seems expensive.
4181 return () unless @perlret;
4182 my($newtext) = $text;
4183 for (my $i = length($text)+1;;$i++) {
4184 last unless length($perlret[0]) && length($perlret[0]) >= $i;
4185 my $try = substr($perlret[0],0,$i);
4186 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4187 # warn "try[$try]tries[@tries]";
4188 if (@tries == @perlret) {
4194 ($newtext,@perlret);
4197 #-> sub CPAN::Complete::cpl ;
4199 my($word,$line,$pos) = @_;
4203 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4205 if ($line =~ s/^(force\s*)//) {
4210 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4211 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4213 } elsif ($line =~ /^(a|ls)\s/) {
4214 @return = cplx('CPAN::Author',uc($word));
4215 } elsif ($line =~ /^b\s/) {
4216 CPAN::Shell->local_bundles;
4217 @return = cplx('CPAN::Bundle',$word);
4218 } elsif ($line =~ /^d\s/) {
4219 @return = cplx('CPAN::Distribution',$word);
4220 } elsif ($line =~ m/^(
4221 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4223 if ($word =~ /^Bundle::/) {
4224 CPAN::Shell->local_bundles;
4226 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4227 } elsif ($line =~ /^i\s/) {
4228 @return = cpl_any($word);
4229 } elsif ($line =~ /^reload\s/) {
4230 @return = cpl_reload($word,$line,$pos);
4231 } elsif ($line =~ /^o\s/) {
4232 @return = cpl_option($word,$line,$pos);
4233 } elsif ($line =~ m/^\S+\s/ ) {
4234 # fallback for future commands and what we have forgotten above
4235 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4242 #-> sub CPAN::Complete::cplx ;
4244 my($class, $word) = @_;
4245 if (CPAN::_sqlite_running) {
4246 $CPAN::SQLite->search($class, "^\Q$word\E");
4248 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4251 #-> sub CPAN::Complete::cpl_any ;
4255 cplx('CPAN::Author',$word),
4256 cplx('CPAN::Bundle',$word),
4257 cplx('CPAN::Distribution',$word),
4258 cplx('CPAN::Module',$word),
4262 #-> sub CPAN::Complete::cpl_reload ;
4264 my($word,$line,$pos) = @_;
4266 my(@words) = split " ", $line;
4267 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4268 my(@ok) = qw(cpan index);
4269 return @ok if @words == 1;
4270 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4273 #-> sub CPAN::Complete::cpl_option ;
4275 my($word,$line,$pos) = @_;
4277 my(@words) = split " ", $line;
4278 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4279 my(@ok) = qw(conf debug);
4280 return @ok if @words == 1;
4281 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4283 } elsif ($words[1] eq 'index') {
4285 } elsif ($words[1] eq 'conf') {
4286 return CPAN::HandleConfig::cpl(@_);
4287 } elsif ($words[1] eq 'debug') {
4288 return sort grep /^\Q$word\E/i,
4289 sort keys %CPAN::DEBUG, 'all';
4293 package CPAN::Index;
4296 #-> sub CPAN::Index::force_reload ;
4299 $CPAN::Index::LAST_TIME = 0;
4303 #-> sub CPAN::Index::reload ;
4305 my($self,$force) = @_;
4308 # XXX check if a newer one is available. (We currently read it
4309 # from time to time)
4310 for ($CPAN::Config->{index_expire}) {
4311 $_ = 0.001 unless $_ && $_ > 0.001;
4313 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4314 # debug here when CPAN doesn't seem to read the Metadata
4316 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4318 unless ($CPAN::META->{PROTOCOL}) {
4319 $self->read_metadata_cache;
4320 $CPAN::META->{PROTOCOL} ||= "1.0";
4322 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
4323 # warn "Setting last_time to 0";
4324 $LAST_TIME = 0; # No warning necessary
4326 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4329 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4331 # IFF we are developing, it helps to wipe out the memory
4332 # between reloads, otherwise it is not what a user expects.
4333 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4334 $CPAN::META = CPAN->new;
4337 local $LAST_TIME = $time;
4338 local $CPAN::META->{PROTOCOL} = PROTOCOL;
4340 my $needshort = $^O eq "dos";
4342 $self->rd_authindex($self
4344 "authors/01mailrc.txt.gz",
4346 File::Spec->catfile('authors', '01mailrc.gz') :
4347 File::Spec->catfile('authors', '01mailrc.txt.gz'),
4350 $debug = "timing reading 01[".($t2 - $time)."]";
4352 return if $CPAN::Signal; # this is sometimes lengthy
4353 $self->rd_modpacks($self
4355 "modules/02packages.details.txt.gz",
4357 File::Spec->catfile('modules', '02packag.gz') :
4358 File::Spec->catfile('modules', '02packages.details.txt.gz'),
4361 $debug .= "02[".($t2 - $time)."]";
4363 return if $CPAN::Signal; # this is sometimes lengthy
4364 $self->rd_modlist($self
4366 "modules/03modlist.data.gz",
4368 File::Spec->catfile('modules', '03mlist.gz') :
4369 File::Spec->catfile('modules', '03modlist.data.gz'),
4371 $self->write_metadata_cache;
4373 $debug .= "03[".($t2 - $time)."]";
4375 CPAN->debug($debug) if $CPAN::DEBUG;
4377 if ($CPAN::Config->{build_dir_reuse}) {
4378 $self->reanimate_build_dir;
4380 if (CPAN::_sqlite_running) {
4381 $CPAN::SQLite->reload(time => $time, force => $force)
4385 $CPAN::META->{PROTOCOL} = PROTOCOL;
4388 #-> sub CPAN::Index::reanimate_build_dir ;
4389 sub reanimate_build_dir {
4391 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4394 return if $HAVE_REANIMATED++;
4395 my $d = $CPAN::Config->{build_dir};
4396 my $dh = DirHandle->new;
4397 opendir $dh, $d or return; # does not exist
4402 $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4403 my @candidates = map { $_->[0] }
4404 sort { $b->[1] <=> $a->[1] }
4405 map { [ $_, -M File::Spec->catfile($d,$_) ] }
4406 grep {/\.yml$/} readdir $dh;
4407 DISTRO: for $dirent (@candidates) {
4408 my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4411 if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4412 my $key = $c->{distribution}{ID};
4413 for my $k (keys %{$c->{distribution}}) {
4414 if ($c->{distribution}{$k}
4415 && ref $c->{distribution}{$k}
4416 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4417 $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4421 #we tried to restore only if element already
4422 #exists; but then we do not work with metadata
4425 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4426 = $c->{distribution};
4427 delete $do->{badtestcnt};
4429 if ($do->{make_test}
4431 && !$do->{make_test}->failed
4435 $do->{install}->failed
4438 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4443 while (($painted/76) < ($i/@candidates)) {
4444 $CPAN::Frontend->myprint(".");
4448 $CPAN::Frontend->myprint(sprintf(
4449 "DONE\nFound %s old builds, restored the state of %s\n",
4450 @candidates ? sprintf("%d",scalar @candidates) : "no",
4451 $restored || "none",
4456 #-> sub CPAN::Index::reload_x ;
4458 my($cl,$wanted,$localname,$force) = @_;
4459 $force |= 2; # means we're dealing with an index here
4460 CPAN::HandleConfig->load; # we should guarantee loading wherever
4461 # we rely on Config XXX
4462 $localname ||= $wanted;
4463 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4467 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4470 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4471 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4472 qq{day$s. I\'ll use that.});
4475 $force |= 1; # means we're quite serious about it.
4477 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4480 #-> sub CPAN::Index::rd_authindex ;
4482 my($cl, $index_target) = @_;
4483 return unless defined $index_target;
4484 return if CPAN::_sqlite_running;
4486 $CPAN::Frontend->myprint("Going to read $index_target\n");
4488 tie *FH, 'CPAN::Tarzip', $index_target;
4491 push @lines, split /\012/ while <FH>;
4495 my($userid,$fullname,$email) =
4496 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4497 $fullname ||= $email;
4498 if ($userid && $fullname && $email){
4499 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4500 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4502 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4505 while (($painted/76) < ($i/@lines)) {
4506 $CPAN::Frontend->myprint(".");
4509 return if $CPAN::Signal;
4511 $CPAN::Frontend->myprint("DONE\n");
4515 my($self,$dist) = @_;
4516 $dist = $self->{'id'} unless defined $dist;
4517 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4521 #-> sub CPAN::Index::rd_modpacks ;
4523 my($self, $index_target) = @_;
4524 return unless defined $index_target;
4525 return if CPAN::_sqlite_running;
4526 $CPAN::Frontend->myprint("Going to read $index_target\n");
4527 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4529 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4532 while (my $bytes = $fh->READ(\$chunk,8192)) {
4535 my @lines = split /\012/, $slurp;
4536 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4539 my($line_count,$last_updated);
4541 my $shift = shift(@lines);
4542 last if $shift =~ /^\s*$/;
4543 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4544 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4546 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4547 if (not defined $line_count) {
4549 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4550 Please check the validity of the index file by comparing it to more
4551 than one CPAN mirror. I'll continue but problems seem likely to
4555 $CPAN::Frontend->mysleep(5);
4556 } elsif ($line_count != scalar @lines) {
4558 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4559 contains a Line-Count header of %d but I see %d lines there. Please
4560 check the validity of the index file by comparing it to more than one
4561 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4562 $index_target, $line_count, scalar(@lines));
4565 if (not defined $last_updated) {
4567 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4568 Please check the validity of the index file by comparing it to more
4569 than one CPAN mirror. I'll continue but problems seem likely to
4573 $CPAN::Frontend->mysleep(5);
4577 ->myprint(sprintf qq{ Database was generated on %s\n},
4579 $DATE_OF_02 = $last_updated;
4582 if ($CPAN::META->has_inst('HTTP::Date')) {
4584 $age -= HTTP::Date::str2time($last_updated);
4586 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
4587 require Time::Local;
4588 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4589 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4590 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4597 qq{Warning: This index file is %d days old.
4598 Please check the host you chose as your CPAN mirror for staleness.
4599 I'll continue but problems seem likely to happen.\a\n},
4602 } elsif ($age < -1) {
4606 qq{Warning: Your system date is %d days behind this index file!
4608 Timestamp index file: %s
4609 Please fix your system time, problems with the make command expected.\n},
4619 # A necessity since we have metadata_cache: delete what isn't
4621 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4622 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4627 # before 1.56 we split into 3 and discarded the rest. From
4628 # 1.57 we assign remaining text to $comment thus allowing to
4629 # influence isa_perl
4630 my($mod,$version,$dist,$comment) = split " ", $_, 4;
4631 my($bundle,$id,$userid);
4633 if ($mod eq 'CPAN' &&
4635 CPAN::Queue->exists('Bundle::CPAN') ||
4636 CPAN::Queue->exists('CPAN')
4640 if ($version > $CPAN::VERSION){
4641 $CPAN::Frontend->mywarn(qq{
4642 New CPAN.pm version (v$version) available.
4643 [Currently running version is v$CPAN::VERSION]
4644 You might want to try
4647 to both upgrade CPAN.pm and run the new version without leaving
4648 the current session.
4651 $CPAN::Frontend->mysleep(2);
4652 $CPAN::Frontend->myprint(qq{\n});
4654 last if $CPAN::Signal;
4655 } elsif ($mod =~ /^Bundle::(.*)/) {
4660 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
4661 # Let's make it a module too, because bundles have so much
4662 # in common with modules.
4664 # Changed in 1.57_63: seems like memory bloat now without
4665 # any value, so commented out
4667 # $CPAN::META->instance('CPAN::Module',$mod);
4671 # instantiate a module object
4672 $id = $CPAN::META->instance('CPAN::Module',$mod);
4676 # Although CPAN prohibits same name with different version the
4677 # indexer may have changed the version for the same distro
4678 # since the last time ("Force Reindexing" feature)
4679 if ($id->cpan_file ne $dist
4681 $id->cpan_version ne $version
4683 $userid = $id->userid || $self->userid($dist);
4685 'CPAN_USERID' => $userid,
4686 'CPAN_VERSION' => $version,
4687 'CPAN_FILE' => $dist,
4691 # instantiate a distribution object
4692 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4693 # we do not need CONTAINSMODS unless we do something with
4694 # this dist, so we better produce it on demand.
4696 ## my $obj = $CPAN::META->instance(
4697 ## 'CPAN::Distribution' => $dist
4699 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4701 $CPAN::META->instance(
4702 'CPAN::Distribution' => $dist
4704 'CPAN_USERID' => $userid,
4705 'CPAN_COMMENT' => $comment,
4709 for my $name ($mod,$dist) {
4710 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4711 $exists{$name} = undef;
4715 while (($painted/76) < ($i/@lines)) {
4716 $CPAN::Frontend->myprint(".");
4719 return if $CPAN::Signal;
4721 $CPAN::Frontend->myprint("DONE\n");
4723 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4724 for my $o ($CPAN::META->all_objects($class)) {
4725 next if exists $exists{$o->{ID}};
4726 $CPAN::META->delete($class,$o->{ID});
4727 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4734 #-> sub CPAN::Index::rd_modlist ;
4736 my($cl,$index_target) = @_;
4737 return unless defined $index_target;
4738 return if CPAN::_sqlite_running;
4739 $CPAN::Frontend->myprint("Going to read $index_target\n");
4740 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4744 while (my $bytes = $fh->READ(\$chunk,8192)) {
4747 my @eval2 = split /\012/, $slurp;
4750 my $shift = shift(@eval2);
4751 if ($shift =~ /^Date:\s+(.*)/){
4752 if ($DATE_OF_03 eq $1){
4753 $CPAN::Frontend->myprint("Unchanged.\n");
4758 last if $shift =~ /^\s*$/;
4760 push @eval2, q{CPAN::Modulelist->data;};
4762 my($comp) = Safe->new("CPAN::Safe1");
4763 my($eval2) = join("\n", @eval2);
4764 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4765 my $ret = $comp->reval($eval2);
4766 Carp::confess($@) if $@;
4767 return if $CPAN::Signal;
4769 my $until = keys(%$ret);
4771 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4773 my $obj = $CPAN::META->instance("CPAN::Module",$_);
4774 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4775 $obj->set(%{$ret->{$_}});
4777 while (($painted/76) < ($i/$until)) {
4778 $CPAN::Frontend->myprint(".");
4781 return if $CPAN::Signal;
4783 $CPAN::Frontend->myprint("DONE\n");
4786 #-> sub CPAN::Index::write_metadata_cache ;
4787 sub write_metadata_cache {
4789 return unless $CPAN::Config->{'cache_metadata'};
4790 return if CPAN::_sqlite_running;
4791 return unless $CPAN::META->has_usable("Storable");
4793 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4794 CPAN::Distribution)) {
4795 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4797 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4798 $cache->{last_time} = $LAST_TIME;
4799 $cache->{DATE_OF_02} = $DATE_OF_02;
4800 $cache->{PROTOCOL} = PROTOCOL;
4801 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4802 eval { Storable::nstore($cache, $metadata_file) };
4803 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4806 #-> sub CPAN::Index::read_metadata_cache ;
4807 sub read_metadata_cache {
4809 return unless $CPAN::Config->{'cache_metadata'};
4810 return if CPAN::_sqlite_running;
4811 return unless $CPAN::META->has_usable("Storable");
4812 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4813 return unless -r $metadata_file and -f $metadata_file;
4814 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4816 eval { $cache = Storable::retrieve($metadata_file) };
4817 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4818 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4822 if (exists $cache->{PROTOCOL}) {
4823 if (PROTOCOL > $cache->{PROTOCOL}) {
4824 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4825 "with protocol v%s, requiring v%s\n",
4832 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4833 "with protocol v1.0\n");
4838 while(my($class,$v) = each %$cache) {
4839 next unless $class =~ /^CPAN::/;
4840 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4841 while (my($id,$ro) = each %$v) {
4842 $CPAN::META->{readwrite}{$class}{$id} ||=
4843 $class->new(ID=>$id, RO=>$ro);
4848 unless ($clcnt) { # sanity check
4849 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4852 if ($idcnt < 1000) {
4853 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4854 "in $metadata_file\n");
4857 $CPAN::META->{PROTOCOL} ||=
4858 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4859 # does initialize to some protocol
4860 $LAST_TIME = $cache->{last_time};
4861 $DATE_OF_02 = $cache->{DATE_OF_02};
4862 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
4863 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4867 package CPAN::InfoObj;
4872 exists $self->{RO} and return $self->{RO};
4875 #-> sub CPAN::InfoObj::cpan_userid
4880 return $ro->{CPAN_USERID} || "N/A";
4882 $self->debug("ID[$self->{ID}]");
4883 # N/A for bundles found locally
4888 sub id { shift->{ID}; }
4890 #-> sub CPAN::InfoObj::new ;
4892 my $this = bless {}, shift;
4897 # The set method may only be used by code that reads index data or
4898 # otherwise "objective" data from the outside world. All session
4899 # related material may do anything else with instance variables but
4900 # must not touch the hash under the RO attribute. The reason is that
4901 # the RO hash gets written to Metadata file and is thus persistent.
4903 #-> sub CPAN::InfoObj::safe_chdir ;
4905 my($self,$todir) = @_;
4906 # we die if we cannot chdir and we are debuggable
4907 Carp::confess("safe_chdir called without todir argument")
4908 unless defined $todir and length $todir;
4910 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4914 unless (-x $todir) {
4915 unless (chmod 0755, $todir) {
4916 my $cwd = CPAN::anycwd();
4917 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4918 "permission to change the permission; cannot ".
4919 "chdir to '$todir'\n");
4920 $CPAN::Frontend->mysleep(5);
4921 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4922 qq{to todir[$todir]: $!});
4926 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4929 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4932 my $cwd = CPAN::anycwd();
4933 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4934 qq{to todir[$todir] (a chmod has been issued): $!});
4939 #-> sub CPAN::InfoObj::set ;
4941 my($self,%att) = @_;
4942 my $class = ref $self;
4944 # This must be ||=, not ||, because only if we write an empty
4945 # reference, only then the set method will write into the readonly
4946 # area. But for Distributions that spring into existence, maybe
4947 # because of a typo, we do not like it that they are written into
4948 # the readonly area and made permanent (at least for a while) and
4949 # that is why we do not "allow" other places to call ->set.
4950 unless ($self->id) {
4951 CPAN->debug("Bug? Empty ID, rejecting");
4954 my $ro = $self->{RO} =
4955 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4957 while (my($k,$v) = each %att) {
4962 #-> sub CPAN::InfoObj::as_glimpse ;
4966 my $class = ref($self);
4967 $class =~ s/^CPAN:://;
4968 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4969 push @m, sprintf "%-15s %s\n", $class, $id;
4973 #-> sub CPAN::InfoObj::as_string ;
4977 my $class = ref($self);
4978 $class =~ s/^CPAN:://;
4979 push @m, $class, " id = $self->{ID}\n";
4981 unless ($ro = $self->ro) {
4982 if (substr($self->{ID},-1,1) eq ".") { # directory
4985 $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4988 for (sort keys %$ro) {
4989 # next if m/^(ID|RO)$/;
4991 if ($_ eq "CPAN_USERID") {
4993 $extra .= $self->fullname;
4994 my $email; # old perls!
4995 if ($email = $CPAN::META->instance("CPAN::Author",
4998 $extra .= " <$email>";
5000 $extra .= " <no email>";
5003 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5004 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
5007 next unless defined $ro->{$_};
5008 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
5010 KEY: for (sort keys %$self) {
5011 next if m/^(ID|RO)$/;
5012 unless (defined $self->{$_}) {
5016 if (ref($self->{$_}) eq "ARRAY") {
5017 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
5018 } elsif (ref($self->{$_}) eq "HASH") {
5020 if (/^CONTAINSMODS$/) {
5021 $value = join(" ",sort keys %{$self->{$_}});
5022 } elsif (/^prereq_pm$/) {
5024 my $v = $self->{$_};
5025 for my $x (sort keys %$v) {
5027 for my $y (sort keys %{$v->{$x}}) {
5028 push @svalue, "$y=>$v->{$x}{$y}";
5030 push @value, "$x\:" . join ",", @svalue if @svalue;
5032 $value = join ";", @value;
5034 $value = $self->{$_};
5042 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
5048 #-> sub CPAN::InfoObj::fullname ;
5051 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5054 #-> sub CPAN::InfoObj::dump ;
5056 my($self, $what) = @_;
5057 unless ($CPAN::META->has_inst("Data::Dumper")) {
5058 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5060 local $Data::Dumper::Sortkeys;
5061 $Data::Dumper::Sortkeys = 1;
5062 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5063 if (length $out > 100000) {
5064 my $fh_pager = FileHandle->new;
5065 local($SIG{PIPE}) = "IGNORE";
5066 my $pager = $CPAN::Config->{'pager'} || "cat";
5067 $fh_pager->open("|$pager")
5068 or die "Could not open pager $pager\: $!";
5069 $fh_pager->print($out);
5072 $CPAN::Frontend->myprint($out);
5076 package CPAN::Author;
5079 #-> sub CPAN::Author::force
5085 #-> sub CPAN::Author::force
5088 delete $self->{force};
5091 #-> sub CPAN::Author::id
5094 my $id = $self->{ID};
5095 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5099 #-> sub CPAN::Author::as_glimpse ;
5103 my $class = ref($self);
5104 $class =~ s/^CPAN:://;
5105 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5113 #-> sub CPAN::Author::fullname ;
5115 shift->ro->{FULLNAME};
5119 #-> sub CPAN::Author::email ;
5120 sub email { shift->ro->{EMAIL}; }
5122 #-> sub CPAN::Author::ls ;
5125 my $glob = shift || "";
5126 my $silent = shift || 0;
5129 # adapted from CPAN::Distribution::verifyCHECKSUM ;
5130 my(@csf); # chksumfile
5131 @csf = $self->id =~ /(.)(.)(.*)/;
5132 $csf[1] = join "", @csf[0,1];
5133 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5135 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5136 unless (grep {$_->[2] eq $csf[1]} @dl) {
5137 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5140 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5141 unless (grep {$_->[2] eq $csf[2]} @dl) {
5142 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5145 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5147 if ($CPAN::META->has_inst("Text::Glob")) {
5148 my $rglob = Text::Glob::glob_to_regex($glob);
5149 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5151 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5154 $CPAN::Frontend->myprint(join "", map {
5155 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5156 } sort { $a->[2] cmp $b->[2] } @dl);
5160 # returns an array of arrays, the latter contain (size,mtime,filename)
5161 #-> sub CPAN::Author::dir_listing ;
5164 my $chksumfile = shift;
5165 my $recursive = shift;
5166 my $may_ftp = shift;
5169 File::Spec->catfile($CPAN::Config->{keep_source_where},
5170 "authors", "id", @$chksumfile);
5174 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5175 # hazard. (Without GPG installed they are not that much better,
5177 $fh = FileHandle->new;
5178 if (open($fh, $lc_want)) {
5179 my $line = <$fh>; close $fh;
5180 unlink($lc_want) unless $line =~ /PGP/;
5184 # connect "force" argument with "index_expire".
5185 my $force = $self->{force};
5186 if (my @stat = stat $lc_want) {
5187 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5191 $lc_file = CPAN::FTP->localize(
5192 "authors/id/@$chksumfile",
5197 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5198 $chksumfile->[-1] .= ".gz";
5199 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5202 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5203 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5209 $lc_file = $lc_want;
5210 # we *could* second-guess and if the user has a file: URL,
5211 # then we could look there. But on the other hand, if they do
5212 # have a file: URL, wy did they choose to set
5213 # $CPAN::Config->{show_upload_date} to false?
5216 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5217 $fh = FileHandle->new;
5219 if (open $fh, $lc_file){
5222 $eval =~ s/\015?\012/\n/g;
5224 my($comp) = Safe->new();
5225 $cksum = $comp->reval($eval);
5227 rename $lc_file, "$lc_file.bad";
5228 Carp::confess($@) if $@;
5230 } elsif ($may_ftp) {
5231 Carp::carp "Could not open '$lc_file' for reading.";
5233 # Maybe should warn: "You may want to set show_upload_date to a true value"
5237 for $f (sort keys %$cksum) {
5238 if (exists $cksum->{$f}{isdir}) {
5240 my(@dir) = @$chksumfile;
5242 push @dir, $f, "CHECKSUMS";
5244 [$_->[0], $_->[1], "$f/$_->[2]"]
5245 } $self->dir_listing(\@dir,1,$may_ftp);
5247 push @result, [ 0, "-", $f ];
5251 ($cksum->{$f}{"size"}||0),
5252 $cksum->{$f}{"mtime"}||"---",
5260 package CPAN::Distribution;
5266 my $ro = $self->ro or return;
5270 # CPAN::Distribution::undelay
5273 delete $self->{later};
5276 # add the A/AN/ stuff
5277 # CPAN::Distribution::normalize
5280 $s = $self->id unless defined $s;
5281 if (substr($s,-1,1) eq ".") {
5282 # using a global because we are sometimes called as static method
5283 if (!$CPAN::META->{LOCK}
5284 && !$CPAN::Have_warned->{"$s is unlocked"}++
5286 $CPAN::Frontend->mywarn("You are visiting the local directory
5288 without lock, take care that concurrent processes do not do likewise.\n");
5289 $CPAN::Frontend->mysleep(1);
5292 $s = "$CPAN::iCwd/.";
5293 } elsif (File::Spec->file_name_is_absolute($s)) {
5294 } elsif (File::Spec->can("rel2abs")) {
5295 $s = File::Spec->rel2abs($s);
5297 $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5299 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5300 unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5301 for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5302 $_->{build_dir} = $s;
5303 $_->{archived} = "local_directory";
5304 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5310 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5312 return $s if $s =~ m:^N/A|^Contact Author: ;
5313 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5314 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5315 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5320 #-> sub CPAN::Distribution::author ;
5324 if (substr($self->id,-1,1) eq ".") {
5325 $authorid = "LOCAL";
5327 ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5329 CPAN::Shell->expand("Author",$authorid);
5332 # tries to get the yaml from CPAN instead of the distro itself:
5333 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5336 my $meta = $self->pretty_id;
5337 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5338 my(@ls) = CPAN::Shell->globls($meta);
5339 my $norm = $self->normalize($meta);
5343 File::Spec->catfile(
5344 $CPAN::Config->{keep_source_where},
5349 $self->debug("Doing localize") if $CPAN::DEBUG;
5350 unless ($local_file =
5351 CPAN::FTP->localize("authors/id/$norm",
5353 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5355 my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5358 #-> sub CPAN::Distribution::cpan_userid
5361 if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5364 return $self->SUPER::cpan_userid;
5367 #-> sub CPAN::Distribution::pretty_id
5371 return $id unless $id =~ m|^./../|;
5375 # mark as dirty/clean
5376 #-> sub CPAN::Distribution::color_cmd_tmps ;
5377 sub color_cmd_tmps {
5379 my($depth) = shift || 0;
5380 my($color) = shift || 0;
5381 my($ancestors) = shift || [];
5382 # a distribution needs to recurse into its prereq_pms
5384 return if exists $self->{incommandcolor}
5385 && $self->{incommandcolor}==$color;
5387 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5389 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5390 my $prereq_pm = $self->prereq_pm;
5391 if (defined $prereq_pm) {
5392 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5393 keys %{$prereq_pm->{build_requires}||{}}) {
5394 next PREREQ if $pre eq "perl";
5396 unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5397 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5398 $CPAN::Frontend->mysleep(2);
5401 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5405 delete $self->{sponsored_mods};
5407 # as we are at the end of a command, we'll give up this
5408 # reminder of a broken test. Other commands may test this guy
5409 # again. Maybe 'badtestcnt' should be renamed to
5410 # 'makte_test_failed_within_command'?
5411 delete $self->{badtestcnt};
5413 $self->{incommandcolor} = $color;
5416 #-> sub CPAN::Distribution::as_string ;
5419 $self->containsmods;
5421 $self->SUPER::as_string(@_);
5424 #-> sub CPAN::Distribution::containsmods ;
5427 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5428 my $dist_id = $self->{ID};
5429 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5430 my $mod_file = $mod->cpan_file or next;
5431 my $mod_id = $mod->{ID} or next;
5432 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5434 if ($CPAN::Signal) {
5435 delete $self->{CONTAINSMODS};
5438 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5440 keys %{$self->{CONTAINSMODS}||{}};
5443 #-> sub CPAN::Distribution::upload_date ;
5446 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5447 my(@local_wanted) = split(/\//,$self->id);
5448 my $filename = pop @local_wanted;
5449 push @local_wanted, "CHECKSUMS";
5450 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5451 return unless $author;
5452 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5454 my($dirent) = grep { $_->[2] eq $filename } @dl;
5455 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5456 return unless $dirent->[1];
5457 return $self->{UPLOAD_DATE} = $dirent->[1];
5460 #-> sub CPAN::Distribution::uptodate ;
5464 foreach $c ($self->containsmods) {
5465 my $obj = CPAN::Shell->expandany($c);
5466 unless ($obj->uptodate){
5467 my $id = $self->pretty_id;
5468 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5475 #-> sub CPAN::Distribution::called_for ;
5478 $self->{CALLED_FOR} = $id if defined $id;
5479 return $self->{CALLED_FOR};
5482 #-> sub CPAN::Distribution::get ;
5485 $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5486 if (my $goto = $self->prefs->{goto}) {
5487 $CPAN::Frontend->mywarn
5489 "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5491 $self->{prefs_file},
5492 $self->{prefs_file_doc},
5494 return $self->goto($goto);
5496 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5498 : ($ENV{PERLLIB} || "");
5500 $CPAN::META->set_perl5lib;
5501 local $ENV{MAKEFLAGS}; # protect us from outer make calls
5505 $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5506 if ($self->prefs->{disabled}) {
5508 "Disabled via prefs file '%s' doc %d",
5509 $self->{prefs_file},
5510 $self->{prefs_file_doc},
5513 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5514 # note: not intended to be persistent but at least visible
5515 # during this session
5517 if (exists $self->{build_dir}) {
5518 # this deserves print, not warn:
5519 $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
5520 "$self->{build_dir}\n"
5525 # although we talk about 'force' we shall not test on
5526 # force directly. New model of force tries to refrain from
5527 # direct checking of force.
5528 exists $self->{unwrapped} and (
5529 UNIVERSAL::can($self->{unwrapped},"failed") ?
5530 $self->{unwrapped}->failed :
5531 $self->{unwrapped} =~ /^NO/
5533 and push @e, "Unwrapping had some problem, won't try again without force";
5536 $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5538 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5541 # Get the file on local disk
5546 File::Spec->catfile(
5547 $CPAN::Config->{keep_source_where},
5550 split(/\//,$self->id)
5553 $self->debug("Doing localize") if $CPAN::DEBUG;
5554 unless ($local_file =
5555 CPAN::FTP->localize("authors/id/$self->{ID}",
5558 if ($CPAN::Index::DATE_OF_02) {
5559 $note = "Note: Current database in memory was generated ".
5560 "on $CPAN::Index::DATE_OF_02\n";
5562 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5565 $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5566 $self->{localfile} = $local_file;
5567 return if $CPAN::Signal;
5572 if ($CPAN::META->has_inst("Digest::SHA")) {
5573 $self->debug("Digest::SHA is installed, verifying");
5574 $self->verifyCHECKSUM;
5576 $self->debug("Digest::SHA is NOT installed");
5578 return if $CPAN::Signal;
5581 # Create a clean room and go there
5583 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5584 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5585 $self->safe_chdir($builddir);
5586 $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5587 File::Path::rmtree("tmp-$$");
5588 unless (mkdir "tmp-$$", 0755) {
5589 $CPAN::Frontend->unrecoverable_error(<<EOF);
5590 Couldn't mkdir '$builddir/tmp-$$': $!
5592 Cannot continue: Please find the reason why I cannot make the
5595 and fix the problem, then retry.
5600 $self->safe_chdir($sub_wd);
5603 $self->safe_chdir("tmp-$$");
5608 my $ct = eval{CPAN::Tarzip->new($local_file)};
5610 $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5611 delete $self->{build_dir};
5614 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5615 $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5616 $self->untar_me($ct);
5617 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5618 $self->unzip_me($ct);
5620 $self->{was_uncompressed}++ unless $ct->gtest();
5621 $local_file = $self->handle_singlefile($local_file);
5623 # $self->{archived} = "NO";
5624 # $self->safe_chdir($sub_wd);
5628 # we are still in the tmp directory!
5629 # Let's check if the package has its own directory.
5630 my $dh = DirHandle->new(File::Spec->curdir)
5631 or Carp::croak("Couldn't opendir .: $!");
5632 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5635 # XXX here we want in each branch File::Temp to protect all build_dir directories
5636 if (CPAN->has_inst("File::Temp")) {
5640 if (@readdir == 1 && -d $readdir[0]) {
5641 $tdir_base = $readdir[0];
5642 $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5643 my $dh2 = DirHandle->new($from_dir)
5644 or Carp::croak("Couldn't opendir $from_dir: $!");
5645 @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5647 my $userid = $self->cpan_userid;
5648 CPAN->debug("userid[$userid]");
5649 if (!$userid or $userid eq "N/A") {
5652 $tdir_base = $userid;
5653 $from_dir = File::Spec->curdir;
5654 @dirents = @readdir;
5656 $packagedir = File::Temp::tempdir(
5657 "$tdir_base-XXXXXX",
5662 for $f (@dirents) { # is already without "." and ".."
5663 my $from = File::Spec->catdir($from_dir,$f);
5664 my $to = File::Spec->catdir($packagedir,$f);
5665 unless (File::Copy::move($from,$to)) {
5667 $from = File::Spec->rel2abs($from);
5668 Carp::confess("Couldn't move $from to $to: $err");
5671 } else { # older code below, still better than nothing when there is no File::Temp
5673 if (@readdir == 1 && -d $readdir[0]) {
5674 $distdir = $readdir[0];
5675 $packagedir = File::Spec->catdir($builddir,$distdir);
5676 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5678 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5680 File::Path::rmtree($packagedir);
5681 unless (File::Copy::move($distdir,$packagedir)) {
5682 $CPAN::Frontend->unrecoverable_error(<<EOF);
5683 Couldn't move '$distdir' to '$packagedir': $!
5685 Cannot continue: Please find the reason why I cannot move
5686 $builddir/tmp-$$/$distdir
5689 and fix the problem, then retry
5693 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5700 my $userid = $self->cpan_userid;
5701 CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5702 if (!$userid or $userid eq "N/A") {
5705 my $pragmatic_dir = $userid . '000';
5706 $pragmatic_dir =~ s/\W_//g;
5707 $pragmatic_dir++ while -d "../$pragmatic_dir";
5708 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5709 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5710 File::Path::mkpath($packagedir);
5712 for $f (@readdir) { # is already without "." and ".."
5713 my $to = File::Spec->catdir($packagedir,$f);
5714 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5719 $self->safe_chdir($sub_wd);
5723 $self->{build_dir} = $packagedir;
5724 $self->safe_chdir($builddir);
5725 File::Path::rmtree("tmp-$$");
5727 $self->safe_chdir($packagedir);
5728 $self->_signature_business();
5729 $self->safe_chdir($builddir);
5730 return if $CPAN::Signal;
5733 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5734 my($mpl_exists) = -f $mpl;
5735 unless ($mpl_exists) {
5736 # NFS has been reported to have racing problems after the
5737 # renaming of a directory in some environments.
5739 $CPAN::Frontend->mysleep(1);
5740 my $mpldh = DirHandle->new($packagedir)
5741 or Carp::croak("Couldn't opendir $packagedir: $!");
5742 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5745 my $prefer_installer = "eumm"; # eumm|mb
5746 if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5747 if ($mpl_exists) { # they *can* choose
5748 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5749 q{prefer_installer});
5751 $prefer_installer = "mb";
5754 return unless $self->patch;
5755 if (lc($prefer_installer) eq "mb") {
5756 $self->{modulebuild} = 1;
5757 } elsif (! $mpl_exists) {
5758 $self->_edge_cases($mpl,$packagedir,$local_file);
5760 if ($self->{build_dir}
5762 $CPAN::Config->{build_dir_reuse}
5764 $self->store_persistent_state;
5770 #-> CPAN::Distribution::store_persistent_state
5771 sub store_persistent_state {
5773 my $dir = $self->{build_dir};
5774 unless (File::Spec->canonpath(File::Basename::dirname($dir))
5775 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5776 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5777 "will not store persistent state\n");
5780 my $file = sprintf "%s.yml", $dir;
5781 my $yaml_module = CPAN::_yaml_module;
5782 if ($CPAN::META->has_inst($yaml_module)) {
5783 CPAN->_yaml_dumpfile(
5787 perl => CPAN::_perl_fingerprint,
5788 distribution => $self,
5792 $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
5793 "will not store persistent state\n");
5797 #-> CPAN::Distribution::patch
5799 my($self,$patch) = @_;
5800 my $norm = $self->normalize($patch);
5802 File::Spec->catfile(
5803 $CPAN::Config->{keep_source_where},
5808 $self->debug("Doing localize") if $CPAN::DEBUG;
5809 return CPAN::FTP->localize("authors/id/$norm",
5813 #-> CPAN::Distribution::patch
5816 $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
5817 my $patches = $self->prefs->{patches};
5819 $self->debug("patches[$patches]") if $CPAN::DEBUG;
5821 return unless @$patches;
5822 $self->safe_chdir($self->{build_dir});
5823 CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
5824 my $patchbin = $CPAN::Config->{patch};
5825 unless ($patchbin && length $patchbin) {
5826 $CPAN::Frontend->mydie("No external patch command configured\n\n".
5827 "Please run 'o conf init /patch/'\n\n");
5829 unless (MM->maybe_command($patchbin)) {
5830 $CPAN::Frontend->mydie("No external patch command available\n\n".
5831 "Please run 'o conf init /patch/'\n\n");
5833 $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5834 local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5835 # supported everywhere (and then,
5836 # not ever necessary there)
5837 my $stdpatchargs = "-N --fuzz=3";
5838 my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5839 $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5840 for my $patch (@$patches) {
5841 unless (-f $patch) {
5842 if (my $trydl = $self->try_download($patch)) {
5845 my $fail = "Could not find patch '$patch'";
5846 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5847 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5848 delete $self->{build_dir};
5852 $CPAN::Frontend->myprint(" $patch\n");
5853 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5856 my $ppp = $self->_patch_p_parameter($readfh);
5857 if ($ppp eq "applypatch") {
5858 $pcommand = "$CPAN::Config->{applypatch} -verbose";
5860 my $thispatchargs = join " ", $stdpatchargs, $ppp;
5861 $pcommand = "$patchbin $thispatchargs";
5864 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
5865 my $writefh = FileHandle->new;
5866 $CPAN::Frontend->myprint(" $pcommand\n");
5867 unless (open $writefh, "|$pcommand") {
5868 my $fail = "Could not fork '$pcommand'";
5869 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5870 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5871 delete $self->{build_dir};
5874 while (my $x = $readfh->READLINE) {
5877 unless (close $writefh) {
5878 my $fail = "Could not apply patch '$patch'";
5879 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5880 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5881 delete $self->{build_dir};
5890 sub _patch_p_parameter {
5893 my $cnt_p0files = 0;
5895 while ($_ = $fh->READLINE) {
5897 $CPAN::Config->{applypatch}
5899 /\#\#\#\# ApplyPatch data follows \#\#\#\#/
5903 next unless /^[\*\+]{3}\s(\S+)/;
5906 $cnt_p0files++ if -f $file;
5907 CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
5910 return "-p1" unless $cnt_files;
5911 return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
5914 #-> sub CPAN::Distribution::_edge_cases
5915 # with "configure" or "Makefile" or single file scripts
5917 my($self,$mpl,$packagedir,$local_file) = @_;
5918 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
5922 my($configure) = File::Spec->catfile($packagedir,"Configure");
5923 if (-f $configure) {
5924 # do we have anything to do?
5925 $self->{configure} = $configure;
5926 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
5927 $CPAN::Frontend->mywarn(qq{
5928 Package comes with a Makefile and without a Makefile.PL.
5929 We\'ll try to build it with that Makefile then.
5931 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5932 $CPAN::Frontend->mysleep(2);
5934 my $cf = $self->called_for || "unknown";
5939 $cf =~ s|[/\\:]||g; # risk of filesystem damage
5940 $cf = "unknown" unless length($cf);
5941 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
5942 (The test -f "$mpl" returned false.)
5943 Writing one on our own (setting NAME to $cf)\a\n});
5944 $self->{had_no_makefile_pl}++;
5945 $CPAN::Frontend->mysleep(3);
5947 # Writing our own Makefile.PL
5950 if ($self->{archived} eq "maybe_pl") {
5951 my $fh = FileHandle->new;
5952 my $script_file = File::Spec->catfile($packagedir,$local_file);
5953 $fh->open($script_file)
5954 or Carp::croak("Could not open $script_file: $!");
5956 # name parsen und prereq
5957 my($state) = "poddir";
5958 my($name, $prereq) = ("", "");
5960 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
5963 } elsif ($1 eq 'PREREQUISITES') {
5966 } elsif ($state =~ m{^(name|prereq)$}) {
5971 } elsif ($state eq "name") {
5976 } elsif ($state eq "prereq") {
5979 } elsif (/^=cut\b/) {
5986 s{.*<}{}; # strip X<...>
5990 $prereq = join " ", split /\s+/, $prereq;
5991 my($PREREQ_PM) = join("\n", map {
5992 s{.*<}{}; # strip X<...>
5994 if (/[\s\'\"]/) { # prose?
5996 s/[^\w:]$//; # period?
5997 " "x28 . "'$_' => 0,";
5999 } split /\s*,\s*/, $prereq);
6002 EXE_FILES => ['$name'],
6008 my $to_file = File::Spec->catfile($packagedir, $name);
6009 rename $script_file, $to_file
6010 or die "Can't rename $script_file to $to_file: $!";
6014 my $fh = FileHandle->new;
6016 or Carp::croak("Could not open >$mpl: $!");
6018 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6019 # because there was no Makefile.PL supplied.
6020 # Autogenerated on: }.scalar localtime().qq{
6022 use ExtUtils::MakeMaker;
6024 NAME => q[$cf],$script
6031 #-> CPAN::Distribution::_signature_business
6032 sub _signature_business {
6034 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6037 if ($CPAN::META->has_inst("Module::Signature")) {
6038 if (-f "SIGNATURE") {
6039 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6040 my $rv = Module::Signature::verify();
6041 if ($rv != Module::Signature::SIGNATURE_OK() and
6042 $rv != Module::Signature::SIGNATURE_MISSING()) {
6043 $CPAN::Frontend->mywarn(
6044 qq{\nSignature invalid for }.
6045 qq{distribution file. }.
6046 qq{Please investigate.\n\n}
6050 sprintf(qq{I'd recommend removing %s. Its signature
6051 is invalid. Maybe you have configured your 'urllist' with
6052 a bad URL. Please check this array with 'o conf urllist', and
6053 retry. For more information, try opening a subshell with
6061 $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6062 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6063 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6065 $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6066 $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6069 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6072 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6077 #-> CPAN::Distribution::untar_me ;
6080 $self->{archived} = "tar";
6082 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6084 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6088 # CPAN::Distribution::unzip_me ;
6091 $self->{archived} = "zip";
6093 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6095 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6100 sub handle_singlefile {
6101 my($self,$local_file) = @_;
6103 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6104 $self->{archived} = "pm";
6106 $self->{archived} = "maybe_pl";
6109 my $to = File::Basename::basename($local_file);
6110 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6111 if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6112 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6114 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6117 File::Copy::cp($local_file,".");
6118 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6123 #-> sub CPAN::Distribution::new ;
6125 my($class,%att) = @_;
6127 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6129 my $this = { %att };
6130 return bless $this, $class;
6133 #-> sub CPAN::Distribution::look ;
6137 if ($^O eq 'MacOS') {
6138 $self->Mac::BuildTools::look;
6142 if ( $CPAN::Config->{'shell'} ) {
6143 $CPAN::Frontend->myprint(qq{
6144 Trying to open a subshell in the build directory...
6147 $CPAN::Frontend->myprint(qq{
6148 Your configuration does not define a value for subshells.
6149 Please define it with "o conf shell <your shell>"
6153 my $dist = $self->id;
6155 unless ($dir = $self->dir) {
6158 unless ($dir ||= $self->dir) {
6159 $CPAN::Frontend->mywarn(qq{
6160 Could not determine which directory to use for looking at $dist.
6164 my $pwd = CPAN::anycwd();
6165 $self->safe_chdir($dir);
6166 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6168 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6169 $ENV{CPAN_SHELL_LEVEL} += 1;
6170 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6171 unless (system($shell) == 0) {
6173 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6176 $self->safe_chdir($pwd);
6179 # CPAN::Distribution::cvs_import ;
6183 my $dir = $self->dir;
6185 my $package = $self->called_for;
6186 my $module = $CPAN::META->instance('CPAN::Module', $package);
6187 my $version = $module->cpan_version;
6189 my $userid = $self->cpan_userid;
6191 my $cvs_dir = (split /\//, $dir)[-1];
6192 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6194 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6196 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6197 if ($cvs_site_perl) {
6198 $cvs_dir = "$cvs_site_perl/$cvs_dir";
6200 my $cvs_log = qq{"imported $package $version sources"};
6201 $version =~ s/\./_/g;
6202 # XXX cvs: undocumented and unclear how it was meant to work
6203 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6204 "$cvs_dir", $userid, "v$version");
6206 my $pwd = CPAN::anycwd();
6207 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6209 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6211 $CPAN::Frontend->myprint(qq{@cmd\n});
6212 system(@cmd) == 0 or
6214 $CPAN::Frontend->mydie("cvs import failed");
6215 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6218 #-> sub CPAN::Distribution::readme ;
6221 my($dist) = $self->id;
6222 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6223 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6226 File::Spec->catfile(
6227 $CPAN::Config->{keep_source_where},
6230 split(/\//,"$sans.readme"),
6232 $self->debug("Doing localize") if $CPAN::DEBUG;
6233 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6235 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6237 if ($^O eq 'MacOS') {
6238 Mac::BuildTools::launch_file($local_file);
6242 my $fh_pager = FileHandle->new;
6243 local($SIG{PIPE}) = "IGNORE";
6244 my $pager = $CPAN::Config->{'pager'} || "cat";
6245 $fh_pager->open("|$pager")
6246 or die "Could not open pager $pager\: $!";
6247 my $fh_readme = FileHandle->new;
6248 $fh_readme->open($local_file)
6249 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6250 $CPAN::Frontend->myprint(qq{
6255 $fh_pager->print(<$fh_readme>);
6259 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6260 sub verifyCHECKSUM {
6264 $self->{CHECKSUM_STATUS} ||= "";
6265 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6266 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6268 my($lc_want,$lc_file,@local,$basename);
6269 @local = split(/\//,$self->id);
6271 push @local, "CHECKSUMS";
6273 File::Spec->catfile($CPAN::Config->{keep_source_where},
6274 "authors", "id", @local);
6276 if (my $size = -s $lc_want) {
6277 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6278 if ($self->CHECKSUM_check_file($lc_want,1)) {
6279 return $self->{CHECKSUM_STATUS} = "OK";
6282 $lc_file = CPAN::FTP->localize("authors/id/@local",
6285 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6286 $local[-1] .= ".gz";
6287 $lc_file = CPAN::FTP->localize("authors/id/@local",
6290 $lc_file =~ s/\.gz(?!\n)\Z//;
6291 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6296 if ($self->CHECKSUM_check_file($lc_file)) {
6297 return $self->{CHECKSUM_STATUS} = "OK";
6301 #-> sub CPAN::Distribution::SIG_check_file ;
6302 sub SIG_check_file {
6303 my($self,$chk_file) = @_;
6304 my $rv = eval { Module::Signature::_verify($chk_file) };
6306 if ($rv == Module::Signature::SIGNATURE_OK()) {
6307 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6308 return $self->{SIG_STATUS} = "OK";
6310 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6311 qq{distribution file. }.
6312 qq{Please investigate.\n\n}.
6314 $CPAN::META->instance(
6319 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6320 is invalid. Maybe you have configured your 'urllist' with
6321 a bad URL. Please check this array with 'o conf urllist', and
6324 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6328 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6330 # sloppy is 1 when we have an old checksums file that maybe is good
6333 sub CHECKSUM_check_file {
6334 my($self,$chk_file,$sloppy) = @_;
6335 my($cksum,$file,$basename);
6338 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6339 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6342 if ($CPAN::META->has_inst("Module::Signature")) {
6343 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6344 $self->SIG_check_file($chk_file);
6346 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6350 $file = $self->{localfile};
6351 $basename = File::Basename::basename($file);
6352 my $fh = FileHandle->new;
6353 if (open $fh, $chk_file){
6356 $eval =~ s/\015?\012/\n/g;
6358 my($comp) = Safe->new();
6359 $cksum = $comp->reval($eval);
6361 rename $chk_file, "$chk_file.bad";
6362 Carp::confess($@) if $@;
6365 Carp::carp "Could not open $chk_file for reading";
6368 if (! ref $cksum or ref $cksum ne "HASH") {
6369 $CPAN::Frontend->mywarn(qq{
6370 Warning: checksum file '$chk_file' broken.
6372 When trying to read that file I expected to get a hash reference
6373 for further processing, but got garbage instead.
6375 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6376 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6377 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6379 } elsif (exists $cksum->{$basename}{sha256}) {
6380 $self->debug("Found checksum for $basename:" .
6381 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6385 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6387 $fh = CPAN::Tarzip->TIEHANDLE($file);
6390 my $dg = Digest::SHA->new(256);
6393 while ($fh->READ($ref, 4096) > 0){
6396 my $hexdigest = $dg->hexdigest;
6397 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6401 $CPAN::Frontend->myprint("Checksum for $file ok\n");
6402 return $self->{CHECKSUM_STATUS} = "OK";
6404 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6405 qq{distribution file. }.
6406 qq{Please investigate.\n\n}.
6408 $CPAN::META->instance(
6413 my $wrap = qq{I\'d recommend removing $file. Its
6414 checksum is incorrect. Maybe you have configured your 'urllist' with
6415 a bad URL. Please check this array with 'o conf urllist', and
6418 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6420 # former versions just returned here but this seems a
6421 # serious threat that deserves a die
6423 # $CPAN::Frontend->myprint("\n\n");
6427 # close $fh if fileno($fh);
6430 unless ($self->{CHECKSUM_STATUS}) {
6431 $CPAN::Frontend->mywarn(qq{
6432 Warning: No checksum for $basename in $chk_file.
6434 The cause for this may be that the file is very new and the checksum
6435 has not yet been calculated, but it may also be that something is
6436 going awry right now.
6438 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6439 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6441 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6446 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6448 my($self,$fh,$expect) = @_;
6449 if ($CPAN::META->has_inst("Digest::SHA")) {
6450 my $dg = Digest::SHA->new(256);
6452 while (read($fh, $data, 4096)){
6455 my $hexdigest = $dg->hexdigest;
6456 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6457 return $hexdigest eq $expect;
6462 #-> sub CPAN::Distribution::force ;
6464 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6465 # effect by autoinspection, not by inspecting a global variable. One
6466 # of the reason why this was chosen to work that way was the treatment
6467 # of dependencies. They should not automatically inherit the force
6468 # status. But this has the downside that ^C and die() will return to
6469 # the prompt but will not be able to reset the force_update
6470 # attributes. We try to correct for it currently in the read_metadata
6471 # routine, and immediately before we check for a Signal. I hope this
6472 # works out in one of v1.57_53ff
6474 # "Force get forgets previous error conditions"
6476 #-> sub CPAN::Distribution::fforce ;
6478 my($self, $method) = @_;
6479 $self->force($method,1);
6482 #-> sub CPAN::Distribution::force ;
6484 my($self, $method,$fforce) = @_;
6502 "prereq_pm_detected",
6516 my $methodmatch = 0;
6518 PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6519 $methodmatch = 1 if $fforce || $phase eq $method;
6520 next unless $methodmatch;
6521 ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6522 if ($phase eq "get") {
6523 if (substr($self->id,-1,1) eq "."
6524 && $att =~ /(unwrapped|build_dir|archived)/ ) {
6525 # cannot be undone for local distros
6528 if ($att eq "build_dir"
6529 && $self->{build_dir}
6530 && $CPAN::META->{is_tested}
6532 delete $CPAN::META->{is_tested}{$self->{build_dir}};
6534 } elsif ($phase eq "test") {
6535 if ($att eq "make_test"
6536 && $self->{make_test}
6537 && $self->{make_test}{COMMANDID}
6538 && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6540 # endless loop too likely
6544 delete $self->{$att};
6545 if ($ldebug || $CPAN::DEBUG) {
6546 # local $CPAN::DEBUG = 16; # Distribution
6547 CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6551 if ($method && $method =~ /make|test|install/) {
6552 $self->{force_update} = 1; # name should probably have been force_install
6556 #-> sub CPAN::Distribution::notest ;
6558 my($self, $method) = @_;
6559 # warn "XDEBUG: set notest for $self $method";
6560 $self->{"notest"}++; # name should probably have been force_install
6563 #-> sub CPAN::Distribution::unnotest ;
6566 # warn "XDEBUG: deleting notest";
6567 delete $self->{'notest'};
6570 #-> sub CPAN::Distribution::unforce ;
6573 delete $self->{force_update};
6576 #-> sub CPAN::Distribution::isa_perl ;
6579 my $file = File::Basename::basename($self->id);
6580 if ($file =~ m{ ^ perl
6589 \.tar[._-](?:gz|bz2)
6593 } elsif ($self->cpan_comment
6595 $self->cpan_comment =~ /isa_perl\(.+?\)/){
6601 #-> sub CPAN::Distribution::perl ;
6606 carp __PACKAGE__ . "::perl was called without parameters.";
6608 return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6612 #-> sub CPAN::Distribution::make ;
6615 if (my $goto = $self->prefs->{goto}) {
6616 return $self->goto($goto);
6618 my $make = $self->{modulebuild} ? "Build" : "make";
6619 # Emergency brake if they said install Pippi and get newest perl
6620 if ($self->isa_perl) {
6622 $self->called_for ne $self->id &&
6623 ! $self->{force_update}
6625 # if we die here, we break bundles
6628 qq{The most recent version "%s" of the module "%s"
6629 is part of the perl-%s distribution. To install that, you need to run
6630 force install %s --or--
6633 $CPAN::META->instance(
6642 $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6643 $CPAN::Frontend->mysleep(1);
6647 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6649 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6651 : ($ENV{PERLLIB} || "");
6652 $CPAN::META->set_perl5lib;
6653 local $ENV{MAKEFLAGS}; # protect us from outer make calls
6656 delete $self->{force_update};
6663 if (!$self->{archived} || $self->{archived} eq "NO") {
6664 push @e, "Is neither a tar nor a zip archive.";
6667 if (!$self->{unwrapped}
6669 UNIVERSAL::can($self->{unwrapped},"failed") ?
6670 $self->{unwrapped}->failed :
6671 $self->{unwrapped} =~ /^NO/
6673 push @e, "Had problems unarchiving. Please build manually";
6676 unless ($self->{force_update}) {
6677 exists $self->{signature_verify} and
6679 UNIVERSAL::can($self->{signature_verify},"failed") ?
6680 $self->{signature_verify}->failed :
6681 $self->{signature_verify} =~ /^NO/
6683 and push @e, "Did not pass the signature test.";
6686 if (exists $self->{writemakefile} &&
6688 UNIVERSAL::can($self->{writemakefile},"failed") ?
6689 $self->{writemakefile}->failed :
6690 $self->{writemakefile} =~ /^NO/
6692 # XXX maybe a retry would be in order?
6693 my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6694 $self->{writemakefile}->text :
6695 $self->{writemakefile};
6697 $err ||= "Had some problem writing Makefile";
6698 $err .= ", won't make";
6702 defined $self->{make} and push @e,
6703 "Has already been made";
6705 if (exists $self->{later} and length($self->{later})) {
6706 if ($self->unsat_prereq) {
6707 push @e, $self->{later};
6708 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6709 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6710 # are not sufficient to be sure if we really must/may do the delete
6711 # here. SO I accept the suggested patch for now. If we trigger a bug
6712 # again, I must go into deep contemplation about the {later} flag.
6715 # delete $self->{later};
6719 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6720 $builddir = $self->dir or
6721 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6722 unless (chdir $builddir) {
6723 push @e, "Couldn't chdir to '$builddir': $!";
6725 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
6728 delete $self->{force_update};
6731 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
6732 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6734 if ($^O eq 'MacOS') {
6735 Mac::BuildTools::make($self);
6740 while (my($k,$v) = each %ENV) {
6741 next unless defined $v;
6746 if (my $commandline = $self->prefs->{pl}{commandline}) {
6747 $system = $commandline;
6749 } elsif ($self->{'configure'}) {
6750 $system = $self->{'configure'};
6751 } elsif ($self->{modulebuild}) {
6752 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6753 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6755 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6757 # This needs a handler that can be turned on or off:
6758 # $switch = "-MExtUtils::MakeMaker ".
6759 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6761 my $makepl_arg = $self->make_x_arg("pl");
6762 $system = sprintf("%s%s Makefile.PL%s",
6764 $switch ? " $switch" : "",
6765 $makepl_arg ? " $makepl_arg" : "",
6768 if (my $env = $self->prefs->{pl}{env}) {
6769 for my $e (keys %$env) {
6770 $ENV{$e} = $env->{$e};
6773 if (exists $self->{writemakefile}) {
6775 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6779 if ($CPAN::Config->{inactivity_timeout}) {
6781 if ($Config::Config{d_alarm}
6783 $Config::Config{d_alarm} eq "define"
6787 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6788 "variable 'inactivity_timeout' to ".
6789 "'$CPAN::Config->{inactivity_timeout}'. But ".
6790 "on this machine the system call 'alarm' ".
6791 "isn't available. This means that we cannot ".
6792 "provide the feature of intercepting long ".
6793 "waiting code and will turn this feature off.\n"
6795 $CPAN::Config->{inactivity_timeout} = 0;
6798 if ($go_via_alarm) {
6800 alarm $CPAN::Config->{inactivity_timeout};
6801 local $SIG{CHLD}; # = sub { wait };
6802 if (defined($pid = fork)) {
6807 # note, this exec isn't necessary if
6808 # inactivity_timeout is 0. On the Mac I'd
6809 # suggest, we set it always to 0.
6813 $CPAN::Frontend->myprint("Cannot fork: $!");
6822 $CPAN::Frontend->myprint($err);
6823 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6828 if (my $expect_model = $self->_prefs_with_expect("pl")) {
6829 $ret = $self->_run_via_expect($system,$expect_model);
6831 && $self->{writemakefile}
6832 && $self->{writemakefile}->failed) {
6837 $ret = system($system);
6840 $self->{writemakefile} = CPAN::Distrostatus
6841 ->new("NO '$system' returned status $ret");
6842 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6843 $self->store_persistent_state;
6844 $self->store_persistent_state;
6848 if (-f "Makefile" || -f "Build") {
6849 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6850 delete $self->{make_clean}; # if cleaned before, enable next
6852 $self->{writemakefile} = CPAN::Distrostatus
6853 ->new(qq{NO -- Unknown reason});
6857 delete $self->{force_update};
6860 if (my @prereq = $self->unsat_prereq){
6861 if ($prereq[0][0] eq "perl") {
6862 my $need = "requires perl '$prereq[0][1]'";
6863 my $id = $self->pretty_id;
6864 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6865 $self->{make} = CPAN::Distrostatus->new("NO $need");
6866 $self->store_persistent_state;
6869 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6873 delete $self->{force_update};
6876 if (my $commandline = $self->prefs->{make}{commandline}) {
6877 $system = $commandline;
6880 if ($self->{modulebuild}) {
6881 unless (-f "Build") {
6882 my $cwd = CPAN::anycwd();
6883 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6884 " in cwd[$cwd]. Danger, Will Robinson!");
6885 $CPAN::Frontend->mysleep(5);
6887 $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
6889 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
6891 $system =~ s/\s+$//;
6892 my $make_arg = $self->make_x_arg("make");
6893 $system = sprintf("%s%s",
6895 $make_arg ? " $make_arg" : "",
6898 if (my $env = $self->prefs->{make}{env}) { # overriding the local
6899 # ENV of PL, not the
6901 # unlikely to be a risk
6902 for my $e (keys %$env) {
6903 $ENV{$e} = $env->{$e};
6906 my $expect_model = $self->_prefs_with_expect("make");
6907 my $want_expect = 0;
6908 if ( $expect_model && @{$expect_model->{talk}} ) {
6909 my $can_expect = $CPAN::META->has_inst("Expect");
6913 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
6919 $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
6921 $system_ok = system($system) == 0;
6923 $self->introduce_myself;
6925 $CPAN::Frontend->myprint(" $system -- OK\n");
6926 $self->{make} = CPAN::Distrostatus->new("YES");
6928 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
6929 $self->{make} = CPAN::Distrostatus->new("NO");
6930 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
6932 $self->store_persistent_state;
6935 # CPAN::Distribution::_run_via_expect
6936 sub _run_via_expect {
6937 my($self,$system,$expect_model) = @_;
6938 CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
6939 if ($CPAN::META->has_inst("Expect")) {
6940 my $expo = Expect->new; # expo Expect object;
6941 $expo->spawn($system);
6942 $expect_model->{mode} ||= "deterministic";
6943 if ($expect_model->{mode} eq "deterministic") {
6944 return $self->_run_via_expect_deterministic($expo,$expect_model);
6945 } elsif ($expect_model->{mode} eq "anyorder") {
6946 return $self->_run_via_expect_anyorder($expo,$expect_model);
6948 die "Panic: Illegal expect mode: $expect_model->{mode}";
6951 $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
6952 return system($system);
6956 sub _run_via_expect_anyorder {
6957 my($self,$expo,$expect_model) = @_;
6958 my $timeout = $expect_model->{timeout} || 5;
6959 my @expectacopy = @{$expect_model->{talk}}; # we trash it!
6962 my($eof,$ran_into_timeout);
6963 my @match = $expo->expect($timeout,
6968 $ran_into_timeout++;
6975 $but .= $expo->clear_accum;
6978 return $expo->exitstatus();
6979 } elsif ($ran_into_timeout) {
6980 # warn "DEBUG: they are asking a question, but[$but]";
6981 for (my $i = 0; $i <= $#expectacopy; $i+=2) {
6982 my($next,$send) = @expectacopy[$i,$i+1];
6983 my $regex = eval "qr{$next}";
6984 # warn "DEBUG: will compare with regex[$regex].";
6985 if ($but =~ /$regex/) {
6986 # warn "DEBUG: will send send[$send]";
6988 splice @expectacopy, $i, 2; # never allow reusing an QA pair
6992 my $why = "could not answer a question during the dialog";
6993 $CPAN::Frontend->mywarn("Failing: $why\n");
6994 $self->{writemakefile} =
6995 CPAN::Distrostatus->new("NO $why");
7001 sub _run_via_expect_deterministic {
7002 my($self,$expo,$expect_model) = @_;
7003 my $ran_into_timeout;
7004 my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7005 my $expecta = $expect_model->{talk};
7006 EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7007 my($re,$send) = @$expecta[$i,$i+1];
7008 CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7009 my $regex = eval "qr{$re}";
7010 $expo->expect($timeout,
7012 my $but = $expo->clear_accum;
7013 $CPAN::Frontend->mywarn("EOF (maybe harmless)
7014 expected[$regex]\nbut[$but]\n\n");
7018 my $but = $expo->clear_accum;
7019 $CPAN::Frontend->mywarn("TIMEOUT
7020 expected[$regex]\nbut[$but]\n\n");
7021 $ran_into_timeout++;
7024 if ($ran_into_timeout){
7025 # note that the caller expects 0 for success
7026 $self->{writemakefile} =
7027 CPAN::Distrostatus->new("NO timeout during expect dialog");
7033 return $expo->exitstatus();
7036 #-> CPAN::Distribution::_validate_distropref
7037 sub _validate_distropref {
7038 my($self,@args) = @_;
7040 $CPAN::META->has_inst("CPAN::Kwalify")
7042 $CPAN::META->has_inst("Kwalify")
7044 eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7046 $CPAN::Frontend->mywarn($@);
7049 CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7053 #-> CPAN::Distribution::_find_prefs
7056 my $distroid = $self->pretty_id;
7057 #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7058 my $prefs_dir = $CPAN::Config->{prefs_dir};
7059 eval { File::Path::mkpath($prefs_dir); };
7061 $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7063 my $yaml_module = CPAN::_yaml_module;
7065 if ($CPAN::META->has_inst($yaml_module)) {
7066 push @extensions, "yml";
7069 if ($CPAN::META->has_inst("Data::Dumper")) {
7070 push @extensions, "dd";
7071 push @fallbacks, "Data::Dumper";
7073 if ($CPAN::META->has_inst("Storable")) {
7074 push @extensions, "st";
7075 push @fallbacks, "Storable";
7079 unless ($self->{have_complained_about_missing_yaml}++) {
7080 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7081 "to @fallbacks to read prefs '$prefs_dir'\n");
7084 unless ($self->{have_complained_about_missing_yaml}++) {
7085 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7086 "read prefs '$prefs_dir'\n");
7091 my $dh = DirHandle->new($prefs_dir)
7092 or die Carp::croak("Couldn't open '$prefs_dir': $!");
7093 DIRENT: for (sort $dh->read) {
7094 next if $_ eq "." || $_ eq "..";
7095 my $exte = join "|", @extensions;
7096 next unless /\.($exte)$/;
7098 my $abs = File::Spec->catfile($prefs_dir, $_);
7100 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7102 if ($thisexte eq "yml") {
7103 # need no eval because if we have no YAML we do not try to read *.yml
7104 #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7105 @distropref = @{CPAN->_yaml_loadfile($abs)};
7106 #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7107 } elsif ($thisexte eq "dd") {
7110 open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7116 $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7119 while (${"VAR".$i}) {
7120 push @distropref, ${"VAR".$i};
7123 } elsif ($thisexte eq "st") {
7124 # eval because Storable is never forward compatible
7125 eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7127 $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7128 "$_, skipping\: $@");
7129 $CPAN::Frontend->mysleep(4);
7134 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7135 ELEMENT: for my $y (0..$#distropref) {
7136 my $distropref = $distropref[$y];
7137 $self->_validate_distropref($distropref,$abs,$y);
7138 my $match = $distropref->{match};
7140 #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7144 # do not take the order of C<keys %$match> because
7145 # "module" is by far the slowest
7146 for my $sub_attribute (qw(distribution perl module)) {
7147 next unless exists $match->{$sub_attribute};
7148 my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7149 if ($sub_attribute eq "module") {
7151 #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7152 my @modules = $self->containsmods;
7153 #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7154 MODULE: for my $module (@modules) {
7155 $okm ||= $module =~ /$qr/;
7156 last MODULE if $okm;
7159 } elsif ($sub_attribute eq "distribution") {
7160 my $okd = $distroid =~ /$qr/;
7162 } elsif ($sub_attribute eq "perl") {
7163 my $okp = $^X =~ /$qr/;
7166 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7167 "unknown sub_attribut '$sub_attribute'. ".
7169 "remove, cannot continue.");
7171 last if $ok == 0; # short circuit
7173 #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7176 prefs => $distropref,
7178 prefs_file_doc => $y,
7190 # CPAN::Distribution::prefs
7193 if (exists $self->{prefs}) {
7194 return $self->{prefs}; # XXX comment out during debugging
7196 if ($CPAN::Config->{prefs_dir}) {
7197 CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7198 my $prefs = $self->_find_prefs();
7199 $prefs ||= ""; # avoid warning next line
7200 CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7202 for my $x (qw(prefs prefs_file prefs_file_doc)) {
7203 $self->{$x} = $prefs->{$x};
7207 File::Basename::basename($self->{prefs_file}),
7208 $self->{prefs_file_doc},
7210 my $filler1 = "_" x 22;
7211 my $filler2 = int(66 - length($bs))/2;
7212 $filler2 = 0 if $filler2 < 0;
7213 $filler2 = " " x $filler2;
7214 $CPAN::Frontend->myprint("
7215 $filler1 D i s t r o P r e f s $filler1
7216 $filler2 $bs $filler2
7218 $CPAN::Frontend->mysleep(1);
7219 return $self->{prefs};
7225 # CPAN::Distribution::make_x_arg
7227 my($self, $whixh) = @_;
7229 my $prefs = $self->prefs;
7232 && exists $prefs->{$whixh}
7233 && exists $prefs->{$whixh}{args}
7234 && $prefs->{$whixh}{args}
7236 $make_x_arg = join(" ",
7237 map {CPAN::HandleConfig
7238 ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7241 my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7242 $make_x_arg ||= $CPAN::Config->{$what};
7246 # CPAN::Distribution::_make_command
7253 CPAN::HandleConfig->prefs_lookup($self,
7255 || $Config::Config{make}
7259 # Old style call, without object. Deprecated
7260 Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7263 CPAN::HandleConfig->prefs_lookup($self,q{make})
7264 || $CPAN::Config->{make}
7265 || $Config::Config{make}
7270 #-> sub CPAN::Distribution::follow_prereqs ;
7271 sub follow_prereqs {
7273 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7274 return unless @prereq_tuples;
7275 my @prereq = map { $_->[0] } @prereq_tuples;
7276 my $pretty_id = $self->pretty_id;
7278 b => "build_requires",
7282 my($filler1,$filler2,$filler3,$filler4);
7283 my $unsat = "Unsatisfied dependencies detected during";
7284 my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7286 my $r = int(($w - length($unsat))/2);
7287 my $l = $w - length($unsat) - $r;
7288 $filler1 = "-"x4 . " "x$l;
7289 $filler2 = " "x$r . "-"x4 . "\n";
7292 my $r = int(($w - length($pretty_id))/2);
7293 my $l = $w - length($pretty_id) - $r;
7294 $filler3 = "-"x4 . " "x$l;
7295 $filler4 = " "x$r . "-"x4 . "\n";
7298 myprint("$filler1 $unsat $filler2".
7299 "$filler3 $pretty_id $filler4".
7300 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7303 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7305 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7306 my $answer = CPAN::Shell::colorable_makemaker_prompt(
7307 "Shall I follow them and prepend them to the queue
7308 of modules we are processing right now?", "yes");
7309 $follow = $answer =~ /^\s*y/i;
7313 myprint(" Ignoring dependencies on modules @prereq\n");
7317 # color them as dirty
7318 for my $p (@prereq) {
7319 # warn "calling color_cmd_tmps(0,1)";
7320 my $any = CPAN::Shell->expandany($p);
7322 $any->color_cmd_tmps(0,1);
7324 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7325 $CPAN::Frontend->mysleep(2);
7328 # queue them and re-queue yourself
7329 CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7330 reverse @prereq_tuples);
7331 $self->{later} = "Delayed until after prerequisites";
7332 return 1; # signal success to the queuerunner
7336 #-> sub CPAN::Distribution::unsat_prereq ;
7337 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7338 # return ([perl=>5.008]) if we need a newer perl than we are running under
7341 my $prereq_pm = $self->prereq_pm or return;
7343 my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7344 NEED: while (my($need_module, $need_version) = each %merged) {
7345 my($available_version,$available_file);
7346 if ($need_module eq "perl") {
7347 $available_version = $];
7348 $available_file = $^X;
7350 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7351 next if $nmo->uptodate;
7352 $available_file = $nmo->available_file;
7354 # if they have not specified a version, we accept any installed one
7355 if (not defined $need_version or
7356 $need_version eq "0" or
7357 $need_version eq "undef") {
7358 next if defined $available_file;
7361 $available_version = $nmo->available_version;
7364 # We only want to install prereqs if either they're not installed
7365 # or if the installed version is too old. We cannot omit this
7366 # check, because if 'force' is in effect, nobody else will check.
7367 if (defined $available_file) {
7368 my(@all_requirements) = split /\s*,\s*/, $need_version;
7371 RQ: for my $rq (@all_requirements) {
7372 if ($rq =~ s|>=\s*||) {
7373 } elsif ($rq =~ s|>\s*||) {
7375 if (CPAN::Version->vgt($available_version,$rq)){
7379 } elsif ($rq =~ s|!=\s*||) {
7381 if (CPAN::Version->vcmp($available_version,$rq)){
7387 } elsif ($rq =~ m|<=?\s*|) {
7389 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7393 if (! CPAN::Version->vgt($rq, $available_version)){
7396 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7397 "available_version[%s]rq[%s]ok[%d]",
7401 CPAN::Version->readable($rq),
7405 next NEED if $ok == @all_requirements;
7408 if ($need_module eq "perl") {
7409 return ["perl", $need_version];
7411 if ($self->{sponsored_mods}{$need_module}++){
7412 # We have already sponsored it and for some reason it's still
7413 # not available. So we do nothing. Or what should we do?
7414 # if we push it again, we have a potential infinite loop
7417 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7418 push @need, [$need_module,$needed_as];
7423 #-> sub CPAN::Distribution::read_yaml ;
7426 return $self->{yaml_content} if exists $self->{yaml_content};
7427 my $build_dir = $self->{build_dir};
7428 my $yaml = File::Spec->catfile($build_dir,"META.yml");
7429 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7430 return unless -f $yaml;
7431 eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7433 $CPAN::Frontend->mywarn("Could not read ".
7434 "'$yaml'. Falling back to other ".
7435 "methods to determine prerequisites\n");
7436 return $self->{yaml_content} = undef; # if we die, then we
7437 # cannot read YAML's own
7440 if (not exists $self->{yaml_content}{dynamic_config}
7441 or $self->{yaml_content}{dynamic_config}
7443 $self->{yaml_content} = undef;
7445 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7447 return $self->{yaml_content};
7450 #-> sub CPAN::Distribution::prereq_pm ;
7453 $self->{prereq_pm_detected} ||= 0;
7454 CPAN->debug("prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7455 return $self->{prereq_pm} if $self->{prereq_pm_detected};
7456 return unless $self->{writemakefile} # no need to have succeeded
7457 # but we must have run it
7458 || $self->{modulebuild};
7459 CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7460 $self->{writemakefile}||"",
7461 $self->{modulebuild}||"",
7464 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7465 $req = $yaml->{requires} || {};
7466 $breq = $yaml->{build_requires} || {};
7467 undef $req unless ref $req eq "HASH" && %$req;
7469 if ($yaml->{generated_by} &&
7470 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7471 my $eummv = do { local $^W = 0; $1+0; };
7472 if ($eummv < 6.2501) {
7473 # thanks to Slaven for digging that out: MM before
7474 # that could be wrong because it could reflect a
7481 while (my($k,$v) = each %{$req||{}}) {
7484 } elsif ($k =~ /[A-Za-z]/ &&
7486 $CPAN::META->exists("Module",$v)
7488 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7489 "requires hash: $k => $v; I'll take both ".
7490 "key and value as a module name\n");
7491 $CPAN::Frontend->mysleep(1);
7497 $req = $areq if $do_replace;
7500 unless ($req || $breq) {
7501 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7502 my $makefile = File::Spec->catfile($build_dir,"Makefile");
7506 $fh = FileHandle->new("<$makefile\0")) {
7507 CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7510 last if /MakeMaker post_initialize section/;
7512 \s+PREREQ_PM\s+=>\s+(.+)
7515 # warn "Found prereq expr[$p]";
7517 # Regexp modified by A.Speer to remember actual version of file
7518 # PREREQ_PM hash key wants, then add to
7519 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
7520 # In case a prereq is mentioned twice, complain.
7521 if ( defined $req->{$1} ) {
7522 warn "Warning: PREREQ_PM mentions $1 more than once, ".
7523 "last mention wins";
7531 unless ($req || $breq) {
7532 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7533 my $buildfile = File::Spec->catfile($build_dir,"Build");
7534 if (-f $buildfile) {
7535 CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7536 my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7537 if (-f $build_prereqs) {
7538 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7539 my $content = do { local *FH;
7540 open FH, $build_prereqs
7541 or $CPAN::Frontend->mydie("Could not open ".
7542 "'$build_prereqs': $!");
7546 my $bphash = eval $content;
7549 $req = $bphash->{requires} || +{};
7550 $breq = $bphash->{build_requires} || +{};
7556 && ! -f "Makefile.PL"
7557 && ! exists $req->{"Module::Build"}
7558 && ! $CPAN::META->has_inst("Module::Build")) {
7559 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
7560 "undeclared prerequisite.\n".
7561 " Adding it now as such.\n"
7563 $CPAN::Frontend->mysleep(5);
7564 $req->{"Module::Build"} = 0;
7565 delete $self->{writemakefile};
7567 if ($req || $breq) {
7568 $self->{prereq_pm_detected}++;
7569 return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7573 #-> sub CPAN::Distribution::test ;
7576 if (my $goto = $self->prefs->{goto}) {
7577 return $self->goto($goto);
7581 delete $self->{force_update};
7584 # warn "XDEBUG: checking for notest: $self->{notest} $self";
7585 if ($self->{notest}) {
7586 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7590 my $make = $self->{modulebuild} ? "Build" : "make";
7592 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7594 : ($ENV{PERLLIB} || "");
7596 $CPAN::META->set_perl5lib;
7597 local $ENV{MAKEFLAGS}; # protect us from outer make calls
7599 $CPAN::Frontend->myprint("Running $make test\n");
7600 if (my @prereq = $self->unsat_prereq){
7601 unless ($prereq[0][0] eq "perl") {
7602 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7607 unless (exists $self->{make} or exists $self->{later}) {
7609 "Make had some problems, won't test";
7612 exists $self->{make} and
7614 UNIVERSAL::can($self->{make},"failed") ?
7615 $self->{make}->failed :
7616 $self->{make} =~ /^NO/
7617 ) and push @e, "Can't test without successful make";
7619 $self->{badtestcnt} ||= 0;
7620 $self->{badtestcnt} > 0 and
7621 push @e, "Won't repeat unsuccessful test during this command";
7623 exists $self->{later} and length($self->{later}) and
7624 push @e, $self->{later};
7626 if (exists $self->{build_dir}) {
7627 if ($CPAN::META->{is_tested}{$self->{build_dir}}
7629 exists $self->{make_test}
7632 UNIVERSAL::can($self->{make_test},"failed") ?
7633 $self->{make_test}->failed :
7634 $self->{make_test} =~ /^NO/
7637 push @e, "Has already been tested successfully";
7640 push @e, "Has no own directory";
7642 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7643 unless (chdir $self->{build_dir}) {
7644 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7646 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
7648 $self->debug("Changed directory to $self->{build_dir}")
7651 if ($^O eq 'MacOS') {
7652 Mac::BuildTools::make_test($self);
7656 if ($self->{modulebuild}) {
7657 my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7658 if (CPAN::Version->vlt($v,2.62)) {
7659 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7660 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7661 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7667 if (my $commandline = $self->prefs->{test}{commandline}) {
7668 $system = $commandline;
7670 } elsif ($self->{modulebuild}) {
7671 $system = sprintf "%s test", $self->_build_command();
7673 $system = join " ", $self->_make_command(), "test";
7677 while (my($k,$v) = each %ENV) {
7678 next unless defined $v;
7682 if (my $env = $self->prefs->{test}{env}) {
7683 for my $e (keys %$env) {
7684 $ENV{$e} = $env->{$e};
7687 my $expect_model = $self->_prefs_with_expect("test");
7688 my $want_expect = 0;
7689 if ( $expect_model && @{$expect_model->{talk}} ) {
7690 my $can_expect = $CPAN::META->has_inst("Expect");
7694 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7695 "testing without\n");
7698 my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7702 my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7706 $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7707 "testing without\n");
7710 my $ready_to_report = $want_report;
7711 if ($ready_to_report
7713 substr($self->id,-1,1) eq "."
7715 $self->author->id eq "LOCAL"
7718 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7719 "for local directories\n");
7720 $ready_to_report = 0;
7722 if ($ready_to_report
7724 $self->prefs->{patches}
7726 @{$self->prefs->{patches}}
7730 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7731 "when the source has been patched\n");
7732 $ready_to_report = 0;
7735 if ($ready_to_report) {
7736 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7737 "not supported when distroprefs specify ".
7738 "an interactive test\n");
7740 $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7741 } elsif ( $ready_to_report ) {
7742 $tests_ok = CPAN::Reporter::test($self, $system);
7744 $tests_ok = system($system) == 0;
7746 $self->introduce_myself;
7751 # local $CPAN::DEBUG = 16; # Distribution
7752 for my $m (keys %{$self->{sponsored_mods}}) {
7753 my $m_obj = CPAN::Shell->expand("Module",$m);
7754 # XXX we need available_version which reflects
7755 # $ENV{PERL5LIB} so that already tested but not yet
7756 # installed modules are counted.
7757 my $available_version = $m_obj->available_version;
7758 my $available_file = $m_obj->available_file;
7759 if ($available_version &&
7760 !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
7762 CPAN->debug("m[$m] good enough available_version[$available_version]")
7764 } elsif ($available_file
7766 !$self->{prereq_pm}{$m}
7768 $self->{prereq_pm}{$m} == 0
7771 # lex Class::Accessor::Chained::Fast which has no $VERSION
7772 CPAN->debug("m[$m] have available_file[$available_file]")
7780 my $which = join ",", @prereq;
7781 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
7782 "$cnt dependencies missing ($which)";
7783 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
7784 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
7785 $self->store_persistent_state;
7790 $CPAN::Frontend->myprint(" $system -- OK\n");
7791 $self->{make_test} = CPAN::Distrostatus->new("YES");
7792 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
7793 # probably impossible to need the next line because badtestcnt
7794 # has a lifespan of one command
7795 delete $self->{badtestcnt};
7797 $self->{make_test} = CPAN::Distrostatus->new("NO");
7798 $self->{badtestcnt}++;
7799 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
7801 $self->store_persistent_state;
7804 sub _prefs_with_expect {
7805 my($self,$where) = @_;
7806 return unless my $prefs = $self->prefs;
7807 return unless my $where_prefs = $prefs->{$where};
7808 if ($where_prefs->{expect}) {
7810 mode => "deterministic",
7812 talk => $where_prefs->{expect},
7814 } elsif ($where_prefs->{"eexpect"}) {
7815 return $where_prefs->{"eexpect"};
7820 #-> sub CPAN::Distribution::clean ;
7823 my $make = $self->{modulebuild} ? "Build" : "make";
7824 $CPAN::Frontend->myprint("Running $make clean\n");
7825 unless (exists $self->{archived}) {
7826 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
7827 "/untarred, nothing done\n");
7830 unless (exists $self->{build_dir}) {
7831 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
7836 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
7837 push @e, "make clean already called once";
7838 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7840 chdir $self->{build_dir} or
7841 Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
7842 $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
7844 if ($^O eq 'MacOS') {
7845 Mac::BuildTools::make_clean($self);
7850 if ($self->{modulebuild}) {
7851 unless (-f "Build") {
7852 my $cwd = CPAN::anycwd();
7853 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
7854 " in cwd[$cwd]. Danger, Will Robinson!");
7855 $CPAN::Frontend->mysleep(5);
7857 $system = sprintf "%s clean", $self->_build_command();
7859 $system = join " ", $self->_make_command(), "clean";
7861 my $system_ok = system($system) == 0;
7862 $self->introduce_myself;
7864 $CPAN::Frontend->myprint(" $system -- OK\n");
7868 # Jost Krieger pointed out that this "force" was wrong because
7869 # it has the effect that the next "install" on this distribution
7870 # will untar everything again. Instead we should bring the
7871 # object's state back to where it is after untarring.
7882 $self->{make_clean} = CPAN::Distrostatus->new("YES");
7885 # Hmmm, what to do if make clean failed?
7887 $self->{make_clean} = CPAN::Distrostatus->new("NO");
7888 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
7890 # 2006-02-27: seems silly to me to force a make now
7891 # $self->force("make"); # so that this directory won't be used again
7894 $self->store_persistent_state;
7897 #-> sub CPAN::Distribution::goto ;
7899 my($self,$goto) = @_;
7900 $goto = $self->normalize($goto);
7902 # inject into the queue
7904 CPAN::Queue->delete($self->id);
7905 CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
7907 # and run where we left off
7909 my($method) = (caller(1))[3];
7910 CPAN->instance("CPAN::Distribution",$goto)->$method;
7911 CPAN::Queue->delete_first($goto);
7914 #-> sub CPAN::Distribution::install ;
7917 if (my $goto = $self->prefs->{goto}) {
7918 return $self->goto($goto);
7922 delete $self->{force_update};
7925 my $make = $self->{modulebuild} ? "Build" : "make";
7926 $CPAN::Frontend->myprint("Running $make install\n");
7929 unless (exists $self->{make} or exists $self->{later}) {
7931 "Make had some problems, won't install";
7934 exists $self->{make} and
7936 UNIVERSAL::can($self->{make},"failed") ?
7937 $self->{make}->failed :
7938 $self->{make} =~ /^NO/
7940 push @e, "Make had returned bad status, install seems impossible";
7942 if (exists $self->{build_dir}) {
7944 push @e, "Has no own directory";
7947 if (exists $self->{make_test} and
7949 UNIVERSAL::can($self->{make_test},"failed") ?
7950 $self->{make_test}->failed :
7951 $self->{make_test} =~ /^NO/
7953 if ($self->{force_update}) {
7954 $self->{make_test}->text("FAILED but failure ignored because ".
7955 "'force' in effect");
7957 push @e, "make test had returned bad status, ".
7958 "won't install without force"
7961 if (exists $self->{install}) {
7962 if (UNIVERSAL::can($self->{install},"text") ?
7963 $self->{install}->text eq "YES" :
7964 $self->{install} =~ /^YES/
7966 push @e, "Already done";
7968 # comment in Todo on 2006-02-11; maybe retry?
7969 push @e, "Already tried without success";
7973 exists $self->{later} and length($self->{later}) and
7974 push @e, $self->{later};
7976 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
7977 unless (chdir $self->{build_dir}) {
7978 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7980 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
7982 $self->debug("Changed directory to $self->{build_dir}")
7985 if ($^O eq 'MacOS') {
7986 Mac::BuildTools::make_install($self);
7991 if (my $commandline = $self->prefs->{install}{commandline}) {
7992 $system = $commandline;
7994 } elsif ($self->{modulebuild}) {
7995 my($mbuild_install_build_command) =
7996 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
7997 $CPAN::Config->{mbuild_install_build_command} ?
7998 $CPAN::Config->{mbuild_install_build_command} :
7999 $self->_build_command();
8000 $system = sprintf("%s install %s",
8001 $mbuild_install_build_command,
8002 $CPAN::Config->{mbuild_install_arg},
8005 my($make_install_make_command) =
8006 CPAN::HandleConfig->prefs_lookup($self,
8007 q{make_install_make_command})
8008 || $self->_make_command();
8009 $system = sprintf("%s install %s",
8010 $make_install_make_command,
8011 $CPAN::Config->{make_install_arg},
8015 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8016 my $brip = CPAN::HandleConfig->prefs_lookup($self,
8017 q{build_requires_install_policy});
8020 my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8021 my $want_install = "yes";
8022 if ($reqtype eq "b") {
8023 if ($brip eq "no") {
8024 $want_install = "no";
8025 } elsif ($brip =~ m|^ask/(.+)|) {
8027 $default = "yes" unless $default =~ /^(y|n)/i;
8029 CPAN::Shell::colorable_makemaker_prompt
8030 ("$id is just needed temporarily during building or testing. ".
8031 "Do you want to install it permanently? (Y/n)",
8035 unless ($want_install =~ /^y/i) {
8036 my $is_only = "is only 'build_requires'";
8037 $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8038 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8039 delete $self->{force_update};
8042 my($pipe) = FileHandle->new("$system $stderr |");
8045 print $_; # intentionally NOT use Frontend->myprint because it
8046 # looks irritating when we markup in color what we
8047 # just pass through from an external program
8051 my $close_ok = $? == 0;
8052 $self->introduce_myself;
8054 $CPAN::Frontend->myprint(" $system -- OK\n");
8055 $CPAN::META->is_installed($self->{build_dir});
8056 $self->{install} = CPAN::Distrostatus->new("YES");
8058 $self->{install} = CPAN::Distrostatus->new("NO");
8059 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
8061 CPAN::HandleConfig->prefs_lookup($self,
8062 q{make_install_make_command});
8064 $makeout =~ /permission/s
8068 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8072 $CPAN::Frontend->myprint(
8074 qq{ You may have to su }.
8075 qq{to root to install the package\n}.
8076 qq{ (Or you may want to run something like\n}.
8077 qq{ o conf make_install_make_command 'sudo make'\n}.
8078 qq{ to raise your permissions.}
8082 delete $self->{force_update};
8084 $self->store_persistent_state;
8087 sub introduce_myself {
8089 $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
8092 #-> sub CPAN::Distribution::dir ;
8097 #-> sub CPAN::Distribution::perldoc ;
8101 my($dist) = $self->id;
8102 my $package = $self->called_for;
8104 $self->_display_url( $CPAN::Defaultdocs . $package );
8107 #-> sub CPAN::Distribution::_check_binary ;
8109 my ($dist,$shell,$binary) = @_;
8112 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8115 if ($CPAN::META->has_inst("File::Which")) {
8116 return File::Which::which($binary);
8119 $pid = open README, "which $binary|"
8120 or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8126 or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8130 $CPAN::Frontend->myprint(qq{ + $out \n})
8131 if $CPAN::DEBUG && $out;
8136 #-> sub CPAN::Distribution::_display_url ;
8138 my($self,$url) = @_;
8139 my($res,$saved_file,$pid,$out);
8141 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8144 # should we define it in the config instead?
8145 my $html_converter = "html2text";
8147 my $web_browser = $CPAN::Config->{'lynx'} || undef;
8148 my $web_browser_out = $web_browser
8149 ? CPAN::Distribution->_check_binary($self,$web_browser)
8152 if ($web_browser_out) {
8153 # web browser found, run the action
8154 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8155 $CPAN::Frontend->myprint(qq{system[$browser $url]})
8157 $CPAN::Frontend->myprint(qq{
8160 with browser $browser
8162 $CPAN::Frontend->mysleep(1);
8163 system("$browser $url");
8164 if ($saved_file) { 1 while unlink($saved_file) }
8166 # web browser not found, let's try text only
8167 my $html_converter_out =
8168 CPAN::Distribution->_check_binary($self,$html_converter);
8169 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8171 if ($html_converter_out ) {
8172 # html2text found, run it
8173 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8174 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8175 unless defined($saved_file);
8178 $pid = open README, "$html_converter $saved_file |"
8179 or $CPAN::Frontend->mydie(qq{
8180 Could not fork '$html_converter $saved_file': $!});
8182 if ($CPAN::META->has_inst("File::Temp")) {
8183 $fh = File::Temp->new(
8184 template => 'cpan_htmlconvert_XXXX',
8188 $filename = $fh->filename;
8190 $filename = "cpan_htmlconvert_$$.txt";
8191 $fh = FileHandle->new();
8192 open $fh, ">$filename" or die;
8198 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8199 my $tmpin = $fh->filename;
8200 $CPAN::Frontend->myprint(sprintf(qq{
8202 saved output to %s\n},
8210 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8211 my $fh_pager = FileHandle->new;
8212 local($SIG{PIPE}) = "IGNORE";
8213 my $pager = $CPAN::Config->{'pager'} || "cat";
8214 $fh_pager->open("|$pager")
8215 or $CPAN::Frontend->mydie(qq{
8216 Could not open pager '$pager': $!});
8217 $CPAN::Frontend->myprint(qq{
8222 $CPAN::Frontend->mysleep(1);
8223 $fh_pager->print(<FH>);
8226 # coldn't find the web browser or html converter
8227 $CPAN::Frontend->myprint(qq{
8228 You need to install lynx or $html_converter to use this feature.});
8233 #-> sub CPAN::Distribution::_getsave_url ;
8235 my($dist, $shell, $url) = @_;
8237 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8241 if ($CPAN::META->has_inst("File::Temp")) {
8242 $fh = File::Temp->new(
8243 template => "cpan_getsave_url_XXXX",
8247 $filename = $fh->filename;
8249 $fh = FileHandle->new;
8250 $filename = "cpan_getsave_url_$$.html";
8252 my $tmpin = $filename;
8253 if ($CPAN::META->has_usable('LWP')) {
8254 $CPAN::Frontend->myprint("Fetching with LWP:
8258 CPAN::LWP::UserAgent->config;
8259 eval { $Ua = CPAN::LWP::UserAgent->new; };
8261 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8265 $Ua->proxy('http', $var)
8266 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8268 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8271 my $req = HTTP::Request->new(GET => $url);
8272 $req->header('Accept' => 'text/html');
8273 my $res = $Ua->request($req);
8274 if ($res->is_success) {
8275 $CPAN::Frontend->myprint(" + request successful.\n")
8277 print $fh $res->content;
8279 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8283 $CPAN::Frontend->myprint(sprintf(
8284 "LWP failed with code[%s], message[%s]\n",
8291 $CPAN::Frontend->mywarn(" LWP not available\n");
8296 # sub CPAN::Distribution::_build_command
8297 sub _build_command {
8299 if ($^O eq "MSWin32") { # special code needed at least up to
8300 # Module::Build 0.2611 and 0.2706; a fix
8301 # in M:B has been promised 2006-01-30
8302 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8303 return "$perl ./Build";
8308 package CPAN::Bundle;
8313 $CPAN::Frontend->myprint($self->as_string);
8318 delete $self->{later};
8319 for my $c ( $self->contains ) {
8320 my $obj = CPAN::Shell->expandany($c) or next;
8325 # mark as dirty/clean
8326 #-> sub CPAN::Bundle::color_cmd_tmps ;
8327 sub color_cmd_tmps {
8329 my($depth) = shift || 0;
8330 my($color) = shift || 0;
8331 my($ancestors) = shift || [];
8332 # a module needs to recurse to its cpan_file, a distribution needs
8333 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8335 return if exists $self->{incommandcolor}
8336 && $self->{incommandcolor}==$color;
8338 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8340 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8342 for my $c ( $self->contains ) {
8343 my $obj = CPAN::Shell->expandany($c) or next;
8344 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8345 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8347 # never reached code?
8349 #delete $self->{badtestcnt};
8351 $self->{incommandcolor} = $color;
8354 #-> sub CPAN::Bundle::as_string ;
8358 # following line must be "=", not "||=" because we have a moving target
8359 $self->{INST_VERSION} = $self->inst_version;
8360 return $self->SUPER::as_string;
8363 #-> sub CPAN::Bundle::contains ;
8366 my($inst_file) = $self->inst_file || "";
8367 my($id) = $self->id;
8368 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8369 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8372 unless ($inst_file) {
8373 # Try to get at it in the cpan directory
8374 $self->debug("no inst_file") if $CPAN::DEBUG;
8376 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8377 $cpan_file = $self->cpan_file;
8378 if ($cpan_file eq "N/A") {
8379 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8380 Maybe stale symlink? Maybe removed during session? Giving up.\n");
8382 my $dist = $CPAN::META->instance('CPAN::Distribution',
8384 $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8386 $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8387 my($todir) = $CPAN::Config->{'cpan_home'};
8388 my(@me,$from,$to,$me);
8389 @me = split /::/, $self->id;
8391 $me = File::Spec->catfile(@me);
8392 $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8393 $to = File::Spec->catfile($todir,$me);
8394 File::Path::mkpath(File::Basename::dirname($to));
8395 File::Copy::copy($from, $to)
8396 or Carp::confess("Couldn't copy $from to $to: $!");
8400 my $fh = FileHandle->new;
8402 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8404 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8406 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8407 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8408 next unless $in_cont;
8413 push @result, (split " ", $_, 2)[0];
8416 delete $self->{STATUS};
8417 $self->{CONTAINS} = \@result;
8418 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8420 $CPAN::Frontend->mywarn(qq{
8421 The bundle file "$inst_file" may be a broken
8422 bundlefile. It seems not to contain any bundle definition.
8423 Please check the file and if it is bogus, please delete it.
8424 Sorry for the inconvenience.
8430 #-> sub CPAN::Bundle::find_bundle_file
8431 # $where is in local format, $what is in unix format
8432 sub find_bundle_file {
8433 my($self,$where,$what) = @_;
8434 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8435 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8436 ### my $bu = File::Spec->catfile($where,$what);
8437 ### return $bu if -f $bu;
8438 my $manifest = File::Spec->catfile($where,"MANIFEST");
8439 unless (-f $manifest) {
8440 require ExtUtils::Manifest;
8441 my $cwd = CPAN::anycwd();
8442 $self->safe_chdir($where);
8443 ExtUtils::Manifest::mkmanifest();
8444 $self->safe_chdir($cwd);
8446 my $fh = FileHandle->new($manifest)
8447 or Carp::croak("Couldn't open $manifest: $!");
8449 my $bundle_filename = $what;
8450 $bundle_filename =~ s|Bundle.*/||;
8451 my $bundle_unixpath;
8454 my($file) = /(\S+)/;
8455 if ($file =~ m|\Q$what\E$|) {
8456 $bundle_unixpath = $file;
8457 # return File::Spec->catfile($where,$bundle_unixpath); # bad
8460 # retry if she managed to have no Bundle directory
8461 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8463 return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8464 if $bundle_unixpath;
8465 Carp::croak("Couldn't find a Bundle file in $where");
8468 # needs to work quite differently from Module::inst_file because of
8469 # cpan_home/Bundle/ directory and the possibility that we have
8470 # shadowing effect. As it makes no sense to take the first in @INC for
8471 # Bundles, we parse them all for $VERSION and take the newest.
8473 #-> sub CPAN::Bundle::inst_file ;
8478 @me = split /::/, $self->id;
8481 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8482 my $bfile = File::Spec->catfile($incdir, @me);
8483 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8484 next unless -f $bfile;
8485 my $foundv = MM->parse_version($bfile);
8486 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8487 $self->{INST_FILE} = $bfile;
8488 $self->{INST_VERSION} = $bestv = $foundv;
8494 #-> sub CPAN::Bundle::inst_version ;
8497 $self->inst_file; # finds INST_VERSION as side effect
8498 $self->{INST_VERSION};
8501 #-> sub CPAN::Bundle::rematein ;
8503 my($self,$meth) = @_;
8504 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8505 my($id) = $self->id;
8506 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8507 unless $self->inst_file || $self->cpan_file;
8509 for $s ($self->contains) {
8510 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8511 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8512 if ($type eq 'CPAN::Distribution') {
8513 $CPAN::Frontend->mywarn(qq{
8514 The Bundle }.$self->id.qq{ contains
8515 explicitly a file '$s'.
8516 Going to $meth that.
8518 $CPAN::Frontend->mysleep(5);
8520 # possibly noisy action:
8521 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8522 my $obj = $CPAN::META->instance($type,$s);
8523 $obj->{reqtype} = $self->{reqtype};
8525 if ($obj->isa('CPAN::Bundle')
8527 exists $obj->{install_failed}
8529 ref($obj->{install_failed}) eq "HASH"
8531 for (keys %{$obj->{install_failed}}) {
8532 $self->{install_failed}{$_} = undef; # propagate faiure up
8535 $fail{$s} = 1; # the bundle itself may have succeeded but
8540 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
8541 $success ||= $obj->{install} && $obj->{install} eq "YES";
8543 delete $self->{install_failed}{$s};
8550 # recap with less noise
8551 if ( $meth eq "install" ) {
8554 my $raw = sprintf(qq{Bundle summary:
8555 The following items in bundle %s had installation problems:},
8558 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
8559 $CPAN::Frontend->myprint("\n");
8562 for $s ($self->contains) {
8564 $paragraph .= "$s ";
8565 $self->{install_failed}{$s} = undef;
8566 $reported{$s} = undef;
8569 my $report_propagated;
8570 for $s (sort keys %{$self->{install_failed}}) {
8571 next if exists $reported{$s};
8572 $paragraph .= "and the following items had problems
8573 during recursive bundle calls: " unless $report_propagated++;
8574 $paragraph .= "$s ";
8576 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
8577 $CPAN::Frontend->myprint("\n");
8579 $self->{install} = 'YES';
8584 # If a bundle contains another that contains an xs_file we have here,
8585 # we just don't bother I suppose
8586 #-> sub CPAN::Bundle::xs_file
8591 #-> sub CPAN::Bundle::force ;
8592 sub fforce { shift->rematein('fforce',@_); }
8593 #-> sub CPAN::Bundle::force ;
8594 sub force { shift->rematein('force',@_); }
8595 #-> sub CPAN::Bundle::notest ;
8596 sub notest { shift->rematein('notest',@_); }
8597 #-> sub CPAN::Bundle::get ;
8598 sub get { shift->rematein('get',@_); }
8599 #-> sub CPAN::Bundle::make ;
8600 sub make { shift->rematein('make',@_); }
8601 #-> sub CPAN::Bundle::test ;
8604 # $self->{badtestcnt} ||= 0;
8605 $self->rematein('test',@_);
8607 #-> sub CPAN::Bundle::install ;
8610 $self->rematein('install',@_);
8612 #-> sub CPAN::Bundle::clean ;
8613 sub clean { shift->rematein('clean',@_); }
8615 #-> sub CPAN::Bundle::uptodate ;
8618 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8620 foreach $c ($self->contains) {
8621 my $obj = CPAN::Shell->expandany($c);
8622 return 0 unless $obj->uptodate;
8627 #-> sub CPAN::Bundle::readme ;
8630 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8631 No File found for bundle } . $self->id . qq{\n}), return;
8632 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8633 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8636 package CPAN::Module;
8640 # sub CPAN::Module::userid
8645 return $ro->{userid} || $ro->{CPAN_USERID};
8647 # sub CPAN::Module::description
8650 my $ro = $self->ro or return "";
8656 CPAN::Shell->expand("Distribution",$self->cpan_file);
8659 # sub CPAN::Module::undelay
8662 delete $self->{later};
8663 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8668 # mark as dirty/clean
8669 #-> sub CPAN::Module::color_cmd_tmps ;
8670 sub color_cmd_tmps {
8672 my($depth) = shift || 0;
8673 my($color) = shift || 0;
8674 my($ancestors) = shift || [];
8675 # a module needs to recurse to its cpan_file
8677 return if exists $self->{incommandcolor}
8678 && $self->{incommandcolor}==$color;
8679 return if $depth>=1 && $self->uptodate;
8681 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8683 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8685 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8686 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8690 # delete $self->{badtestcnt};
8692 $self->{incommandcolor} = $color;
8695 #-> sub CPAN::Module::as_glimpse ;
8699 my $class = ref($self);
8700 $class =~ s/^CPAN:://;
8704 $CPAN::Shell::COLOR_REGISTERED
8706 $CPAN::META->has_inst("Term::ANSIColor")
8710 $color_on = Term::ANSIColor::color("green");
8711 $color_off = Term::ANSIColor::color("reset");
8713 my $uptodateness = " ";
8714 if ($class eq "Bundle") {
8715 } elsif ($self->uptodate) {
8716 $uptodateness = "=";
8717 } elsif ($self->inst_version) {
8718 $uptodateness = "<";
8720 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8726 ($self->distribution ?
8727 $self->distribution->pretty_id :
8734 #-> sub CPAN::Module::dslip_status
8738 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
8739 pre-alpha alpha beta released
8741 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
8742 developer comp.lang.perl.*
8744 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
8745 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
8747 object-oriented pragma
8749 @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8753 distribution_allowed
8754 restricted_distribution
8756 for my $x (qw(d s l i p)) {
8757 $stat->{$x}{' '} = 'unknown';
8758 $stat->{$x}{'?'} = 'unknown';
8761 return +{} unless $ro && $ro->{statd};
8768 DV => $stat->{D}{$ro->{statd}},
8769 SV => $stat->{S}{$ro->{stats}},
8770 LV => $stat->{L}{$ro->{statl}},
8771 IV => $stat->{I}{$ro->{stati}},
8772 PV => $stat->{P}{$ro->{statp}},
8776 #-> sub CPAN::Module::as_string ;
8780 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8781 my $class = ref($self);
8782 $class =~ s/^CPAN:://;
8784 push @m, $class, " id = $self->{ID}\n";
8785 my $sprintf = " %-12s %s\n";
8786 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8787 if $self->description;
8788 my $sprintf2 = " %-12s %s (%s)\n";
8790 $userid = $self->userid;
8793 if ($author = CPAN::Shell->expand('Author',$userid)) {
8796 if ($m = $author->email) {
8803 $author->fullname . $email
8807 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
8808 if $self->cpan_version;
8809 if (my $cpan_file = $self->cpan_file){
8810 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
8811 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
8812 my $upload_date = $dist->upload_date;
8814 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
8818 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
8819 my $dslip = $self->dslip_status;
8823 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
8825 my $local_file = $self->inst_file;
8826 unless ($self->{MANPAGE}) {
8829 $manpage = $self->manpage_headline($local_file);
8831 # If we have already untarred it, we should look there
8832 my $dist = $CPAN::META->instance('CPAN::Distribution',
8834 # warn "dist[$dist]";
8835 # mff=manifest file; mfh=manifest handle
8840 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
8842 $mfh = FileHandle->new($mff)
8844 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
8845 my $lfre = $self->id; # local file RE
8848 my($lfl); # local file file
8850 my(@mflines) = <$mfh>;
8855 while (length($lfre)>5 and !$lfl) {
8856 ($lfl) = grep /$lfre/, @mflines;
8857 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
8860 $lfl =~ s/\s.*//; # remove comments
8861 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
8862 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
8863 # warn "lfl_abs[$lfl_abs]";
8865 $manpage = $self->manpage_headline($lfl_abs);
8869 $self->{MANPAGE} = $manpage if $manpage;
8872 for $item (qw/MANPAGE/) {
8873 push @m, sprintf($sprintf, $item, $self->{$item})
8874 if exists $self->{$item};
8876 for $item (qw/CONTAINS/) {
8877 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
8878 if exists $self->{$item} && @{$self->{$item}};
8880 push @m, sprintf($sprintf, 'INST_FILE',
8881 $local_file || "(not installed)");
8882 push @m, sprintf($sprintf, 'INST_VERSION',
8883 $self->inst_version) if $local_file;
8887 sub manpage_headline {
8888 my($self,$local_file) = @_;
8889 my(@local_file) = $local_file;
8890 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
8891 push @local_file, $local_file;
8893 for $locf (@local_file) {
8894 next unless -f $locf;
8895 my $fh = FileHandle->new($locf)
8896 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
8900 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
8901 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
8918 #-> sub CPAN::Module::cpan_file ;
8919 # Note: also inherited by CPAN::Bundle
8922 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
8923 unless ($self->ro) {
8924 CPAN::Index->reload;
8927 if ($ro && defined $ro->{CPAN_FILE}){
8928 return $ro->{CPAN_FILE};
8930 my $userid = $self->userid;
8932 if ($CPAN::META->exists("CPAN::Author",$userid)) {
8933 my $author = $CPAN::META->instance("CPAN::Author",
8935 my $fullname = $author->fullname;
8936 my $email = $author->email;
8937 unless (defined $fullname && defined $email) {
8938 return sprintf("Contact Author %s",
8942 return "Contact Author $fullname <$email>";
8944 return "Contact Author $userid (Email address not available)";
8952 #-> sub CPAN::Module::cpan_version ;
8958 # Can happen with modules that are not on CPAN
8961 $ro->{CPAN_VERSION} = 'undef'
8962 unless defined $ro->{CPAN_VERSION};
8963 $ro->{CPAN_VERSION};
8966 #-> sub CPAN::Module::force ;
8969 $self->{force_update} = 1;
8972 #-> sub CPAN::Module::fforce ;
8975 $self->{force_update} = 2;
8980 # warn "XDEBUG: set notest for Module";
8981 $self->{'notest'}++;
8984 #-> sub CPAN::Module::rematein ;
8986 my($self,$meth) = @_;
8987 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
8990 my $cpan_file = $self->cpan_file;
8991 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
8992 $CPAN::Frontend->mywarn(sprintf qq{
8993 The module %s isn\'t available on CPAN.
8995 Either the module has not yet been uploaded to CPAN, or it is
8996 temporary unavailable. Please contact the author to find out
8997 more about the status. Try 'i %s'.
9004 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9005 $pack->called_for($self->id);
9006 if (exists $self->{force_update}){
9007 if ($self->{force_update} == 2) {
9008 $pack->fforce($meth);
9010 $pack->force($meth);
9013 $pack->notest($meth) if exists $self->{'notest'};
9015 $pack->{reqtype} ||= "";
9016 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9017 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9018 if ($pack->{reqtype}) {
9019 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9020 $pack->{reqtype} = $self->{reqtype};
9022 exists $pack->{install}
9025 UNIVERSAL::can($pack->{install},"failed") ?
9026 $pack->{install}->failed :
9027 $pack->{install} =~ /^NO/
9030 delete $pack->{install};
9031 $CPAN::Frontend->mywarn
9032 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9036 $pack->{reqtype} = $self->{reqtype};
9043 $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9044 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
9045 delete $self->{force_update};
9046 delete $self->{'notest'};
9052 #-> sub CPAN::Module::perldoc ;
9053 sub perldoc { shift->rematein('perldoc') }
9054 #-> sub CPAN::Module::readme ;
9055 sub readme { shift->rematein('readme') }
9056 #-> sub CPAN::Module::look ;
9057 sub look { shift->rematein('look') }
9058 #-> sub CPAN::Module::cvs_import ;
9059 sub cvs_import { shift->rematein('cvs_import') }
9060 #-> sub CPAN::Module::get ;
9061 sub get { shift->rematein('get',@_) }
9062 #-> sub CPAN::Module::make ;
9063 sub make { shift->rematein('make') }
9064 #-> sub CPAN::Module::test ;
9067 # $self->{badtestcnt} ||= 0;
9068 $self->rematein('test',@_);
9070 #-> sub CPAN::Module::uptodate ;
9073 local($_); # protect against a bug in MakeMaker 6.17
9074 my($latest) = $self->cpan_version;
9076 my($inst_file) = $self->inst_file;
9078 if (defined $inst_file) {
9079 $have = $self->inst_version;
9084 ! CPAN::Version->vgt($latest, $have)
9086 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9087 "latest[$latest] have[$have]") if $CPAN::DEBUG;
9092 #-> sub CPAN::Module::install ;
9098 not exists $self->{force_update}
9100 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9102 $self->inst_version,
9108 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9109 $CPAN::Frontend->mywarn(qq{
9110 \n\n\n ***WARNING***
9111 The module $self->{ID} has no active maintainer.\n\n\n
9113 $CPAN::Frontend->mysleep(5);
9115 $self->rematein('install') if $doit;
9117 #-> sub CPAN::Module::clean ;
9118 sub clean { shift->rematein('clean') }
9120 #-> sub CPAN::Module::inst_file ;
9123 $self->_file_in_path([@INC]);
9126 #-> sub CPAN::Module::available_file ;
9127 sub available_file {
9129 my $sep = $Config::Config{path_sep};
9130 my $perllib = $ENV{PERL5LIB};
9131 $perllib = $ENV{PERLLIB} unless defined $perllib;
9132 my @perllib = split(/$sep/,$perllib) if defined $perllib;
9133 $self->_file_in_path([@perllib,@INC]);
9136 #-> sub CPAN::Module::file_in_path ;
9138 my($self,$path) = @_;
9140 @packpath = split /::/, $self->{ID};
9141 $packpath[-1] .= ".pm";
9142 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9143 unshift @packpath, "Term", "ReadLine"; # historical reasons
9145 foreach $dir (@$path) {
9146 my $pmfile = File::Spec->catfile($dir,@packpath);
9154 #-> sub CPAN::Module::xs_file ;
9158 @packpath = split /::/, $self->{ID};
9159 push @packpath, $packpath[-1];
9160 $packpath[-1] .= "." . $Config::Config{'dlext'};
9161 foreach $dir (@INC) {
9162 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9170 #-> sub CPAN::Module::inst_version ;
9173 my $parsefile = $self->inst_file or return;
9174 my $have = $self->parse_version($parsefile);
9178 #-> sub CPAN::Module::inst_version ;
9179 sub available_version {
9181 my $parsefile = $self->available_file or return;
9182 my $have = $self->parse_version($parsefile);
9186 #-> sub CPAN::Module::parse_version ;
9188 my($self,$parsefile) = @_;
9189 my $have = MM->parse_version($parsefile);
9190 $have = "undef" unless defined $have && length $have;
9191 $have =~ s/^ //; # since the %vd hack these two lines here are needed
9192 $have =~ s/ $//; # trailing whitespace happens all the time
9194 $have = CPAN::Version->readable($have);
9196 $have =~ s/\s*//g; # stringify to float around floating point issues
9197 $have; # no stringify needed, \s* above matches always
9210 CPAN - query, download and build perl modules from CPAN sites
9216 perl -MCPAN -e shell;
9224 cpan> install Acme::Meta # in the shell
9226 CPAN::Shell->install("Acme::Meta"); # in perl
9230 cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
9233 install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
9237 $mo = CPAN::Shell->expandany($mod);
9238 $mo = CPAN::Shell->expand("Module",$mod); # same thing
9240 # distribution objects:
9242 $do = CPAN::Shell->expand("Module",$mod)->distribution;
9243 $do = CPAN::Shell->expandany($distro); # same thing
9244 $do = CPAN::Shell->expand("Distribution",
9245 $distro); # same thing
9249 The CPAN module is designed to automate the make and install of perl
9250 modules and extensions. It includes some primitive searching
9251 capabilities and knows how to use Net::FTP or LWP (or some external
9252 download clients) to fetch the raw data from the net.
9254 Distributions are fetched from one or more of the mirrored CPAN
9255 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
9258 The CPAN module also supports the concept of named and versioned
9259 I<bundles> of modules. Bundles simplify the handling of sets of
9260 related modules. See Bundles below.
9262 The package contains a session manager and a cache manager. The
9263 session manager keeps track of what has been fetched, built and
9264 installed in the current session. The cache manager keeps track of the
9265 disk space occupied by the make processes and deletes excess space
9266 according to a simple FIFO mechanism.
9268 All methods provided are accessible in a programmer style and in an
9269 interactive shell style.
9271 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9273 The interactive mode is entered by running
9275 perl -MCPAN -e shell
9277 which puts you into a readline interface. If Term::ReadKey and either
9278 Term::ReadLine::Perl or Term::ReadLine::Gnu are installed it supports
9279 both history and command completion.
9281 Once you are on the command line, type 'h' to get a one page help
9282 screen and the rest should be self-explanatory.
9284 The function call C<shell> takes two optional arguments, one is the
9285 prompt, the second is the default initial command line (the latter
9286 only works if a real ReadLine interface module is installed).
9288 The most common uses of the interactive modes are
9292 =item Searching for authors, bundles, distribution files and modules
9294 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9295 for each of the four categories and another, C<i> for any of the
9296 mentioned four. Each of the four entities is implemented as a class
9297 with slightly differing methods for displaying an object.
9299 Arguments you pass to these commands are either strings exactly matching
9300 the identification string of an object or regular expressions that are
9301 then matched case-insensitively against various attributes of the
9302 objects. The parser recognizes a regular expression only if you
9303 enclose it between two slashes.
9305 The principle is that the number of found objects influences how an
9306 item is displayed. If the search finds one item, the result is
9307 displayed with the rather verbose method C<as_string>, but if we find
9308 more than one, we display each object with the terse method
9311 =item get, make, test, install, clean modules or distributions
9313 These commands take any number of arguments and investigate what is
9314 necessary to perform the action. If the argument is a distribution
9315 file name (recognized by embedded slashes), it is processed. If it is
9316 a module, CPAN determines the distribution file in which this module
9317 is included and processes that, following any dependencies named in
9318 the module's META.yml or Makefile.PL (this behavior is controlled by
9319 the configuration parameter C<prerequisites_policy>.)
9321 C<get> downloads a distribution file and untars or unzips it, C<make>
9322 builds it, C<test> runs the test suite, and C<install> installs it.
9324 Any C<make> or C<test> are run unconditionally. An
9326 install <distribution_file>
9328 also is run unconditionally. But for
9332 CPAN checks if an install is actually needed for it and prints
9333 I<module up to date> in the case that the distribution file containing
9334 the module doesn't need to be updated.
9336 CPAN also keeps track of what it has done within the current session
9337 and doesn't try to build a package a second time regardless if it
9338 succeeded or not. It does not repeat a test run if the test
9339 has been run successfully before. Same for install runs.
9341 The C<force> pragma may precede another command (currently: C<get>,
9342 C<make>, C<test>, or C<install>) and executes the command from scratch
9343 and tries to continue in case of some errors. See the section below on
9344 The C<force> and the C<fforce> pragma.
9346 The C<notest> pragma may be used to skip the test part in the build
9351 cpan> notest install Tk
9353 A C<clean> command results in a
9357 being executed within the distribution file's working directory.
9359 =item readme, perldoc, look module or distribution
9361 C<readme> displays the README file of the associated distribution.
9362 C<Look> gets and untars (if not yet done) the distribution file,
9363 changes to the appropriate directory and opens a subshell process in
9364 that directory. C<perldoc> displays the pod documentation of the
9365 module in html or plain text format.
9369 =item ls globbing_expression
9371 The first form lists all distribution files in and below an author's
9372 CPAN directory as they are stored in the CHECKUMS files distributed on
9373 CPAN. The listing goes recursive into all subdirectories.
9375 The second form allows to limit or expand the output with shell
9376 globbing as in the following examples:
9382 The last example is very slow and outputs extra progress indicators
9383 that break the alignment of the result.
9385 Note that globbing only lists directories explicitly asked for, for
9386 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9387 regarded as a bug and may be changed in future versions.
9391 The C<failed> command reports all distributions that failed on one of
9392 C<make>, C<test> or C<install> for some reason in the currently
9393 running shell session.
9395 =item Persistence between sessions
9397 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9398 the internal state of all modules is written to disk after each step.
9399 The files contain a signature of the currently running perl version
9402 If the configurations variable C<build_dir_reuse> is set to a true
9403 value, then CPAN.pm reads the collected YAML files. If the stored
9404 signature matches the currently running perl the stored state is
9405 loaded into memory such that effectively persistence between sessions
9408 =item The C<force> and the C<fforce> pragma
9410 To speed things up in complex installation scenarios, CPAN.pm keeps
9411 track of what it has already done and refuses to do some things a
9412 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9413 A C<test> is only repeated if the previous test was unsuccessful. The
9414 diagnostic message when CPAN.pm refuses to do something a second time
9415 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9416 something similar. Another situation where CPAN refuses to act is an
9417 C<install> if the according C<test> was not successful.
9419 In all these cases, the user can override the goatish behaviour by
9420 prepending the command with the word force, for example:
9423 cpan> force make AUTHOR/Bar-3.14.tar.gz
9424 cpan> force test Baz
9425 cpan> force install Acme::Meta
9427 Each I<forced> command is executed with the according part of its
9430 The C<fforce> pragma is a variant that emulates a C<force get> which
9431 erases the entire memory followed by the action specified, effectively
9432 restarting the whole get/make/test/install procedure from scratch.
9436 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9437 Batch jobs can run without a lockfile and do not disturb each other.
9439 The shell offers to run in I<degraded mode> when another process is
9440 holding the lockfile. This is an experimental feature that is not yet
9441 tested very well. This second shell then does not write the history
9442 file, does not use the metadata file and has a different prompt.
9446 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9447 in the cpan-shell it is intended that you can press C<^C> anytime and
9448 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9449 to clean up and leave the shell loop. You can emulate the effect of a
9450 SIGTERM by sending two consecutive SIGINTs, which usually means by
9451 pressing C<^C> twice.
9453 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9454 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9455 Build.PL> subprocess.
9461 The commands that are available in the shell interface are methods in
9462 the package CPAN::Shell. If you enter the shell command, all your
9463 input is split by the Text::ParseWords::shellwords() routine which
9464 acts like most shells do. The first word is being interpreted as the
9465 method to be called and the rest of the words are treated as arguments
9466 to this method. Continuation lines are supported if a line ends with a
9471 C<autobundle> writes a bundle file into the
9472 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9473 a list of all modules that are both available from CPAN and currently
9474 installed within @INC. The name of the bundle file is based on the
9475 current date and a counter.
9479 This commands provides a statistical overview over recent download
9480 activities. The data for this is collected in the YAML file
9481 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9482 configured or YAML not installed, then no stats are provided.
9486 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9487 directory so that you can save your own preferences instead of the
9492 recompile() is a very special command in that it takes no argument and
9493 runs the make/test/install cycle with brute force over all installed
9494 dynamically loadable extensions (aka XS modules) with 'force' in
9495 effect. The primary purpose of this command is to finish a network
9496 installation. Imagine, you have a common source tree for two different
9497 architectures. You decide to do a completely independent fresh
9498 installation. You start on one architecture with the help of a Bundle
9499 file produced earlier. CPAN installs the whole Bundle for you, but
9500 when you try to repeat the job on the second architecture, CPAN
9501 responds with a C<"Foo up to date"> message for all modules. So you
9502 invoke CPAN's recompile on the second architecture and you're done.
9504 Another popular use for C<recompile> is to act as a rescue in case your
9505 perl breaks binary compatibility. If one of the modules that CPAN uses
9506 is in turn depending on binary compatibility (so you cannot run CPAN
9507 commands), then you should try the CPAN::Nox module for recovery.
9509 =head2 report Bundle|Distribution|Module
9511 The C<report> command temporarily turns on the C<test_report> config
9512 variable, then runs the C<force test> command with the given
9513 arguments. The C<force> pragma is used to re-run the tests and repeat
9514 every step that might have failed before.
9516 =head2 upgrade [Module|/Regex/]...
9518 The C<upgrade> command first runs an C<r> command with the given
9519 arguments and then installs the newest versions of all modules that
9520 were listed by that.
9522 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9524 Although it may be considered internal, the class hierarchy does matter
9525 for both users and programmer. CPAN.pm deals with above mentioned four
9526 classes, and all those classes share a set of methods. A classical
9527 single polymorphism is in effect. A metaclass object registers all
9528 objects of all kinds and indexes them with a string. The strings
9529 referencing objects have a separated namespace (well, not completely
9534 words containing a "/" (slash) Distribution
9535 words starting with Bundle:: Bundle
9536 everything else Module or Author
9538 Modules know their associated Distribution objects. They always refer
9539 to the most recent official release. Developers may mark their releases
9540 as unstable development versions (by inserting an underbar into the
9541 module version number which will also be reflected in the distribution
9542 name when you run 'make dist'), so the really hottest and newest
9543 distribution is not always the default. If a module Foo circulates
9544 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9545 way to install version 1.23 by saying
9549 This would install the complete distribution file (say
9550 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9551 like to install version 1.23_90, you need to know where the
9552 distribution file resides on CPAN relative to the authors/id/
9553 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9554 so you would have to say
9556 install BAR/Foo-1.23_90.tar.gz
9558 The first example will be driven by an object of the class
9559 CPAN::Module, the second by an object of class CPAN::Distribution.
9561 =head2 Integrating local directories
9563 Distribution objects are normally distributions from the CPAN, but
9564 there is a slightly degenerate case for Distribution objects, too, of
9565 projects held on the local disk. These distribution objects have the
9566 same name as the local directory and end with a dot. A dot by itself
9567 is also allowed for the current directory at the time CPAN.pm was
9568 used. All actions such as C<make>, C<test>, and C<install> are applied
9569 directly to that directory. This gives the command C<cpan .> an
9570 interesting touch: while the normal mantra of installing a CPAN module
9571 without CPAN.pm is one of
9573 perl Makefile.PL perl Build.PL
9574 ( go and get prerequisites )
9576 make test ./Build test
9577 make install ./Build install
9579 the command C<cpan .> does all of this at once. It figures out which
9580 of the two mantras is appropriate, fetches and installs all
9581 prerequisites, cares for them recursively and finally finishes the
9582 installation of the module in the current directory, be it a CPAN
9585 The typical usage case is for private modules or working copies of
9586 projects from remote repositories on the local disk.
9588 =head1 PROGRAMMER'S INTERFACE
9590 If you do not enter the shell, the available shell commands are both
9591 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
9592 functions in the calling package (C<install(...)>). Before calling low-level
9593 commands it makes sense to initialize components of CPAN you need, e.g.:
9595 CPAN::HandleConfig->load;
9596 CPAN::Shell::setup_output;
9597 CPAN::Index->reload;
9599 High-level commands do such initializations automatically.
9601 There's currently only one class that has a stable interface -
9602 CPAN::Shell. All commands that are available in the CPAN shell are
9603 methods of the class CPAN::Shell. Each of the commands that produce
9604 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
9605 the IDs of all modules within the list.
9609 =item expand($type,@things)
9611 The IDs of all objects available within a program are strings that can
9612 be expanded to the corresponding real objects with the
9613 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
9614 list of CPAN::Module objects according to the C<@things> arguments
9615 given. In scalar context it only returns the first element of the
9618 =item expandany(@things)
9620 Like expand, but returns objects of the appropriate type, i.e.
9621 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
9622 CPAN::Distribution objects for distributions. Note: it does not expand
9623 to CPAN::Author objects.
9625 =item Programming Examples
9627 This enables the programmer to do operations that combine
9628 functionalities that are available in the shell.
9630 # install everything that is outdated on my disk:
9631 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
9633 # install my favorite programs if necessary:
9634 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
9635 CPAN::Shell->install($mod);
9638 # list all modules on my disk that have no VERSION number
9639 for $mod (CPAN::Shell->expand("Module","/./")){
9640 next unless $mod->inst_file;
9641 # MakeMaker convention for undefined $VERSION:
9642 next unless $mod->inst_version eq "undef";
9643 print "No VERSION in ", $mod->id, "\n";
9646 # find out which distribution on CPAN contains a module:
9647 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
9649 Or if you want to write a cronjob to watch The CPAN, you could list
9650 all modules that need updating. First a quick and dirty way:
9652 perl -e 'use CPAN; CPAN::Shell->r;'
9654 If you don't want to get any output in the case that all modules are
9655 up to date, you can parse the output of above command for the regular
9656 expression //modules are up to date// and decide to mail the output
9657 only if it doesn't match. Ick?
9659 If you prefer to do it more in a programmer style in one single
9660 process, maybe something like this suits you better:
9662 # list all modules on my disk that have newer versions on CPAN
9663 for $mod (CPAN::Shell->expand("Module","/./")){
9664 next unless $mod->inst_file;
9665 next if $mod->uptodate;
9666 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
9667 $mod->id, $mod->inst_version, $mod->cpan_version;
9670 If that gives you too much output every day, you maybe only want to
9671 watch for three modules. You can write
9673 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
9675 as the first line instead. Or you can combine some of the above
9678 # watch only for a new mod_perl module
9679 $mod = CPAN::Shell->expand("Module","mod_perl");
9680 exit if $mod->uptodate;
9681 # new mod_perl arrived, let me know all update recommendations
9686 =head2 Methods in the other Classes
9690 =item CPAN::Author::as_glimpse()
9692 Returns a one-line description of the author
9694 =item CPAN::Author::as_string()
9696 Returns a multi-line description of the author
9698 =item CPAN::Author::email()
9700 Returns the author's email address
9702 =item CPAN::Author::fullname()
9704 Returns the author's name
9706 =item CPAN::Author::name()
9708 An alias for fullname
9710 =item CPAN::Bundle::as_glimpse()
9712 Returns a one-line description of the bundle
9714 =item CPAN::Bundle::as_string()
9716 Returns a multi-line description of the bundle
9718 =item CPAN::Bundle::clean()
9720 Recursively runs the C<clean> method on all items contained in the bundle.
9722 =item CPAN::Bundle::contains()
9724 Returns a list of objects' IDs contained in a bundle. The associated
9725 objects may be bundles, modules or distributions.
9727 =item CPAN::Bundle::force($method,@args)
9729 Forces CPAN to perform a task that it normally would have refused to
9730 do. Force takes as arguments a method name to be called and any number
9731 of additional arguments that should be passed to the called method.
9732 The internals of the object get the needed changes so that CPAN.pm
9733 does not refuse to take the action. The C<force> is passed recursively
9734 to all contained objects. See also the section above on the C<force>
9735 and the C<fforce> pragma.
9737 =item CPAN::Bundle::get()
9739 Recursively runs the C<get> method on all items contained in the bundle
9741 =item CPAN::Bundle::inst_file()
9743 Returns the highest installed version of the bundle in either @INC or
9744 C<$CPAN::Config->{cpan_home}>. Note that this is different from
9745 CPAN::Module::inst_file.
9747 =item CPAN::Bundle::inst_version()
9749 Like CPAN::Bundle::inst_file, but returns the $VERSION
9751 =item CPAN::Bundle::uptodate()
9753 Returns 1 if the bundle itself and all its members are uptodate.
9755 =item CPAN::Bundle::install()
9757 Recursively runs the C<install> method on all items contained in the bundle
9759 =item CPAN::Bundle::make()
9761 Recursively runs the C<make> method on all items contained in the bundle
9763 =item CPAN::Bundle::readme()
9765 Recursively runs the C<readme> method on all items contained in the bundle
9767 =item CPAN::Bundle::test()
9769 Recursively runs the C<test> method on all items contained in the bundle
9771 =item CPAN::Distribution::as_glimpse()
9773 Returns a one-line description of the distribution
9775 =item CPAN::Distribution::as_string()
9777 Returns a multi-line description of the distribution
9779 =item CPAN::Distribution::author
9781 Returns the CPAN::Author object of the maintainer who uploaded this
9784 =item CPAN::Distribution::clean()
9786 Changes to the directory where the distribution has been unpacked and
9787 runs C<make clean> there.
9789 =item CPAN::Distribution::containsmods()
9791 Returns a list of IDs of modules contained in a distribution file.
9792 Only works for distributions listed in the 02packages.details.txt.gz
9793 file. This typically means that only the most recent version of a
9794 distribution is covered.
9796 =item CPAN::Distribution::cvs_import()
9798 Changes to the directory where the distribution has been unpacked and
9801 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
9805 =item CPAN::Distribution::dir()
9807 Returns the directory into which this distribution has been unpacked.
9809 =item CPAN::Distribution::force($method,@args)
9811 Forces CPAN to perform a task that it normally would have refused to
9812 do. Force takes as arguments a method name to be called and any number
9813 of additional arguments that should be passed to the called method.
9814 The internals of the object get the needed changes so that CPAN.pm
9815 does not refuse to take the action. See also the section above on the
9816 C<force> and the C<fforce> pragma.
9818 =item CPAN::Distribution::get()
9820 Downloads the distribution from CPAN and unpacks it. Does nothing if
9821 the distribution has already been downloaded and unpacked within the
9824 =item CPAN::Distribution::install()
9826 Changes to the directory where the distribution has been unpacked and
9827 runs the external command C<make install> there. If C<make> has not
9828 yet been run, it will be run first. A C<make test> will be issued in
9829 any case and if this fails, the install will be canceled. The
9830 cancellation can be avoided by letting C<force> run the C<install> for
9833 This install method has only the power to install the distribution if
9834 there are no dependencies in the way. To install an object and all of
9835 its dependencies, use CPAN::Shell->install.
9837 Note that install() gives no meaningful return value. See uptodate().
9839 =item CPAN::Distribution::isa_perl()
9841 Returns 1 if this distribution file seems to be a perl distribution.
9842 Normally this is derived from the file name only, but the index from
9843 CPAN can contain a hint to achieve a return value of true for other
9846 =item CPAN::Distribution::look()
9848 Changes to the directory where the distribution has been unpacked and
9849 opens a subshell there. Exiting the subshell returns.
9851 =item CPAN::Distribution::make()
9853 First runs the C<get> method to make sure the distribution is
9854 downloaded and unpacked. Changes to the directory where the
9855 distribution has been unpacked and runs the external commands C<perl
9856 Makefile.PL> or C<perl Build.PL> and C<make> there.
9858 =item CPAN::Distribution::perldoc()
9860 Downloads the pod documentation of the file associated with a
9861 distribution (in html format) and runs it through the external
9862 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
9863 isn't available, it converts it to plain text with external
9864 command html2text and runs it through the pager specified
9865 in C<$CPAN::Config->{pager}>
9867 =item CPAN::Distribution::prefs()
9869 Returns the hash reference from the first matching YAML file that the
9870 user has deposited in the C<prefs_dir/> directory. The first
9871 succeeding match wins. The files in the C<prefs_dir/> are processed
9872 alphabetically and the canonical distroname (e.g.
9873 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
9874 stored in the $root->{match}{distribution} attribute value.
9875 Additionally all module names contained in a distribution are matched
9876 agains the regular expressions in the $root->{match}{module} attribute
9877 value. The two match values are ANDed together. Each of the two
9878 attributes are optional.
9880 =item CPAN::Distribution::prereq_pm()
9882 Returns the hash reference that has been announced by a distribution
9883 as the merge of the C<requires> element and the C<build_requires>
9884 element of the META.yml or the C<PREREQ_PM> hash in the
9885 C<Makefile.PL>. Note: works only after an attempt has been made to
9886 C<make> the distribution. Returns undef otherwise.
9888 =item CPAN::Distribution::readme()
9890 Downloads the README file associated with a distribution and runs it
9891 through the pager specified in C<$CPAN::Config->{pager}>.
9893 =item CPAN::Distribution::read_yaml()
9895 Returns the content of the META.yml of this distro as a hashref. Note:
9896 works only after an attempt has been made to C<make> the distribution.
9897 Returns undef otherwise. Also returns undef if the content of META.yml
9900 =item CPAN::Distribution::test()
9902 Changes to the directory where the distribution has been unpacked and
9903 runs C<make test> there.
9905 =item CPAN::Distribution::uptodate()
9907 Returns 1 if all the modules contained in the distribution are
9908 uptodate. Relies on containsmods.
9910 =item CPAN::Index::force_reload()
9912 Forces a reload of all indices.
9914 =item CPAN::Index::reload()
9916 Reloads all indices if they have not been read for more than
9917 C<$CPAN::Config->{index_expire}> days.
9919 =item CPAN::InfoObj::dump()
9921 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
9922 inherit this method. It prints the data structure associated with an
9923 object. Useful for debugging. Note: the data structure is considered
9924 internal and thus subject to change without notice.
9926 =item CPAN::Module::as_glimpse()
9928 Returns a one-line description of the module in four columns: The
9929 first column contains the word C<Module>, the second column consists
9930 of one character: an equals sign if this module is already installed
9931 and uptodate, a less-than sign if this module is installed but can be
9932 upgraded, and a space if the module is not installed. The third column
9933 is the name of the module and the fourth column gives maintainer or
9934 distribution information.
9936 =item CPAN::Module::as_string()
9938 Returns a multi-line description of the module
9940 =item CPAN::Module::clean()
9942 Runs a clean on the distribution associated with this module.
9944 =item CPAN::Module::cpan_file()
9946 Returns the filename on CPAN that is associated with the module.
9948 =item CPAN::Module::cpan_version()
9950 Returns the latest version of this module available on CPAN.
9952 =item CPAN::Module::cvs_import()
9954 Runs a cvs_import on the distribution associated with this module.
9956 =item CPAN::Module::description()
9958 Returns a 44 character description of this module. Only available for
9959 modules listed in The Module List (CPAN/modules/00modlist.long.html
9960 or 00modlist.long.txt.gz)
9962 =item CPAN::Module::distribution()
9964 Returns the CPAN::Distribution object that contains the current
9965 version of this module.
9967 =item CPAN::Module::dslip_status()
9969 Returns a hash reference. The keys of the hash are the letters C<D>,
9970 C<S>, C<L>, C<I>, and <P>, for development status, support level,
9971 language, interface and public licence respectively. The data for the
9972 DSLIP status are collected by pause.perl.org when authors register
9973 their namespaces. The values of the 5 hash elements are one-character
9974 words whose meaning is described in the table below. There are also 5
9975 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
9976 verbose value of the 5 status variables.
9978 Where the 'DSLIP' characters have the following meanings:
9980 D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
9981 i - Idea, listed to gain consensus or as a placeholder
9982 c - under construction but pre-alpha (not yet released)
9983 a/b - Alpha/Beta testing
9985 M - Mature (no rigorous definition)
9986 S - Standard, supplied with Perl 5
9991 u - Usenet newsgroup comp.lang.perl.modules
9992 n - None known, try comp.lang.perl.modules
9993 a - abandoned; volunteers welcome to take over maintainance
9996 p - Perl-only, no compiler needed, should be platform independent
9997 c - C and perl, a C compiler will be needed
9998 h - Hybrid, written in perl with optional C code, no compiler needed
9999 + - C++ and perl, a C++ compiler will be needed
10000 o - perl and another language other than C or C++
10002 I - Interface Style
10003 f - plain Functions, no references used
10004 h - hybrid, object and function interfaces available
10005 n - no interface at all (huh?)
10006 r - some use of unblessed References or ties
10007 O - Object oriented using blessed references and/or inheritance
10010 p - Standard-Perl: user may choose between GPL and Artistic
10011 g - GPL: GNU General Public License
10012 l - LGPL: "GNU Lesser General Public License" (previously known as
10013 "GNU Library General Public License")
10014 b - BSD: The BSD License
10015 a - Artistic license alone
10016 o - open source: appoved by www.opensource.org
10017 d - allows distribution without restrictions
10018 r - restricted distribtion
10019 n - no license at all
10021 =item CPAN::Module::force($method,@args)
10023 Forces CPAN to perform a task that it normally would have refused to
10024 do. Force takes as arguments a method name to be called and any number
10025 of additional arguments that should be passed to the called method.
10026 The internals of the object get the needed changes so that CPAN.pm
10027 does not refuse to take the action. See also the section above on the
10028 C<force> and the C<fforce> pragma.
10030 =item CPAN::Module::get()
10032 Runs a get on the distribution associated with this module.
10034 =item CPAN::Module::inst_file()
10036 Returns the filename of the module found in @INC. The first file found
10037 is reported just like perl itself stops searching @INC when it finds a
10040 =item CPAN::Module::available_file()
10042 Returns the filename of the module found in PERL5LIB or @INC. The
10043 first file found is reported. The advantage of this method over
10044 C<inst_file> is that modules that have been tested but not yet
10045 installed are included because PERL5LIB keeps track of tested modules.
10047 =item CPAN::Module::inst_version()
10049 Returns the version number of the installed module in readable format.
10051 =item CPAN::Module::available_version()
10053 Returns the version number of the available module in readable format.
10055 =item CPAN::Module::install()
10057 Runs an C<install> on the distribution associated with this module.
10059 =item CPAN::Module::look()
10061 Changes to the directory where the distribution associated with this
10062 module has been unpacked and opens a subshell there. Exiting the
10065 =item CPAN::Module::make()
10067 Runs a C<make> on the distribution associated with this module.
10069 =item CPAN::Module::manpage_headline()
10071 If module is installed, peeks into the module's manpage, reads the
10072 headline and returns it. Moreover, if the module has been downloaded
10073 within this session, does the equivalent on the downloaded module even
10074 if it is not installed.
10076 =item CPAN::Module::perldoc()
10078 Runs a C<perldoc> on this module.
10080 =item CPAN::Module::readme()
10082 Runs a C<readme> on the distribution associated with this module.
10084 =item CPAN::Module::test()
10086 Runs a C<test> on the distribution associated with this module.
10088 =item CPAN::Module::uptodate()
10090 Returns 1 if the module is installed and up-to-date.
10092 =item CPAN::Module::userid()
10094 Returns the author's ID of the module.
10098 =head2 Cache Manager
10100 Currently the cache manager only keeps track of the build directory
10101 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
10102 deletes complete directories below C<build_dir> as soon as the size of
10103 all directories there gets bigger than $CPAN::Config->{build_cache}
10104 (in MB). The contents of this cache may be used for later
10105 re-installations that you intend to do manually, but will never be
10106 trusted by CPAN itself. This is due to the fact that the user might
10107 use these directories for building modules on different architectures.
10109 There is another directory ($CPAN::Config->{keep_source_where}) where
10110 the original distribution files are kept. This directory is not
10111 covered by the cache manager and must be controlled by the user. If
10112 you choose to have the same directory as build_dir and as
10113 keep_source_where directory, then your sources will be deleted with
10114 the same fifo mechanism.
10118 A bundle is just a perl module in the namespace Bundle:: that does not
10119 define any functions or methods. It usually only contains documentation.
10121 It starts like a perl module with a package declaration and a $VERSION
10122 variable. After that the pod section looks like any other pod with the
10123 only difference being that I<one special pod section> exists starting with
10128 In this pod section each line obeys the format
10130 Module_Name [Version_String] [- optional text]
10132 The only required part is the first field, the name of a module
10133 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
10134 of the line is optional. The comment part is delimited by a dash just
10135 as in the man page header.
10137 The distribution of a bundle should follow the same convention as
10138 other distributions.
10140 Bundles are treated specially in the CPAN package. If you say 'install
10141 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
10142 the modules in the CONTENTS section of the pod. You can install your
10143 own Bundles locally by placing a conformant Bundle file somewhere into
10144 your @INC path. The autobundle() command which is available in the
10145 shell interface does that for you by including all currently installed
10146 modules in a snapshot bundle file.
10148 =head1 PREREQUISITES
10150 If you have a local mirror of CPAN and can access all files with
10151 "file:" URLs, then you only need a perl better than perl5.003 to run
10152 this module. Otherwise Net::FTP is strongly recommended. LWP may be
10153 required for non-UNIX systems or if your nearest CPAN site is
10154 associated with a URL that is not C<ftp:>.
10156 If you have neither Net::FTP nor LWP, there is a fallback mechanism
10157 implemented for an external ftp command or for an external lynx
10162 =head2 Finding packages and VERSION
10164 This module presumes that all packages on CPAN
10170 declare their $VERSION variable in an easy to parse manner. This
10171 prerequisite can hardly be relaxed because it consumes far too much
10172 memory to load all packages into the running program just to determine
10173 the $VERSION variable. Currently all programs that are dealing with
10174 version use something like this
10176 perl -MExtUtils::MakeMaker -le \
10177 'print MM->parse_version(shift)' filename
10179 If you are author of a package and wonder if your $VERSION can be
10180 parsed, please try the above method.
10184 come as compressed or gzipped tarfiles or as zip files and contain a
10185 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
10186 without much enthusiasm).
10192 The debugging of this module is a bit complex, because we have
10193 interferences of the software producing the indices on CPAN, of the
10194 mirroring process on CPAN, of packaging, of configuration, of
10195 synchronicity, and of bugs within CPAN.pm.
10197 For debugging the code of CPAN.pm itself in interactive mode some more
10198 or less useful debugging aid can be turned on for most packages within
10199 CPAN.pm with one of
10203 =item o debug package...
10205 sets debug mode for packages.
10207 =item o debug -package...
10209 unsets debug mode for packages.
10213 turns debugging on for all packages.
10215 =item o debug number
10219 which sets the debugging packages directly. Note that C<o debug 0>
10220 turns debugging off.
10222 What seems quite a successful strategy is the combination of C<reload
10223 cpan> and the debugging switches. Add a new debug statement while
10224 running in the shell and then issue a C<reload cpan> and see the new
10225 debugging messages immediately without losing the current context.
10227 C<o debug> without an argument lists the valid package names and the
10228 current set of packages in debugging mode. C<o debug> has built-in
10229 completion support.
10231 For debugging of CPAN data there is the C<dump> command which takes
10232 the same arguments as make/test/install and outputs each object's
10233 Data::Dumper dump. If an argument looks like a perl variable and
10234 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
10235 Data::Dumper directly.
10237 =head2 Floppy, Zip, Offline Mode
10239 CPAN.pm works nicely without network too. If you maintain machines
10240 that are not networked at all, you should consider working with file:
10241 URLs. Of course, you have to collect your modules somewhere first. So
10242 you might use CPAN.pm to put together all you need on a networked
10243 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
10244 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
10245 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
10246 with this floppy. See also below the paragraph about CD-ROM support.
10248 =head2 Basic Utilities for Programmers
10252 =item has_inst($module)
10254 Returns true if the module is installed. Used to load all modules into
10255 the running CPAN.pm which are considered optional. The config variable
10256 C<dontload_list> can be used to intercept the C<has_inst()> call such
10257 that an optional module is not loaded despite being available. For
10258 example the following command will prevent that C<YAML.pm> is being
10261 cpan> o conf dontload_list push YAML
10263 See the source for details.
10265 =item has_usable($module)
10267 Returns true if the module is installed and is in a usable state. Only
10268 useful for a handful of modules that are used internally. See the
10269 source for details.
10271 =item instance($module)
10273 The constructor for all the singletons used to represent modules,
10274 distributions, authors and bundles. If the object already exists, this
10275 method returns the object, otherwise it calls the constructor.
10279 =head1 CONFIGURATION
10281 When the CPAN module is used for the first time, a configuration
10282 dialog tries to determine a couple of site specific options. The
10283 result of the dialog is stored in a hash reference C< $CPAN::Config >
10284 in a file CPAN/Config.pm.
10286 The default values defined in the CPAN/Config.pm file can be
10287 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10288 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10289 added to the search path of the CPAN module before the use() or
10290 require() statements. The mkmyconfig command writes this file for you.
10292 The C<o conf> command has various bells and whistles:
10296 =item completion support
10298 If you have a ReadLine module installed, you can hit TAB at any point
10299 of the commandline and C<o conf> will offer you completion for the
10300 built-in subcommands and/or config variable names.
10302 =item displaying some help: o conf help
10304 Displays a short help
10306 =item displaying current values: o conf [KEY]
10308 Displays the current value(s) for this config variable. Without KEY
10309 displays all subcommands and config variables.
10315 =item changing of scalar values: o conf KEY VALUE
10317 Sets the config variable KEY to VALUE. The empty string can be
10318 specified as usual in shells, with C<''> or C<"">
10322 o conf wget /usr/bin/wget
10324 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10326 If a config variable name ends with C<list>, it is a list. C<o conf
10327 KEY shift> removes the first element of the list, C<o conf KEY pop>
10328 removes the last element of the list. C<o conf KEYS unshift LIST>
10329 prepends a list of values to the list, C<o conf KEYS push LIST>
10330 appends a list of valued to the list.
10332 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10335 Finally, any other list of arguments is taken as a new list value for
10336 the KEY variable discarding the previous value.
10340 o conf urllist unshift http://cpan.dev.local/CPAN
10341 o conf urllist splice 3 1
10342 o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10344 =item interactive editing: o conf init [MATCH|LIST]
10346 Runs an interactive configuration dialog for matching variables.
10347 Without argument runs the dialog over all supported config variables.
10348 To specify a MATCH the argument must be enclosed by slashes.
10352 o conf init ftp_passive ftp_proxy
10353 o conf init /color/
10355 =item reverting to saved: o conf defaults
10357 Reverts all config variables to the state in the saved config file.
10359 =item saving the config: o conf commit
10361 Saves all config variables to the current config file (CPAN/Config.pm
10362 or CPAN/MyConfig.pm that was loaded at start).
10366 The configuration dialog can be started any time later again by
10367 issuing the command C< o conf init > in the CPAN shell. A subset of
10368 the configuration dialog can be run by issuing C<o conf init WORD>
10369 where WORD is any valid config variable or a regular expression.
10371 =head2 Config Variables
10373 Currently the following keys in the hash reference $CPAN::Config are
10376 applypatch path to external prg
10377 auto_commit commit all changes to config variables to disk
10378 build_cache size of cache for directories to build modules
10379 build_dir locally accessible directory to build modules
10380 build_dir_reuse boolean if distros in build_dir are persistent
10381 build_requires_install_policy
10382 to install or not to install: when a module is
10383 only needed for building. yes|no|ask/yes|ask/no
10384 bzip2 path to external prg
10385 cache_metadata use serializer to cache metadata
10386 commands_quote prefered character to use for quoting external
10387 commands when running them. Defaults to double
10388 quote on Windows, single tick everywhere else;
10389 can be set to space to disable quoting
10390 check_sigs if signatures should be verified
10391 colorize_debug Term::ANSIColor attributes for debugging output
10392 colorize_output boolean if Term::ANSIColor should colorize output
10393 colorize_print Term::ANSIColor attributes for normal output
10394 colorize_warn Term::ANSIColor attributes for warnings
10395 commandnumber_in_prompt
10396 boolean if you want to see current command number
10397 cpan_home local directory reserved for this package
10398 curl path to external prg
10399 dontload_hash DEPRECATED
10400 dontload_list arrayref: modules in the list will not be
10401 loaded by the CPAN::has_inst() routine
10402 ftp path to external prg
10403 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
10404 ftp_proxy proxy host for ftp requests
10406 gpg path to external prg
10407 gzip location of external program gzip
10408 histfile file to maintain history between sessions
10409 histsize maximum number of lines to keep in histfile
10410 http_proxy proxy host for http requests
10411 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10412 after this many seconds inactivity. Set to 0 to
10414 index_expire after this many days refetch index files
10415 inhibit_startup_message
10416 if true, does not print the startup message
10417 keep_source_where directory in which to keep the source (if we do)
10418 lynx path to external prg
10419 make location of external make program
10420 make_arg arguments that should always be passed to 'make'
10421 make_install_make_command
10422 the make command for running 'make install', for
10423 example 'sudo make'
10424 make_install_arg same as make_arg for 'make install'
10425 makepl_arg arguments passed to 'perl Makefile.PL'
10426 mbuild_arg arguments passed to './Build'
10427 mbuild_install_arg arguments passed to './Build install'
10428 mbuild_install_build_command
10429 command to use instead of './Build' when we are
10430 in the install stage, for example 'sudo ./Build'
10431 mbuildpl_arg arguments passed to 'perl Build.PL'
10432 ncftp path to external prg
10433 ncftpget path to external prg
10434 no_proxy don't proxy to these hosts/domains (comma separated list)
10435 pager location of external program more (or any pager)
10436 password your password if you CPAN server wants one
10437 patch path to external prg
10438 prefer_installer legal values are MB and EUMM: if a module comes
10439 with both a Makefile.PL and a Build.PL, use the
10440 former (EUMM) or the latter (MB); if the module
10441 comes with only one of the two, that one will be
10443 prerequisites_policy
10444 what to do if you are missing module prerequisites
10445 ('follow' automatically, 'ask' me, or 'ignore')
10446 prefs_dir local directory to store per-distro build options
10447 proxy_user username for accessing an authenticating proxy
10448 proxy_pass password for accessing an authenticating proxy
10449 randomize_urllist add some randomness to the sequence of the urllist
10450 scan_cache controls scanning of cache ('atstart' or 'never')
10451 shell your favorite shell
10452 show_upload_date boolean if commands should try to determine upload date
10453 tar location of external program tar
10454 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
10455 (and nonsense for characters outside latin range)
10456 term_ornaments boolean to turn ReadLine ornamenting on/off
10457 test_report email test reports (if CPAN::Reporter is installed)
10458 unzip location of external program unzip
10459 urllist arrayref to nearby CPAN sites (or equivalent locations)
10460 use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
10461 username your username if you CPAN server wants one
10462 wait_list arrayref to a wait server to try (See CPAN::WAIT)
10463 wget path to external prg
10464 yaml_module which module to use to read/write YAML files
10466 You can set and query each of these options interactively in the cpan
10467 shell with the command set defined within the C<o conf> command:
10471 =item C<o conf E<lt>scalar optionE<gt>>
10473 prints the current value of the I<scalar option>
10475 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10477 Sets the value of the I<scalar option> to I<value>
10479 =item C<o conf E<lt>list optionE<gt>>
10481 prints the current value of the I<list option> in MakeMaker's
10484 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10486 shifts or pops the array in the I<list option> variable
10488 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10490 works like the corresponding perl commands.
10494 =head2 CPAN::anycwd($path): Note on config variable getcwd
10496 CPAN.pm changes the current working directory often and needs to
10497 determine its own current working directory. Per default it uses
10498 Cwd::cwd but if this doesn't work on your system for some reason,
10499 alternatives can be configured according to the following table:
10517 Calls the external command cwd.
10521 =head2 Note on the format of the urllist parameter
10523 urllist parameters are URLs according to RFC 1738. We do a little
10524 guessing if your URL is not compliant, but if you have problems with
10525 C<file> URLs, please try the correct format. Either:
10527 file://localhost/whatever/ftp/pub/CPAN/
10531 file:///home/ftp/pub/CPAN/
10533 =head2 urllist parameter has CD-ROM support
10535 The C<urllist> parameter of the configuration table contains a list of
10536 URLs that are to be used for downloading. If the list contains any
10537 C<file> URLs, CPAN always tries to get files from there first. This
10538 feature is disabled for index files. So the recommendation for the
10539 owner of a CD-ROM with CPAN contents is: include your local, possibly
10540 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10542 o conf urllist push file://localhost/CDROM/CPAN
10544 CPAN.pm will then fetch the index files from one of the CPAN sites
10545 that come at the beginning of urllist. It will later check for each
10546 module if there is a local copy of the most recent version.
10548 Another peculiarity of urllist is that the site that we could
10549 successfully fetch the last file from automatically gets a preference
10550 token and is tried as the first site for the next request. So if you
10551 add a new site at runtime it may happen that the previously preferred
10552 site will be tried another time. This means that if you want to disallow
10553 a site for the next transfer, it must be explicitly removed from
10556 =head2 Maintaining the urllist parameter
10558 If you have YAML.pm (or some other YAML module configured in
10559 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10560 about recent downloads. You can view the statistics with the C<hosts>
10561 command or inspect them directly by looking into the C<FTPstats.yml>
10562 file in your C<cpan_home> directory.
10564 To get some interesting statistics it is recommended to set the
10565 C<randomize_urllist> parameter that introduces some amount of
10566 randomness into the URL selection.
10568 =head2 prefs_dir for avoiding interactive questions (ALPHA)
10570 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10571 still considered experimental and may still be changed)
10573 The files in the directory specified in C<prefs_dir> are YAML files
10574 that specify how CPAN.pm shall treat distributions that deviate from
10575 the normal non-interactive model of building and installing CPAN
10578 Some modules try to get some data from the user interactively thus
10579 disturbing the installation of large bundles like Phalanx100 or
10580 modules like Plagger.
10582 CPAN.pm can use YAML files to either pass additional arguments to one
10583 of the four commands, set environment variables or instantiate an
10584 Expect object that reads from the console and enters answers on your
10585 behalf (latter option requires Expect.pm installed). A further option
10586 is to apply patches from the local disk or from CPAN.
10588 CPAN.pm comes with a couple of such YAML files. The structure is
10589 currently not documented because in flux. Please see the distroprefs
10590 directory of the CPAN distribution for examples and follow the
10591 C<00.README> file in there.
10593 Please note that setting the environment variable PERL_MM_USE_DEFAULT
10594 to a true value can also get you a long way if you want to always pick
10595 the default answers. But this only works if the author of a package
10596 used the prompt function provided by ExtUtils::MakeMaker and if the
10597 defaults are OK for you.
10601 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
10602 install foreign, unmasked, unsigned code on your machine. We compare
10603 to a checksum that comes from the net just as the distribution file
10604 itself. But we try to make it easy to add security on demand:
10606 =head2 Cryptographically signed modules
10608 Since release 1.77 CPAN.pm has been able to verify cryptographically
10609 signed module distributions using Module::Signature. The CPAN modules
10610 can be signed by their authors, thus giving more security. The simple
10611 unsigned MD5 checksums that were used before by CPAN protect mainly
10612 against accidental file corruption.
10614 You will need to have Module::Signature installed, which in turn
10615 requires that you have at least one of Crypt::OpenPGP module or the
10616 command-line F<gpg> tool installed.
10618 You will also need to be able to connect over the Internet to the public
10619 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
10621 The configuration parameter check_sigs is there to turn signature
10622 checking on or off.
10626 Most functions in package CPAN are exported per default. The reason
10627 for this is that the primary use is intended for the cpan shell or for
10632 When the CPAN shell enters a subshell via the look command, it sets
10633 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
10636 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
10638 When the config variable ftp_passive is set, all downloads will be run
10639 with the environment variable FTP_PASSIVE set to this value. This is
10640 in general a good idea as it influences both Net::FTP and LWP based
10641 connections. The same effect can be achieved by starting the cpan
10642 shell with this environment variable set. For Net::FTP alone, one can
10643 also always set passive mode by running libnetcfg.
10645 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
10647 Populating a freshly installed perl with my favorite modules is pretty
10648 easy if you maintain a private bundle definition file. To get a useful
10649 blueprint of a bundle definition file, the command autobundle can be used
10650 on the CPAN shell command line. This command writes a bundle definition
10651 file for all modules that are installed for the currently running perl
10652 interpreter. It's recommended to run this command only once and from then
10653 on maintain the file manually under a private name, say
10654 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
10656 cpan> install Bundle::my_bundle
10658 then answer a few questions and then go out for a coffee.
10660 Maintaining a bundle definition file means keeping track of two
10661 things: dependencies and interactivity. CPAN.pm sometimes fails on
10662 calculating dependencies because not all modules define all MakeMaker
10663 attributes correctly, so a bundle definition file should specify
10664 prerequisites as early as possible. On the other hand, it's a bit
10665 annoying that many distributions need some interactive configuring. So
10666 what I try to accomplish in my private bundle file is to have the
10667 packages that need to be configured early in the file and the gentle
10668 ones later, so I can go out after a few minutes and leave CPAN.pm
10671 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
10673 Thanks to Graham Barr for contributing the following paragraphs about
10674 the interaction between perl, and various firewall configurations. For
10675 further information on firewalls, it is recommended to consult the
10676 documentation that comes with the ncftp program. If you are unable to
10677 go through the firewall with a simple Perl setup, it is very likely
10678 that you can configure ncftp so that it works for your firewall.
10680 =head2 Three basic types of firewalls
10682 Firewalls can be categorized into three basic types.
10686 =item http firewall
10688 This is where the firewall machine runs a web server and to access the
10689 outside world you must do it via the web server. If you set environment
10690 variables like http_proxy or ftp_proxy to a values beginning with http://
10691 or in your web browser you have to set proxy information then you know
10692 you are running an http firewall.
10694 To access servers outside these types of firewalls with perl (even for
10695 ftp) you will need to use LWP.
10699 This where the firewall machine runs an ftp server. This kind of
10700 firewall will only let you access ftp servers outside the firewall.
10701 This is usually done by connecting to the firewall with ftp, then
10702 entering a username like "user@outside.host.com"
10704 To access servers outside these type of firewalls with perl you
10705 will need to use Net::FTP.
10707 =item One way visibility
10709 I say one way visibility as these firewalls try to make themselves look
10710 invisible to the users inside the firewall. An FTP data connection is
10711 normally created by sending the remote server your IP address and then
10712 listening for the connection. But the remote server will not be able to
10713 connect to you because of the firewall. So for these types of firewall
10714 FTP connections need to be done in a passive mode.
10716 There are two that I can think off.
10722 If you are using a SOCKS firewall you will need to compile perl and link
10723 it with the SOCKS library, this is what is normally called a 'socksified'
10724 perl. With this executable you will be able to connect to servers outside
10725 the firewall as if it is not there.
10727 =item IP Masquerade
10729 This is the firewall implemented in the Linux kernel, it allows you to
10730 hide a complete network behind one IP address. With this firewall no
10731 special compiling is needed as you can access hosts directly.
10733 For accessing ftp servers behind such firewalls you usually need to
10734 set the environment variable C<FTP_PASSIVE> or the config variable
10735 ftp_passive to a true value.
10741 =head2 Configuring lynx or ncftp for going through a firewall
10743 If you can go through your firewall with e.g. lynx, presumably with a
10746 /usr/local/bin/lynx -pscott:tiger
10748 then you would configure CPAN.pm with the command
10750 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
10752 That's all. Similarly for ncftp or ftp, you would configure something
10755 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
10757 Your mileage may vary...
10765 I installed a new version of module X but CPAN keeps saying,
10766 I have the old version installed
10768 Most probably you B<do> have the old version installed. This can
10769 happen if a module installs itself into a different directory in the
10770 @INC path than it was previously installed. This is not really a
10771 CPAN.pm problem, you would have the same problem when installing the
10772 module manually. The easiest way to prevent this behaviour is to add
10773 the argument C<UNINST=1> to the C<make install> call, and that is why
10774 many people add this argument permanently by configuring
10776 o conf make_install_arg UNINST=1
10780 So why is UNINST=1 not the default?
10782 Because there are people who have their precise expectations about who
10783 may install where in the @INC path and who uses which @INC array. In
10784 fine tuned environments C<UNINST=1> can cause damage.
10788 I want to clean up my mess, and install a new perl along with
10789 all modules I have. How do I go about it?
10791 Run the autobundle command for your old perl and optionally rename the
10792 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
10793 with the Configure option prefix, e.g.
10795 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
10797 Install the bundle file you produced in the first step with something like
10799 cpan> install Bundle::mybundle
10805 When I install bundles or multiple modules with one command
10806 there is too much output to keep track of.
10808 You may want to configure something like
10810 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
10811 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
10813 so that STDOUT is captured in a file for later inspection.
10818 I am not root, how can I install a module in a personal directory?
10820 First of all, you will want to use your own configuration, not the one
10821 that your root user installed. If you do not have permission to write
10822 in the cpan directory that root has configured, you will be asked if
10823 you want to create your own config. Answering "yes" will bring you into
10824 CPAN's configuration stage, using the system config for all defaults except
10825 things that have to do with CPAN's work directory, saving your choices to
10826 your MyConfig.pm file.
10828 You can also manually initiate this process with the following command:
10830 % perl -MCPAN -e 'mkmyconfig'
10836 from the CPAN shell.
10838 You will most probably also want to configure something like this:
10840 o conf makepl_arg "LIB=~/myperl/lib \
10841 INSTALLMAN1DIR=~/myperl/man/man1 \
10842 INSTALLMAN3DIR=~/myperl/man/man3"
10844 You can make this setting permanent like all C<o conf> settings with
10847 You will have to add ~/myperl/man to the MANPATH environment variable
10848 and also tell your perl programs to look into ~/myperl/lib, e.g. by
10851 use lib "$ENV{HOME}/myperl/lib";
10853 or setting the PERL5LIB environment variable.
10855 While we're speaking about $ENV{HOME}, it might be worth mentioning,
10856 that for Windows we use the File::HomeDir module that provides an
10857 equivalent to the concept of the home directory on Unix.
10859 Another thing you should bear in mind is that the UNINST parameter can
10860 be dnagerous when you are installing into a private area because you
10861 might accidentally remove modules that other people depend on that are
10862 not using the private area.
10866 How to get a package, unwrap it, and make a change before building it?
10868 Have a look at the C<look> (!) command.
10872 I installed a Bundle and had a couple of fails. When I
10873 retried, everything resolved nicely. Can this be fixed to work
10876 The reason for this is that CPAN does not know the dependencies of all
10877 modules when it starts out. To decide about the additional items to
10878 install, it just uses data found in the META.yml file or the generated
10879 Makefile. An undetected missing piece breaks the process. But it may
10880 well be that your Bundle installs some prerequisite later than some
10881 depending item and thus your second try is able to resolve everything.
10882 Please note, CPAN.pm does not know the dependency tree in advance and
10883 cannot sort the queue of things to install in a topologically correct
10884 order. It resolves perfectly well IF all modules declare the
10885 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
10886 the C<requires> stanza of Module::Build. For bundles which fail and
10887 you need to install often, it is recommended to sort the Bundle
10888 definition file manually.
10892 In our intranet we have many modules for internal use. How
10893 can I integrate these modules with CPAN.pm but without uploading
10894 the modules to CPAN?
10896 Have a look at the CPAN::Site module.
10900 When I run CPAN's shell, I get an error message about things in my
10901 /etc/inputrc (or ~/.inputrc) file.
10903 These are readline issues and can only be fixed by studying readline
10904 configuration on your architecture and adjusting the referenced file
10905 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
10906 and edit them. Quite often harmless changes like uppercasing or
10907 lowercasing some arguments solves the problem.
10911 Some authors have strange characters in their names.
10913 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
10914 expecting ISO-8859-1 charset, a converter can be activated by setting
10915 term_is_latin to a true value in your config file. One way of doing so
10918 cpan> o conf term_is_latin 1
10920 If other charset support is needed, please file a bugreport against
10921 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
10922 the support or maybe UTF-8 terminals become widely available.
10926 When an install fails for some reason and then I correct the error
10927 condition and retry, CPAN.pm refuses to install the module, saying
10928 C<Already tried without success>.
10930 Use the force pragma like so
10932 force install Foo::Bar
10938 and then 'make install' directly in the subshell.
10942 How do I install a "DEVELOPER RELEASE" of a module?
10944 By default, CPAN will install the latest non-developer release of a
10945 module. If you want to install a dev release, you have to specify the
10946 partial path starting with the author id to the tarball you wish to
10949 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
10951 Note that you can use the C<ls> command to get this path listed.
10955 How do I install a module and all its dependencies from the commandline,
10956 without being prompted for anything, despite my CPAN configuration
10959 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
10960 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
10961 asked any questions at all (assuming the modules you are installing are
10962 nice about obeying that variable as well):
10964 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
10968 How do I create a Module::Build based Build.PL derived from an
10969 ExtUtils::MakeMaker focused Makefile.PL?
10971 http://search.cpan.org/search?query=Module::Build::Convert
10973 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
10977 What's the best CPAN site for me?
10979 The urllist config parameter is yours. You can add and remove sites at
10980 will. You should find out which sites have the best uptodateness,
10981 bandwidth, reliability, etc. and are topologically close to you. Some
10982 people prefer fast downloads, others uptodateness, others reliability.
10983 You decide which to try in which order.
10985 Henk P. Penning maintains a site that collects data about CPAN sites:
10987 http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
10991 =head1 COMPATIBILITY
10993 =head2 OLD PERL VERSIONS
10995 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
10996 newer versions. It is getting more and more difficult to get the
10997 minimal prerequisites working on older perls. It is close to
10998 impossible to get the whole Bundle::CPAN working there. If you're in
10999 the position to have only these old versions, be advised that CPAN is
11000 designed to work fine without the Bundle::CPAN installed.
11002 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11003 compatible with ancient perls and that File::Temp is listed as a
11004 prerequisite but CPAN has reasonable workarounds if it is missing.
11008 This module and its competitor, the CPANPLUS module, are both much
11009 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11010 more modular but it was never tried to make it compatible with CPAN.pm.
11012 =head1 SECURITY ADVICE
11014 This software enables you to upgrade software on your computer and so
11015 is inherently dangerous because the newly installed software may
11016 contain bugs and may alter the way your computer works or even make it
11017 unusable. Please consider backing up your data before every upgrade.
11021 Please report bugs via http://rt.cpan.org/
11023 Before submitting a bug, please make sure that the traditional method
11024 of building a Perl module package from a shell by following the
11025 installation instructions of that package still works in your
11030 Andreas Koenig C<< <andk@cpan.org> >>
11034 This program is free software; you can redistribute it and/or
11035 modify it under the same terms as Perl itself.
11037 See L<http://www.perl.com/perl/misc/Artistic.html>
11039 =head1 TRANSLATIONS
11041 Kawai,Takanori provides a Japanese translation of this manpage at
11042 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11046 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)