1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $CPAN::VERSION = '1.88_52';
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 ();
27 use Sys::Hostname qw(hostname);
28 use Text::ParseWords ();
31 # we need to run chdir all over and we would get at wrong libraries
34 if (File::Spec->can("rel2abs")) {
36 $inc = File::Spec->rel2abs($inc);
42 require Mac::BuildTools if $^O eq 'MacOS';
44 END { $CPAN::End++; &cleanup; }
47 $CPAN::Frontend ||= "CPAN::Shell";
48 unless (@CPAN::Defaultsites){
49 @CPAN::Defaultsites = map {
50 CPAN::URL->new(TEXT => $_, FROM => "DEF")
52 "http://www.perl.org/CPAN/",
53 "ftp://ftp.perl.org/pub/CPAN/";
55 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
56 $CPAN::Perl ||= CPAN::find_perl();
57 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
58 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
61 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
62 $Signal $Suppress_readline $Frontend
63 @Defaultsites $Have_warned $Defaultdocs $Defaultrecent
68 @CPAN::ISA = qw(CPAN::Debug Exporter);
70 # note that these functions live in CPAN::Shell and get executed via
71 # AUTOLOAD when called directly
93 sub soft_chdir_with_alternatives ($);
96 $autoload_recursion ||= 0;
98 #-> sub CPAN::AUTOLOAD ;
100 $autoload_recursion++;
104 warn "Refusing to autoload '$l' while signal pending";
105 $autoload_recursion--;
108 if ($autoload_recursion > 1) {
109 my $fullcommand = join " ", map { "'$_'" } $l, @_;
110 warn "Refusing to autoload $fullcommand in recursion\n";
111 $autoload_recursion--;
115 @export{@EXPORT} = '';
116 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
117 if (exists $export{$l}){
120 die(qq{Unknown CPAN command "$AUTOLOAD". }.
121 qq{Type ? for help.\n});
123 $autoload_recursion--;
127 #-> sub CPAN::shell ;
130 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
131 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
133 my $oprompt = shift || CPAN::Prompt->new;
134 my $prompt = $oprompt;
135 my $commandline = shift || "";
136 $CPAN::CurrentCommandId ||= 1;
139 unless ($Suppress_readline) {
140 require Term::ReadLine;
143 $term->ReadLine eq "Term::ReadLine::Stub"
145 $term = Term::ReadLine->new('CPAN Monitor');
147 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
148 my $attribs = $term->Attribs;
149 $attribs->{attempted_completion_function} = sub {
150 &CPAN::Complete::gnu_cpl;
153 $readline::rl_completion_function =
154 $readline::rl_completion_function = 'CPAN::Complete::cpl';
156 if (my $histfile = $CPAN::Config->{'histfile'}) {{
157 unless ($term->can("AddHistory")) {
158 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
161 my($fh) = FileHandle->new;
162 open $fh, "<$histfile" or last;
166 $term->AddHistory($_);
170 for ($CPAN::Config->{term_ornaments}) { # alias
171 local $Term::ReadLine::termcap_nowarn = 1;
172 $term->ornaments($_) if defined;
174 # $term->OUT is autoflushed anyway
175 my $odef = select STDERR;
182 # no strict; # I do not recall why no strict was here (2000-09-03)
184 my @cwd = grep { defined $_ and length $_ }
186 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
187 File::Spec->rootdir();
188 my $try_detect_readline;
189 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
190 my $rl_avail = $Suppress_readline ? "suppressed" :
191 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
192 "available (try 'install Bundle::CPAN')";
194 unless ($CPAN::Config->{'inhibit_startup_message'}){
195 $CPAN::Frontend->myprint(
197 cpan shell -- CPAN exploration and modules installation (v%s)
205 my($continuation) = "";
206 my $last_term_ornaments;
207 SHELLCOMMAND: while () {
208 if ($Suppress_readline) {
210 last SHELLCOMMAND unless defined ($_ = <> );
213 last SHELLCOMMAND unless
214 defined ($_ = $term->readline($prompt, $commandline));
216 $_ = "$continuation$_" if $continuation;
218 next SHELLCOMMAND if /^$/;
219 $_ = 'h' if /^\s*\?/;
220 if (/^(?:q(?:uit)?|bye|exit)$/i) {
231 use vars qw($import_done);
232 CPAN->import(':DEFAULT') unless $import_done++;
233 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
240 if ($] < 5.00322) { # parsewords had a bug until recently
243 eval { @line = Text::ParseWords::shellwords($_) };
244 warn($@), next SHELLCOMMAND if $@;
245 warn("Text::Parsewords could not parse the line [$_]"),
246 next SHELLCOMMAND unless @line;
248 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
249 my $command = shift @line;
250 eval { CPAN::Shell->$command(@line) };
252 if ($command =~ /^(make|test|install|force|notest|clean|upgrade)$/) {
253 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
255 soft_chdir_with_alternatives(\@cwd);
256 $CPAN::Frontend->myprint("\n");
258 $CPAN::CurrentCommandId++;
262 $commandline = ""; # I do want to be able to pass a default to
263 # shell, but on the second command I see no
266 CPAN::Queue->nullify_queue;
267 if ($try_detect_readline) {
268 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
270 $CPAN::META->has_inst("Term::ReadLine::Perl")
272 delete $INC{"Term/ReadLine.pm"};
274 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
275 require Term::ReadLine;
276 $CPAN::Frontend->myprint("\n$redef subroutines in ".
277 "Term::ReadLine redefined\n");
282 if ($term and $term->can("ornaments")) {
283 for ($CPAN::Config->{term_ornaments}) { # alias
285 if (not defined $last_term_ornaments
286 or $_ != $last_term_ornaments
288 local $Term::ReadLine::termcap_nowarn = 1;
289 $term->ornaments($_);
290 $last_term_ornaments = $_;
293 undef $last_term_ornaments;
298 soft_chdir_with_alternatives(\@cwd);
301 sub soft_chdir_with_alternatives ($) {
304 my $root = File::Spec->rootdir();
305 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
306 Trying '$root' as temporary haven.
311 if (chdir $cwd->[0]) {
315 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
316 Trying to chdir to "$cwd->[1]" instead.
320 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
326 package CPAN::CacheMgr;
328 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
333 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
334 @CPAN::FTP::ISA = qw(CPAN::Debug);
336 package CPAN::LWP::UserAgent;
338 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
339 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
341 package CPAN::Complete;
343 @CPAN::Complete::ISA = qw(CPAN::Debug);
344 @CPAN::Complete::COMMANDS = sort qw(
345 ! a b d h i m o q r u
369 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
370 @CPAN::Index::ISA = qw(CPAN::Debug);
373 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
376 package CPAN::InfoObj;
378 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
380 package CPAN::Author;
382 @CPAN::Author::ISA = qw(CPAN::InfoObj);
384 package CPAN::Distribution;
386 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
388 package CPAN::Bundle;
390 @CPAN::Bundle::ISA = qw(CPAN::Module);
392 package CPAN::Module;
394 @CPAN::Module::ISA = qw(CPAN::InfoObj);
396 package CPAN::Exception::RecursiveDependency;
398 use overload '""' => "as_string";
405 for my $dep (@$deps) {
407 last if $seen{$dep}++;
409 bless { deps => \@deps }, $class;
414 "\nRecursive dependency detected:\n " .
415 join("\n => ", @{$self->{deps}}) .
416 ".\nCannot continue.\n";
419 package CPAN::Prompt; use overload '""' => "as_string";
420 use vars qw($prompt);
422 $CPAN::CurrentCommandId ||= 0;
427 if ($CPAN::Config->{commandnumber_in_prompt}) {
428 sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
434 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
435 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
436 # planned are things like age or quality
438 my($class,%args) = @_;
450 $self->{TEXT} = $set;
455 package CPAN::Distrostatus;
456 use overload '""' => "as_string",
459 my($class,$arg) = @_;
462 FAILED => substr($arg,0,2) eq "NO",
463 COMMANDID => $CPAN::CurrentCommandId,
466 sub commandid { shift->{COMMANDID} }
467 sub failed { shift->{FAILED} }
471 $self->{TEXT} = $set;
482 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY
485 @CPAN::Shell::ISA = qw(CPAN::Debug);
486 $COLOR_REGISTERED ||= 0;
489 # $GLOBAL_AUTOLOAD_RECURSION = 12;
490 $autoload_recursion ||= 0;
492 #-> sub CPAN::Shell::AUTOLOAD ;
494 $autoload_recursion++;
496 my $class = shift(@_);
497 # warn "autoload[$l] class[$class]";
500 warn "Refusing to autoload '$l' while signal pending";
501 $autoload_recursion--;
504 if ($autoload_recursion > 1) {
505 my $fullcommand = join " ", map { "'$_'" } $l, @_;
506 warn "Refusing to autoload $fullcommand in recursion\n";
507 $autoload_recursion--;
511 # XXX needs to be reconsidered
512 if ($CPAN::META->has_inst('CPAN::WAIT')) {
515 $CPAN::Frontend->mywarn(qq{
516 Commands starting with "w" require CPAN::WAIT to be installed.
517 Please consider installing CPAN::WAIT to use the fulltext index.
518 For this you just need to type
523 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
527 $autoload_recursion--;
534 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
536 # from here on only subs.
537 ################################################################################
539 sub suggest_myconfig () {
540 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
541 $CPAN::Frontend->myprint("You don't seem to have a user ".
542 "configuration (MyConfig.pm) yet.\n");
543 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
544 "user configuration now? (Y/n)",
547 CPAN::Shell->mkmyconfig();
550 $CPAN::Frontend->mydie("OK, giving up.");
555 #-> sub CPAN::all_objects ;
557 my($mgr,$class) = @_;
558 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
559 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
561 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
564 # Called by shell, not in batch mode. In batch mode I see no risk in
565 # having many processes updating something as installations are
566 # continually checked at runtime. In shell mode I suspect it is
567 # unintentional to open more than one shell at a time
569 #-> sub CPAN::checklock ;
572 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
573 if (-f $lockfile && -M _ > 0) {
574 my $fh = FileHandle->new($lockfile) or
575 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
576 my $otherpid = <$fh>;
577 my $otherhost = <$fh>;
579 if (defined $otherpid && $otherpid) {
582 if (defined $otherhost && $otherhost) {
585 my $thishost = hostname();
586 if (defined $otherhost && defined $thishost &&
587 $otherhost ne '' && $thishost ne '' &&
588 $otherhost ne $thishost) {
589 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
590 "reports other host $otherhost and other ".
591 "process $otherpid.\n".
592 "Cannot proceed.\n"));
594 elsif (defined $otherpid && $otherpid) {
595 return if $$ == $otherpid; # should never happen
596 $CPAN::Frontend->mywarn(
598 There seems to be running another CPAN process (pid $otherpid). Contacting...
600 if (kill 0, $otherpid) {
601 $CPAN::Frontend->mydie(qq{Other job is running.
602 You may want to kill it and delete the lockfile, maybe. On UNIX try:
606 } elsif (-w $lockfile) {
608 CPAN::Shell::colorable_makemaker_prompt
609 (qq{Other job not responding. Shall I overwrite }.
610 qq{the lockfile '$lockfile'? (Y/n)},"y");
611 $CPAN::Frontend->myexit("Ok, bye\n")
612 unless $ans =~ /^y/i;
615 qq{Lockfile '$lockfile' not writeable by you. }.
616 qq{Cannot proceed.\n}.
618 qq{ rm '$lockfile'\n}.
619 qq{ and then rerun us.\n}
623 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
624 "reports other process with ID ".
625 "$otherpid. Cannot proceed.\n"));
628 my $dotcpan = $CPAN::Config->{cpan_home};
629 eval { File::Path::mkpath($dotcpan);};
631 # A special case at least for Jarkko.
636 $symlinkcpan = readlink $dotcpan;
637 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
638 eval { File::Path::mkpath($symlinkcpan); };
642 $CPAN::Frontend->mywarn(qq{
643 Working directory $symlinkcpan created.
647 unless (-d $dotcpan) {
649 Your configuration suggests "$dotcpan" as your
650 CPAN.pm working directory. I could not create this directory due
651 to this error: $firsterror\n};
653 As "$dotcpan" is a symlink to "$symlinkcpan",
654 I tried to create that, but I failed with this error: $seconderror
657 Please make sure the directory exists and is writable.
659 $CPAN::Frontend->myprint($mess);
660 return suggest_myconfig;
662 } # $@ after eval mkpath $dotcpan
664 unless ($fh = FileHandle->new(">$lockfile")) {
665 if ($! =~ /Permission/) {
666 $CPAN::Frontend->myprint(qq{
668 Your configuration suggests that CPAN.pm should use a working
670 $CPAN::Config->{cpan_home}
671 Unfortunately we could not create the lock file
673 due to permission problems.
675 Please make sure that the configuration variable
676 \$CPAN::Config->{cpan_home}
677 points to a directory where you can write a .lock file. You can set
678 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
681 return suggest_myconfig;
684 $fh->print($$, "\n");
685 $fh->print(hostname(), "\n");
686 $self->{LOCK} = $lockfile;
691 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
697 die "Got yet another signal" if $Signal > 1;
698 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
699 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
703 # From: Larry Wall <larry@wall.org>
704 # Subject: Re: deprecating SIGDIE
705 # To: perl5-porters@perl.org
706 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
708 # The original intent of __DIE__ was only to allow you to substitute one
709 # kind of death for another on an application-wide basis without respect
710 # to whether you were in an eval or not. As a global backstop, it should
711 # not be used any more lightly (or any more heavily :-) than class
712 # UNIVERSAL. Any attempt to build a general exception model on it should
713 # be politely squashed. Any bug that causes every eval {} to have to be
714 # modified should be not so politely squashed.
716 # Those are my current opinions. It is also my optinion that polite
717 # arguments degenerate to personal arguments far too frequently, and that
718 # when they do, it's because both people wanted it to, or at least didn't
719 # sufficiently want it not to.
723 # global backstop to cleanup if we should really die
724 $SIG{__DIE__} = \&cleanup;
725 $self->debug("Signal handler set.") if $CPAN::DEBUG;
728 #-> sub CPAN::DESTROY ;
730 &cleanup; # need an eval?
733 #-> sub CPAN::anycwd ;
736 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
741 sub cwd {Cwd::cwd();}
743 #-> sub CPAN::getcwd ;
744 sub getcwd {Cwd::getcwd();}
746 #-> sub CPAN::fastcwd ;
747 sub fastcwd {Cwd::fastcwd();}
749 #-> sub CPAN::backtickcwd ;
750 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
752 #-> sub CPAN::find_perl ;
754 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
755 my $pwd = $CPAN::iCwd = CPAN::anycwd();
756 my $candidate = File::Spec->catfile($pwd,$^X);
757 $perl ||= $candidate if MM->maybe_command($candidate);
760 my ($component,$perl_name);
761 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
762 PATH_COMPONENT: foreach $component (File::Spec->path(),
763 $Config::Config{'binexp'}) {
764 next unless defined($component) && $component;
765 my($abs) = File::Spec->catfile($component,$perl_name);
766 if (MM->maybe_command($abs)) {
778 #-> sub CPAN::exists ;
780 my($mgr,$class,$id) = @_;
781 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
783 ### Carp::croak "exists called without class argument" unless $class;
785 $id =~ s/:+/::/g if $class eq "CPAN::Module";
786 exists $META->{readonly}{$class}{$id} or
787 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
790 #-> sub CPAN::delete ;
792 my($mgr,$class,$id) = @_;
793 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
794 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
797 #-> sub CPAN::has_usable
798 # has_inst is sometimes too optimistic, we should replace it with this
799 # has_usable whenever a case is given
801 my($self,$mod,$message) = @_;
802 return 1 if $HAS_USABLE->{$mod};
803 my $has_inst = $self->has_inst($mod,$message);
804 return unless $has_inst;
807 LWP => [ # we frequently had "Can't locate object
808 # method "new" via package "LWP::UserAgent" at
809 # (eval 69) line 2006
811 sub {require LWP::UserAgent},
812 sub {require HTTP::Request},
813 sub {require URI::URL},
816 sub {require Net::FTP},
817 sub {require Net::Config},
820 sub {require File::HomeDir;
821 unless (File::HomeDir->VERSION >= 0.52){
822 for ("Will not use File::HomeDir, need 0.52\n") {
823 $CPAN::Frontend->mywarn($_);
830 if ($usable->{$mod}) {
831 for my $c (0..$#{$usable->{$mod}}) {
832 my $code = $usable->{$mod}[$c];
833 my $ret = eval { &$code() };
834 $ret = "" unless defined $ret;
836 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
841 return $HAS_USABLE->{$mod} = 1;
844 #-> sub CPAN::has_inst
846 my($self,$mod,$message) = @_;
847 Carp::croak("CPAN->has_inst() called without an argument")
849 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
850 keys %{$CPAN::Config->{dontload_hash}||{}},
851 @{$CPAN::Config->{dontload_list}||[]};
852 if (defined $message && $message eq "no" # afair only used by Nox
856 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
864 # checking %INC is wrong, because $INC{LWP} may be true
865 # although $INC{"URI/URL.pm"} may have failed. But as
866 # I really want to say "bla loaded OK", I have to somehow
868 ### warn "$file in %INC"; #debug
870 } elsif (eval { require $file }) {
871 # eval is good: if we haven't yet read the database it's
872 # perfect and if we have installed the module in the meantime,
873 # it tries again. The second require is only a NOOP returning
874 # 1 if we had success, otherwise it's retrying
876 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
877 if ($mod eq "CPAN::WAIT") {
878 push @CPAN::Shell::ISA, 'CPAN::WAIT';
881 } elsif ($mod eq "Net::FTP") {
882 $CPAN::Frontend->mywarn(qq{
883 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
885 install Bundle::libnet
887 }) unless $Have_warned->{"Net::FTP"}++;
888 $CPAN::Frontend->mysleep(3);
889 } elsif ($mod eq "Digest::SHA"){
890 if ($Have_warned->{"Digest::SHA"}++) {
891 $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
892 qq{because Digest::SHA not installed.\n});
894 $CPAN::Frontend->mywarn(qq{
895 CPAN: checksum security checks disabled because Digest::SHA not installed.
896 Please consider installing the Digest::SHA module.
899 $CPAN::Frontend->mysleep(2);
901 } elsif ($mod eq "Module::Signature"){
902 if (not $CPAN::Config->{check_sigs}) {
903 # they do not want us:-(
904 } elsif (not $Have_warned->{"Module::Signature"}++) {
905 # No point in complaining unless the user can
906 # reasonably install and use it.
907 if (eval { require Crypt::OpenPGP; 1 } ||
909 defined $CPAN::Config->{'gpg'}
911 $CPAN::Config->{'gpg'} =~ /\S/
914 $CPAN::Frontend->mywarn(qq{
915 CPAN: Module::Signature security checks disabled because Module::Signature
916 not installed. Please consider installing the Module::Signature module.
917 You may also need to be able to connect over the Internet to the public
918 keyservers like pgp.mit.edu (port 11371).
921 $CPAN::Frontend->mysleep(2);
925 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
930 #-> sub CPAN::instance ;
932 my($mgr,$class,$id) = @_;
935 # unsafe meta access, ok?
936 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
937 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
945 #-> sub CPAN::cleanup ;
947 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
948 local $SIG{__DIE__} = '';
953 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
955 $subroutine eq '(eval)';
957 return if $ineval && !$CPAN::End;
958 return unless defined $META->{LOCK};
959 return unless -f $META->{LOCK};
961 unlink $META->{LOCK};
963 # Carp::cluck("DEBUGGING");
964 $CPAN::Frontend->myprint("Lockfile removed.\n");
967 #-> sub CPAN::savehist
970 my($histfile,$histsize);
971 unless ($histfile = $CPAN::Config->{'histfile'}){
972 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
975 $histsize = $CPAN::Config->{'histsize'} || 100;
977 unless ($CPAN::term->can("GetHistory")) {
978 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
984 my @h = $CPAN::term->GetHistory;
985 splice @h, 0, @h-$histsize if @h>$histsize;
986 my($fh) = FileHandle->new;
987 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
988 local $\ = local $, = "\n";
994 my($self,$what) = @_;
995 $self->{is_tested}{$what} = 1;
998 # unsets the is_tested flag: as soon as the thing is installed, it is
999 # not needed in set_perl5lib anymore
1001 my($self,$what) = @_;
1002 delete $self->{is_tested}{$what};
1007 $self->{is_tested} ||= {};
1008 return unless %{$self->{is_tested}};
1009 my $env = $ENV{PERL5LIB};
1010 $env = $ENV{PERLLIB} unless defined $env;
1012 push @env, $env if defined $env and length $env;
1013 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1014 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1015 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1018 package CPAN::CacheMgr;
1021 #-> sub CPAN::CacheMgr::as_string ;
1023 eval { require Data::Dumper };
1025 return shift->SUPER::as_string;
1027 return Data::Dumper::Dumper(shift);
1031 #-> sub CPAN::CacheMgr::cachesize ;
1036 #-> sub CPAN::CacheMgr::tidyup ;
1039 return unless -d $self->{ID};
1040 while ($self->{DU} > $self->{'MAX'} ) {
1041 my($toremove) = shift @{$self->{FIFO}};
1042 $CPAN::Frontend->myprint(sprintf(
1043 "Deleting from cache".
1044 ": $toremove (%.1f>%.1f MB)\n",
1045 $self->{DU}, $self->{'MAX'})
1047 return if $CPAN::Signal;
1048 $self->force_clean_cache($toremove);
1049 return if $CPAN::Signal;
1053 #-> sub CPAN::CacheMgr::dir ;
1058 #-> sub CPAN::CacheMgr::entries ;
1060 my($self,$dir) = @_;
1061 return unless defined $dir;
1062 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1063 $dir ||= $self->{ID};
1064 my($cwd) = CPAN::anycwd();
1065 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1066 my $dh = DirHandle->new(File::Spec->curdir)
1067 or Carp::croak("Couldn't opendir $dir: $!");
1070 next if $_ eq "." || $_ eq "..";
1072 push @entries, File::Spec->catfile($dir,$_);
1074 push @entries, File::Spec->catdir($dir,$_);
1076 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1079 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1080 sort { -M $b <=> -M $a} @entries;
1083 #-> sub CPAN::CacheMgr::disk_usage ;
1085 my($self,$dir) = @_;
1086 return if exists $self->{SIZE}{$dir};
1087 return if $CPAN::Signal;
1091 unless (chmod 0755, $dir) {
1092 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1093 "permission to change the permission; cannot ".
1094 "estimate disk usage of '$dir'\n");
1095 $CPAN::Frontend->mysleep(5);
1100 $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1105 $File::Find::prune++ if $CPAN::Signal;
1107 if ($^O eq 'MacOS') {
1109 my $cat = Mac::Files::FSpGetCatInfo($_);
1110 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1114 unless (chmod 0755, $_) {
1115 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1116 "the permission to change the permission; ".
1117 "can only partially estimate disk usage ".
1119 $CPAN::Frontend->mysleep(5);
1130 return if $CPAN::Signal;
1131 $self->{SIZE}{$dir} = $Du/1024/1024;
1132 push @{$self->{FIFO}}, $dir;
1133 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1134 $self->{DU} += $Du/1024/1024;
1138 #-> sub CPAN::CacheMgr::force_clean_cache ;
1139 sub force_clean_cache {
1140 my($self,$dir) = @_;
1141 return unless -e $dir;
1142 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1144 File::Path::rmtree($dir);
1145 $self->{DU} -= $self->{SIZE}{$dir};
1146 delete $self->{SIZE}{$dir};
1149 #-> sub CPAN::CacheMgr::new ;
1156 ID => $CPAN::Config->{'build_dir'},
1157 MAX => $CPAN::Config->{'build_cache'},
1158 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1161 File::Path::mkpath($self->{ID});
1162 my $dh = DirHandle->new($self->{ID});
1163 bless $self, $class;
1166 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1168 CPAN->debug($debug) if $CPAN::DEBUG;
1172 #-> sub CPAN::CacheMgr::scan_cache ;
1175 return if $self->{SCAN} eq 'never';
1176 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1177 unless $self->{SCAN} eq 'atstart';
1178 $CPAN::Frontend->myprint(
1179 sprintf("Scanning cache %s for sizes\n",
1182 for $e ($self->entries($self->{ID})) {
1183 next if $e eq ".." || $e eq ".";
1184 $self->disk_usage($e);
1185 return if $CPAN::Signal;
1190 package CPAN::Shell;
1193 #-> sub CPAN::Shell::h ;
1195 my($class,$about) = @_;
1196 if (defined $about) {
1197 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1199 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1200 $CPAN::Frontend->myprint(qq{
1201 Display Information $filler (ver $CPAN::VERSION)
1202 command argument description
1203 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1204 i WORD or /REGEXP/ about any of the above
1205 ls AUTHOR or GLOB about files in the author's directory
1206 (with WORD being a module, bundle or author name or a distribution
1207 name of the form AUTHOR/DISTRIBUTION)
1209 Download, Test, Make, Install...
1210 get download clean make clean
1211 make make (implies get) look open subshell in dist directory
1212 test make test (implies make) readme display these README files
1213 install make install (implies test) perldoc display POD documentation
1216 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1217 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1220 force COMMAND unconditionally do command
1221 notest COMMAND skip testing
1224 h,? display this menu ! perl-code eval a perl command
1225 o conf [opt] set and query options q quit the cpan shell
1226 reload cpan load CPAN.pm again reload index load newer indices
1227 autobundle Snapshot recent latest CPAN uploads});
1233 #-> sub CPAN::Shell::a ;
1235 my($self,@arg) = @_;
1236 # authors are always UPPERCASE
1238 $_ = uc $_ unless /=/;
1240 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1243 #-> sub CPAN::Shell::globls ;
1245 my($self,$s,$pragmas) = @_;
1246 # ls is really very different, but we had it once as an ordinary
1247 # command in the Shell (upto rev. 321) and we could not handle
1249 my(@accept,@preexpand);
1250 if ($s =~ /[\*\?\/]/) {
1251 if ($CPAN::META->has_inst("Text::Glob")) {
1252 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1253 my $rau = Text::Glob::glob_to_regex(uc $au);
1254 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1256 push @preexpand, map { $_->id . "/" . $pathglob }
1257 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1259 my $rau = Text::Glob::glob_to_regex(uc $s);
1260 push @preexpand, map { $_->id }
1261 CPAN::Shell->expand_by_method('CPAN::Author',
1266 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1269 push @preexpand, uc $s;
1272 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1273 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1278 my $silent = @accept>1;
1279 my $last_alpha = "";
1281 for my $a (@accept){
1282 my($author,$pathglob);
1283 if ($a =~ m|(.*?)/(.*)|) {
1286 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1288 $a2) or die "No author found for $a2";
1290 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1292 $a) or die "No author found for $a";
1295 my $alpha = substr $author->id, 0, 1;
1297 if ($alpha eq $last_alpha) {
1301 $last_alpha = $alpha;
1303 $CPAN::Frontend->myprint($ad);
1305 for my $pragma (@$pragmas) {
1306 if ($author->can($pragma)) {
1310 push @results, $author->ls($pathglob,$silent); # silent if
1313 for my $pragma (@$pragmas) {
1314 my $meth = "un$pragma";
1315 if ($author->can($meth)) {
1323 #-> sub CPAN::Shell::local_bundles ;
1325 my($self,@which) = @_;
1326 my($incdir,$bdir,$dh);
1327 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1328 my @bbase = "Bundle";
1329 while (my $bbase = shift @bbase) {
1330 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1331 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1332 if ($dh = DirHandle->new($bdir)) { # may fail
1334 for $entry ($dh->read) {
1335 next if $entry =~ /^\./;
1336 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1337 if (-d File::Spec->catdir($bdir,$entry)){
1338 push @bbase, "$bbase\::$entry";
1340 next unless $entry =~ s/\.pm(?!\n)\Z//;
1341 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1349 #-> sub CPAN::Shell::b ;
1351 my($self,@which) = @_;
1352 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1353 $self->local_bundles;
1354 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1357 #-> sub CPAN::Shell::d ;
1358 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1360 #-> sub CPAN::Shell::m ;
1361 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1363 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1366 #-> sub CPAN::Shell::i ;
1370 @args = '/./' unless @args;
1372 for my $type (qw/Bundle Distribution Module/) {
1373 push @result, $self->expand($type,@args);
1375 # Authors are always uppercase.
1376 push @result, $self->expand("Author", map { uc $_ } @args);
1378 my $result = @result == 1 ?
1379 $result[0]->as_string :
1381 "No objects found of any type for argument @args\n" :
1383 (map {$_->as_glimpse} @result),
1384 scalar @result, " items found\n",
1386 $CPAN::Frontend->myprint($result);
1389 #-> sub CPAN::Shell::o ;
1391 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1392 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1393 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1394 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1396 my($self,$o_type,@o_what) = @_;
1399 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1400 if ($o_type eq 'conf') {
1401 if (!@o_what) { # print all things, "o conf"
1403 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1405 if (exists $INC{'CPAN/Config.pm'}) {
1406 push @from, $INC{'CPAN/Config.pm'};
1408 if (exists $INC{'CPAN/MyConfig.pm'}) {
1409 push @from, $INC{'CPAN/MyConfig.pm'};
1411 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1412 $CPAN::Frontend->myprint(":\n");
1413 for $k (sort keys %CPAN::HandleConfig::can) {
1414 $v = $CPAN::HandleConfig::can{$k};
1415 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1417 $CPAN::Frontend->myprint("\n");
1418 for $k (sort keys %$CPAN::Config) {
1419 CPAN::HandleConfig->prettyprint($k);
1421 $CPAN::Frontend->myprint("\n");
1422 } elsif (!CPAN::HandleConfig->edit(@o_what)) {
1423 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1426 } elsif ($o_type eq 'debug') {
1428 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1431 my($what) = shift @o_what;
1432 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1433 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1436 if ( exists $CPAN::DEBUG{$what} ) {
1437 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1438 } elsif ($what =~ /^\d/) {
1439 $CPAN::DEBUG = $what;
1440 } elsif (lc $what eq 'all') {
1442 for (values %CPAN::DEBUG) {
1445 $CPAN::DEBUG = $max;
1448 for (keys %CPAN::DEBUG) {
1449 next unless lc($_) eq lc($what);
1450 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1453 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1458 my $raw = "Valid options for debug are ".
1459 join(", ",sort(keys %CPAN::DEBUG), 'all').
1460 qq{ or a number. Completion works on the options. }.
1461 qq{Case is ignored.};
1463 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1464 $CPAN::Frontend->myprint("\n\n");
1467 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1469 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1470 $v = $CPAN::DEBUG{$k};
1471 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1472 if $v & $CPAN::DEBUG;
1475 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1478 $CPAN::Frontend->myprint(qq{
1480 conf set or get configuration variables
1481 debug set or get debugging options
1486 sub paintdots_onreload {
1489 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1493 # $CPAN::Frontend->myprint(".($subr)");
1494 $CPAN::Frontend->myprint(".");
1501 #-> sub CPAN::Shell::reload ;
1503 my($self,$command,@arg) = @_;
1505 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1506 if ($command =~ /^cpan$/i) {
1508 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1512 "CPAN/HandleConfig.pm",
1513 "CPAN/FirstTime.pm",
1520 MFILE: for my $f (@relo) {
1521 next unless exists $INC{$f};
1525 $CPAN::Frontend->myprint("($p");
1526 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1527 $self->reload_this($f) or $failed++;
1528 my $v = eval "$p\::->VERSION";
1529 $CPAN::Frontend->myprint("v$v)");
1531 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1532 $failed++ unless $redef;
1534 my $errors = $failed == 1 ? "error" : "errors";
1535 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1538 } elsif ($command =~ /^index$/i) {
1539 CPAN::Index->force_reload;
1541 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
1542 index re-reads the index files\n});
1546 # reload means only load again what we have loaded before
1547 #-> sub CPAN::Shell::reload_this ;
1550 CPAN->debug("f[$f]") if $CPAN::DEBUG;
1551 return 1 unless $INC{$f}; # we never loaded this, so we do not
1553 my $pwd = CPAN::anycwd();
1554 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1556 for my $inc (@INC) {
1557 $file = File::Spec->catfile($inc,split /\//, $f);
1561 CPAN->debug("file[$file]") if $CPAN::DEBUG;
1563 unless ($file && -f $file) {
1564 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1566 @inc = substr($file,0,-length($f)); # bring in back to me!
1568 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1570 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1573 my $fh = FileHandle->new($file) or
1574 $CPAN::Frontend->mydie("Could not open $file: $!");
1577 my $content = <$fh>;
1578 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1582 eval "require '$f'";
1590 #-> sub CPAN::Shell::mkmyconfig ;
1592 my($self, $cpanpm, %args) = @_;
1593 require CPAN::FirstTime;
1594 my $home = CPAN::HandleConfig::home;
1595 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1596 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1597 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1598 CPAN::HandleConfig::require_myconfig_or_config;
1599 $CPAN::Config ||= {};
1604 keep_source_where => undef,
1607 CPAN::FirstTime::init($cpanpm, %args);
1610 #-> sub CPAN::Shell::_binary_extensions ;
1611 sub _binary_extensions {
1612 my($self) = shift @_;
1613 my(@result,$module,%seen,%need,$headerdone);
1614 for $module ($self->expand('Module','/./')) {
1615 my $file = $module->cpan_file;
1616 next if $file eq "N/A";
1617 next if $file =~ /^Contact Author/;
1618 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1619 next if $dist->isa_perl;
1620 next unless $module->xs_file;
1622 $CPAN::Frontend->myprint(".");
1623 push @result, $module;
1625 # print join " | ", @result;
1626 $CPAN::Frontend->myprint("\n");
1630 #-> sub CPAN::Shell::recompile ;
1632 my($self) = shift @_;
1633 my($module,@module,$cpan_file,%dist);
1634 @module = $self->_binary_extensions();
1635 for $module (@module){ # we force now and compile later, so we
1637 $cpan_file = $module->cpan_file;
1638 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1640 $dist{$cpan_file}++;
1642 for $cpan_file (sort keys %dist) {
1643 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1644 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1646 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1647 # stop a package from recompiling,
1648 # e.g. IO-1.12 when we have perl5.003_10
1652 #-> sub CPAN::Shell::scripts ;
1654 my($self, $arg) = @_;
1655 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1657 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1658 unless ($CPAN::META->has_inst($req)) {
1659 $CPAN::Frontend->mywarn(" $req not available\n");
1662 my $p = HTML::LinkExtor->new();
1663 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1664 unless (-f $indexfile) {
1665 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1667 $p->parse_file($indexfile);
1670 if ($arg =~ s|^/(.+)/$|$1|) {
1671 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1673 for my $l ($p->links) {
1674 my $tag = shift @$l;
1675 next unless $tag eq "a";
1677 my $href = $att{href};
1678 next unless $href =~ s|^\.\./authors/id/./../||;
1681 if ($href =~ $qrarg) {
1685 if ($href =~ /\Q$arg\E/) {
1693 # now filter for the latest version if there is more than one of a name
1699 $stems{$stem} ||= [];
1700 push @{$stems{$stem}}, $href;
1702 for (sort keys %stems) {
1704 if (@{$stems{$_}} > 1) {
1705 $highest = List::Util::reduce {
1706 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1709 $highest = $stems{$_}[0];
1711 $CPAN::Frontend->myprint("$highest\n");
1715 #-> sub CPAN::Shell::upgrade ;
1717 my($self,@args) = @_;
1718 $self->install($self->r(@args));
1721 #-> sub CPAN::Shell::_u_r_common ;
1723 my($self) = shift @_;
1724 my($what) = shift @_;
1725 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1726 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1727 $what && $what =~ /^[aru]$/;
1729 @args = '/./' unless @args;
1730 my(@result,$module,%seen,%need,$headerdone,
1731 $version_undefs,$version_zeroes);
1732 $version_undefs = $version_zeroes = 0;
1733 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1734 my @expand = $self->expand('Module',@args);
1735 my $expand = scalar @expand;
1736 if (0) { # Looks like noise to me, was very useful for debugging
1737 # for metadata cache
1738 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1740 MODULE: for $module (@expand) {
1741 my $file = $module->cpan_file;
1742 next MODULE unless defined $file; # ??
1743 $file =~ s|^./../||;
1744 my($latest) = $module->cpan_version;
1745 my($inst_file) = $module->inst_file;
1747 return if $CPAN::Signal;
1750 $have = $module->inst_version;
1751 } elsif ($what eq "r") {
1752 $have = $module->inst_version;
1754 if ($have eq "undef"){
1756 } elsif ($have == 0){
1759 next MODULE unless CPAN::Version->vgt($latest, $have);
1760 # to be pedantic we should probably say:
1761 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1762 # to catch the case where CPAN has a version 0 and we have a version undef
1763 } elsif ($what eq "u") {
1769 } elsif ($what eq "r") {
1771 } elsif ($what eq "u") {
1775 return if $CPAN::Signal; # this is sometimes lengthy
1778 push @result, sprintf "%s %s\n", $module->id, $have;
1779 } elsif ($what eq "r") {
1780 push @result, $module->id;
1781 next MODULE if $seen{$file}++;
1782 } elsif ($what eq "u") {
1783 push @result, $module->id;
1784 next MODULE if $seen{$file}++;
1785 next MODULE if $file =~ /^Contact/;
1787 unless ($headerdone++){
1788 $CPAN::Frontend->myprint("\n");
1789 $CPAN::Frontend->myprint(sprintf(
1792 "Package namespace",
1801 # $GLOBAL_AUTOLOAD_RECURSION = 12;
1805 $CPAN::META->has_inst("Term::ANSIColor")
1807 $module->description
1809 $color_on = Term::ANSIColor::color("green");
1810 $color_off = Term::ANSIColor::color("reset");
1812 $CPAN::Frontend->myprint(sprintf $sprintf,
1819 $need{$module->id}++;
1823 $CPAN::Frontend->myprint("No modules found for @args\n");
1824 } elsif ($what eq "r") {
1825 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1829 if ($version_zeroes) {
1830 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1831 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1832 qq{a version number of 0\n});
1834 if ($version_undefs) {
1835 my $s_has = $version_undefs > 1 ? "s have" : " has";
1836 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1837 qq{parseable version number\n});
1843 #-> sub CPAN::Shell::r ;
1845 shift->_u_r_common("r",@_);
1848 #-> sub CPAN::Shell::u ;
1850 shift->_u_r_common("u",@_);
1853 #-> sub CPAN::Shell::failed ;
1855 my($self,$only_id,$silent) = @_;
1857 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1859 NAY: for my $nosayer (
1867 next unless exists $d->{$nosayer};
1869 $d->{$nosayer}->can("failed") ?
1870 $d->{$nosayer}->failed :
1871 $d->{$nosayer} =~ /^NO/
1873 next NAY if $only_id && $only_id != (
1874 $d->{$nosayer}->can("commandid")
1876 $d->{$nosayer}->commandid
1878 $CPAN::CurrentCommandId
1883 next DIST unless $failed;
1887 # " %-45s: %s %s\n",
1890 $d->{$failed}->can("failed") ?
1892 $d->{$failed}->commandid,
1895 $d->{$failed}->text,
1905 my $scope = $only_id ? "command" : "session";
1907 my $print = join "",
1908 map { sprintf " %-45s: %s %s\n", @$_[1,2,3] }
1909 sort { $a->[0] <=> $b->[0] } @failed;
1910 $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
1911 } elsif (!$only_id || !$silent) {
1912 $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
1916 # XXX intentionally undocumented because completely bogus, unportable,
1919 #-> sub CPAN::Shell::status ;
1922 require Devel::Size;
1923 my $ps = FileHandle->new;
1924 open $ps, "/proc/$$/status";
1927 next unless /VmSize:\s+(\d+)/;
1931 $CPAN::Frontend->mywarn(sprintf(
1932 "%-27s %6d\n%-27s %6d\n",
1936 Devel::Size::total_size($CPAN::META)/1024,
1938 for my $k (sort keys %$CPAN::META) {
1939 next unless substr($k,0,4) eq "read";
1940 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
1941 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
1942 warn sprintf " %-25s %6d (keys: %6d)\n",
1944 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1945 scalar keys %{$CPAN::META->{$k}{$k2}};
1950 #-> sub CPAN::Shell::autobundle ;
1953 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1954 my(@bundle) = $self->_u_r_common("a",@_);
1955 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1956 File::Path::mkpath($todir);
1957 unless (-d $todir) {
1958 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1961 my($y,$m,$d) = (localtime)[5,4,3];
1965 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1966 my($to) = File::Spec->catfile($todir,"$me.pm");
1968 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1969 $to = File::Spec->catfile($todir,"$me.pm");
1971 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1973 "package Bundle::$me;\n\n",
1974 "\$VERSION = '0.01';\n\n",
1978 "Bundle::$me - Snapshot of installation on ",
1979 $Config::Config{'myhostname'},
1982 "\n\n=head1 SYNOPSIS\n\n",
1983 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1984 "=head1 CONTENTS\n\n",
1985 join("\n", @bundle),
1986 "\n\n=head1 CONFIGURATION\n\n",
1988 "\n\n=head1 AUTHOR\n\n",
1989 "This Bundle has been generated automatically ",
1990 "by the autobundle routine in CPAN.pm.\n",
1993 $CPAN::Frontend->myprint("\nWrote bundle file
1997 #-> sub CPAN::Shell::expandany ;
2000 CPAN->debug("s[$s]") if $CPAN::DEBUG;
2001 if ($s =~ m|/|) { # looks like a file
2002 $s = CPAN::Distribution->normalize($s);
2003 return $CPAN::META->instance('CPAN::Distribution',$s);
2004 # Distributions spring into existence, not expand
2005 } elsif ($s =~ m|^Bundle::|) {
2006 $self->local_bundles; # scanning so late for bundles seems
2007 # both attractive and crumpy: always
2008 # current state but easy to forget
2010 return $self->expand('Bundle',$s);
2012 return $self->expand('Module',$s)
2013 if $CPAN::META->exists('CPAN::Module',$s);
2018 #-> sub CPAN::Shell::expand ;
2021 my($type,@args) = @_;
2022 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2023 my $class = "CPAN::$type";
2024 my $methods = ['id'];
2025 for my $meth (qw(name)) {
2026 next if $] < 5.00303; # no "can"
2027 next unless $class->can($meth);
2028 push @$methods, $meth;
2030 $self->expand_by_method($class,$methods,@args);
2033 sub expand_by_method {
2035 my($class,$methods,@args) = @_;
2038 my($regex,$command);
2039 if ($arg =~ m|^/(.*)/$|) {
2041 } elsif ($arg =~ m/=/) {
2045 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2047 defined $regex ? $regex : "UNDEFINED",
2048 defined $command ? $command : "UNDEFINED",
2050 if (defined $regex) {
2052 $CPAN::META->all_objects($class)
2055 # BUG, we got an empty object somewhere
2056 require Data::Dumper;
2057 CPAN->debug(sprintf(
2058 "Bug in CPAN: Empty id on obj[%s][%s]",
2060 Data::Dumper::Dumper($obj)
2064 for my $method (@$methods) {
2065 my $match = eval {$obj->$method() =~ /$regex/i};
2067 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2068 $err ||= $@; # if we were too restrictive above
2069 $CPAN::Frontend->mydie("$err\n");
2076 } elsif ($command) {
2077 die "equal sign in command disabled (immature interface), ".
2079 ! \$CPAN::Shell::ADVANCED_QUERY=1
2080 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2081 that may go away anytime.\n"
2082 unless $ADVANCED_QUERY;
2083 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2084 my($matchcrit) = $criterion =~ m/^~(.+)/;
2088 $CPAN::META->all_objects($class)
2090 my $lhs = $self->$method() or next; # () for 5.00503
2092 push @m, $self if $lhs =~ m/$matchcrit/;
2094 push @m, $self if $lhs eq $criterion;
2099 if ( $class eq 'CPAN::Bundle' ) {
2100 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2101 } elsif ($class eq "CPAN::Distribution") {
2102 $xarg = CPAN::Distribution->normalize($arg);
2106 if ($CPAN::META->exists($class,$xarg)) {
2107 $obj = $CPAN::META->instance($class,$xarg);
2108 } elsif ($CPAN::META->exists($class,$arg)) {
2109 $obj = $CPAN::META->instance($class,$arg);
2116 @m = sort {$a->id cmp $b->id} @m;
2117 if ( $CPAN::DEBUG ) {
2118 my $wantarray = wantarray;
2119 my $join_m = join ",", map {$_->id} @m;
2120 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2122 return wantarray ? @m : $m[0];
2125 #-> sub CPAN::Shell::format_result ;
2128 my($type,@args) = @_;
2129 @args = '/./' unless @args;
2130 my(@result) = $self->expand($type,@args);
2131 my $result = @result == 1 ?
2132 $result[0]->as_string :
2134 "No objects of type $type found for argument @args\n" :
2136 (map {$_->as_glimpse} @result),
2137 scalar @result, " items found\n",
2142 #-> sub CPAN::Shell::report_fh ;
2144 my $installation_report_fh;
2145 my $previously_noticed = 0;
2148 return $installation_report_fh if $installation_report_fh;
2149 if ($CPAN::META->has_inst("File::Temp")) {
2150 $installation_report_fh
2152 template => 'cpan_install_XXXX',
2157 unless ( $installation_report_fh ) {
2158 warn("Couldn't open installation report file; " .
2159 "no report file will be generated."
2160 ) unless $previously_noticed++;
2166 # The only reason for this method is currently to have a reliable
2167 # debugging utility that reveals which output is going through which
2168 # channel. No, I don't like the colors ;-)
2170 # to turn colordebugging on, write
2171 # cpan> o conf colorize_output 1
2173 #-> sub CPAN::Shell::print_ornamented ;
2175 my $print_ornamented_have_warned = 0;
2176 sub colorize_output {
2177 my $colorize_output = $CPAN::Config->{colorize_output};
2178 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2179 unless ($print_ornamented_have_warned++) {
2180 # no myprint/mywarn within myprint/mywarn!
2181 warn "Colorize_output is set to true but Term::ANSIColor is not
2182 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2184 $colorize_output = 0;
2186 return $colorize_output;
2191 sub print_ornamented {
2192 my($self,$what,$ornament) = @_;
2193 return unless defined $what;
2195 local $| = 1; # Flush immediately
2196 if ( $CPAN::Be_Silent ) {
2197 print {report_fh()} $what;
2200 my $swhat = "$what"; # stringify if it is an object
2201 if ($CPAN::Config->{term_is_latin}){
2204 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2206 if ($self->colorize_output) {
2207 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2208 # if you want to have this configurable, please file a bugreport
2209 $ornament = "black on_cyan";
2211 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2213 print "Term::ANSIColor rejects color[$ornament]: $@\n
2214 Please choose a different color (Hint: try 'o conf init color.*')\n";
2218 Term::ANSIColor::color("reset");
2224 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2225 # where to use what! I think, we send everything to STDOUT and use
2226 # print for normal/good news and warn for news that need more
2227 # attention. Yes, this is our working contract for now.
2229 my($self,$what) = @_;
2231 $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2235 my($self,$what) = @_;
2236 $self->myprint($what);
2241 my($self,$what) = @_;
2242 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2245 # only to be used for shell commands
2247 my($self,$what) = @_;
2248 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2250 # If it is the shell, we want that the following die to be silent,
2251 # but if it is not the shell, we would need a 'die $what'. We need
2252 # to take care that only shell commands use mydie. Is this
2258 # sub CPAN::Shell::colorable_makemaker_prompt
2259 sub colorable_makemaker_prompt {
2261 if (CPAN::Shell->colorize_output) {
2262 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2263 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2266 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2267 if (CPAN::Shell->colorize_output) {
2268 print Term::ANSIColor::color('reset');
2273 # use this only for unrecoverable errors!
2274 sub unrecoverable_error {
2275 my($self,$what) = @_;
2276 my @lines = split /\n/, $what;
2278 for my $l (@lines) {
2279 $longest = length $l if length $l > $longest;
2281 $longest = 62 if $longest > 62;
2282 for my $l (@lines) {
2288 if (length $l < 66) {
2289 $l = pack "A66 A*", $l, "<==";
2293 unshift @lines, "\n";
2294 $self->mydie(join "", @lines);
2298 my($self, $sleep) = @_;
2303 return if -t STDOUT;
2304 my $odef = select STDERR;
2311 #-> sub CPAN::Shell::rematein ;
2312 # RE-adme||MA-ke||TE-st||IN-stall
2315 my($meth,@some) = @_;
2317 while($meth =~ /^(force|notest)$/) {
2318 push @pragma, $meth;
2319 $meth = shift @some or
2320 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2324 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2326 # Here is the place to set "test_count" on all involved parties to
2327 # 0. We then can pass this counter on to the involved
2328 # distributions and those can refuse to test if test_count > X. In
2329 # the first stab at it we could use a 1 for "X".
2331 # But when do I reset the distributions to start with 0 again?
2332 # Jost suggested to have a random or cycling interaction ID that
2333 # we pass through. But the ID is something that is just left lying
2334 # around in addition to the counter, so I'd prefer to set the
2335 # counter to 0 now, and repeat at the end of the loop. But what
2336 # about dependencies? They appear later and are not reset, they
2337 # enter the queue but not its copy. How do they get a sensible
2340 # construct the queue
2342 STHING: foreach $s (@some) {
2345 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2347 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2348 } elsif ($s =~ m|^/|) { # looks like a regexp
2349 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2350 "not supported. Rejecting argument '$s'\n");
2351 $CPAN::Frontend->mysleep(2);
2353 } elsif ($meth eq "ls") {
2354 $self->globls($s,\@pragma);
2357 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2358 $obj = CPAN::Shell->expandany($s);
2361 } elsif (ref $obj) {
2362 $obj->color_cmd_tmps(0,1);
2363 CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2365 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2366 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2367 if ($meth =~ /^(dump|ls)$/) {
2370 $CPAN::Frontend->mywarn(
2372 "Don't be silly, you can't $meth ",
2376 $CPAN::Frontend->mysleep(2);
2378 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2379 CPAN::InfoObj->dump($s);
2382 ->mywarn(qq{Warning: Cannot $meth $s, }.
2383 qq{don't know what it is.
2388 to find objects with matching identifiers.
2390 $CPAN::Frontend->mysleep(2);
2394 # queuerunner (please be warned: when I started to change the
2395 # queue to hold objects instead of names, I made one or two
2396 # mistakes and never found which. I reverted back instead)
2397 while (my $q = CPAN::Queue->first) {
2399 my $s = $q->as_string;
2400 my $reqtype = $q->reqtype || "";
2401 $obj = CPAN::Shell->expandany($s);
2402 $obj->{reqtype} ||= "";
2403 CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2404 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2405 if ($obj->{reqtype}) {
2406 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2407 $obj->{reqtype} = $reqtype;
2409 exists $obj->{install}
2412 $obj->{install}->can("failed") ?
2413 $obj->{install}->failed :
2414 $obj->{install} =~ /^NO/
2417 delete $obj->{install};
2418 $CPAN::Frontend->mywarn
2419 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2423 $obj->{reqtype} = $reqtype;
2426 for my $pragma (@pragma) {
2429 ($] < 5.00303 || $obj->can($pragma))){
2430 ### compatibility with 5.003
2431 $obj->$pragma($meth); # the pragma "force" in
2432 # "CPAN::Distribution" must know
2433 # what we are intending
2436 if ($]>=5.00303 && $obj->can('called_for')) {
2437 $obj->called_for($s);
2439 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2440 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2443 CPAN::Queue->delete($s);
2445 CPAN->debug("failed");
2449 CPAN::Queue->delete_first($s);
2451 for my $obj (@qcopy) {
2452 $obj->color_cmd_tmps(0,0);
2453 delete $obj->{incommandcolor};
2457 #-> sub CPAN::Shell::recent ;
2461 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2466 # set up the dispatching methods
2468 for my $command (qw(
2483 *$command = sub { shift->rematein($command, @_); };
2487 package CPAN::LWP::UserAgent;
2491 return if $SETUPDONE;
2492 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2493 require LWP::UserAgent;
2494 @ISA = qw(Exporter LWP::UserAgent);
2497 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
2501 sub get_basic_credentials {
2502 my($self, $realm, $uri, $proxy) = @_;
2503 if ($USER && $PASSWD) {
2504 return ($USER, $PASSWD);
2507 ($USER,$PASSWD) = $self->get_proxy_credentials();
2509 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2511 return($USER,$PASSWD);
2514 sub get_proxy_credentials {
2516 my ($user, $password);
2517 if ( defined $CPAN::Config->{proxy_user} &&
2518 defined $CPAN::Config->{proxy_pass}) {
2519 $user = $CPAN::Config->{proxy_user};
2520 $password = $CPAN::Config->{proxy_pass};
2521 return ($user, $password);
2523 my $username_prompt = "\nProxy authentication needed!
2524 (Note: to permanently configure username and password run
2525 o conf proxy_user your_username
2526 o conf proxy_pass your_password
2528 ($user, $password) =
2529 _get_username_and_password_from_user($username_prompt);
2530 return ($user,$password);
2533 sub get_non_proxy_credentials {
2535 my ($user,$password);
2536 if ( defined $CPAN::Config->{username} &&
2537 defined $CPAN::Config->{password}) {
2538 $user = $CPAN::Config->{username};
2539 $password = $CPAN::Config->{password};
2540 return ($user, $password);
2542 my $username_prompt = "\nAuthentication needed!
2543 (Note: to permanently configure username and password run
2544 o conf username your_username
2545 o conf password your_password
2548 ($user, $password) =
2549 _get_username_and_password_from_user($username_prompt);
2550 return ($user,$password);
2553 sub _get_username_and_password_from_user {
2555 my $username_message = shift;
2556 my ($username,$password);
2558 ExtUtils::MakeMaker->import(qw(prompt));
2559 $username = prompt($username_message);
2560 if ($CPAN::META->has_inst("Term::ReadKey")) {
2561 Term::ReadKey::ReadMode("noecho");
2564 $CPAN::Frontend->mywarn(
2565 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2568 $password = prompt("Password:");
2570 if ($CPAN::META->has_inst("Term::ReadKey")) {
2571 Term::ReadKey::ReadMode("restore");
2573 $CPAN::Frontend->myprint("\n\n");
2574 return ($username,$password);
2577 # mirror(): Its purpose is to deal with proxy authentication. When we
2578 # call SUPER::mirror, we relly call the mirror method in
2579 # LWP::UserAgent. LWP::UserAgent will then call
2580 # $self->get_basic_credentials or some equivalent and this will be
2581 # $self->dispatched to our own get_basic_credentials method.
2583 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2585 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2586 # although we have gone through our get_basic_credentials, the proxy
2587 # server refuses to connect. This could be a case where the username or
2588 # password has changed in the meantime, so I'm trying once again without
2589 # $USER and $PASSWD to give the get_basic_credentials routine another
2590 # chance to set $USER and $PASSWD.
2592 # mirror(): Its purpose is to deal with proxy authentication. When we
2593 # call SUPER::mirror, we relly call the mirror method in
2594 # LWP::UserAgent. LWP::UserAgent will then call
2595 # $self->get_basic_credentials or some equivalent and this will be
2596 # $self->dispatched to our own get_basic_credentials method.
2598 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2600 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2601 # although we have gone through our get_basic_credentials, the proxy
2602 # server refuses to connect. This could be a case where the username or
2603 # password has changed in the meantime, so I'm trying once again without
2604 # $USER and $PASSWD to give the get_basic_credentials routine another
2605 # chance to set $USER and $PASSWD.
2608 my($self,$url,$aslocal) = @_;
2609 my $result = $self->SUPER::mirror($url,$aslocal);
2610 if ($result->code == 407) {
2613 $result = $self->SUPER::mirror($url,$aslocal);
2621 #-> sub CPAN::FTP::ftp_get ;
2623 my($class,$host,$dir,$file,$target) = @_;
2625 qq[Going to fetch file [$file] from dir [$dir]
2626 on host [$host] as local [$target]\n]
2628 my $ftp = Net::FTP->new($host);
2630 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
2633 return 0 unless defined $ftp;
2634 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2635 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2636 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2637 my $msg = $ftp->message;
2638 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
2641 unless ( $ftp->cwd($dir) ){
2642 my $msg = $ftp->message;
2643 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
2647 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2648 unless ( $ftp->get($file,$target) ){
2649 my $msg = $ftp->message;
2650 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
2653 $ftp->quit; # it's ok if this fails
2657 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2659 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2660 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2662 # > *** 1562,1567 ****
2663 # > --- 1562,1580 ----
2664 # > return 1 if substr($url,0,4) eq "file";
2665 # > return 1 unless $url =~ m|://([^/]+)|;
2667 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2669 # > + $proxy =~ m|://([^/:]+)|;
2671 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2672 # > + if ($noproxy) {
2673 # > + if ($host !~ /$noproxy$/) {
2674 # > + $host = $proxy;
2677 # > + $host = $proxy;
2680 # > require Net::Ping;
2681 # > return 1 unless $Net::Ping::VERSION >= 2;
2685 #-> sub CPAN::FTP::localize ;
2687 my($self,$file,$aslocal,$force) = @_;
2689 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2690 unless defined $aslocal;
2691 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2694 if ($^O eq 'MacOS') {
2695 # Comment by AK on 2000-09-03: Uniq short filenames would be
2696 # available in CHECKSUMS file
2697 my($name, $path) = File::Basename::fileparse($aslocal, '');
2698 if (length($name) > 31) {
2709 my $size = 31 - length($suf);
2710 while (length($name) > $size) {
2714 $aslocal = File::Spec->catfile($path, $name);
2718 if (-f $aslocal && -r _ && !($force & 1)){
2720 if ($size = -s $aslocal) {
2721 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
2724 # empty file from a previous unsuccessful attempt to download it
2726 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
2727 "could not remove.");
2732 rename $aslocal, "$aslocal.bak";
2736 my($aslocal_dir) = File::Basename::dirname($aslocal);
2737 File::Path::mkpath($aslocal_dir);
2738 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2739 qq{directory "$aslocal_dir".
2740 I\'ll continue, but if you encounter problems, they may be due
2741 to insufficient permissions.\n}) unless -w $aslocal_dir;
2743 # Inheritance is not easier to manage than a few if/else branches
2744 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2746 CPAN::LWP::UserAgent->config;
2747 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2749 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2753 $Ua->proxy('ftp', $var)
2754 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2755 $Ua->proxy('http', $var)
2756 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2759 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2761 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2762 # > use ones that require basic autorization.
2764 # > Example of when I use it manually in my own stuff:
2766 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2767 # > $req->proxy_authorization_basic("username","password");
2768 # > $res = $ua->request($req);
2772 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2776 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2777 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2780 # Try the list of urls for each single object. We keep a record
2781 # where we did get a file from
2782 my(@reordered,$last);
2783 $CPAN::Config->{urllist} ||= [];
2784 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2785 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
2786 $CPAN::Config->{urllist} = [];
2788 $last = $#{$CPAN::Config->{urllist}};
2789 if ($force & 2) { # local cpans probably out of date, don't reorder
2790 @reordered = (0..$last);
2794 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2796 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2798 defined($ThesiteURL)
2800 ($CPAN::Config->{urllist}[$b] eq $ThesiteURL)
2802 ($CPAN::Config->{urllist}[$a] eq $ThesiteURL)
2807 $self->debug("Themethod[$Themethod]") if $CPAN::DEBUG;
2809 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2811 @levels = qw/easy hard hardest/;
2813 @levels = qw/easy/ if $^O eq 'MacOS';
2815 local $ENV{FTP_PASSIVE} =
2816 exists $CPAN::Config->{ftp_passive} ?
2817 $CPAN::Config->{ftp_passive} : 1;
2818 for $levelno (0..$#levels) {
2819 my $level = $levels[$levelno];
2820 my $method = "host$level";
2821 my @host_seq = $level eq "easy" ?
2822 @reordered : 0..$last; # reordered has CDROM up front
2823 my @urllist = map { $CPAN::Config->{urllist}[$_] } @host_seq;
2824 for my $u (@urllist) {
2825 if ($u->can("text")) {
2826 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
2828 $u .= "/" unless substr($u,-1) eq "/";
2829 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
2832 for my $u (@CPAN::Defaultsites) {
2833 push @urllist, $u unless grep { $_ eq $u } @urllist;
2835 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
2836 my $ret = $self->$method(\@urllist,$file,$aslocal);
2838 $Themethod = $level;
2840 # utime $now, $now, $aslocal; # too bad, if we do that, we
2841 # might alter a local mirror
2842 $self->debug("level[$level]") if $CPAN::DEBUG;
2846 last if $CPAN::Signal; # need to cleanup
2849 unless ($CPAN::Signal) {
2852 if (@{$CPAN::Config->{urllist}}) {
2854 qq{Please check, if the URLs I found in your configuration file \(}.
2855 join(", ", @{$CPAN::Config->{urllist}}).
2858 push @mess, qq{Your urllist is empty!};
2860 push @mess, qq{The urllist can be edited.},
2861 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2862 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
2863 $CPAN::Frontend->mywarn("Could not fetch $file\n");
2864 $CPAN::Frontend->mysleep(2);
2867 rename "$aslocal.bak", $aslocal;
2868 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2869 $self->ls($aslocal));
2875 # package CPAN::FTP;
2877 my($self,$host_seq,$file,$aslocal) = @_;
2879 HOSTEASY: for $ro_url (@$host_seq) {
2880 my $url .= "$ro_url$file";
2881 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2882 if ($url =~ /^file:/) {
2884 if ($CPAN::META->has_inst('URI::URL')) {
2885 my $u = URI::URL->new($url);
2887 } else { # works only on Unix, is poorly constructed, but
2888 # hopefully better than nothing.
2889 # RFC 1738 says fileurl BNF is
2890 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2891 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2893 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2894 $l =~ s|^file:||; # assume they
2898 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
2900 $self->debug("local file[$l]") if $CPAN::DEBUG;
2901 if ( -f $l && -r _) {
2902 $ThesiteURL = $ro_url;
2905 if ($l =~ /(.+)\.gz$/) {
2907 if ( -f $ungz && -r _) {
2908 $ThesiteURL = $ro_url;
2912 # Maybe mirror has compressed it?
2914 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2915 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
2917 $ThesiteURL = $ro_url;
2922 if ($CPAN::META->has_usable('LWP')) {
2923 $CPAN::Frontend->myprint("Fetching with LWP:
2927 CPAN::LWP::UserAgent->config;
2928 eval { $Ua = CPAN::LWP::UserAgent->new; };
2930 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2933 my $res = $Ua->mirror($url, $aslocal);
2934 if ($res->is_success) {
2935 $ThesiteURL = $ro_url;
2937 utime $now, $now, $aslocal; # download time is more
2938 # important than upload
2941 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2942 my $gzurl = "$url.gz";
2943 $CPAN::Frontend->myprint("Fetching with LWP:
2946 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2947 if ($res->is_success &&
2948 CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
2950 $ThesiteURL = $ro_url;
2954 $CPAN::Frontend->myprint(sprintf(
2955 "LWP failed with code[%s] message[%s]\n",
2959 # Alan Burlison informed me that in firewall environments
2960 # Net::FTP can still succeed where LWP fails. So we do not
2961 # skip Net::FTP anymore when LWP is available.
2964 $ro_url->can("text")
2966 $ro_url->{FROM} eq "USER"
2968 my $ret = $self->hosthard([$ro_url],$file,$aslocal);
2969 return $ret if $ret;
2971 $CPAN::Frontend->mywarn(" LWP not available\n");
2973 return if $CPAN::Signal;
2974 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2975 # that's the nice and easy way thanks to Graham
2976 my($host,$dir,$getfile) = ($1,$2,$3);
2977 if ($CPAN::META->has_usable('Net::FTP')) {
2979 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2982 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2983 "aslocal[$aslocal]") if $CPAN::DEBUG;
2984 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2985 $ThesiteURL = $ro_url;
2988 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2989 my $gz = "$aslocal.gz";
2990 $CPAN::Frontend->myprint("Fetching with Net::FTP
2993 if (CPAN::FTP->ftp_get($host,
2997 CPAN::Tarzip->new($gz)->gunzip($aslocal)
2999 $ThesiteURL = $ro_url;
3006 return if $CPAN::Signal;
3010 # package CPAN::FTP;
3012 my($self,$host_seq,$file,$aslocal) = @_;
3014 # Came back if Net::FTP couldn't establish connection (or
3015 # failed otherwise) Maybe they are behind a firewall, but they
3016 # gave us a socksified (or other) ftp program...
3019 my($devnull) = $CPAN::Config->{devnull} || "";
3021 my($aslocal_dir) = File::Basename::dirname($aslocal);
3022 File::Path::mkpath($aslocal_dir);
3023 HOSTHARD: for $ro_url (@$host_seq) {
3024 my $url = "$ro_url$file";
3025 my($proto,$host,$dir,$getfile);
3027 # Courtesy Mark Conty mark_conty@cargill.com change from
3028 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3030 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3031 # proto not yet used
3032 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3034 next HOSTHARD; # who said, we could ftp anything except ftp?
3036 next HOSTHARD if $proto eq "file"; # file URLs would have had
3037 # success above. Likely a bogus URL
3039 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3041 # Try the most capable first and leave ncftp* for last as it only
3043 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3044 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3045 next unless defined $funkyftp;
3046 next if $funkyftp =~ /^\s*$/;
3048 my($asl_ungz, $asl_gz);
3049 ($asl_ungz = $aslocal) =~ s/\.gz//;
3050 $asl_gz = "$asl_ungz.gz";
3052 my($src_switch) = "";
3054 my($stdout_redir) = " > $asl_ungz";
3056 $src_switch = " -source";
3057 } elsif ($f eq "ncftp"){
3058 $src_switch = " -c";
3059 } elsif ($f eq "wget"){
3060 $src_switch = " -O $asl_ungz";
3062 } elsif ($f eq 'curl'){
3063 $src_switch = ' -L -f -s -S --netrc-optional';
3066 if ($f eq "ncftpget"){
3067 $chdir = "cd $aslocal_dir && ";
3070 $CPAN::Frontend->myprint(
3072 Trying with "$funkyftp$src_switch" to get
3076 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3077 $self->debug("system[$system]") if $CPAN::DEBUG;
3078 my($wstatus) = system($system);
3080 # lynx returns 0 when it fails somewhere
3082 my $content = do { local *FH; open FH, $asl_ungz or die; local $/; <FH> };
3083 if ($content =~ /^<.*<title>[45]/si) {
3084 $CPAN::Frontend->mywarn(qq{
3085 No success, the file that lynx has has downloaded looks like an error message:
3088 $CPAN::Frontend->mysleep(1);
3092 $CPAN::Frontend->myprint(qq{
3093 No success, the file that lynx has has downloaded is an empty file.
3098 if ($wstatus == 0) {
3101 } elsif ($asl_ungz ne $aslocal) {
3102 # test gzip integrity
3103 if (CPAN::Tarzip->new($asl_ungz)->gtest) {
3104 # e.g. foo.tar is gzipped --> foo.tar.gz
3105 rename $asl_ungz, $aslocal;
3107 CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
3110 $ThesiteURL = $ro_url;
3112 } elsif ($url !~ /\.gz(?!\n)\Z/) {
3114 -f $asl_ungz && -s _ == 0;
3115 my $gz = "$aslocal.gz";
3116 my $gzurl = "$url.gz";
3117 $CPAN::Frontend->myprint(
3119 Trying with "$funkyftp$src_switch" to get
3122 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3123 $self->debug("system[$system]") if $CPAN::DEBUG;
3125 if (($wstatus = system($system)) == 0
3129 # test gzip integrity
3130 my $ct = CPAN::Tarzip->new($asl_gz);
3132 $ct->gunzip($aslocal);
3134 # somebody uncompressed file for us?
3135 rename $asl_ungz, $aslocal;
3137 $ThesiteURL = $ro_url;
3140 unlink $asl_gz if -f $asl_gz;
3143 my $estatus = $wstatus >> 8;
3144 my $size = -f $aslocal ?
3145 ", left\n$aslocal with size ".-s _ :
3146 "\nWarning: expected file [$aslocal] doesn't exist";
3147 $CPAN::Frontend->myprint(qq{
3148 System call "$system"
3149 returned status $estatus (wstat $wstatus)$size
3152 return if $CPAN::Signal;
3153 } # transfer programs
3157 # package CPAN::FTP;
3159 my($self,$host_seq,$file,$aslocal) = @_;
3162 my($aslocal_dir) = File::Basename::dirname($aslocal);
3163 File::Path::mkpath($aslocal_dir);
3164 my $ftpbin = $CPAN::Config->{ftp};
3165 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
3166 $CPAN::Frontend->myprint("No external ftp command available\n\n");
3169 $CPAN::Frontend->mywarn(qq{
3170 As a last ressort we now switch to the external ftp command '$ftpbin'
3173 Doing so often leads to problems that are hard to diagnose.
3175 If you're victim of such problems, please consider unsetting the ftp
3176 config variable with
3182 $CPAN::Frontend->mysleep(2);
3183 HOSTHARDEST: for $ro_url (@$host_seq) {
3184 my $url = "$ro_url$file";
3185 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3186 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3189 my($host,$dir,$getfile) = ($1,$2,$3);
3191 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3192 $ctime,$blksize,$blocks) = stat($aslocal);
3193 $timestamp = $mtime ||= 0;
3194 my($netrc) = CPAN::FTP::netrc->new;
3195 my($netrcfile) = $netrc->netrc;
3196 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3197 my $targetfile = File::Basename::basename($aslocal);
3203 map("cd $_", split /\//, $dir), # RFC 1738
3205 "get $getfile $targetfile",
3209 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3210 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3211 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3213 $netrc->contains($host))) if $CPAN::DEBUG;
3214 if ($netrc->protected) {
3215 my $dialog = join "", map { " $_\n" } @dialog;
3217 if ($netrc->contains($host)) {
3218 $netrc_explain = "Relying that your .netrc entry for '$host' ".
3219 "manages the login";
3221 $netrc_explain = "Relying that your default .netrc entry ".
3222 "manages the login";
3224 $CPAN::Frontend->myprint(qq{
3225 Trying with external ftp to get
3228 Going to send the dialog
3232 $self->talk_ftp("$ftpbin$verbose $host",
3234 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3235 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3237 if ($mtime > $timestamp) {
3238 $CPAN::Frontend->myprint("GOT $aslocal\n");
3239 $ThesiteURL = $ro_url;
3242 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3244 return if $CPAN::Signal;
3246 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3247 qq{correctly protected.\n});
3250 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3251 nor does it have a default entry\n");
3254 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3255 # then and login manually to host, using e-mail as
3257 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3261 "user anonymous $Config::Config{'cf_email'}"
3263 my $dialog = join "", map { " $_\n" } @dialog;
3264 $CPAN::Frontend->myprint(qq{
3265 Trying with external ftp to get
3267 Going to send the dialog
3271 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3272 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3273 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3275 if ($mtime > $timestamp) {
3276 $CPAN::Frontend->myprint("GOT $aslocal\n");
3277 $ThesiteURL = $ro_url;
3280 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3282 return if $CPAN::Signal;
3283 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3284 $CPAN::Frontend->mysleep(2);
3288 # package CPAN::FTP;
3290 my($self,$command,@dialog) = @_;
3291 my $fh = FileHandle->new;
3292 $fh->open("|$command") or die "Couldn't open ftp: $!";
3293 foreach (@dialog) { $fh->print("$_\n") }
3294 $fh->close; # Wait for process to complete
3296 my $estatus = $wstatus >> 8;
3297 $CPAN::Frontend->myprint(qq{
3298 Subprocess "|$command"
3299 returned status $estatus (wstat $wstatus)
3303 # find2perl needs modularization, too, all the following is stolen
3307 my($self,$name) = @_;
3308 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3309 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3311 my($perms,%user,%group);
3315 $blocks = int(($blocks + 1) / 2);
3318 $blocks = int(($sizemm + 1023) / 1024);
3321 if (-f _) { $perms = '-'; }
3322 elsif (-d _) { $perms = 'd'; }
3323 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3324 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3325 elsif (-p _) { $perms = 'p'; }
3326 elsif (-S _) { $perms = 's'; }
3327 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3329 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3330 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3331 my $tmpmode = $mode;
3332 my $tmp = $rwx[$tmpmode & 7];
3334 $tmp = $rwx[$tmpmode & 7] . $tmp;
3336 $tmp = $rwx[$tmpmode & 7] . $tmp;
3337 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3338 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3339 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3342 my $user = $user{$uid} || $uid; # too lazy to implement lookup
3343 my $group = $group{$gid} || $gid;
3345 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3347 my($moname) = $moname[$mon];
3348 if (-M _ > 365.25 / 2) {
3349 $timeyear = $year + 1900;
3352 $timeyear = sprintf("%02d:%02d", $hour, $min);
3355 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3369 package CPAN::FTP::netrc;
3372 # package CPAN::FTP::netrc;
3375 my $home = CPAN::HandleConfig::home;
3376 my $file = File::Spec->catfile($home,".netrc");
3378 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3379 $atime,$mtime,$ctime,$blksize,$blocks)
3384 my($fh,@machines,$hasdefault);
3386 $fh = FileHandle->new or die "Could not create a filehandle";
3388 if($fh->open($file)){
3389 $protected = ($mode & 077) == 0;
3391 NETRC: while (<$fh>) {
3392 my(@tokens) = split " ", $_;
3393 TOKEN: while (@tokens) {
3394 my($t) = shift @tokens;
3395 if ($t eq "default"){
3399 last TOKEN if $t eq "macdef";
3400 if ($t eq "machine") {
3401 push @machines, shift @tokens;
3406 $file = $hasdefault = $protected = "";
3410 'mach' => [@machines],
3412 'hasdefault' => $hasdefault,
3413 'protected' => $protected,
3417 # CPAN::FTP::netrc::hasdefault;
3418 sub hasdefault { shift->{'hasdefault'} }
3419 sub netrc { shift->{'netrc'} }
3420 sub protected { shift->{'protected'} }
3422 my($self,$mach) = @_;
3423 for ( @{$self->{'mach'}} ) {
3424 return 1 if $_ eq $mach;
3429 package CPAN::Complete;
3433 my($text, $line, $start, $end) = @_;
3434 my(@perlret) = cpl($text, $line, $start);
3435 # find longest common match. Can anybody show me how to peruse
3436 # T::R::Gnu to have this done automatically? Seems expensive.
3437 return () unless @perlret;
3438 my($newtext) = $text;
3439 for (my $i = length($text)+1;;$i++) {
3440 last unless length($perlret[0]) && length($perlret[0]) >= $i;
3441 my $try = substr($perlret[0],0,$i);
3442 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3443 # warn "try[$try]tries[@tries]";
3444 if (@tries == @perlret) {
3450 ($newtext,@perlret);
3453 #-> sub CPAN::Complete::cpl ;
3455 my($word,$line,$pos) = @_;
3459 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3461 if ($line =~ s/^(force\s*)//) {
3466 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3467 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3469 } elsif ($line =~ /^(a|ls)\s/) {
3470 @return = cplx('CPAN::Author',uc($word));
3471 } elsif ($line =~ /^b\s/) {
3472 CPAN::Shell->local_bundles;
3473 @return = cplx('CPAN::Bundle',$word);
3474 } elsif ($line =~ /^d\s/) {
3475 @return = cplx('CPAN::Distribution',$word);
3476 } elsif ($line =~ m/^(
3477 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3479 if ($word =~ /^Bundle::/) {
3480 CPAN::Shell->local_bundles;
3482 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3483 } elsif ($line =~ /^i\s/) {
3484 @return = cpl_any($word);
3485 } elsif ($line =~ /^reload\s/) {
3486 @return = cpl_reload($word,$line,$pos);
3487 } elsif ($line =~ /^o\s/) {
3488 @return = cpl_option($word,$line,$pos);
3489 } elsif ($line =~ m/^\S+\s/ ) {
3490 # fallback for future commands and what we have forgotten above
3491 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3498 #-> sub CPAN::Complete::cplx ;
3500 my($class, $word) = @_;
3501 # I believed for many years that this was sorted, today I
3502 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3503 # make it sorted again. Maybe sort was dropped when GNU-readline
3504 # support came in? The RCS file is difficult to read on that:-(
3505 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3508 #-> sub CPAN::Complete::cpl_any ;
3512 cplx('CPAN::Author',$word),
3513 cplx('CPAN::Bundle',$word),
3514 cplx('CPAN::Distribution',$word),
3515 cplx('CPAN::Module',$word),
3519 #-> sub CPAN::Complete::cpl_reload ;
3521 my($word,$line,$pos) = @_;
3523 my(@words) = split " ", $line;
3524 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3525 my(@ok) = qw(cpan index);
3526 return @ok if @words == 1;
3527 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3530 #-> sub CPAN::Complete::cpl_option ;
3532 my($word,$line,$pos) = @_;
3534 my(@words) = split " ", $line;
3535 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3536 my(@ok) = qw(conf debug);
3537 return @ok if @words == 1;
3538 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3540 } elsif ($words[1] eq 'index') {
3542 } elsif ($words[1] eq 'conf') {
3543 return CPAN::HandleConfig::cpl(@_);
3544 } elsif ($words[1] eq 'debug') {
3545 return sort grep /^\Q$word\E/i,
3546 sort keys %CPAN::DEBUG, 'all';
3550 package CPAN::Index;
3553 #-> sub CPAN::Index::force_reload ;
3556 $CPAN::Index::LAST_TIME = 0;
3560 #-> sub CPAN::Index::reload ;
3562 my($cl,$force) = @_;
3565 # XXX check if a newer one is available. (We currently read it
3566 # from time to time)
3567 for ($CPAN::Config->{index_expire}) {
3568 $_ = 0.001 unless $_ && $_ > 0.001;
3570 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3571 # debug here when CPAN doesn't seem to read the Metadata
3573 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3575 unless ($CPAN::META->{PROTOCOL}) {
3576 $cl->read_metadata_cache;
3577 $CPAN::META->{PROTOCOL} ||= "1.0";
3579 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3580 # warn "Setting last_time to 0";
3581 $LAST_TIME = 0; # No warning necessary
3583 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3586 # IFF we are developing, it helps to wipe out the memory
3587 # between reloads, otherwise it is not what a user expects.
3588 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3589 $CPAN::META = CPAN->new;
3593 local $LAST_TIME = $time;
3594 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3596 my $needshort = $^O eq "dos";
3598 $cl->rd_authindex($cl
3600 "authors/01mailrc.txt.gz",
3602 File::Spec->catfile('authors', '01mailrc.gz') :
3603 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3606 $debug = "timing reading 01[".($t2 - $time)."]";
3608 return if $CPAN::Signal; # this is sometimes lengthy
3609 $cl->rd_modpacks($cl
3611 "modules/02packages.details.txt.gz",
3613 File::Spec->catfile('modules', '02packag.gz') :
3614 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3617 $debug .= "02[".($t2 - $time)."]";
3619 return if $CPAN::Signal; # this is sometimes lengthy
3622 "modules/03modlist.data.gz",
3624 File::Spec->catfile('modules', '03mlist.gz') :
3625 File::Spec->catfile('modules', '03modlist.data.gz'),
3627 $cl->write_metadata_cache;
3629 $debug .= "03[".($t2 - $time)."]";
3631 CPAN->debug($debug) if $CPAN::DEBUG;
3634 $CPAN::META->{PROTOCOL} = PROTOCOL;
3637 #-> sub CPAN::Index::reload_x ;
3639 my($cl,$wanted,$localname,$force) = @_;
3640 $force |= 2; # means we're dealing with an index here
3641 CPAN::HandleConfig->load; # we should guarantee loading wherever
3642 # we rely on Config XXX
3643 $localname ||= $wanted;
3644 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3648 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3651 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3652 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3653 qq{day$s. I\'ll use that.});
3656 $force |= 1; # means we're quite serious about it.
3658 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3661 #-> sub CPAN::Index::rd_authindex ;
3663 my($cl, $index_target) = @_;
3665 return unless defined $index_target;
3666 $CPAN::Frontend->myprint("Going to read $index_target\n");
3668 tie *FH, 'CPAN::Tarzip', $index_target;
3671 push @lines, split /\012/ while <FH>;
3673 my $modulus = int(@lines/75) || 1;
3675 my($userid,$fullname,$email) =
3676 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3677 next unless $userid && $fullname && $email;
3679 # instantiate an author object
3680 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3681 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3682 $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
3683 return if $CPAN::Signal;
3685 $CPAN::Frontend->myprint("DONE\n");
3689 my($self,$dist) = @_;
3690 $dist = $self->{'id'} unless defined $dist;
3691 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3695 #-> sub CPAN::Index::rd_modpacks ;
3697 my($self, $index_target) = @_;
3698 return unless defined $index_target;
3699 $CPAN::Frontend->myprint("Going to read $index_target\n");
3700 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3702 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
3705 while (my $bytes = $fh->READ(\$chunk,8192)) {
3708 my @lines = split /\012/, $slurp;
3709 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
3712 my($line_count,$last_updated);
3714 my $shift = shift(@lines);
3715 last if $shift =~ /^\s*$/;
3716 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3717 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3719 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
3720 if (not defined $line_count) {
3722 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
3723 Please check the validity of the index file by comparing it to more
3724 than one CPAN mirror. I'll continue but problems seem likely to
3728 $CPAN::Frontend->mysleep(5);
3729 } elsif ($line_count != scalar @lines) {
3731 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
3732 contains a Line-Count header of %d but I see %d lines there. Please
3733 check the validity of the index file by comparing it to more than one
3734 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3735 $index_target, $line_count, scalar(@lines));
3738 if (not defined $last_updated) {
3740 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
3741 Please check the validity of the index file by comparing it to more
3742 than one CPAN mirror. I'll continue but problems seem likely to
3746 $CPAN::Frontend->mysleep(5);
3750 ->myprint(sprintf qq{ Database was generated on %s\n},
3752 $DATE_OF_02 = $last_updated;
3755 if ($CPAN::META->has_inst('HTTP::Date')) {
3757 $age -= HTTP::Date::str2time($last_updated);
3759 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
3760 require Time::Local;
3761 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
3762 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
3763 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
3770 qq{Warning: This index file is %d days old.
3771 Please check the host you chose as your CPAN mirror for staleness.
3772 I'll continue but problems seem likely to happen.\a\n},
3775 } elsif ($age < -1) {
3779 qq{Warning: Your system date is %d days behind this index file!
3781 Timestamp index file: %s
3782 Please fix your system time, problems with the make command expected.\n},
3792 # A necessity since we have metadata_cache: delete what isn't
3794 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3795 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3798 my $modulus = int(@lines/75) || 1;
3800 # before 1.56 we split into 3 and discarded the rest. From
3801 # 1.57 we assign remaining text to $comment thus allowing to
3802 # influence isa_perl
3803 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3804 my($bundle,$id,$userid);
3806 if ($mod eq 'CPAN' &&
3808 CPAN::Queue->exists('Bundle::CPAN') ||
3809 CPAN::Queue->exists('CPAN')
3813 if ($version > $CPAN::VERSION){
3814 $CPAN::Frontend->mywarn(qq{
3815 New CPAN.pm version (v$version) available.
3816 [Currently running version is v$CPAN::VERSION]
3817 You might want to try
3820 to both upgrade CPAN.pm and run the new version without leaving
3821 the current session.
3824 $CPAN::Frontend->mysleep(2);
3825 $CPAN::Frontend->myprint(qq{\n});
3827 last if $CPAN::Signal;
3828 } elsif ($mod =~ /^Bundle::(.*)/) {
3833 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3834 # Let's make it a module too, because bundles have so much
3835 # in common with modules.
3837 # Changed in 1.57_63: seems like memory bloat now without
3838 # any value, so commented out
3840 # $CPAN::META->instance('CPAN::Module',$mod);
3844 # instantiate a module object
3845 $id = $CPAN::META->instance('CPAN::Module',$mod);
3849 # Although CPAN prohibits same name with different version the
3850 # indexer may have changed the version for the same distro
3851 # since the last time ("Force Reindexing" feature)
3852 if ($id->cpan_file ne $dist
3854 $id->cpan_version ne $version
3856 $userid = $id->userid || $self->userid($dist);
3858 'CPAN_USERID' => $userid,
3859 'CPAN_VERSION' => $version,
3860 'CPAN_FILE' => $dist,
3864 # instantiate a distribution object
3865 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3866 # we do not need CONTAINSMODS unless we do something with
3867 # this dist, so we better produce it on demand.
3869 ## my $obj = $CPAN::META->instance(
3870 ## 'CPAN::Distribution' => $dist
3872 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3874 $CPAN::META->instance(
3875 'CPAN::Distribution' => $dist
3877 'CPAN_USERID' => $userid,
3878 'CPAN_COMMENT' => $comment,
3882 for my $name ($mod,$dist) {
3883 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
3884 $exists{$name} = undef;
3887 $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
3888 return if $CPAN::Signal;
3890 $CPAN::Frontend->myprint("DONE\n");
3892 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3893 for my $o ($CPAN::META->all_objects($class)) {
3894 next if exists $exists{$o->{ID}};
3895 $CPAN::META->delete($class,$o->{ID});
3896 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3903 #-> sub CPAN::Index::rd_modlist ;
3905 my($cl,$index_target) = @_;
3906 return unless defined $index_target;
3907 $CPAN::Frontend->myprint("Going to read $index_target\n");
3908 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3912 while (my $bytes = $fh->READ(\$chunk,8192)) {
3915 my @eval2 = split /\012/, $slurp;
3918 my $shift = shift(@eval2);
3919 if ($shift =~ /^Date:\s+(.*)/){
3920 if ($DATE_OF_03 eq $1){
3921 $CPAN::Frontend->myprint("Unchanged.\n");
3926 last if $shift =~ /^\s*$/;
3928 push @eval2, q{CPAN::Modulelist->data;};
3930 my($comp) = Safe->new("CPAN::Safe1");
3931 my($eval2) = join("\n", @eval2);
3932 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
3933 my $ret = $comp->reval($eval2);
3934 Carp::confess($@) if $@;
3935 return if $CPAN::Signal;
3937 my $until = keys %$ret;
3938 my $modulus = int($until/75) || 1;
3939 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
3941 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3942 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3943 $obj->set(%{$ret->{$_}});
3944 $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
3945 return if $CPAN::Signal;
3947 $CPAN::Frontend->myprint("DONE\n");
3950 #-> sub CPAN::Index::write_metadata_cache ;
3951 sub write_metadata_cache {
3953 return unless $CPAN::Config->{'cache_metadata'};
3954 return unless $CPAN::META->has_usable("Storable");
3956 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3957 CPAN::Distribution)) {
3958 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3960 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3961 $cache->{last_time} = $LAST_TIME;
3962 $cache->{DATE_OF_02} = $DATE_OF_02;
3963 $cache->{PROTOCOL} = PROTOCOL;
3964 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3965 eval { Storable::nstore($cache, $metadata_file) };
3966 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3969 #-> sub CPAN::Index::read_metadata_cache ;
3970 sub read_metadata_cache {
3972 return unless $CPAN::Config->{'cache_metadata'};
3973 return unless $CPAN::META->has_usable("Storable");
3974 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3975 return unless -r $metadata_file and -f $metadata_file;
3976 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3978 eval { $cache = Storable::retrieve($metadata_file) };
3979 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3980 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
3984 if (exists $cache->{PROTOCOL}) {
3985 if (PROTOCOL > $cache->{PROTOCOL}) {
3986 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3987 "with protocol v%s, requiring v%s\n",
3994 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3995 "with protocol v1.0\n");
4000 while(my($class,$v) = each %$cache) {
4001 next unless $class =~ /^CPAN::/;
4002 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4003 while (my($id,$ro) = each %$v) {
4004 $CPAN::META->{readwrite}{$class}{$id} ||=
4005 $class->new(ID=>$id, RO=>$ro);
4010 unless ($clcnt) { # sanity check
4011 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4014 if ($idcnt < 1000) {
4015 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4016 "in $metadata_file\n");
4019 $CPAN::META->{PROTOCOL} ||=
4020 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4021 # does initialize to some protocol
4022 $LAST_TIME = $cache->{last_time};
4023 $DATE_OF_02 = $cache->{DATE_OF_02};
4024 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
4025 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4029 package CPAN::InfoObj;
4034 exists $self->{RO} and return $self->{RO};
4039 my $ro = $self->ro or return "N/A"; # N/A for bundles found locally
4040 return $ro->{CPAN_USERID} || "N/A";
4043 sub id { shift->{ID}; }
4045 #-> sub CPAN::InfoObj::new ;
4047 my $this = bless {}, shift;
4052 # The set method may only be used by code that reads index data or
4053 # otherwise "objective" data from the outside world. All session
4054 # related material may do anything else with instance variables but
4055 # must not touch the hash under the RO attribute. The reason is that
4056 # the RO hash gets written to Metadata file and is thus persistent.
4058 #-> sub CPAN::InfoObj::safe_chdir ;
4060 my($self,$todir) = @_;
4061 # we die if we cannot chdir and we are debuggable
4062 Carp::confess("safe_chdir called without todir argument")
4063 unless defined $todir and length $todir;
4065 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4069 unless (-x $todir) {
4070 unless (chmod 0755, $todir) {
4071 my $cwd = CPAN::anycwd();
4072 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4073 "permission to change the permission; cannot ".
4074 "chdir to '$todir'\n");
4075 $CPAN::Frontend->mysleep(5);
4076 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4077 qq{to todir[$todir]: $!});
4081 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4084 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4087 my $cwd = CPAN::anycwd();
4088 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4089 qq{to todir[$todir] (a chmod has been issued): $!});
4094 #-> sub CPAN::InfoObj::set ;
4096 my($self,%att) = @_;
4097 my $class = ref $self;
4099 # This must be ||=, not ||, because only if we write an empty
4100 # reference, only then the set method will write into the readonly
4101 # area. But for Distributions that spring into existence, maybe
4102 # because of a typo, we do not like it that they are written into
4103 # the readonly area and made permanent (at least for a while) and
4104 # that is why we do not "allow" other places to call ->set.
4105 unless ($self->id) {
4106 CPAN->debug("Bug? Empty ID, rejecting");
4109 my $ro = $self->{RO} =
4110 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4112 while (my($k,$v) = each %att) {
4117 #-> sub CPAN::InfoObj::as_glimpse ;
4121 my $class = ref($self);
4122 $class =~ s/^CPAN:://;
4123 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4124 push @m, sprintf "%-15s %s\n", $class, $id;
4128 #-> sub CPAN::InfoObj::as_string ;
4132 my $class = ref($self);
4133 $class =~ s/^CPAN:://;
4134 push @m, $class, " id = $self->{ID}\n";
4136 unless ($ro = $self->ro) {
4137 $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4139 for (sort keys %$ro) {
4140 # next if m/^(ID|RO)$/;
4142 if ($_ eq "CPAN_USERID") {
4144 $extra .= $self->fullname;
4145 my $email; # old perls!
4146 if ($email = $CPAN::META->instance("CPAN::Author",
4149 $extra .= " <$email>";
4151 $extra .= " <no email>";
4154 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4155 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
4158 next unless defined $ro->{$_};
4159 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
4161 for (sort keys %$self) {
4162 next if m/^(ID|RO)$/;
4163 if (ref($self->{$_}) eq "ARRAY") {
4164 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
4165 } elsif (ref($self->{$_}) eq "HASH") {
4169 join(" ",sort keys %{$self->{$_}}),
4172 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
4178 #-> sub CPAN::InfoObj::fullname ;
4181 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4184 #-> sub CPAN::InfoObj::dump ;
4186 my($self, $what) = @_;
4187 unless ($CPAN::META->has_inst("Data::Dumper")) {
4188 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4190 local $Data::Dumper::Sortkeys;
4191 $Data::Dumper::Sortkeys = 1;
4192 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4193 if (length $out > 100000) {
4194 my $fh_pager = FileHandle->new;
4195 local($SIG{PIPE}) = "IGNORE";
4196 my $pager = $CPAN::Config->{'pager'} || "cat";
4197 $fh_pager->open("|$pager")
4198 or die "Could not open pager $pager\: $!";
4199 $fh_pager->print($out);
4202 $CPAN::Frontend->myprint($out);
4206 package CPAN::Author;
4209 #-> sub CPAN::Author::force
4215 #-> sub CPAN::Author::force
4218 delete $self->{force};
4221 #-> sub CPAN::Author::id
4224 my $id = $self->{ID};
4225 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4229 #-> sub CPAN::Author::as_glimpse ;
4233 my $class = ref($self);
4234 $class =~ s/^CPAN:://;
4235 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4243 #-> sub CPAN::Author::fullname ;
4245 shift->ro->{FULLNAME};
4249 #-> sub CPAN::Author::email ;
4250 sub email { shift->ro->{EMAIL}; }
4252 #-> sub CPAN::Author::ls ;
4255 my $glob = shift || "";
4256 my $silent = shift || 0;
4259 # adapted from CPAN::Distribution::verifyCHECKSUM ;
4260 my(@csf); # chksumfile
4261 @csf = $self->id =~ /(.)(.)(.*)/;
4262 $csf[1] = join "", @csf[0,1];
4263 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4265 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4266 unless (grep {$_->[2] eq $csf[1]} @dl) {
4267 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4270 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4271 unless (grep {$_->[2] eq $csf[2]} @dl) {
4272 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4275 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4277 if ($CPAN::META->has_inst("Text::Glob")) {
4278 my $rglob = Text::Glob::glob_to_regex($glob);
4279 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4281 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4284 $CPAN::Frontend->myprint(join "", map {
4285 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4286 } sort { $a->[2] cmp $b->[2] } @dl);
4290 # returns an array of arrays, the latter contain (size,mtime,filename)
4291 #-> sub CPAN::Author::dir_listing ;
4294 my $chksumfile = shift;
4295 my $recursive = shift;
4296 my $may_ftp = shift;
4299 File::Spec->catfile($CPAN::Config->{keep_source_where},
4300 "authors", "id", @$chksumfile);
4304 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4305 # hazard. (Without GPG installed they are not that much better,
4307 $fh = FileHandle->new;
4308 if (open($fh, $lc_want)) {
4309 my $line = <$fh>; close $fh;
4310 unlink($lc_want) unless $line =~ /PGP/;
4314 # connect "force" argument with "index_expire".
4315 my $force = $self->{force};
4316 if (my @stat = stat $lc_want) {
4317 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4321 $lc_file = CPAN::FTP->localize(
4322 "authors/id/@$chksumfile",
4327 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4328 $chksumfile->[-1] .= ".gz";
4329 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4332 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4333 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4339 $lc_file = $lc_want;
4340 # we *could* second-guess and if the user has a file: URL,
4341 # then we could look there. But on the other hand, if they do
4342 # have a file: URL, wy did they choose to set
4343 # $CPAN::Config->{show_upload_date} to false?
4346 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
4347 $fh = FileHandle->new;
4349 if (open $fh, $lc_file){
4352 $eval =~ s/\015?\012/\n/g;
4354 my($comp) = Safe->new();
4355 $cksum = $comp->reval($eval);
4357 rename $lc_file, "$lc_file.bad";
4358 Carp::confess($@) if $@;
4360 } elsif ($may_ftp) {
4361 Carp::carp "Could not open '$lc_file' for reading.";
4363 # Maybe should warn: "You may want to set show_upload_date to a true value"
4367 for $f (sort keys %$cksum) {
4368 if (exists $cksum->{$f}{isdir}) {
4370 my(@dir) = @$chksumfile;
4372 push @dir, $f, "CHECKSUMS";
4374 [$_->[0], $_->[1], "$f/$_->[2]"]
4375 } $self->dir_listing(\@dir,1,$may_ftp);
4377 push @result, [ 0, "-", $f ];
4381 ($cksum->{$f}{"size"}||0),
4382 $cksum->{$f}{"mtime"}||"---",
4390 package CPAN::Distribution;
4396 my $ro = $self->ro or return;
4400 # CPAN::Distribution::undelay
4403 delete $self->{later};
4406 # add the A/AN/ stuff
4407 # CPAN::Distribution::normalize
4410 $s = $self->id unless defined $s;
4414 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
4416 return $s if $s =~ m:^N/A|^Contact Author: ;
4417 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
4418 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
4419 CPAN->debug("s[$s]") if $CPAN::DEBUG;
4424 #-> sub CPAN::Distribution::author ;
4427 my($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
4428 CPAN::Shell->expand("Author",$authorid);
4431 # tries to get the yaml from CPAN instead of the distro itself:
4432 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
4435 my $meta = $self->pretty_id;
4436 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
4437 my(@ls) = CPAN::Shell->globls($meta);
4438 my $norm = $self->normalize($meta);
4442 File::Spec->catfile(
4443 $CPAN::Config->{keep_source_where},
4448 $self->debug("Doing localize") if $CPAN::DEBUG;
4449 unless ($local_file =
4450 CPAN::FTP->localize("authors/id/$norm",
4452 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
4454 if ($CPAN::META->has_inst("YAML")) {
4455 my $yaml = YAML::LoadFile($local_file);
4458 $CPAN::Frontend->mydie("Yaml not installed, cannot parse '$local_file'\n");
4462 #-> sub CPAN::Distribution::pretty_id
4466 return $id unless $id =~ m|^./../|;
4470 # mark as dirty/clean
4471 #-> sub CPAN::Distribution::color_cmd_tmps ;
4472 sub color_cmd_tmps {
4474 my($depth) = shift || 0;
4475 my($color) = shift || 0;
4476 my($ancestors) = shift || [];
4477 # a distribution needs to recurse into its prereq_pms
4479 return if exists $self->{incommandcolor}
4480 && $self->{incommandcolor}==$color;
4482 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4484 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4485 my $prereq_pm = $self->prereq_pm;
4486 if (defined $prereq_pm) {
4487 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
4488 keys %{$prereq_pm->{build_requires}||{}}) {
4489 next PREREQ if $pre eq "perl";
4491 unless ($premo = CPAN::Shell->expand("Module",$pre)) {
4492 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
4493 $CPAN::Frontend->mysleep(2);
4496 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4500 delete $self->{sponsored_mods};
4501 delete $self->{badtestcnt};
4503 $self->{incommandcolor} = $color;
4506 #-> sub CPAN::Distribution::as_string ;
4509 $self->containsmods;
4511 $self->SUPER::as_string(@_);
4514 #-> sub CPAN::Distribution::containsmods ;
4517 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
4518 my $dist_id = $self->{ID};
4519 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
4520 my $mod_file = $mod->cpan_file or next;
4521 my $mod_id = $mod->{ID} or next;
4522 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
4524 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
4526 keys %{$self->{CONTAINSMODS}};
4529 #-> sub CPAN::Distribution::upload_date ;
4532 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4533 my(@local_wanted) = split(/\//,$self->id);
4534 my $filename = pop @local_wanted;
4535 push @local_wanted, "CHECKSUMS";
4536 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4537 return unless $author;
4538 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4540 my($dirent) = grep { $_->[2] eq $filename } @dl;
4541 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4542 return unless $dirent->[1];
4543 return $self->{UPLOAD_DATE} = $dirent->[1];
4546 #-> sub CPAN::Distribution::uptodate ;
4550 foreach $c ($self->containsmods) {
4551 my $obj = CPAN::Shell->expandany($c);
4552 unless ($obj->uptodate){
4553 my $id = $self->pretty_id;
4554 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
4561 #-> sub CPAN::Distribution::called_for ;
4564 $self->{CALLED_FOR} = $id if defined $id;
4565 return $self->{CALLED_FOR};
4568 #-> sub CPAN::Distribution::get ;
4573 exists $self->{'build_dir'} and push @e,
4574 "Is already unwrapped into directory $self->{'build_dir'}";
4575 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4577 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4580 # Get the file on local disk
4585 File::Spec->catfile(
4586 $CPAN::Config->{keep_source_where},
4589 split(/\//,$self->id)
4592 $self->debug("Doing localize") if $CPAN::DEBUG;
4593 unless ($local_file =
4594 CPAN::FTP->localize("authors/id/$self->{ID}",
4597 if ($CPAN::Index::DATE_OF_02) {
4598 $note = "Note: Current database in memory was generated ".
4599 "on $CPAN::Index::DATE_OF_02\n";
4601 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4603 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4604 $self->{localfile} = $local_file;
4605 return if $CPAN::Signal;
4610 if ($CPAN::META->has_inst("Digest::SHA")) {
4611 $self->debug("Digest::SHA is installed, verifying");
4612 $self->verifyCHECKSUM;
4614 $self->debug("Digest::SHA is NOT installed");
4616 return if $CPAN::Signal;
4619 # Create a clean room and go there
4621 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4622 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4623 $self->safe_chdir($builddir);
4624 $self->debug("Removing tmp") if $CPAN::DEBUG;
4625 File::Path::rmtree("tmp");
4626 unless (mkdir "tmp", 0755) {
4627 $CPAN::Frontend->unrecoverable_error(<<EOF);
4628 Couldn't mkdir '$builddir/tmp': $!
4630 Cannot continue: Please find the reason why I cannot make the
4633 and fix the problem, then retry.
4638 $self->safe_chdir($sub_wd);
4641 $self->safe_chdir("tmp");
4646 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4647 my $ct = CPAN::Tarzip->new($local_file);
4648 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
4649 $self->{was_uncompressed}++ unless $ct->gtest();
4650 $self->untar_me($ct);
4651 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4652 $self->unzip_me($ct);
4654 $self->{was_uncompressed}++ unless $ct->gtest();
4655 $self->debug("calling pm2dir for local_file[$local_file]")
4657 $local_file = $self->handle_singlefile($local_file);
4659 # $self->{archived} = "NO";
4660 # $self->safe_chdir($sub_wd);
4664 # we are still in the tmp directory!
4665 # Let's check if the package has its own directory.
4666 my $dh = DirHandle->new(File::Spec->curdir)
4667 or Carp::croak("Couldn't opendir .: $!");
4668 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4670 my ($distdir,$packagedir);
4671 if (@readdir == 1 && -d $readdir[0]) {
4672 $distdir = $readdir[0];
4673 $packagedir = File::Spec->catdir($builddir,$distdir);
4674 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4676 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4678 File::Path::rmtree($packagedir);
4679 unless (File::Copy::move($distdir,$packagedir)) {
4680 $CPAN::Frontend->unrecoverable_error(<<EOF);
4681 Couldn't move '$distdir' to '$packagedir': $!
4683 Cannot continue: Please find the reason why I cannot move
4684 $builddir/tmp/$distdir
4687 and fix the problem, then retry
4691 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4698 my $userid = $self->cpan_userid;
4700 CPAN->debug("no userid? self[$self]");
4703 my $pragmatic_dir = $userid . '000';
4704 $pragmatic_dir =~ s/\W_//g;
4705 $pragmatic_dir++ while -d "../$pragmatic_dir";
4706 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4707 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4708 File::Path::mkpath($packagedir);
4710 for $f (@readdir) { # is already without "." and ".."
4711 my $to = File::Spec->catdir($packagedir,$f);
4712 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4716 $self->safe_chdir($sub_wd);
4720 $self->{'build_dir'} = $packagedir;
4721 $self->safe_chdir($builddir);
4722 File::Path::rmtree("tmp");
4724 $self->safe_chdir($packagedir);
4725 if ($CPAN::Config->{check_sigs}) {
4726 if ($CPAN::META->has_inst("Module::Signature")) {
4727 if (-f "SIGNATURE") {
4728 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4729 my $rv = Module::Signature::verify();
4730 if ($rv != Module::Signature::SIGNATURE_OK() and
4731 $rv != Module::Signature::SIGNATURE_MISSING()) {
4732 $CPAN::Frontend->myprint(
4733 qq{\nSignature invalid for }.
4734 qq{distribution file. }.
4735 qq{Please investigate.\n\n}.
4737 $CPAN::META->instance(
4744 sprintf(qq{I'd recommend removing %s. Its signature
4745 is invalid. Maybe you have configured your 'urllist' with
4746 a bad URL. Please check this array with 'o conf urllist', and
4747 retry. For more information, try opening a subshell with
4755 $self->{signature_verify} = CPAN::Distrostatus->new("NO");
4756 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
4757 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
4759 $self->{signature_verify} = CPAN::Distrostatus->new("YES");
4760 $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
4763 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
4766 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4769 $self->safe_chdir($builddir);
4770 return if $CPAN::Signal;
4773 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4774 my($mpl_exists) = -f $mpl;
4775 unless ($mpl_exists) {
4776 # NFS has been reported to have racing problems after the
4777 # renaming of a directory in some environments.
4779 $CPAN::Frontend->mysleep(1);
4780 my $mpldh = DirHandle->new($packagedir)
4781 or Carp::croak("Couldn't opendir $packagedir: $!");
4782 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4785 my $prefer_installer = "eumm"; # eumm|mb
4786 if (-f File::Spec->catfile($packagedir,"Build.PL")) {
4787 if ($mpl_exists) { # they *can* choose
4788 if ($CPAN::META->has_inst("Module::Build")) {
4789 $prefer_installer = $CPAN::Config->{prefer_installer};
4792 $prefer_installer = "mb";
4795 if (lc($prefer_installer) eq "mb") {
4796 $self->{modulebuild} = 1;
4797 } elsif (! $mpl_exists) {
4798 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4802 my($configure) = File::Spec->catfile($packagedir,"Configure");
4803 if (-f $configure) {
4804 # do we have anything to do?
4805 $self->{'configure'} = $configure;
4806 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4807 $CPAN::Frontend->mywarn(qq{
4808 Package comes with a Makefile and without a Makefile.PL.
4809 We\'ll try to build it with that Makefile then.
4811 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
4812 $CPAN::Frontend->mysleep(2);
4814 my $cf = $self->called_for || "unknown";
4819 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4820 $cf = "unknown" unless length($cf);
4821 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
4822 (The test -f "$mpl" returned false.)
4823 Writing one on our own (setting NAME to $cf)\a\n});
4824 $self->{had_no_makefile_pl}++;
4825 $CPAN::Frontend->mysleep(3);
4827 # Writing our own Makefile.PL
4830 if ($self->{archived} eq "maybe_pl"){
4831 my $fh = FileHandle->new;
4832 my $script_file = File::Spec->catfile($packagedir,$local_file);
4833 $fh->open($script_file)
4834 or Carp::croak("Could not open $script_file: $!");
4836 # name parsen und prereq
4837 my($state) = "poddir";
4838 my($name, $prereq) = ("", "");
4840 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
4843 } elsif ($1 eq 'PREREQUISITES') {
4846 } elsif ($state =~ m{^(name|prereq)$}) {
4851 } elsif ($state eq "name") {
4856 } elsif ($state eq "prereq") {
4859 } elsif (/^=cut\b/) {
4866 s{.*<}{}; # strip X<...>
4870 $prereq = join " ", split /\s+/, $prereq;
4871 my($PREREQ_PM) = join("\n", map {
4872 s{.*<}{}; # strip X<...>
4874 if (/[\s\'\"]/) { # prose?
4876 s/[^\w:]$//; # period?
4877 " "x28 . "'$_' => 0,";
4879 } split /\s*,\s*/, $prereq);
4882 EXE_FILES => ['$name'],
4888 my $to_file = File::Spec->catfile($packagedir, $name);
4889 rename $script_file, $to_file
4890 or die "Can't rename $script_file to $to_file: $!";
4893 my $fh = FileHandle->new;
4895 or Carp::croak("Could not open >$mpl: $!");
4897 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4898 # because there was no Makefile.PL supplied.
4899 # Autogenerated on: }.scalar localtime().qq{
4901 use ExtUtils::MakeMaker;
4903 NAME => q[$cf],$script
4913 # CPAN::Distribution::untar_me ;
4916 $self->{archived} = "tar";
4918 $self->{unwrapped} = "YES";
4920 $self->{unwrapped} = "NO";
4924 # CPAN::Distribution::unzip_me ;
4927 $self->{archived} = "zip";
4929 $self->{unwrapped} = "YES";
4931 $self->{unwrapped} = "NO";
4936 sub handle_singlefile {
4937 my($self,$local_file) = @_;
4939 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
4940 $self->{archived} = "pm";
4942 $self->{archived} = "maybe_pl";
4945 my $to = File::Basename::basename($local_file);
4946 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4947 if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
4948 $self->{unwrapped} = "YES";
4950 $self->{unwrapped} = "NO";
4953 File::Copy::cp($local_file,".");
4954 $self->{unwrapped} = "YES";
4959 #-> sub CPAN::Distribution::new ;
4961 my($class,%att) = @_;
4963 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4965 my $this = { %att };
4966 return bless $this, $class;
4969 #-> sub CPAN::Distribution::look ;
4973 if ($^O eq 'MacOS') {
4974 $self->Mac::BuildTools::look;
4978 if ( $CPAN::Config->{'shell'} ) {
4979 $CPAN::Frontend->myprint(qq{
4980 Trying to open a subshell in the build directory...
4983 $CPAN::Frontend->myprint(qq{
4984 Your configuration does not define a value for subshells.
4985 Please define it with "o conf shell <your shell>"
4989 my $dist = $self->id;
4991 unless ($dir = $self->dir) {
4994 unless ($dir ||= $self->dir) {
4995 $CPAN::Frontend->mywarn(qq{
4996 Could not determine which directory to use for looking at $dist.
5000 my $pwd = CPAN::anycwd();
5001 $self->safe_chdir($dir);
5002 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5004 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
5005 $ENV{CPAN_SHELL_LEVEL} += 1;
5006 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5007 unless (system($shell) == 0) {
5009 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
5012 $self->safe_chdir($pwd);
5015 # CPAN::Distribution::cvs_import ;
5019 my $dir = $self->dir;
5021 my $package = $self->called_for;
5022 my $module = $CPAN::META->instance('CPAN::Module', $package);
5023 my $version = $module->cpan_version;
5025 my $userid = $self->cpan_userid;
5027 my $cvs_dir = (split /\//, $dir)[-1];
5028 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
5030 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
5032 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
5033 if ($cvs_site_perl) {
5034 $cvs_dir = "$cvs_site_perl/$cvs_dir";
5036 my $cvs_log = qq{"imported $package $version sources"};
5037 $version =~ s/\./_/g;
5038 # XXX cvs: undocumented and unclear how it was meant to work
5039 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
5040 "$cvs_dir", $userid, "v$version");
5042 my $pwd = CPAN::anycwd();
5043 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
5045 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
5047 $CPAN::Frontend->myprint(qq{@cmd\n});
5048 system(@cmd) == 0 or
5050 $CPAN::Frontend->mydie("cvs import failed");
5051 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5054 #-> sub CPAN::Distribution::readme ;
5057 my($dist) = $self->id;
5058 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
5059 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
5062 File::Spec->catfile(
5063 $CPAN::Config->{keep_source_where},
5066 split(/\//,"$sans.readme"),
5068 $self->debug("Doing localize") if $CPAN::DEBUG;
5069 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
5071 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
5073 if ($^O eq 'MacOS') {
5074 Mac::BuildTools::launch_file($local_file);
5078 my $fh_pager = FileHandle->new;
5079 local($SIG{PIPE}) = "IGNORE";
5080 my $pager = $CPAN::Config->{'pager'} || "cat";
5081 $fh_pager->open("|$pager")
5082 or die "Could not open pager $pager\: $!";
5083 my $fh_readme = FileHandle->new;
5084 $fh_readme->open($local_file)
5085 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
5086 $CPAN::Frontend->myprint(qq{
5091 $fh_pager->print(<$fh_readme>);
5095 #-> sub CPAN::Distribution::verifyCHECKSUM ;
5096 sub verifyCHECKSUM {
5100 $self->{CHECKSUM_STATUS} ||= "";
5101 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
5102 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5104 my($lc_want,$lc_file,@local,$basename);
5105 @local = split(/\//,$self->id);
5107 push @local, "CHECKSUMS";
5109 File::Spec->catfile($CPAN::Config->{keep_source_where},
5110 "authors", "id", @local);
5112 if (my $size = -s $lc_want) {
5113 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
5114 if ($self->CHECKSUM_check_file($lc_want,1)) {
5115 return $self->{CHECKSUM_STATUS} = "OK";
5118 $lc_file = CPAN::FTP->localize("authors/id/@local",
5121 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5122 $local[-1] .= ".gz";
5123 $lc_file = CPAN::FTP->localize("authors/id/@local",
5126 $lc_file =~ s/\.gz(?!\n)\Z//;
5127 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
5132 if ($self->CHECKSUM_check_file($lc_file)) {
5133 return $self->{CHECKSUM_STATUS} = "OK";
5137 #-> sub CPAN::Distribution::SIG_check_file ;
5138 sub SIG_check_file {
5139 my($self,$chk_file) = @_;
5140 my $rv = eval { Module::Signature::_verify($chk_file) };
5142 if ($rv == Module::Signature::SIGNATURE_OK()) {
5143 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
5144 return $self->{SIG_STATUS} = "OK";
5146 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
5147 qq{distribution file. }.
5148 qq{Please investigate.\n\n}.
5150 $CPAN::META->instance(
5155 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
5156 is invalid. Maybe you have configured your 'urllist' with
5157 a bad URL. Please check this array with 'o conf urllist', and
5160 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5164 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
5166 # sloppy is 1 when we have an old checksums file that maybe is good
5169 sub CHECKSUM_check_file {
5170 my($self,$chk_file,$sloppy) = @_;
5171 my($cksum,$file,$basename);
5174 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
5175 if ($CPAN::Config->{check_sigs}) {
5176 if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
5177 $self->debug("Module::Signature is installed, verifying");
5178 $self->SIG_check_file($chk_file);
5180 $self->debug("Module::Signature is NOT installed");
5184 $file = $self->{localfile};
5185 $basename = File::Basename::basename($file);
5186 my $fh = FileHandle->new;
5187 if (open $fh, $chk_file){
5190 $eval =~ s/\015?\012/\n/g;
5192 my($comp) = Safe->new();
5193 $cksum = $comp->reval($eval);
5195 rename $chk_file, "$chk_file.bad";
5196 Carp::confess($@) if $@;
5199 Carp::carp "Could not open $chk_file for reading";
5202 if (! ref $cksum or ref $cksum ne "HASH") {
5203 $CPAN::Frontend->mywarn(qq{
5204 Warning: checksum file '$chk_file' broken.
5206 When trying to read that file I expected to get a hash reference
5207 for further processing, but got garbage instead.
5209 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
5210 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5211 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
5213 } elsif (exists $cksum->{$basename}{sha256}) {
5214 $self->debug("Found checksum for $basename:" .
5215 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
5219 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
5221 $fh = CPAN::Tarzip->TIEHANDLE($file);
5224 my $dg = Digest::SHA->new(256);
5227 while ($fh->READ($ref, 4096) > 0){
5230 my $hexdigest = $dg->hexdigest;
5231 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
5235 $CPAN::Frontend->myprint("Checksum for $file ok\n");
5236 return $self->{CHECKSUM_STATUS} = "OK";
5238 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
5239 qq{distribution file. }.
5240 qq{Please investigate.\n\n}.
5242 $CPAN::META->instance(
5247 my $wrap = qq{I\'d recommend removing $file. Its
5248 checksum is incorrect. Maybe you have configured your 'urllist' with
5249 a bad URL. Please check this array with 'o conf urllist', and
5252 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
5254 # former versions just returned here but this seems a
5255 # serious threat that deserves a die
5257 # $CPAN::Frontend->myprint("\n\n");
5261 # close $fh if fileno($fh);
5264 unless ($self->{CHECKSUM_STATUS}) {
5265 $CPAN::Frontend->mywarn(qq{
5266 Warning: No checksum for $basename in $chk_file.
5268 The cause for this may be that the file is very new and the checksum
5269 has not yet been calculated, but it may also be that something is
5270 going awry right now.
5272 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
5273 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
5275 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
5280 #-> sub CPAN::Distribution::eq_CHECKSUM ;
5282 my($self,$fh,$expect) = @_;
5283 if ($CPAN::META->has_inst("Digest::SHA")) {
5284 my $dg = Digest::SHA->new(256);
5286 while (read($fh, $data, 4096)){
5289 my $hexdigest = $dg->hexdigest;
5290 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
5291 return $hexdigest eq $expect;
5296 #-> sub CPAN::Distribution::force ;
5298 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
5299 # effect by autoinspection, not by inspecting a global variable. One
5300 # of the reason why this was chosen to work that way was the treatment
5301 # of dependencies. They should not automatically inherit the force
5302 # status. But this has the downside that ^C and die() will return to
5303 # the prompt but will not be able to reset the force_update
5304 # attributes. We try to correct for it currently in the read_metadata
5305 # routine, and immediately before we check for a Signal. I hope this
5306 # works out in one of v1.57_53ff
5308 # "Force get forgets previous error conditions"
5310 #-> sub CPAN::Distribution::force ;
5312 my($self, $method) = @_;
5314 CHECKSUM_STATUS archived build_dir localfile make install unwrapped
5315 writemakefile modulebuild make_test signature_verify
5317 delete $self->{$att};
5319 if ($method && $method =~ /make|test|install/) {
5320 $self->{"force_update"}++; # name should probably have been force_install
5325 my($self, $method) = @_;
5326 # warn "XDEBUG: set notest for $self $method";
5327 $self->{"notest"}++; # name should probably have been force_install
5332 # warn "XDEBUG: deleting notest";
5333 delete $self->{'notest'};
5336 #-> sub CPAN::Distribution::unforce ;
5339 delete $self->{'force_update'};
5342 #-> sub CPAN::Distribution::isa_perl ;
5345 my $file = File::Basename::basename($self->id);
5346 if ($file =~ m{ ^ perl
5359 } elsif ($self->cpan_comment
5361 $self->cpan_comment =~ /isa_perl\(.+?\)/){
5367 #-> sub CPAN::Distribution::perl ;
5372 carp __PACKAGE__ . "::perl was called without parameters.";
5374 return CPAN::HandleConfig->safe_quote($CPAN::Perl);
5378 #-> sub CPAN::Distribution::make ;
5381 my $make = $self->{modulebuild} ? "Build" : "make";
5382 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
5383 # Emergency brake if they said install Pippi and get newest perl
5384 if ($self->isa_perl) {
5386 $self->called_for ne $self->id &&
5387 ! $self->{force_update}
5389 # if we die here, we break bundles
5390 $CPAN::Frontend->mywarn(sprintf qq{
5391 The most recent version "%s" of the module "%s"
5392 comes with the current version of perl (%s).
5393 I\'ll build that only if you ask for something like
5398 $CPAN::META->instance(
5406 $self->{make} = CPAN::Distrostatus->new("NO isa perl");
5407 $CPAN::Frontend->mysleep(1);
5413 delete $self->{force_update};
5418 !$self->{archived} || $self->{archived} eq "NO" and push @e,
5419 "Is neither a tar nor a zip archive.";
5421 !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
5422 "Had problems unarchiving. Please build manually";
5424 unless ($self->{force_update}) {
5425 exists $self->{signature_verify} and (
5426 $self->{signature_verify}->can("failed") ?
5427 $self->{signature_verify}->failed :
5428 $self->{signature_verify} =~ /^NO/
5430 and push @e, "Did not pass the signature test.";
5433 if (exists $self->{writemakefile} &&
5435 $self->{writemakefile}->can("failed") ?
5436 $self->{writemakefile}->failed :
5437 $self->{writemakefile} =~ /^NO/
5439 # XXX maybe a retry would be in order?
5440 my $err = $self->{writemakefile}->can("text") ?
5441 $self->{writemakefile}->text :
5442 $self->{writemakefile};
5444 $err ||= "Had some problem writing Makefile";
5445 $err .= ", won't make";
5449 defined $self->{make} and push @e,
5450 "Has already been processed within this session";
5452 if (exists $self->{later} and length($self->{later})) {
5453 if ($self->unsat_prereq) {
5454 push @e, $self->{later};
5455 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
5456 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
5457 # are not sufficient to be sure if we really must/may do the delete
5458 # here. SO I accept the suggested patch for now. If we trigger a bug
5459 # again, I must go into deep contemplation about the {later} flag.
5462 # delete $self->{later};
5466 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5469 delete $self->{force_update};
5472 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
5473 my $builddir = $self->dir or
5474 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
5475 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
5476 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
5478 if ($^O eq 'MacOS') {
5479 Mac::BuildTools::make($self);
5484 if ($self->{'configure'}) {
5485 $system = $self->{'configure'};
5486 } elsif ($self->{modulebuild}) {
5487 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5488 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
5490 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
5492 # This needs a handler that can be turned on or off:
5493 # $switch = "-MExtUtils::MakeMaker ".
5494 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
5496 $system = sprintf("%s%s Makefile.PL%s",
5498 $switch ? " $switch" : "",
5499 $CPAN::Config->{makepl_arg} ? " $CPAN::Config->{makepl_arg}" : "",
5502 unless (exists $self->{writemakefile}) {
5503 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
5507 if ($CPAN::Config->{inactivity_timeout}) {
5509 if ($Config::Config{d_alarm}
5511 $Config::Config{d_alarm} eq "define"
5515 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
5516 "variable 'inactivity_timeout' to ".
5517 "'$CPAN::Config->{inactivity_timeout}'. But ".
5518 "on this machine the system call 'alarm' ".
5519 "isn't available. This means that we cannot ".
5520 "provide the feature of intercepting long ".
5521 "waiting code and will turn this feature off.\n"
5523 $CPAN::Config->{inactivity_timeout} = 0;
5526 if ($go_via_alarm) {
5528 alarm $CPAN::Config->{inactivity_timeout};
5529 local $SIG{CHLD}; # = sub { wait };
5530 if (defined($pid = fork)) {
5535 # note, this exec isn't necessary if
5536 # inactivity_timeout is 0. On the Mac I'd
5537 # suggest, we set it always to 0.
5541 $CPAN::Frontend->myprint("Cannot fork: $!");
5550 $CPAN::Frontend->myprint($err);
5551 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
5556 $ret = system($system);
5558 $self->{writemakefile} = CPAN::Distrostatus
5559 ->new("NO '$system' returned status $ret");
5560 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
5564 if (-f "Makefile" || -f "Build") {
5565 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
5566 delete $self->{make_clean}; # if cleaned before, enable next
5568 $self->{writemakefile} = CPAN::Distrostatus
5569 ->new(qq{NO -- Unknown reason.});
5573 delete $self->{force_update};
5576 if (my @prereq = $self->unsat_prereq){
5577 if ($prereq[0][0] eq "perl") {
5578 my $need = "requires perl '$prereq[0][1]'";
5579 my $id = $self->pretty_id;
5580 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
5581 $self->{make} = CPAN::Distrostatus->new("NO $need");
5584 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
5587 if ($self->{modulebuild}) {
5588 unless (-f "Build") {
5590 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
5591 " in cwd[$cwd]. Danger, Will Robinson!");
5592 $CPAN::Frontend->mysleep(5);
5594 $system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
5596 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
5598 if (system($system) == 0) {
5599 $CPAN::Frontend->myprint(" $system -- OK\n");
5600 $self->{make} = CPAN::Distrostatus->new("YES");
5602 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
5603 $self->{make} = CPAN::Distrostatus->new("NO");
5604 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
5614 $CPAN::Config->{make} || $Config::Config{make} || 'make'
5617 # Old style call, without object. Deprecated
5618 Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
5620 safe_quote(undef, $CPAN::Config->{make} || $Config::Config{make} || 'make');
5624 #-> sub CPAN::Distribution::follow_prereqs ;
5625 sub follow_prereqs {
5627 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
5628 return unless @prereq_tuples;
5629 my @prereq = map { $_->[0] } @prereq_tuples;
5632 b => "build_requires",
5637 myprint("---- Unsatisfied dependencies detected ".
5638 "during [$id] -----\n".
5639 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
5642 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
5644 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
5645 my $answer = CPAN::Shell::colorable_makemaker_prompt(
5646 "Shall I follow them and prepend them to the queue
5647 of modules we are processing right now?", "yes");
5648 $follow = $answer =~ /^\s*y/i;
5652 myprint(" Ignoring dependencies on modules @prereq\n");
5655 # color them as dirty
5656 for my $p (@prereq) {
5657 # warn "calling color_cmd_tmps(0,1)";
5658 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
5660 # queue them and re-queue yourself
5661 CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
5662 reverse @prereq_tuples);
5663 $self->{later} = "Delayed until after prerequisites";
5664 return 1; # signal success to the queuerunner
5668 #-> sub CPAN::Distribution::unsat_prereq ;
5669 # return ([Foo=>1],[Bar=>1.2]) for normal modules
5670 # return ([perl=>5.008]) if we need a newer perl than we are running under
5673 my $prereq_pm = $self->prereq_pm or return;
5675 my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
5676 NEED: while (my($need_module, $need_version) = each %merged) {
5677 my($have_version,$inst_file);
5678 if ($need_module eq "perl") {
5682 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
5683 next if $nmo->uptodate;
5684 $inst_file = $nmo->inst_file;
5686 # if they have not specified a version, we accept any installed one
5687 if (not defined $need_version or
5688 $need_version eq "0" or
5689 $need_version eq "undef") {
5690 next if defined $inst_file;
5693 $have_version = $nmo->inst_version;
5696 # We only want to install prereqs if either they're not installed
5697 # or if the installed version is too old. We cannot omit this
5698 # check, because if 'force' is in effect, nobody else will check.
5699 if (defined $inst_file) {
5700 my(@all_requirements) = split /\s*,\s*/, $need_version;
5703 RQ: for my $rq (@all_requirements) {
5704 if ($rq =~ s|>=\s*||) {
5705 } elsif ($rq =~ s|>\s*||) {
5707 if (CPAN::Version->vgt($have_version,$rq)){
5711 } elsif ($rq =~ s|!=\s*||) {
5713 if (CPAN::Version->vcmp($have_version,$rq)){
5719 } elsif ($rq =~ m|<=?\s*|) {
5721 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
5725 if (! CPAN::Version->vgt($rq, $have_version)){
5728 CPAN->debug(sprintf("need_module[%s]inst_file[%s]".
5729 "inst_version[%s]rq[%s]ok[%d]",
5733 CPAN::Version->readable($rq),
5737 next NEED if $ok == @all_requirements;
5740 if ($need_module eq "perl") {
5741 return ["perl", $need_version];
5743 if ($self->{sponsored_mods}{$need_module}++){
5744 # We have already sponsored it and for some reason it's still
5745 # not available. So we do nothing. Or what should we do?
5746 # if we push it again, we have a potential infinite loop
5749 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
5750 push @need, [$need_module,$needed_as];
5755 #-> sub CPAN::Distribution::read_yaml ;
5758 return $self->{yaml_content} if exists $self->{yaml_content};
5759 my $build_dir = $self->{build_dir};
5760 my $yaml = File::Spec->catfile($build_dir,"META.yml");
5761 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
5762 return unless -f $yaml;
5763 if ($CPAN::META->has_inst("YAML")) {
5764 eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
5766 $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
5769 if (not exists $self->{yaml_content}{dynamic_config}
5770 or $self->{yaml_content}{dynamic_config}
5772 $self->{yaml_content} = undef;
5775 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
5777 return $self->{yaml_content};
5780 #-> sub CPAN::Distribution::prereq_pm ;
5783 return $self->{prereq_pm} if
5784 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
5785 return unless $self->{writemakefile} # no need to have succeeded
5786 # but we must have run it
5787 || $self->{modulebuild};
5789 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
5790 $req = $yaml->{requires} || {};
5791 $breq = $yaml->{build_requires} || {};
5792 undef $req unless ref $req eq "HASH" && %$req;
5794 if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
5795 my $eummv = do { local $^W = 0; $1+0; };
5796 if ($eummv < 6.2501) {
5797 # thanks to Slaven for digging that out: MM before
5798 # that could be wrong because it could reflect a
5805 while (my($k,$v) = each %{$req||{}}) {
5808 } elsif ($k =~ /[A-Za-z]/ &&
5810 $CPAN::META->exists("Module",$v)
5812 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
5813 "requires hash: $k => $v; I'll take both ".
5814 "key and value as a module name\n");
5815 $CPAN::Frontend->mysleep(1);
5821 $req = $areq if $do_replace;
5824 unless ($req || $breq) {
5825 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
5826 my $makefile = File::Spec->catfile($build_dir,"Makefile");
5830 $fh = FileHandle->new("<$makefile\0")) {
5833 last if /MakeMaker post_initialize section/;
5835 \s+PREREQ_PM\s+=>\s+(.+)
5838 # warn "Found prereq expr[$p]";
5840 # Regexp modified by A.Speer to remember actual version of file
5841 # PREREQ_PM hash key wants, then add to
5842 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
5843 # In case a prereq is mentioned twice, complain.
5844 if ( defined $req->{$1} ) {
5845 warn "Warning: PREREQ_PM mentions $1 more than once, ".
5846 "last mention wins";
5852 } elsif (-f "Build") {
5853 if ($CPAN::META->has_inst("Module::Build")) {
5854 $req = Module::Build->current->requires();
5855 $breq = Module::Build->current->build_requires();
5860 && ! -f "Makefile.PL"
5861 && ! exists $req->{"Module::Build"}
5862 && ! $CPAN::META->has_inst("Module::Build")) {
5863 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
5864 "undeclared prerequisite.\n".
5865 " Adding it now as such.\n"
5867 $CPAN::Frontend->mysleep(5);
5868 $req->{"Module::Build"} = 0;
5869 delete $self->{writemakefile};
5871 $self->{prereq_pm_detected}++;
5872 return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
5875 #-> sub CPAN::Distribution::test ;
5880 delete $self->{force_update};
5883 # warn "XDEBUG: checking for notest: $self->{notest} $self";
5884 if ($self->{notest}) {
5885 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
5889 my $make = $self->{modulebuild} ? "Build" : "make";
5890 $CPAN::Frontend->myprint("Running $make test\n");
5891 if (my @prereq = $self->unsat_prereq){
5892 unless ($prereq[0][0] eq "perl") {
5893 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
5898 unless (exists $self->{make} or exists $self->{later}) {
5900 "Make had some problems, won't test";
5903 exists $self->{make} and
5905 $self->{make}->can("failed") ?
5906 $self->{make}->failed :
5907 $self->{make} =~ /^NO/
5908 ) and push @e, "Can't test without successful make";
5910 exists $self->{build_dir} or push @e, "Has no own directory";
5911 $self->{badtestcnt} ||= 0;
5912 $self->{badtestcnt} > 0 and
5913 push @e, "Won't repeat unsuccessful test during this command";
5915 exists $self->{later} and length($self->{later}) and
5916 push @e, $self->{later};
5918 if ($CPAN::META->{is_tested}{$self->{build_dir}}
5920 exists $self->{make_test}
5923 $self->{make_test}->can("failed") ?
5924 $self->{make_test}->failed :
5925 $self->{make_test} =~ /^NO/
5928 push @e, "Already tested successfully";
5931 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5933 chdir $self->{'build_dir'} or
5934 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5935 $self->debug("Changed directory to $self->{'build_dir'}")
5938 if ($^O eq 'MacOS') {
5939 Mac::BuildTools::make_test($self);
5943 if ($self->{modulebuild}) {
5944 my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
5945 if (CPAN::Version->vlt($v,2.62)) {
5946 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
5947 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
5948 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
5953 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5955 : ($ENV{PERLLIB} || "");
5957 $CPAN::META->set_perl5lib;
5958 local $ENV{MAKEFLAGS}; # protect us from outer make calls
5961 if ($self->{modulebuild}) {
5962 $system = sprintf "%s test", $self->_build_command();
5964 $system = join " ", $self->_make_command(), "test";
5967 if ( $CPAN::Config->{test_report} &&
5968 $CPAN::META->has_inst("CPAN::Reporter") ) {
5969 $tests_ok = CPAN::Reporter::test($self, $system);
5971 $tests_ok = system($system) == 0;
5974 $CPAN::Frontend->myprint(" $system -- OK\n");
5975 $CPAN::META->is_tested($self->{'build_dir'});
5976 $self->{make_test} = CPAN::Distrostatus->new("YES");
5978 $self->{make_test} = CPAN::Distrostatus->new("NO");
5979 $self->{badtestcnt}++;
5980 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
5984 #-> sub CPAN::Distribution::clean ;
5987 my $make = $self->{modulebuild} ? "Build" : "make";
5988 $CPAN::Frontend->myprint("Running $make clean\n");
5989 unless (exists $self->{archived}) {
5990 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
5991 "/untarred, nothing done\n");
5994 unless (exists $self->{build_dir}) {
5995 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
6000 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
6001 push @e, "make clean already called once";
6002 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6004 chdir $self->{'build_dir'} or
6005 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
6006 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
6008 if ($^O eq 'MacOS') {
6009 Mac::BuildTools::make_clean($self);
6014 if ($self->{modulebuild}) {
6015 unless (-f "Build") {
6017 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
6018 " in cwd[$cwd]. Danger, Will Robinson!");
6019 $CPAN::Frontend->mysleep(5);
6021 $system = sprintf "%s clean", $self->_build_command();
6023 $system = join " ", $self->_make_command(), "clean";
6025 if (system($system) == 0) {
6026 $CPAN::Frontend->myprint(" $system -- OK\n");
6030 # Jost Krieger pointed out that this "force" was wrong because
6031 # it has the effect that the next "install" on this distribution
6032 # will untar everything again. Instead we should bring the
6033 # object's state back to where it is after untarring.
6044 $self->{make_clean} = CPAN::Distrostatus->new("YES");
6047 # Hmmm, what to do if make clean failed?
6049 $self->{make_clean} = CPAN::Distrostatus->new("NO");
6050 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
6052 # 2006-02-27: seems silly to me to force a make now
6053 # $self->force("make"); # so that this directory won't be used again
6058 #-> sub CPAN::Distribution::install ;
6063 delete $self->{force_update};
6066 my $make = $self->{modulebuild} ? "Build" : "make";
6067 $CPAN::Frontend->myprint("Running $make install\n");
6070 exists $self->{build_dir} or push @e, "Has no own directory";
6072 unless (exists $self->{make} or exists $self->{later}) {
6074 "Make had some problems, won't install";
6077 exists $self->{make} and
6079 $self->{make}->can("failed") ?
6080 $self->{make}->failed :
6081 $self->{make} =~ /^NO/
6083 push @e, "make had returned bad status, install seems impossible";
6085 if (exists $self->{make_test} and
6087 $self->{make_test}->can("failed") ?
6088 $self->{make_test}->failed :
6089 $self->{make_test} =~ /^NO/
6091 if ($self->{force_update}) {
6092 $self->{make_test}->text("FAILED but failure ignored because ".
6093 "'force' in effect");
6095 push @e, "make test had returned bad status, ".
6096 "won't install without force"
6099 if (exists $self->{'install'}) {
6100 if ($self->{'install'}->can("text") ?
6101 $self->{'install'}->text eq "YES" :
6102 $self->{'install'} =~ /^YES/
6104 push @e, "Already done";
6106 # comment in Todo on 2006-02-11; maybe retry?
6107 push @e, "Already tried without success";
6111 exists $self->{later} and length($self->{later}) and
6112 push @e, $self->{later};
6114 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
6116 chdir $self->{'build_dir'} or
6117 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
6118 $self->debug("Changed directory to $self->{'build_dir'}")
6121 if ($^O eq 'MacOS') {
6122 Mac::BuildTools::make_install($self);
6127 if ($self->{modulebuild}) {
6128 my($mbuild_install_build_command) =
6129 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
6130 $CPAN::Config->{mbuild_install_build_command} ?
6131 $CPAN::Config->{mbuild_install_build_command} :
6132 $self->_build_command();
6133 $system = sprintf("%s install %s",
6134 $mbuild_install_build_command,
6135 $CPAN::Config->{mbuild_install_arg},
6138 my($make_install_make_command) = $CPAN::Config->{make_install_make_command} ||
6139 $self->_make_command();
6140 $system = sprintf("%s install %s",
6141 $make_install_make_command,
6142 $CPAN::Config->{make_install_arg},
6146 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
6147 $CPAN::Config->{build_requires_install_policy}||="ask/yes";
6149 my $reqtype = $self->{reqtype};
6151 $CPAN::Frontend->mywarn("Unknown require type for '$id', setting to 'r'. ".
6152 "This should not happen and is construed a bug.\n");
6155 my $want_install = "yes";
6156 if ($reqtype eq "b") {
6157 if ($CPAN::Config->{build_requires_install_policy} eq "no") {
6158 $want_install = "no";
6159 } elsif ($CPAN::Config->{build_requires_install_policy} =~ m|^ask/(.+)|) {
6161 $default = "yes" unless $default =~ /^(y|n)/i;
6163 CPAN::Shell::colorable_makemaker_prompt
6164 ("$id is just needed temporarily during building or testing. ".
6165 "Do you want to install it permanently? (Y/n)",
6169 unless ($want_install =~ /^y/i) {
6170 my $is_only = "is only 'build_requires'";
6171 $CPAN::Frontend->mywarn("Not installing because $is_only\n");
6172 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
6173 delete $self->{force_update};
6176 my($pipe) = FileHandle->new("$system $stderr |");
6179 print $_; # intentionally NOT use Frontend->myprint because it
6180 # looks irritating when we markup in color what we
6181 # just pass through from an external program
6186 $CPAN::Frontend->myprint(" $system -- OK\n");
6187 $CPAN::META->is_installed($self->{build_dir});
6188 return $self->{install} = CPAN::Distrostatus->new("YES");
6190 $self->{install} = CPAN::Distrostatus->new("NO");
6191 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
6193 $makeout =~ /permission/s
6196 ! $CPAN::Config->{make_install_make_command}
6197 || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
6200 $CPAN::Frontend->myprint(
6202 qq{ You may have to su }.
6203 qq{to root to install the package\n}.
6204 qq{ (Or you may want to run something like\n}.
6205 qq{ o conf make_install_make_command 'sudo make'\n}.
6206 qq{ to raise your permissions.}
6210 delete $self->{force_update};
6213 #-> sub CPAN::Distribution::dir ;
6215 shift->{'build_dir'};
6218 #-> sub CPAN::Distribution::perldoc ;
6222 my($dist) = $self->id;
6223 my $package = $self->called_for;
6225 $self->_display_url( $CPAN::Defaultdocs . $package );
6228 #-> sub CPAN::Distribution::_check_binary ;
6230 my ($dist,$shell,$binary) = @_;
6233 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
6237 $pid = open README, "which $binary|"
6238 or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
6242 close README or die "Could not run 'which $binary': $!";
6244 $CPAN::Frontend->myprint(qq{ + $out \n})
6245 if $CPAN::DEBUG && $out;
6250 #-> sub CPAN::Distribution::_display_url ;
6252 my($self,$url) = @_;
6253 my($res,$saved_file,$pid,$out);
6255 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
6258 # should we define it in the config instead?
6259 my $html_converter = "html2text";
6261 my $web_browser = $CPAN::Config->{'lynx'} || undef;
6262 my $web_browser_out = $web_browser
6263 ? CPAN::Distribution->_check_binary($self,$web_browser)
6266 if ($web_browser_out) {
6267 # web browser found, run the action
6268 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
6269 $CPAN::Frontend->myprint(qq{system[$browser $url]})
6271 $CPAN::Frontend->myprint(qq{
6274 with browser $browser
6276 $CPAN::Frontend->mysleep(1);
6277 system("$browser $url");
6278 if ($saved_file) { 1 while unlink($saved_file) }
6280 # web browser not found, let's try text only
6281 my $html_converter_out =
6282 CPAN::Distribution->_check_binary($self,$html_converter);
6283 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
6285 if ($html_converter_out ) {
6286 # html2text found, run it
6287 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
6288 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
6289 unless defined($saved_file);
6292 $pid = open README, "$html_converter $saved_file |"
6293 or $CPAN::Frontend->mydie(qq{
6294 Could not fork '$html_converter $saved_file': $!});
6296 if ($CPAN::META->has_inst("File::Temp")) {
6297 $fh = File::Temp->new(
6298 template => 'cpan_htmlconvert_XXXX',
6302 $filename = $fh->filename;
6304 $filename = "cpan_htmlconvert_$$.txt";
6305 $fh = FileHandle->new();
6306 open $fh, ">$filename" or die;
6312 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
6313 my $tmpin = $fh->filename;
6314 $CPAN::Frontend->myprint(sprintf(qq{
6316 saved output to %s\n},
6324 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
6325 my $fh_pager = FileHandle->new;
6326 local($SIG{PIPE}) = "IGNORE";
6327 my $pager = $CPAN::Config->{'pager'} || "cat";
6328 $fh_pager->open("|$pager")
6329 or $CPAN::Frontend->mydie(qq{
6330 Could not open pager '$pager': $!});
6331 $CPAN::Frontend->myprint(qq{
6336 $CPAN::Frontend->mysleep(1);
6337 $fh_pager->print(<FH>);
6340 # coldn't find the web browser or html converter
6341 $CPAN::Frontend->myprint(qq{
6342 You need to install lynx or $html_converter to use this feature.});
6347 #-> sub CPAN::Distribution::_getsave_url ;
6349 my($dist, $shell, $url) = @_;
6351 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
6355 if ($CPAN::META->has_inst("File::Temp")) {
6356 $fh = File::Temp->new(
6357 template => "cpan_getsave_url_XXXX",
6361 $filename = $fh->filename;
6363 $fh = FileHandle->new;
6364 $filename = "cpan_getsave_url_$$.html";
6366 my $tmpin = $filename;
6367 if ($CPAN::META->has_usable('LWP')) {
6368 $CPAN::Frontend->myprint("Fetching with LWP:
6372 CPAN::LWP::UserAgent->config;
6373 eval { $Ua = CPAN::LWP::UserAgent->new; };
6375 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
6379 $Ua->proxy('http', $var)
6380 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
6382 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
6385 my $req = HTTP::Request->new(GET => $url);
6386 $req->header('Accept' => 'text/html');
6387 my $res = $Ua->request($req);
6388 if ($res->is_success) {
6389 $CPAN::Frontend->myprint(" + request successful.\n")
6391 print $fh $res->content;
6393 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
6397 $CPAN::Frontend->myprint(sprintf(
6398 "LWP failed with code[%s], message[%s]\n",
6405 $CPAN::Frontend->mywarn(" LWP not available\n");
6410 # sub CPAN::Distribution::_build_command
6411 sub _build_command {
6413 if ($^O eq "MSWin32") { # special code needed at least up to
6414 # Module::Build 0.2611 and 0.2706; a fix
6415 # in M:B has been promised 2006-01-30
6416 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
6417 return "$perl ./Build";
6422 package CPAN::Bundle;
6427 $CPAN::Frontend->myprint($self->as_string);
6432 delete $self->{later};
6433 for my $c ( $self->contains ) {
6434 my $obj = CPAN::Shell->expandany($c) or next;
6439 # mark as dirty/clean
6440 #-> sub CPAN::Bundle::color_cmd_tmps ;
6441 sub color_cmd_tmps {
6443 my($depth) = shift || 0;
6444 my($color) = shift || 0;
6445 my($ancestors) = shift || [];
6446 # a module needs to recurse to its cpan_file, a distribution needs
6447 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
6449 return if exists $self->{incommandcolor}
6450 && $self->{incommandcolor}==$color;
6452 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
6454 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6456 for my $c ( $self->contains ) {
6457 my $obj = CPAN::Shell->expandany($c) or next;
6458 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
6459 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6462 delete $self->{badtestcnt};
6464 $self->{incommandcolor} = $color;
6467 #-> sub CPAN::Bundle::as_string ;
6471 # following line must be "=", not "||=" because we have a moving target
6472 $self->{INST_VERSION} = $self->inst_version;
6473 return $self->SUPER::as_string;
6476 #-> sub CPAN::Bundle::contains ;
6479 my($inst_file) = $self->inst_file || "";
6480 my($id) = $self->id;
6481 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
6482 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
6485 unless ($inst_file) {
6486 # Try to get at it in the cpan directory
6487 $self->debug("no inst_file") if $CPAN::DEBUG;
6489 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
6490 $cpan_file = $self->cpan_file;
6491 if ($cpan_file eq "N/A") {
6492 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
6493 Maybe stale symlink? Maybe removed during session? Giving up.\n");
6495 my $dist = $CPAN::META->instance('CPAN::Distribution',
6498 $self->debug("id[$dist->{ID}]") if $CPAN::DEBUG;
6499 my($todir) = $CPAN::Config->{'cpan_home'};
6500 my(@me,$from,$to,$me);
6501 @me = split /::/, $self->id;
6503 $me = File::Spec->catfile(@me);
6504 $from = $self->find_bundle_file($dist->{'build_dir'},join('/',@me));
6505 $to = File::Spec->catfile($todir,$me);
6506 File::Path::mkpath(File::Basename::dirname($to));
6507 File::Copy::copy($from, $to)
6508 or Carp::confess("Couldn't copy $from to $to: $!");
6512 my $fh = FileHandle->new;
6514 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
6516 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
6518 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
6519 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
6520 next unless $in_cont;
6525 push @result, (split " ", $_, 2)[0];
6528 delete $self->{STATUS};
6529 $self->{CONTAINS} = \@result;
6530 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
6532 $CPAN::Frontend->mywarn(qq{
6533 The bundle file "$inst_file" may be a broken
6534 bundlefile. It seems not to contain any bundle definition.
6535 Please check the file and if it is bogus, please delete it.
6536 Sorry for the inconvenience.
6542 #-> sub CPAN::Bundle::find_bundle_file
6543 # $where is in local format, $what is in unix format
6544 sub find_bundle_file {
6545 my($self,$where,$what) = @_;
6546 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
6547 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
6548 ### my $bu = File::Spec->catfile($where,$what);
6549 ### return $bu if -f $bu;
6550 my $manifest = File::Spec->catfile($where,"MANIFEST");
6551 unless (-f $manifest) {
6552 require ExtUtils::Manifest;
6553 my $cwd = CPAN::anycwd();
6554 $self->safe_chdir($where);
6555 ExtUtils::Manifest::mkmanifest();
6556 $self->safe_chdir($cwd);
6558 my $fh = FileHandle->new($manifest)
6559 or Carp::croak("Couldn't open $manifest: $!");
6561 my $bundle_filename = $what;
6562 $bundle_filename =~ s|Bundle.*/||;
6563 my $bundle_unixpath;
6566 my($file) = /(\S+)/;
6567 if ($file =~ m|\Q$what\E$|) {
6568 $bundle_unixpath = $file;
6569 # return File::Spec->catfile($where,$bundle_unixpath); # bad
6572 # retry if she managed to have no Bundle directory
6573 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
6575 return File::Spec->catfile($where, split /\//, $bundle_unixpath)
6576 if $bundle_unixpath;
6577 Carp::croak("Couldn't find a Bundle file in $where");
6580 # needs to work quite differently from Module::inst_file because of
6581 # cpan_home/Bundle/ directory and the possibility that we have
6582 # shadowing effect. As it makes no sense to take the first in @INC for
6583 # Bundles, we parse them all for $VERSION and take the newest.
6585 #-> sub CPAN::Bundle::inst_file ;
6590 @me = split /::/, $self->id;
6593 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
6594 my $bfile = File::Spec->catfile($incdir, @me);
6595 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
6596 next unless -f $bfile;
6597 my $foundv = MM->parse_version($bfile);
6598 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
6599 $self->{INST_FILE} = $bfile;
6600 $self->{INST_VERSION} = $bestv = $foundv;
6606 #-> sub CPAN::Bundle::inst_version ;
6609 $self->inst_file; # finds INST_VERSION as side effect
6610 $self->{INST_VERSION};
6613 #-> sub CPAN::Bundle::rematein ;
6615 my($self,$meth) = @_;
6616 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
6617 my($id) = $self->id;
6618 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
6619 unless $self->inst_file || $self->cpan_file;
6621 for $s ($self->contains) {
6622 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
6623 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
6624 if ($type eq 'CPAN::Distribution') {
6625 $CPAN::Frontend->mywarn(qq{
6626 The Bundle }.$self->id.qq{ contains
6627 explicitly a file $s.
6629 $CPAN::Frontend->mysleep(3);
6631 # possibly noisy action:
6632 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
6633 my $obj = $CPAN::META->instance($type,$s);
6634 $obj->{reqtype} = $self->{reqtype};
6636 if ($obj->isa('CPAN::Bundle')
6638 exists $obj->{install_failed}
6640 ref($obj->{install_failed}) eq "HASH"
6642 for (keys %{$obj->{install_failed}}) {
6643 $self->{install_failed}{$_} = undef; # propagate faiure up
6646 $fail{$s} = 1; # the bundle itself may have succeeded but
6651 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
6652 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
6654 delete $self->{install_failed}{$s};
6661 # recap with less noise
6662 if ( $meth eq "install" ) {
6665 my $raw = sprintf(qq{Bundle summary:
6666 The following items in bundle %s had installation problems:},
6669 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
6670 $CPAN::Frontend->myprint("\n");
6673 for $s ($self->contains) {
6675 $paragraph .= "$s ";
6676 $self->{install_failed}{$s} = undef;
6677 $reported{$s} = undef;
6680 my $report_propagated;
6681 for $s (sort keys %{$self->{install_failed}}) {
6682 next if exists $reported{$s};
6683 $paragraph .= "and the following items had problems
6684 during recursive bundle calls: " unless $report_propagated++;
6685 $paragraph .= "$s ";
6687 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
6688 $CPAN::Frontend->myprint("\n");
6690 $self->{'install'} = 'YES';
6695 # If a bundle contains another that contains an xs_file we have here,
6696 # we just don't bother I suppose
6697 #-> sub CPAN::Bundle::xs_file
6702 #-> sub CPAN::Bundle::force ;
6703 sub force { shift->rematein('force',@_); }
6704 #-> sub CPAN::Bundle::notest ;
6705 sub notest { shift->rematein('notest',@_); }
6706 #-> sub CPAN::Bundle::get ;
6707 sub get { shift->rematein('get',@_); }
6708 #-> sub CPAN::Bundle::make ;
6709 sub make { shift->rematein('make',@_); }
6710 #-> sub CPAN::Bundle::test ;
6713 $self->{badtestcnt} ||= 0;
6714 $self->rematein('test',@_);
6716 #-> sub CPAN::Bundle::install ;
6719 $self->rematein('install',@_);
6721 #-> sub CPAN::Bundle::clean ;
6722 sub clean { shift->rematein('clean',@_); }
6724 #-> sub CPAN::Bundle::uptodate ;
6727 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
6729 foreach $c ($self->contains) {
6730 my $obj = CPAN::Shell->expandany($c);
6731 return 0 unless $obj->uptodate;
6736 #-> sub CPAN::Bundle::readme ;
6739 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
6740 No File found for bundle } . $self->id . qq{\n}), return;
6741 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
6742 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
6745 package CPAN::Module;
6749 # sub CPAN::Module::userid
6754 return $ro->{userid} || $ro->{CPAN_USERID};
6756 # sub CPAN::Module::description
6759 my $ro = $self->ro or return "";
6765 CPAN::Shell->expand("Distribution",$self->cpan_file);
6768 # sub CPAN::Module::undelay
6771 delete $self->{later};
6772 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
6777 # mark as dirty/clean
6778 #-> sub CPAN::Module::color_cmd_tmps ;
6779 sub color_cmd_tmps {
6781 my($depth) = shift || 0;
6782 my($color) = shift || 0;
6783 my($ancestors) = shift || [];
6784 # a module needs to recurse to its cpan_file
6786 return if exists $self->{incommandcolor}
6787 && $self->{incommandcolor}==$color;
6788 return if $depth>=1 && $self->uptodate;
6790 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
6792 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6794 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
6795 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6798 delete $self->{badtestcnt};
6800 $self->{incommandcolor} = $color;
6803 #-> sub CPAN::Module::as_glimpse ;
6807 my $class = ref($self);
6808 $class =~ s/^CPAN:://;
6812 $CPAN::Shell::COLOR_REGISTERED
6814 $CPAN::META->has_inst("Term::ANSIColor")
6818 $color_on = Term::ANSIColor::color("green");
6819 $color_off = Term::ANSIColor::color("reset");
6821 my $uptodateness = " ";
6822 if ($class eq "Bundle") {
6823 } elsif ($self->uptodate) {
6824 $uptodateness = "=";
6825 } elsif ($self->inst_version) {
6826 $uptodateness = "<";
6828 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
6834 ($self->distribution ?
6835 $self->distribution->pretty_id :
6842 #-> sub CPAN::Module::dslip_status
6846 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
6847 pre-alpha alpha beta released
6849 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
6850 developer comp.lang.perl.*
6852 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
6853 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
6855 object-oriented pragma
6857 @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
6861 distribution_allowed
6862 restricted_distribution
6864 for my $x (qw(d s l i p)) {
6865 $stat->{$x}{' '} = 'unknown';
6866 $stat->{$x}{'?'} = 'unknown';
6869 return +{} unless $ro && $ro->{statd};
6876 DV => $stat->{D}{$ro->{statd}},
6877 SV => $stat->{S}{$ro->{stats}},
6878 LV => $stat->{L}{$ro->{statl}},
6879 IV => $stat->{I}{$ro->{stati}},
6880 PV => $stat->{P}{$ro->{statp}},
6884 #-> sub CPAN::Module::as_string ;
6888 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
6889 my $class = ref($self);
6890 $class =~ s/^CPAN:://;
6892 push @m, $class, " id = $self->{ID}\n";
6893 my $sprintf = " %-12s %s\n";
6894 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
6895 if $self->description;
6896 my $sprintf2 = " %-12s %s (%s)\n";
6898 $userid = $self->userid;
6901 if ($author = CPAN::Shell->expand('Author',$userid)) {
6904 if ($m = $author->email) {
6911 $author->fullname . $email
6915 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
6916 if $self->cpan_version;
6917 if (my $cpan_file = $self->cpan_file){
6918 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
6919 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
6920 my $upload_date = $dist->upload_date;
6922 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
6926 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
6927 my $dslip = $self->dslip_status;
6931 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
6933 my $local_file = $self->inst_file;
6934 unless ($self->{MANPAGE}) {
6937 $manpage = $self->manpage_headline($local_file);
6939 # If we have already untarred it, we should look there
6940 my $dist = $CPAN::META->instance('CPAN::Distribution',
6942 # warn "dist[$dist]";
6943 # mff=manifest file; mfh=manifest handle
6948 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
6950 $mfh = FileHandle->new($mff)
6952 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
6953 my $lfre = $self->id; # local file RE
6956 my($lfl); # local file file
6958 my(@mflines) = <$mfh>;
6963 while (length($lfre)>5 and !$lfl) {
6964 ($lfl) = grep /$lfre/, @mflines;
6965 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
6968 $lfl =~ s/\s.*//; # remove comments
6969 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
6970 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
6971 # warn "lfl_abs[$lfl_abs]";
6973 $manpage = $self->manpage_headline($lfl_abs);
6977 $self->{MANPAGE} = $manpage if $manpage;
6980 for $item (qw/MANPAGE/) {
6981 push @m, sprintf($sprintf, $item, $self->{$item})
6982 if exists $self->{$item};
6984 for $item (qw/CONTAINS/) {
6985 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
6986 if exists $self->{$item} && @{$self->{$item}};
6988 push @m, sprintf($sprintf, 'INST_FILE',
6989 $local_file || "(not installed)");
6990 push @m, sprintf($sprintf, 'INST_VERSION',
6991 $self->inst_version) if $local_file;
6995 sub manpage_headline {
6996 my($self,$local_file) = @_;
6997 my(@local_file) = $local_file;
6998 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
6999 push @local_file, $local_file;
7001 for $locf (@local_file) {
7002 next unless -f $locf;
7003 my $fh = FileHandle->new($locf)
7004 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
7008 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
7009 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
7026 #-> sub CPAN::Module::cpan_file ;
7027 # Note: also inherited by CPAN::Bundle
7030 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
7031 unless ($self->ro) {
7032 CPAN::Index->reload;
7035 if ($ro && defined $ro->{CPAN_FILE}){
7036 return $ro->{CPAN_FILE};
7038 my $userid = $self->userid;
7040 if ($CPAN::META->exists("CPAN::Author",$userid)) {
7041 my $author = $CPAN::META->instance("CPAN::Author",
7043 my $fullname = $author->fullname;
7044 my $email = $author->email;
7045 unless (defined $fullname && defined $email) {
7046 return sprintf("Contact Author %s",
7050 return "Contact Author $fullname <$email>";
7052 return "Contact Author $userid (Email address not available)";
7060 #-> sub CPAN::Module::cpan_version ;
7066 # Can happen with modules that are not on CPAN
7069 $ro->{CPAN_VERSION} = 'undef'
7070 unless defined $ro->{CPAN_VERSION};
7071 $ro->{CPAN_VERSION};
7074 #-> sub CPAN::Module::force ;
7077 $self->{'force_update'}++;
7082 # warn "XDEBUG: set notest for Module";
7083 $self->{'notest'}++;
7086 #-> sub CPAN::Module::rematein ;
7088 my($self,$meth) = @_;
7089 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
7092 my $cpan_file = $self->cpan_file;
7093 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
7094 $CPAN::Frontend->mywarn(sprintf qq{
7095 The module %s isn\'t available on CPAN.
7097 Either the module has not yet been uploaded to CPAN, or it is
7098 temporary unavailable. Please contact the author to find out
7099 more about the status. Try 'i %s'.
7106 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
7107 $pack->called_for($self->id);
7108 $pack->force($meth) if exists $self->{'force_update'};
7109 $pack->notest($meth) if exists $self->{'notest'};
7111 $pack->{reqtype} ||= "";
7112 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
7113 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
7114 if ($pack->{reqtype}) {
7115 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
7116 $pack->{reqtype} = $self->{reqtype};
7118 exists $pack->{install}
7121 $pack->{install}->can("failed") ?
7122 $pack->{install}->failed :
7123 $pack->{install} =~ /^NO/
7126 delete $pack->{install};
7127 $CPAN::Frontend->mywarn
7128 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
7132 $pack->{reqtype} = $self->{reqtype};
7139 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
7140 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
7141 delete $self->{'force_update'};
7142 delete $self->{'notest'};
7148 #-> sub CPAN::Module::perldoc ;
7149 sub perldoc { shift->rematein('perldoc') }
7150 #-> sub CPAN::Module::readme ;
7151 sub readme { shift->rematein('readme') }
7152 #-> sub CPAN::Module::look ;
7153 sub look { shift->rematein('look') }
7154 #-> sub CPAN::Module::cvs_import ;
7155 sub cvs_import { shift->rematein('cvs_import') }
7156 #-> sub CPAN::Module::get ;
7157 sub get { shift->rematein('get',@_) }
7158 #-> sub CPAN::Module::make ;
7159 sub make { shift->rematein('make') }
7160 #-> sub CPAN::Module::test ;
7163 $self->{badtestcnt} ||= 0;
7164 $self->rematein('test',@_);
7166 #-> sub CPAN::Module::uptodate ;
7169 local($_); # protect against a bug in MakeMaker 6.17
7170 my($latest) = $self->cpan_version;
7172 my($inst_file) = $self->inst_file;
7174 if (defined $inst_file) {
7175 $have = $self->inst_version;
7180 ! CPAN::Version->vgt($latest, $have)
7182 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
7183 "latest[$latest] have[$have]") if $CPAN::DEBUG;
7188 #-> sub CPAN::Module::install ;
7194 not exists $self->{'force_update'}
7196 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
7198 $self->inst_version,
7204 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
7205 $CPAN::Frontend->mywarn(qq{
7206 \n\n\n ***WARNING***
7207 The module $self->{ID} has no active maintainer.\n\n\n
7209 $CPAN::Frontend->mysleep(5);
7211 $self->rematein('install') if $doit;
7213 #-> sub CPAN::Module::clean ;
7214 sub clean { shift->rematein('clean') }
7216 #-> sub CPAN::Module::inst_file ;
7220 @packpath = split /::/, $self->{ID};
7221 $packpath[-1] .= ".pm";
7222 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
7223 unshift @packpath, "Term", "ReadLine"; # historical reasons
7225 foreach $dir (@INC) {
7226 my $pmfile = File::Spec->catfile($dir,@packpath);
7234 #-> sub CPAN::Module::xs_file ;
7238 @packpath = split /::/, $self->{ID};
7239 push @packpath, $packpath[-1];
7240 $packpath[-1] .= "." . $Config::Config{'dlext'};
7241 foreach $dir (@INC) {
7242 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
7250 #-> sub CPAN::Module::inst_version ;
7253 my $parsefile = $self->inst_file or return;
7254 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
7257 $have = MM->parse_version($parsefile) || "undef";
7258 $have =~ s/^ //; # since the %vd hack these two lines here are needed
7259 $have =~ s/ $//; # trailing whitespace happens all the time
7261 # My thoughts about why %vd processing should happen here
7263 # Alt1 maintain it as string with leading v:
7264 # read index files do nothing
7265 # compare it use utility for compare
7266 # print it do nothing
7268 # Alt2 maintain it as what it is
7269 # read index files convert
7270 # compare it use utility because there's still a ">" vs "gt" issue
7271 # print it use CPAN::Version for print
7273 # Seems cleaner to hold it in memory as a string starting with a "v"
7275 # If the author of this module made a mistake and wrote a quoted
7276 # "v1.13" instead of v1.13, we simply leave it at that with the
7277 # effect that *we* will treat it like a v-tring while the rest of
7278 # perl won't. Seems sensible when we consider that any action we
7279 # could take now would just add complexity.
7281 $have = CPAN::Version->readable($have);
7283 $have =~ s/\s*//g; # stringify to float around floating point issues
7284 $have; # no stringify needed, \s* above matches always
7297 CPAN - query, download and build perl modules from CPAN sites
7303 perl -MCPAN -e shell;
7311 $mod = "Acme::Meta";
7313 CPAN::Shell->install($mod); # same thing
7314 CPAN::Shell->expandany($mod)->install; # same thing
7315 CPAN::Shell->expand("Module",$mod)->install; # same thing
7316 CPAN::Shell->expand("Module",$mod)
7317 ->distribution->install; # same thing
7321 $distro = "NWCLARK/Acme-Meta-0.01.tar.gz";
7322 install $distro; # same thing
7323 CPAN::Shell->install($distro); # same thing
7324 CPAN::Shell->expandany($distro)->install; # same thing
7325 CPAN::Shell->expand("Distribution",$distro)->install; # same thing
7329 This module and its competitor, the CPANPLUS module, are both much
7330 cooler than the other.
7332 =head1 COMPATIBILITY
7334 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
7335 newer versions. It is getting more and more difficult to get the
7336 minimal prerequisites working on older perls. It is close to
7337 impossible to get the whole Bundle::CPAN working there. If you're in
7338 the position to have only these old versions, be advised that CPAN is
7339 designed to work fine without the Bundle::CPAN installed.
7341 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
7342 compatible with ancient perls and that File::Temp is listed as a
7343 prerequisite but CPAN has reasonable workarounds if it is missing.
7347 The CPAN module is designed to automate the make and install of perl
7348 modules and extensions. It includes some primitive searching
7349 capabilities and knows how to use Net::FTP or LWP (or some external
7350 download clients) to fetch the raw data from the net.
7352 Modules are fetched from one or more of the mirrored CPAN
7353 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
7356 The CPAN module also supports the concept of named and versioned
7357 I<bundles> of modules. Bundles simplify the handling of sets of
7358 related modules. See Bundles below.
7360 The package contains a session manager and a cache manager. There is
7361 no status retained between sessions. The session manager keeps track
7362 of what has been fetched, built and installed in the current
7363 session. The cache manager keeps track of the disk space occupied by
7364 the make processes and deletes excess space according to a simple FIFO
7367 All methods provided are accessible in a programmer style and in an
7368 interactive shell style.
7370 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
7372 The interactive mode is entered by running
7374 perl -MCPAN -e shell
7376 which puts you into a readline interface. You will have the most fun if
7377 you install Term::ReadKey and Term::ReadLine to enjoy both history and
7380 Once you are on the command line, type 'h' and the rest should be
7383 The function call C<shell> takes two optional arguments, one is the
7384 prompt, the second is the default initial command line (the latter
7385 only works if a real ReadLine interface module is installed).
7387 The most common uses of the interactive modes are
7391 =item Searching for authors, bundles, distribution files and modules
7393 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
7394 for each of the four categories and another, C<i> for any of the
7395 mentioned four. Each of the four entities is implemented as a class
7396 with slightly differing methods for displaying an object.
7398 Arguments you pass to these commands are either strings exactly matching
7399 the identification string of an object or regular expressions that are
7400 then matched case-insensitively against various attributes of the
7401 objects. The parser recognizes a regular expression only if you
7402 enclose it between two slashes.
7404 The principle is that the number of found objects influences how an
7405 item is displayed. If the search finds one item, the result is
7406 displayed with the rather verbose method C<as_string>, but if we find
7407 more than one, we display each object with the terse method
7410 =item make, test, install, clean modules or distributions
7412 These commands take any number of arguments and investigate what is
7413 necessary to perform the action. If the argument is a distribution
7414 file name (recognized by embedded slashes), it is processed. If it is
7415 a module, CPAN determines the distribution file in which this module
7416 is included and processes that, following any dependencies named in
7417 the module's META.yml or Makefile.PL (this behavior is controlled by
7418 the configuration parameter C<prerequisites_policy>.)
7420 Any C<make> or C<test> are run unconditionally. An
7422 install <distribution_file>
7424 also is run unconditionally. But for
7428 CPAN checks if an install is actually needed for it and prints
7429 I<module up to date> in the case that the distribution file containing
7430 the module doesn't need to be updated.
7432 CPAN also keeps track of what it has done within the current session
7433 and doesn't try to build a package a second time regardless if it
7434 succeeded or not. The C<force> pragma may precede another command
7435 (currently: C<make>, C<test>, or C<install>) and executes the
7436 command from scratch and tries to continue in case of some errors.
7440 cpan> install OpenGL
7441 OpenGL is up to date.
7442 cpan> force install OpenGL
7445 OpenGL-0.4/COPYRIGHT
7448 The C<notest> pragma may be set to skip the test part in the build
7453 cpan> notest install Tk
7455 A C<clean> command results in a
7459 being executed within the distribution file's working directory.
7461 =item get, readme, perldoc, look module or distribution
7463 C<get> downloads a distribution file without further action. C<readme>
7464 displays the README file of the associated distribution. C<Look> gets
7465 and untars (if not yet done) the distribution file, changes to the
7466 appropriate directory and opens a subshell process in that directory.
7467 C<perldoc> displays the pod documentation of the module in html or
7472 =item ls globbing_expression
7474 The first form lists all distribution files in and below an author's
7475 CPAN directory as they are stored in the CHECKUMS files distributed on
7476 CPAN. The listing goes recursive into all subdirectories.
7478 The second form allows to limit or expand the output with shell
7479 globbing as in the following examples:
7485 The last example is very slow and outputs extra progress indicators
7486 that break the alignment of the result.
7488 Note that globbing only lists directories explicitly asked for, for
7489 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
7490 regarded as a bug and may be changed in future versions.
7494 The C<failed> command reports all distributions that failed on one of
7495 C<make>, C<test> or C<install> for some reason in the currently
7496 running shell session.
7500 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>
7501 (but the directory can be configured via the C<cpan_home> config
7502 variable). The shell is a bit picky if you try to start another CPAN
7503 session. It dies immediately if there is a lockfile and the lock seems
7504 to belong to a running process. In case you want to run a second shell
7505 session, it is probably safest to maintain another directory, say
7506 C<~/.cpan-for-X/> and a C<~/.cpan-for-X/CPAN/MyConfig.pm> that
7507 contains the configuration options. Then you can start the second
7510 perl -I ~/.cpan-for-X -MCPAN::MyConfig -MCPAN -e shell
7514 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
7515 in the cpan-shell it is intended that you can press C<^C> anytime and
7516 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
7517 to clean up and leave the shell loop. You can emulate the effect of a
7518 SIGTERM by sending two consecutive SIGINTs, which usually means by
7519 pressing C<^C> twice.
7521 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
7522 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
7523 Build.PL> subprocess.
7529 The commands that are available in the shell interface are methods in
7530 the package CPAN::Shell. If you enter the shell command, all your
7531 input is split by the Text::ParseWords::shellwords() routine which
7532 acts like most shells do. The first word is being interpreted as the
7533 method to be called and the rest of the words are treated as arguments
7534 to this method. Continuation lines are supported if a line ends with a
7539 C<autobundle> writes a bundle file into the
7540 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
7541 a list of all modules that are both available from CPAN and currently
7542 installed within @INC. The name of the bundle file is based on the
7543 current date and a counter.
7547 recompile() is a very special command in that it takes no argument and
7548 runs the make/test/install cycle with brute force over all installed
7549 dynamically loadable extensions (aka XS modules) with 'force' in
7550 effect. The primary purpose of this command is to finish a network
7551 installation. Imagine, you have a common source tree for two different
7552 architectures. You decide to do a completely independent fresh
7553 installation. You start on one architecture with the help of a Bundle
7554 file produced earlier. CPAN installs the whole Bundle for you, but
7555 when you try to repeat the job on the second architecture, CPAN
7556 responds with a C<"Foo up to date"> message for all modules. So you
7557 invoke CPAN's recompile on the second architecture and you're done.
7559 Another popular use for C<recompile> is to act as a rescue in case your
7560 perl breaks binary compatibility. If one of the modules that CPAN uses
7561 is in turn depending on binary compatibility (so you cannot run CPAN
7562 commands), then you should try the CPAN::Nox module for recovery.
7564 =head2 upgrade [Module|/Regex/]...
7566 The C<upgrade> command first runs an C<r> command with the given
7567 arguments and then installs the newest versions of all modules that
7568 were listed by that.
7572 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
7573 directory so that you can save your own preferences instead of the
7576 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
7578 Although it may be considered internal, the class hierarchy does matter
7579 for both users and programmer. CPAN.pm deals with above mentioned four
7580 classes, and all those classes share a set of methods. A classical
7581 single polymorphism is in effect. A metaclass object registers all
7582 objects of all kinds and indexes them with a string. The strings
7583 referencing objects have a separated namespace (well, not completely
7588 words containing a "/" (slash) Distribution
7589 words starting with Bundle:: Bundle
7590 everything else Module or Author
7592 Modules know their associated Distribution objects. They always refer
7593 to the most recent official release. Developers may mark their releases
7594 as unstable development versions (by inserting an underbar into the
7595 module version number which will also be reflected in the distribution
7596 name when you run 'make dist'), so the really hottest and newest
7597 distribution is not always the default. If a module Foo circulates
7598 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
7599 way to install version 1.23 by saying
7603 This would install the complete distribution file (say
7604 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
7605 like to install version 1.23_90, you need to know where the
7606 distribution file resides on CPAN relative to the authors/id/
7607 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
7608 so you would have to say
7610 install BAR/Foo-1.23_90.tar.gz
7612 The first example will be driven by an object of the class
7613 CPAN::Module, the second by an object of class CPAN::Distribution.
7615 =head1 PROGRAMMER'S INTERFACE
7617 If you do not enter the shell, the available shell commands are both
7618 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
7619 functions in the calling package (C<install(...)>).
7621 There's currently only one class that has a stable interface -
7622 CPAN::Shell. All commands that are available in the CPAN shell are
7623 methods of the class CPAN::Shell. Each of the commands that produce
7624 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
7625 the IDs of all modules within the list.
7629 =item expand($type,@things)
7631 The IDs of all objects available within a program are strings that can
7632 be expanded to the corresponding real objects with the
7633 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
7634 list of CPAN::Module objects according to the C<@things> arguments
7635 given. In scalar context it only returns the first element of the
7638 =item expandany(@things)
7640 Like expand, but returns objects of the appropriate type, i.e.
7641 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
7642 CPAN::Distribution objects for distributions. Note: it does not expand
7643 to CPAN::Author objects.
7645 =item Programming Examples
7647 This enables the programmer to do operations that combine
7648 functionalities that are available in the shell.
7650 # install everything that is outdated on my disk:
7651 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
7653 # install my favorite programs if necessary:
7654 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
7655 my $obj = CPAN::Shell->expand('Module',$mod);
7659 # list all modules on my disk that have no VERSION number
7660 for $mod (CPAN::Shell->expand("Module","/./")){
7661 next unless $mod->inst_file;
7662 # MakeMaker convention for undefined $VERSION:
7663 next unless $mod->inst_version eq "undef";
7664 print "No VERSION in ", $mod->id, "\n";
7667 # find out which distribution on CPAN contains a module:
7668 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
7670 Or if you want to write a cronjob to watch The CPAN, you could list
7671 all modules that need updating. First a quick and dirty way:
7673 perl -e 'use CPAN; CPAN::Shell->r;'
7675 If you don't want to get any output in the case that all modules are
7676 up to date, you can parse the output of above command for the regular
7677 expression //modules are up to date// and decide to mail the output
7678 only if it doesn't match. Ick?
7680 If you prefer to do it more in a programmer style in one single
7681 process, maybe something like this suits you better:
7683 # list all modules on my disk that have newer versions on CPAN
7684 for $mod (CPAN::Shell->expand("Module","/./")){
7685 next unless $mod->inst_file;
7686 next if $mod->uptodate;
7687 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
7688 $mod->id, $mod->inst_version, $mod->cpan_version;
7691 If that gives you too much output every day, you maybe only want to
7692 watch for three modules. You can write
7694 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
7696 as the first line instead. Or you can combine some of the above
7699 # watch only for a new mod_perl module
7700 $mod = CPAN::Shell->expand("Module","mod_perl");
7701 exit if $mod->uptodate;
7702 # new mod_perl arrived, let me know all update recommendations
7707 =head2 Methods in the other Classes
7709 The programming interface for the classes CPAN::Module,
7710 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
7711 beta and partially even alpha. In the following paragraphs only those
7712 methods are documented that have proven useful over a longer time and
7713 thus are unlikely to change.
7717 =item CPAN::Author::as_glimpse()
7719 Returns a one-line description of the author
7721 =item CPAN::Author::as_string()
7723 Returns a multi-line description of the author
7725 =item CPAN::Author::email()
7727 Returns the author's email address
7729 =item CPAN::Author::fullname()
7731 Returns the author's name
7733 =item CPAN::Author::name()
7735 An alias for fullname
7737 =item CPAN::Bundle::as_glimpse()
7739 Returns a one-line description of the bundle
7741 =item CPAN::Bundle::as_string()
7743 Returns a multi-line description of the bundle
7745 =item CPAN::Bundle::clean()
7747 Recursively runs the C<clean> method on all items contained in the bundle.
7749 =item CPAN::Bundle::contains()
7751 Returns a list of objects' IDs contained in a bundle. The associated
7752 objects may be bundles, modules or distributions.
7754 =item CPAN::Bundle::force($method,@args)
7756 Forces CPAN to perform a task that normally would have failed. Force
7757 takes as arguments a method name to be called and any number of
7758 additional arguments that should be passed to the called method. The
7759 internals of the object get the needed changes so that CPAN.pm does
7760 not refuse to take the action. The C<force> is passed recursively to
7761 all contained objects.
7763 =item CPAN::Bundle::get()
7765 Recursively runs the C<get> method on all items contained in the bundle
7767 =item CPAN::Bundle::inst_file()
7769 Returns the highest installed version of the bundle in either @INC or
7770 C<$CPAN::Config->{cpan_home}>. Note that this is different from
7771 CPAN::Module::inst_file.
7773 =item CPAN::Bundle::inst_version()
7775 Like CPAN::Bundle::inst_file, but returns the $VERSION
7777 =item CPAN::Bundle::uptodate()
7779 Returns 1 if the bundle itself and all its members are uptodate.
7781 =item CPAN::Bundle::install()
7783 Recursively runs the C<install> method on all items contained in the bundle
7785 =item CPAN::Bundle::make()
7787 Recursively runs the C<make> method on all items contained in the bundle
7789 =item CPAN::Bundle::readme()
7791 Recursively runs the C<readme> method on all items contained in the bundle
7793 =item CPAN::Bundle::test()
7795 Recursively runs the C<test> method on all items contained in the bundle
7797 =item CPAN::Distribution::as_glimpse()
7799 Returns a one-line description of the distribution
7801 =item CPAN::Distribution::as_string()
7803 Returns a multi-line description of the distribution
7805 =item CPAN::Distribution::author
7807 Returns the CPAN::Author object of the maintainer who uploaded this
7810 =item CPAN::Distribution::clean()
7812 Changes to the directory where the distribution has been unpacked and
7813 runs C<make clean> there.
7815 =item CPAN::Distribution::containsmods()
7817 Returns a list of IDs of modules contained in a distribution file.
7818 Only works for distributions listed in the 02packages.details.txt.gz
7819 file. This typically means that only the most recent version of a
7820 distribution is covered.
7822 =item CPAN::Distribution::cvs_import()
7824 Changes to the directory where the distribution has been unpacked and
7827 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
7831 =item CPAN::Distribution::dir()
7833 Returns the directory into which this distribution has been unpacked.
7835 =item CPAN::Distribution::force($method,@args)
7837 Forces CPAN to perform a task that normally would have failed. Force
7838 takes as arguments a method name to be called and any number of
7839 additional arguments that should be passed to the called method. The
7840 internals of the object get the needed changes so that CPAN.pm does
7841 not refuse to take the action.
7843 =item CPAN::Distribution::get()
7845 Downloads the distribution from CPAN and unpacks it. Does nothing if
7846 the distribution has already been downloaded and unpacked within the
7849 =item CPAN::Distribution::install()
7851 Changes to the directory where the distribution has been unpacked and
7852 runs the external command C<make install> there. If C<make> has not
7853 yet been run, it will be run first. A C<make test> will be issued in
7854 any case and if this fails, the install will be canceled. The
7855 cancellation can be avoided by letting C<force> run the C<install> for
7858 Note that install() gives no meaningful return value. See uptodate().
7860 =item CPAN::Distribution::isa_perl()
7862 Returns 1 if this distribution file seems to be a perl distribution.
7863 Normally this is derived from the file name only, but the index from
7864 CPAN can contain a hint to achieve a return value of true for other
7867 =item CPAN::Distribution::look()
7869 Changes to the directory where the distribution has been unpacked and
7870 opens a subshell there. Exiting the subshell returns.
7872 =item CPAN::Distribution::make()
7874 First runs the C<get> method to make sure the distribution is
7875 downloaded and unpacked. Changes to the directory where the
7876 distribution has been unpacked and runs the external commands C<perl
7877 Makefile.PL> or C<perl Build.PL> and C<make> there.
7879 =item CPAN::Distribution::perldoc()
7881 Downloads the pod documentation of the file associated with a
7882 distribution (in html format) and runs it through the external
7883 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
7884 isn't available, it converts it to plain text with external
7885 command html2text and runs it through the pager specified
7886 in C<$CPAN::Config->{pager}>
7888 =item CPAN::Distribution::prereq_pm()
7890 Returns the hash reference that has been announced by a distribution
7891 as the merge of the C<requires> element and the C<build_requires>
7892 element of the META.yml or the C<PREREQ_PM> hash in the
7893 C<Makefile.PL>. Note: works only after an attempt has been made to
7894 C<make> the distribution. Returns undef otherwise.
7896 =item CPAN::Distribution::readme()
7898 Downloads the README file associated with a distribution and runs it
7899 through the pager specified in C<$CPAN::Config->{pager}>.
7901 =item CPAN::Distribution::read_yaml()
7903 Returns the content of the META.yml of this distro as a hashref. Note:
7904 works only after an attempt has been made to C<make> the distribution.
7905 Returns undef otherwise.
7907 =item CPAN::Distribution::test()
7909 Changes to the directory where the distribution has been unpacked and
7910 runs C<make test> there.
7912 =item CPAN::Distribution::uptodate()
7914 Returns 1 if all the modules contained in the distribution are
7915 uptodate. Relies on containsmods.
7917 =item CPAN::Index::force_reload()
7919 Forces a reload of all indices.
7921 =item CPAN::Index::reload()
7923 Reloads all indices if they have not been read for more than
7924 C<$CPAN::Config->{index_expire}> days.
7926 =item CPAN::InfoObj::dump()
7928 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
7929 inherit this method. It prints the data structure associated with an
7930 object. Useful for debugging. Note: the data structure is considered
7931 internal and thus subject to change without notice.
7933 =item CPAN::Module::as_glimpse()
7935 Returns a one-line description of the module in four columns: The
7936 first column contains the word C<Module>, the second column consists
7937 of one character: an equals sign if this module is already installed
7938 and uptodate, a less-than sign if this module is installed but can be
7939 upgraded, and a space if the module is not installed. The third column
7940 is the name of the module and the fourth column gives maintainer or
7941 distribution information.
7943 =item CPAN::Module::as_string()
7945 Returns a multi-line description of the module
7947 =item CPAN::Module::clean()
7949 Runs a clean on the distribution associated with this module.
7951 =item CPAN::Module::cpan_file()
7953 Returns the filename on CPAN that is associated with the module.
7955 =item CPAN::Module::cpan_version()
7957 Returns the latest version of this module available on CPAN.
7959 =item CPAN::Module::cvs_import()
7961 Runs a cvs_import on the distribution associated with this module.
7963 =item CPAN::Module::description()
7965 Returns a 44 character description of this module. Only available for
7966 modules listed in The Module List (CPAN/modules/00modlist.long.html
7967 or 00modlist.long.txt.gz)
7969 =item CPAN::Module::distribution()
7971 Returns the CPAN::Distribution object that contains the current
7972 version of this module.
7974 =item CPAN::Module::dslip_status()
7976 Returns a hash reference. The keys of the hash are the letters C<D>,
7977 C<S>, C<L>, C<I>, and <P>, for development status, support level,
7978 language, interface and public licence respectively. The data for the
7979 DSLIP status are collected by pause.perl.org when authors register
7980 their namespaces. The values of the 5 hash elements are one-character
7981 words whose meaning is described in the table below. There are also 5
7982 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
7983 verbose value of the 5 status variables.
7985 Where the 'DSLIP' characters have the following meanings:
7987 D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
7988 i - Idea, listed to gain consensus or as a placeholder
7989 c - under construction but pre-alpha (not yet released)
7990 a/b - Alpha/Beta testing
7992 M - Mature (no rigorous definition)
7993 S - Standard, supplied with Perl 5
7998 u - Usenet newsgroup comp.lang.perl.modules
7999 n - None known, try comp.lang.perl.modules
8000 a - abandoned; volunteers welcome to take over maintainance
8003 p - Perl-only, no compiler needed, should be platform independent
8004 c - C and perl, a C compiler will be needed
8005 h - Hybrid, written in perl with optional C code, no compiler needed
8006 + - C++ and perl, a C++ compiler will be needed
8007 o - perl and another language other than C or C++
8010 f - plain Functions, no references used
8011 h - hybrid, object and function interfaces available
8012 n - no interface at all (huh?)
8013 r - some use of unblessed References or ties
8014 O - Object oriented using blessed references and/or inheritance
8017 p - Standard-Perl: user may choose between GPL and Artistic
8018 g - GPL: GNU General Public License
8019 l - LGPL: "GNU Lesser General Public License" (previously known as
8020 "GNU Library General Public License")
8021 b - BSD: The BSD License
8022 a - Artistic license alone
8023 o - open source: appoved by www.opensource.org
8024 d - allows distribution without restrictions
8025 r - restricted distribtion
8026 n - no license at all
8028 =item CPAN::Module::force($method,@args)
8030 Forces CPAN to perform a task that normally would have failed. Force
8031 takes as arguments a method name to be called and any number of
8032 additional arguments that should be passed to the called method. The
8033 internals of the object get the needed changes so that CPAN.pm does
8034 not refuse to take the action.
8036 =item CPAN::Module::get()
8038 Runs a get on the distribution associated with this module.
8040 =item CPAN::Module::inst_file()
8042 Returns the filename of the module found in @INC. The first file found
8043 is reported just like perl itself stops searching @INC when it finds a
8046 =item CPAN::Module::inst_version()
8048 Returns the version number of the module in readable format.
8050 =item CPAN::Module::install()
8052 Runs an C<install> on the distribution associated with this module.
8054 =item CPAN::Module::look()
8056 Changes to the directory where the distribution associated with this
8057 module has been unpacked and opens a subshell there. Exiting the
8060 =item CPAN::Module::make()
8062 Runs a C<make> on the distribution associated with this module.
8064 =item CPAN::Module::manpage_headline()
8066 If module is installed, peeks into the module's manpage, reads the
8067 headline and returns it. Moreover, if the module has been downloaded
8068 within this session, does the equivalent on the downloaded module even
8069 if it is not installed.
8071 =item CPAN::Module::perldoc()
8073 Runs a C<perldoc> on this module.
8075 =item CPAN::Module::readme()
8077 Runs a C<readme> on the distribution associated with this module.
8079 =item CPAN::Module::test()
8081 Runs a C<test> on the distribution associated with this module.
8083 =item CPAN::Module::uptodate()
8085 Returns 1 if the module is installed and up-to-date.
8087 =item CPAN::Module::userid()
8089 Returns the author's ID of the module.
8093 =head2 Cache Manager
8095 Currently the cache manager only keeps track of the build directory
8096 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
8097 deletes complete directories below C<build_dir> as soon as the size of
8098 all directories there gets bigger than $CPAN::Config->{build_cache}
8099 (in MB). The contents of this cache may be used for later
8100 re-installations that you intend to do manually, but will never be
8101 trusted by CPAN itself. This is due to the fact that the user might
8102 use these directories for building modules on different architectures.
8104 There is another directory ($CPAN::Config->{keep_source_where}) where
8105 the original distribution files are kept. This directory is not
8106 covered by the cache manager and must be controlled by the user. If
8107 you choose to have the same directory as build_dir and as
8108 keep_source_where directory, then your sources will be deleted with
8109 the same fifo mechanism.
8113 A bundle is just a perl module in the namespace Bundle:: that does not
8114 define any functions or methods. It usually only contains documentation.
8116 It starts like a perl module with a package declaration and a $VERSION
8117 variable. After that the pod section looks like any other pod with the
8118 only difference being that I<one special pod section> exists starting with
8123 In this pod section each line obeys the format
8125 Module_Name [Version_String] [- optional text]
8127 The only required part is the first field, the name of a module
8128 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
8129 of the line is optional. The comment part is delimited by a dash just
8130 as in the man page header.
8132 The distribution of a bundle should follow the same convention as
8133 other distributions.
8135 Bundles are treated specially in the CPAN package. If you say 'install
8136 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
8137 the modules in the CONTENTS section of the pod. You can install your
8138 own Bundles locally by placing a conformant Bundle file somewhere into
8139 your @INC path. The autobundle() command which is available in the
8140 shell interface does that for you by including all currently installed
8141 modules in a snapshot bundle file.
8143 =head1 PREREQUISITES
8145 If you have a local mirror of CPAN and can access all files with
8146 "file:" URLs, then you only need a perl better than perl5.003 to run
8147 this module. Otherwise Net::FTP is strongly recommended. LWP may be
8148 required for non-UNIX systems or if your nearest CPAN site is
8149 associated with a URL that is not C<ftp:>.
8151 If you have neither Net::FTP nor LWP, there is a fallback mechanism
8152 implemented for an external ftp command or for an external lynx
8157 =head2 Finding packages and VERSION
8159 This module presumes that all packages on CPAN
8165 declare their $VERSION variable in an easy to parse manner. This
8166 prerequisite can hardly be relaxed because it consumes far too much
8167 memory to load all packages into the running program just to determine
8168 the $VERSION variable. Currently all programs that are dealing with
8169 version use something like this
8171 perl -MExtUtils::MakeMaker -le \
8172 'print MM->parse_version(shift)' filename
8174 If you are author of a package and wonder if your $VERSION can be
8175 parsed, please try the above method.
8179 come as compressed or gzipped tarfiles or as zip files and contain a
8180 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
8181 without much enthusiasm).
8187 The debugging of this module is a bit complex, because we have
8188 interferences of the software producing the indices on CPAN, of the
8189 mirroring process on CPAN, of packaging, of configuration, of
8190 synchronicity, and of bugs within CPAN.pm.
8192 For debugging the code of CPAN.pm itself in interactive mode some more
8193 or less useful debugging aid can be turned on for most packages within
8198 =item o debug package...
8200 sets debug mode for packages.
8202 =item o debug -package...
8204 unsets debug mode for packages.
8208 turns debugging on for all packages.
8210 =item o debug number
8214 which sets the debugging packages directly. Note that C<o debug 0>
8215 turns debugging off.
8217 What seems quite a successful strategy is the combination of C<reload
8218 cpan> and the debugging switches. Add a new debug statement while
8219 running in the shell and then issue a C<reload cpan> and see the new
8220 debugging messages immediately without losing the current context.
8222 C<o debug> without an argument lists the valid package names and the
8223 current set of packages in debugging mode. C<o debug> has built-in
8226 For debugging of CPAN data there is the C<dump> command which takes
8227 the same arguments as make/test/install and outputs each object's
8228 Data::Dumper dump. If an argument looks like a perl variable and
8229 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
8230 Data::Dumper directly.
8232 =head2 Floppy, Zip, Offline Mode
8234 CPAN.pm works nicely without network too. If you maintain machines
8235 that are not networked at all, you should consider working with file:
8236 URLs. Of course, you have to collect your modules somewhere first. So
8237 you might use CPAN.pm to put together all you need on a networked
8238 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
8239 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
8240 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
8241 with this floppy. See also below the paragraph about CD-ROM support.
8243 =head2 Basic Utilities for Programmers
8247 =item has_inst($module)
8249 Returns true if the module is installed. See the source for details.
8251 =item has_usable($module)
8253 Returns true if the module is installed and several and is in a usable
8254 state. Only useful for a handful of modules that are used internally.
8255 See the source for details.
8257 =item instance($module)
8259 The constructor for all the singletons used to represent modules,
8260 distributions, authors and bundles. If the object already exists, this
8261 method returns the object, otherwise it calls the constructor.
8265 =head1 CONFIGURATION
8267 When the CPAN module is used for the first time, a configuration
8268 dialog tries to determine a couple of site specific options. The
8269 result of the dialog is stored in a hash reference C< $CPAN::Config >
8270 in a file CPAN/Config.pm.
8272 The default values defined in the CPAN/Config.pm file can be
8273 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
8274 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
8275 added to the search path of the CPAN module before the use() or
8276 require() statements.
8278 The configuration dialog can be started any time later again by
8279 issuing the command C< o conf init > in the CPAN shell. A subset of
8280 the configuration dialog can be run by issuing C<o conf init WORD>
8281 where WORD is any valid config variable or a regular expression.
8283 Currently the following keys in the hash reference $CPAN::Config are
8286 build_cache size of cache for directories to build modules
8287 build_dir locally accessible directory to build modules
8288 build_requires_install_policy
8289 to install or not to install: when a module is
8290 only needed for building. yes|no|ask/yes|ask/no
8291 bzip2 path to external prg
8292 cache_metadata use serializer to cache metadata
8293 commands_quote prefered character to use for quoting external
8294 commands when running them. Defaults to double
8295 quote on Windows, single tick everywhere else;
8296 can be set to space to disable quoting
8297 check_sigs if signatures should be verified
8298 colorize_output boolean if Term::ANSIColor should colorize output
8299 colorize_print Term::ANSIColor attributes for normal output
8300 colorize_warn Term::ANSIColor attributes for warnings
8301 commandnumber_in_prompt
8302 boolean if you want to see current command number
8303 cpan_home local directory reserved for this package
8304 curl path to external prg
8305 dontload_hash DEPRECATED
8306 dontload_list arrayref: modules in the list will not be
8307 loaded by the CPAN::has_inst() routine
8308 ftp path to external prg
8309 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
8310 ftp_proxy proxy host for ftp requests
8312 gpg path to external prg
8313 gzip location of external program gzip
8314 histfile file to maintain history between sessions
8315 histsize maximum number of lines to keep in histfile
8316 http_proxy proxy host for http requests
8317 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
8318 after this many seconds inactivity. Set to 0 to
8320 index_expire after this many days refetch index files
8321 inhibit_startup_message
8322 if true, does not print the startup message
8323 keep_source_where directory in which to keep the source (if we do)
8324 lynx path to external prg
8325 make location of external make program
8326 make_arg arguments that should always be passed to 'make'
8327 make_install_make_command
8328 the make command for running 'make install', for
8330 make_install_arg same as make_arg for 'make install'
8331 makepl_arg arguments passed to 'perl Makefile.PL'
8332 mbuild_arg arguments passed to './Build'
8333 mbuild_install_arg arguments passed to './Build install'
8334 mbuild_install_build_command
8335 command to use instead of './Build' when we are
8336 in the install stage, for example 'sudo ./Build'
8337 mbuildpl_arg arguments passed to 'perl Build.PL'
8338 ncftp path to external prg
8339 ncftpget path to external prg
8340 no_proxy don't proxy to these hosts/domains (comma separated list)
8341 pager location of external program more (or any pager)
8342 password your password if you CPAN server wants one
8343 prefer_installer legal values are MB and EUMM: if a module comes
8344 with both a Makefile.PL and a Build.PL, use the
8345 former (EUMM) or the latter (MB); if the module
8346 comes with only one of the two, that one will be
8348 prerequisites_policy
8349 what to do if you are missing module prerequisites
8350 ('follow' automatically, 'ask' me, or 'ignore')
8351 proxy_user username for accessing an authenticating proxy
8352 proxy_pass password for accessing an authenticating proxy
8353 scan_cache controls scanning of cache ('atstart' or 'never')
8354 shell your favorite shell
8355 show_upload_date boolean if commands should try to determine upload date
8356 tar location of external program tar
8357 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
8358 (and nonsense for characters outside latin range)
8359 term_ornaments boolean to turn ReadLine ornamenting on/off
8360 test_report email test reports (if CPAN::Reporter is installed)
8361 unzip location of external program unzip
8362 urllist arrayref to nearby CPAN sites (or equivalent locations)
8363 username your username if you CPAN server wants one
8364 wait_list arrayref to a wait server to try (See CPAN::WAIT)
8365 wget path to external prg
8367 You can set and query each of these options interactively in the cpan
8368 shell with the command set defined within the C<o conf> command:
8372 =item C<o conf E<lt>scalar optionE<gt>>
8374 prints the current value of the I<scalar option>
8376 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
8378 Sets the value of the I<scalar option> to I<value>
8380 =item C<o conf E<lt>list optionE<gt>>
8382 prints the current value of the I<list option> in MakeMaker's
8385 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
8387 shifts or pops the array in the I<list option> variable
8389 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
8391 works like the corresponding perl commands.
8395 =head2 CPAN::anycwd($path): Note on config variable getcwd
8397 CPAN.pm changes the current working directory often and needs to
8398 determine its own current working directory. Per default it uses
8399 Cwd::cwd but if this doesn't work on your system for some reason,
8400 alternatives can be configured according to the following table:
8418 Calls the external command cwd.
8422 =head2 Note on urllist parameter's format
8424 urllist parameters are URLs according to RFC 1738. We do a little
8425 guessing if your URL is not compliant, but if you have problems with
8426 file URLs, please try the correct format. Either:
8428 file://localhost/whatever/ftp/pub/CPAN/
8432 file:///home/ftp/pub/CPAN/
8434 =head2 urllist parameter has CD-ROM support
8436 The C<urllist> parameter of the configuration table contains a list of
8437 URLs that are to be used for downloading. If the list contains any
8438 C<file> URLs, CPAN always tries to get files from there first. This
8439 feature is disabled for index files. So the recommendation for the
8440 owner of a CD-ROM with CPAN contents is: include your local, possibly
8441 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
8443 o conf urllist push file://localhost/CDROM/CPAN
8445 CPAN.pm will then fetch the index files from one of the CPAN sites
8446 that come at the beginning of urllist. It will later check for each
8447 module if there is a local copy of the most recent version.
8449 Another peculiarity of urllist is that the site that we could
8450 successfully fetch the last file from automatically gets a preference
8451 token and is tried as the first site for the next request. So if you
8452 add a new site at runtime it may happen that the previously preferred
8453 site will be tried another time. This means that if you want to disallow
8454 a site for the next transfer, it must be explicitly removed from
8459 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
8460 install foreign, unmasked, unsigned code on your machine. We compare
8461 to a checksum that comes from the net just as the distribution file
8462 itself. But we try to make it easy to add security on demand:
8464 =head2 Cryptographically signed modules
8466 Since release 1.77 CPAN.pm has been able to verify cryptographically
8467 signed module distributions using Module::Signature. The CPAN modules
8468 can be signed by their authors, thus giving more security. The simple
8469 unsigned MD5 checksums that were used before by CPAN protect mainly
8470 against accidental file corruption.
8472 You will need to have Module::Signature installed, which in turn
8473 requires that you have at least one of Crypt::OpenPGP module or the
8474 command-line F<gpg> tool installed.
8476 You will also need to be able to connect over the Internet to the public
8477 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
8479 The configuration parameter check_sigs is there to turn signature
8484 Most functions in package CPAN are exported per default. The reason
8485 for this is that the primary use is intended for the cpan shell or for
8490 When the CPAN shell enters a subshell via the look command, it sets
8491 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
8494 When the config variable ftp_passive is set, all downloads will be run
8495 with the environment variable FTP_PASSIVE set to this value. This is
8496 in general a good idea as it influences both Net::FTP and LWP based
8497 connections. The same effect can be achieved by starting the cpan
8498 shell with this environment variable set. For Net::FTP alone, one can
8499 also always set passive mode by running libnetcfg.
8501 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
8503 Populating a freshly installed perl with my favorite modules is pretty
8504 easy if you maintain a private bundle definition file. To get a useful
8505 blueprint of a bundle definition file, the command autobundle can be used
8506 on the CPAN shell command line. This command writes a bundle definition
8507 file for all modules that are installed for the currently running perl
8508 interpreter. It's recommended to run this command only once and from then
8509 on maintain the file manually under a private name, say
8510 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
8512 cpan> install Bundle::my_bundle
8514 then answer a few questions and then go out for a coffee.
8516 Maintaining a bundle definition file means keeping track of two
8517 things: dependencies and interactivity. CPAN.pm sometimes fails on
8518 calculating dependencies because not all modules define all MakeMaker
8519 attributes correctly, so a bundle definition file should specify
8520 prerequisites as early as possible. On the other hand, it's a bit
8521 annoying that many distributions need some interactive configuring. So
8522 what I try to accomplish in my private bundle file is to have the
8523 packages that need to be configured early in the file and the gentle
8524 ones later, so I can go out after a few minutes and leave CPAN.pm
8527 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
8529 Thanks to Graham Barr for contributing the following paragraphs about
8530 the interaction between perl, and various firewall configurations. For
8531 further information on firewalls, it is recommended to consult the
8532 documentation that comes with the ncftp program. If you are unable to
8533 go through the firewall with a simple Perl setup, it is very likely
8534 that you can configure ncftp so that it works for your firewall.
8536 =head2 Three basic types of firewalls
8538 Firewalls can be categorized into three basic types.
8544 This is where the firewall machine runs a web server and to access the
8545 outside world you must do it via the web server. If you set environment
8546 variables like http_proxy or ftp_proxy to a values beginning with http://
8547 or in your web browser you have to set proxy information then you know
8548 you are running an http firewall.
8550 To access servers outside these types of firewalls with perl (even for
8551 ftp) you will need to use LWP.
8555 This where the firewall machine runs an ftp server. This kind of
8556 firewall will only let you access ftp servers outside the firewall.
8557 This is usually done by connecting to the firewall with ftp, then
8558 entering a username like "user@outside.host.com"
8560 To access servers outside these type of firewalls with perl you
8561 will need to use Net::FTP.
8563 =item One way visibility
8565 I say one way visibility as these firewalls try to make themselves look
8566 invisible to the users inside the firewall. An FTP data connection is
8567 normally created by sending the remote server your IP address and then
8568 listening for the connection. But the remote server will not be able to
8569 connect to you because of the firewall. So for these types of firewall
8570 FTP connections need to be done in a passive mode.
8572 There are two that I can think off.
8578 If you are using a SOCKS firewall you will need to compile perl and link
8579 it with the SOCKS library, this is what is normally called a 'socksified'
8580 perl. With this executable you will be able to connect to servers outside
8581 the firewall as if it is not there.
8585 This is the firewall implemented in the Linux kernel, it allows you to
8586 hide a complete network behind one IP address. With this firewall no
8587 special compiling is needed as you can access hosts directly.
8589 For accessing ftp servers behind such firewalls you usually need to
8590 set the environment variable C<FTP_PASSIVE> or the config variable
8591 ftp_passive to a true value.
8597 =head2 Configuring lynx or ncftp for going through a firewall
8599 If you can go through your firewall with e.g. lynx, presumably with a
8602 /usr/local/bin/lynx -pscott:tiger
8604 then you would configure CPAN.pm with the command
8606 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
8608 That's all. Similarly for ncftp or ftp, you would configure something
8611 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
8613 Your mileage may vary...
8621 I installed a new version of module X but CPAN keeps saying,
8622 I have the old version installed
8624 Most probably you B<do> have the old version installed. This can
8625 happen if a module installs itself into a different directory in the
8626 @INC path than it was previously installed. This is not really a
8627 CPAN.pm problem, you would have the same problem when installing the
8628 module manually. The easiest way to prevent this behaviour is to add
8629 the argument C<UNINST=1> to the C<make install> call, and that is why
8630 many people add this argument permanently by configuring
8632 o conf make_install_arg UNINST=1
8636 So why is UNINST=1 not the default?
8638 Because there are people who have their precise expectations about who
8639 may install where in the @INC path and who uses which @INC array. In
8640 fine tuned environments C<UNINST=1> can cause damage.
8644 I want to clean up my mess, and install a new perl along with
8645 all modules I have. How do I go about it?
8647 Run the autobundle command for your old perl and optionally rename the
8648 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
8649 with the Configure option prefix, e.g.
8651 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
8653 Install the bundle file you produced in the first step with something like
8655 cpan> install Bundle::mybundle
8661 When I install bundles or multiple modules with one command
8662 there is too much output to keep track of.
8664 You may want to configure something like
8666 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
8667 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
8669 so that STDOUT is captured in a file for later inspection.
8674 I am not root, how can I install a module in a personal directory?
8676 First of all, you will want to use your own configuration, not the one
8677 that your root user installed. If you do not have permission to write
8678 in the cpan directory that root has configured, you will be asked if
8679 you want to create your own config. Answering "yes" will bring you into
8680 CPAN's configuration stage, using the system config for all defaults except
8681 things that have to do with CPAN's work directory, saving your choices to
8682 your MyConfig.pm file.
8684 You can also manually initiate this process with the following command:
8686 % perl -MCPAN -e 'mkmyconfig'
8692 from the CPAN shell.
8694 You will most probably also want to configure something like this:
8696 o conf makepl_arg "LIB=~/myperl/lib \
8697 INSTALLMAN1DIR=~/myperl/man/man1 \
8698 INSTALLMAN3DIR=~/myperl/man/man3"
8700 You can make this setting permanent like all C<o conf> settings with
8703 You will have to add ~/myperl/man to the MANPATH environment variable
8704 and also tell your perl programs to look into ~/myperl/lib, e.g. by
8707 use lib "$ENV{HOME}/myperl/lib";
8709 or setting the PERL5LIB environment variable.
8711 While we're speaking about $ENV{HOME}, it might be worth mentioning,
8712 that for Windows we use the File::HomeDir module that provides an
8713 equivalent to the concept of the home directory on Unix.
8715 Another thing you should bear in mind is that the UNINST parameter can
8716 be dnagerous when you are installing into a private area because you
8717 might accidentally remove modules that other people depend on that are
8718 not using the private area.
8722 How to get a package, unwrap it, and make a change before building it?
8724 Have a look at the C<look> (!) command.
8728 I installed a Bundle and had a couple of fails. When I
8729 retried, everything resolved nicely. Can this be fixed to work
8732 The reason for this is that CPAN does not know the dependencies of all
8733 modules when it starts out. To decide about the additional items to
8734 install, it just uses data found in the META.yml file or the generated
8735 Makefile. An undetected missing piece breaks the process. But it may
8736 well be that your Bundle installs some prerequisite later than some
8737 depending item and thus your second try is able to resolve everything.
8738 Please note, CPAN.pm does not know the dependency tree in advance and
8739 cannot sort the queue of things to install in a topologically correct
8740 order. It resolves perfectly well IF all modules declare the
8741 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
8742 the C<requires> stanza of Module::Build. For bundles which fail and
8743 you need to install often, it is recommended to sort the Bundle
8744 definition file manually.
8748 In our intranet we have many modules for internal use. How
8749 can I integrate these modules with CPAN.pm but without uploading
8750 the modules to CPAN?
8752 Have a look at the CPAN::Site module.
8756 When I run CPAN's shell, I get an error message about things in my
8757 /etc/inputrc (or ~/.inputrc) file.
8759 These are readline issues and can only be fixed by studying readline
8760 configuration on your architecture and adjusting the referenced file
8761 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
8762 and edit them. Quite often harmless changes like uppercasing or
8763 lowercasing some arguments solves the problem.
8767 Some authors have strange characters in their names.
8769 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
8770 expecting ISO-8859-1 charset, a converter can be activated by setting
8771 term_is_latin to a true value in your config file. One way of doing so
8774 cpan> o conf term_is_latin 1
8776 If other charset support is needed, please file a bugreport against
8777 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
8778 the support or maybe UTF-8 terminals become widely available.
8782 When an install fails for some reason and then I correct the error
8783 condition and retry, CPAN.pm refuses to install the module, saying
8784 C<Already tried without success>.
8786 Use the force pragma like so
8788 force install Foo::Bar
8790 This does a bit more than really needed because it untars the
8791 distribution again and runs make and test and only then install.
8793 Or, if you find this is too fast and you would prefer to do smaller
8798 first and then continue as always. C<Force get> I<forgets> previous
8805 and then 'make install' directly in the subshell.
8807 Or you leave the CPAN shell and start it again.
8809 For the really curious, by accessing internals directly, you I<could>
8811 !delete CPAN::Shell->expandany("Foo::Bar")->distribution->{install}
8813 but this is neither guaranteed to work in the future nor is it a
8818 How do I install a "DEVELOPER RELEASE" of a module?
8820 By default, CPAN will install the latest non-developer release of a
8821 module. If you want to install a dev release, you have to specify the
8822 partial path starting with the author id to the tarball you wish to
8825 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
8827 Note that you can use the C<ls> command to get this path listed.
8831 How do I install a module and all its dependencies from the commandline,
8832 without being prompted for anything, despite my CPAN configuration
8835 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
8836 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
8837 asked any questions at all (assuming the modules you are installing are
8838 nice about obeying that variable as well):
8840 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
8844 How do I create a Module::Build based Build.PL derived from an
8845 ExtUtils::MakeMaker focused Makefile.PL?
8847 http://search.cpan.org/search?query=Module::Build::Convert
8849 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
8856 Please report bugs via http://rt.cpan.org/
8858 Before submitting a bug, please make sure that the traditional method
8859 of building a Perl module package from a shell by following the
8860 installation instructions of that package still works in your
8863 =head1 SECURITY ADVICE
8865 This software enables you to upgrade software on your computer and so
8866 is inherently dangerous because the newly installed software may
8867 contain bugs and may alter the way your computer works or even make it
8868 unusable. Please consider backing up your data before every upgrade.
8872 Andreas Koenig C<< <andk@cpan.org> >>
8876 This program is free software; you can redistribute it and/or
8877 modify it under the same terms as Perl itself.
8879 See L<http://www.perl.com/perl/misc/Artistic.html>
8883 Kawai,Takanori provides a Japanese translation of this manpage at
8884 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
8888 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)