1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $VERSION = eval $VERSION;
7 use CPAN::HandleConfig;
16 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
17 use File::Basename ();
26 use Text::ParseWords ();
28 no lib "."; # we need to run chdir all over and we would get at wrong
31 require Mac::BuildTools if $^O eq 'MacOS';
33 END { $CPAN::End++; &cleanup; }
36 $CPAN::Frontend ||= "CPAN::Shell";
37 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
38 $CPAN::Perl ||= CPAN::find_perl();
39 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
40 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
46 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
47 $Signal $Suppress_readline $Frontend
48 $Defaultsite $Have_warned $Defaultdocs $Defaultrecent
51 @CPAN::ISA = qw(CPAN::Debug Exporter);
54 autobundle bundle expand force notest get cvs_import
55 install make readme recompile shell test clean
59 #-> sub CPAN::AUTOLOAD ;
64 @EXPORT{@EXPORT} = '';
65 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
66 if (exists $EXPORT{$l}){
69 $CPAN::Frontend->mywarn(qq{Unknown CPAN command "$AUTOLOAD". }.
79 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
80 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
82 my $oprompt = shift || "cpan> ";
83 my $prompt = $oprompt;
84 my $commandline = shift || "";
87 unless ($Suppress_readline) {
88 require Term::ReadLine;
91 $term->ReadLine eq "Term::ReadLine::Stub"
93 $term = Term::ReadLine->new('CPAN Monitor');
95 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
96 my $attribs = $term->Attribs;
97 $attribs->{attempted_completion_function} = sub {
98 &CPAN::Complete::gnu_cpl;
101 $readline::rl_completion_function =
102 $readline::rl_completion_function = 'CPAN::Complete::cpl';
104 if (my $histfile = $CPAN::Config->{'histfile'}) {{
105 unless ($term->can("AddHistory")) {
106 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
109 my($fh) = FileHandle->new;
110 open $fh, "<$histfile" or last;
114 $term->AddHistory($_);
118 # $term->OUT is autoflushed anyway
119 my $odef = select STDERR;
126 # no strict; # I do not recall why no strict was here (2000-09-03)
128 my $cwd = CPAN::anycwd();
129 my $try_detect_readline;
130 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
131 my $rl_avail = $Suppress_readline ? "suppressed" :
132 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
133 "available (try 'install Bundle::CPAN')";
135 $CPAN::Frontend->myprint(
137 cpan shell -- CPAN exploration and modules installation (v%s)
144 unless $CPAN::Config->{'inhibit_startup_message'} ;
145 my($continuation) = "";
146 SHELLCOMMAND: while () {
147 if ($Suppress_readline) {
149 last SHELLCOMMAND unless defined ($_ = <> );
152 last SHELLCOMMAND unless
153 defined ($_ = $term->readline($prompt, $commandline));
155 $_ = "$continuation$_" if $continuation;
157 next SHELLCOMMAND if /^$/;
158 $_ = 'h' if /^\s*\?/;
159 if (/^(?:q(?:uit)?|bye|exit)$/i) {
170 use vars qw($import_done);
171 CPAN->import(':DEFAULT') unless $import_done++;
172 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
179 if ($] < 5.00322) { # parsewords had a bug until recently
182 eval { @line = Text::ParseWords::shellwords($_) };
183 warn($@), next SHELLCOMMAND if $@;
184 warn("Text::Parsewords could not parse the line [$_]"),
185 next SHELLCOMMAND unless @line;
187 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
188 my $command = shift @line;
189 eval { CPAN::Shell->$command(@line) };
191 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
192 $CPAN::Frontend->myprint("\n");
197 $commandline = ""; # I do want to be able to pass a default to
198 # shell, but on the second command I see no
201 CPAN::Queue->nullify_queue;
202 if ($try_detect_readline) {
203 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
205 $CPAN::META->has_inst("Term::ReadLine::Perl")
207 delete $INC{"Term/ReadLine.pm"};
209 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
210 require Term::ReadLine;
211 $CPAN::Frontend->myprint("\n$redef subroutines in ".
212 "Term::ReadLine redefined\n");
218 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
221 package CPAN::CacheMgr;
223 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
228 use vars qw($Ua $Thesite $Themethod);
229 @CPAN::FTP::ISA = qw(CPAN::Debug);
231 package CPAN::LWP::UserAgent;
233 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
234 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
236 package CPAN::Complete;
238 @CPAN::Complete::ISA = qw(CPAN::Debug);
239 @CPAN::Complete::COMMANDS = sort qw(
240 ! a b d h i m o q r u autobundle clean dump
241 make test install force readme reload look
242 cvs_import ls perldoc recent
243 ) unless @CPAN::Complete::COMMANDS;
247 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
248 @CPAN::Index::ISA = qw(CPAN::Debug);
251 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
254 package CPAN::InfoObj;
256 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
258 package CPAN::Author;
260 @CPAN::Author::ISA = qw(CPAN::InfoObj);
262 package CPAN::Distribution;
264 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
266 package CPAN::Bundle;
268 @CPAN::Bundle::ISA = qw(CPAN::Module);
270 package CPAN::Module;
272 @CPAN::Module::ISA = qw(CPAN::InfoObj);
274 package CPAN::Exception::RecursiveDependency;
276 use overload '""' => "as_string";
283 for my $dep (@$deps) {
285 last if $seen{$dep}++;
287 bless { deps => \@deps }, $class;
292 "\nRecursive dependency detected:\n " .
293 join("\n => ", @{$self->{deps}}) .
294 ".\nCannot continue.\n";
299 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
300 @CPAN::Shell::ISA = qw(CPAN::Debug);
301 $COLOR_REGISTERED ||= 0;
302 $PRINT_ORNAMENTING ||= 0;
304 #-> sub CPAN::Shell::AUTOLOAD ;
306 my($autoload) = $AUTOLOAD;
307 my $class = shift(@_);
308 # warn "autoload[$autoload] class[$class]";
309 $autoload =~ s/.*:://;
310 if ($autoload =~ /^w/) {
311 if ($CPAN::META->has_inst('CPAN::WAIT')) {
312 CPAN::WAIT->$autoload(@_);
314 $CPAN::Frontend->mywarn(qq{
315 Commands starting with "w" require CPAN::WAIT to be installed.
316 Please consider installing CPAN::WAIT to use the fulltext index.
317 For this you just need to type
322 $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload'. }.
331 # One use of the queue is to determine if we should or shouldn't
332 # announce the availability of a new CPAN module
334 # Now we try to use it for dependency tracking. For that to happen
335 # we need to draw a dependency tree and do the leaves first. This can
336 # easily be reached by running CPAN.pm recursively, but we don't want
337 # to waste memory and run into deep recursion. So what we can do is
340 # CPAN::Queue is the package where the queue is maintained. Dependencies
341 # often have high priority and must be brought to the head of the queue,
342 # possibly by jumping the queue if they are already there. My first code
343 # attempt tried to be extremely correct. Whenever a module needed
344 # immediate treatment, I either unshifted it to the front of the queue,
345 # or, if it was already in the queue, I spliced and let it bypass the
346 # others. This became a too correct model that made it impossible to put
347 # an item more than once into the queue. Why would you need that? Well,
348 # you need temporary duplicates as the manager of the queue is a loop
351 # (1) looks at the first item in the queue without shifting it off
353 # (2) cares for the item
355 # (3) removes the item from the queue, *even if its agenda failed and
356 # even if the item isn't the first in the queue anymore* (that way
357 # protecting against never ending queues)
359 # So if an item has prerequisites, the installation fails now, but we
360 # want to retry later. That's easy if we have it twice in the queue.
362 # I also expect insane dependency situations where an item gets more
363 # than two lives in the queue. Simplest example is triggered by 'install
364 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
365 # get in the way. I wanted the queue manager to be a dumb servant, not
366 # one that knows everything.
368 # Who would I tell in this model that the user wants to be asked before
369 # processing? I can't attach that information to the module object,
370 # because not modules are installed but distributions. So I'd have to
371 # tell the distribution object that it should ask the user before
372 # processing. Where would the question be triggered then? Most probably
373 # in CPAN::Distribution::rematein.
374 # Hope that makes sense, my head is a bit off:-) -- AK
381 my $self = bless { qmod => $s }, $class;
386 # CPAN::Queue::first ;
392 # CPAN::Queue::delete_first ;
394 my($class,$what) = @_;
396 for my $i (0..$#All) {
397 if ( $All[$i]->{qmod} eq $what ) {
404 # CPAN::Queue::jumpqueue ;
408 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
409 join(",",map {$_->{qmod}} @All),
412 WHAT: for my $what (reverse @what) {
414 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
415 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
416 if ($All[$i]->{qmod} eq $what){
418 if ($jumped > 100) { # one's OK if e.g. just
419 # processing now; more are OK if
420 # user typed it several times
421 $CPAN::Frontend->mywarn(
422 qq{Object [$what] queued more than 100 times, ignoring}
428 my $obj = bless { qmod => $what }, $class;
431 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
432 join(",",map {$_->{qmod}} @All),
437 # CPAN::Queue::exists ;
439 my($self,$what) = @_;
440 my @all = map { $_->{qmod} } @All;
441 my $exists = grep { $_->{qmod} eq $what } @All;
442 # warn "in exists what[$what] all[@all] exists[$exists]";
446 # CPAN::Queue::delete ;
449 @All = grep { $_->{qmod} ne $mod } @All;
452 # CPAN::Queue::nullify_queue ;
462 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
464 # from here on only subs.
465 ################################################################################
467 #-> sub CPAN::all_objects ;
469 my($mgr,$class) = @_;
470 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
471 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
473 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
475 *all = \&all_objects;
477 # Called by shell, not in batch mode. In batch mode I see no risk in
478 # having many processes updating something as installations are
479 # continually checked at runtime. In shell mode I suspect it is
480 # unintentional to open more than one shell at a time
482 #-> sub CPAN::checklock ;
485 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
486 if (-f $lockfile && -M _ > 0) {
487 my $fh = FileHandle->new($lockfile) or
488 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
489 my $otherpid = <$fh>;
490 my $otherhost = <$fh>;
492 if (defined $otherpid && $otherpid) {
495 if (defined $otherhost && $otherhost) {
498 my $thishost = hostname();
499 if (defined $otherhost && defined $thishost &&
500 $otherhost ne '' && $thishost ne '' &&
501 $otherhost ne $thishost) {
502 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
503 "reports other host $otherhost and other process $otherpid.\n".
504 "Cannot proceed.\n"));
506 elsif (defined $otherpid && $otherpid) {
507 return if $$ == $otherpid; # should never happen
508 $CPAN::Frontend->mywarn(
510 There seems to be running another CPAN process (pid $otherpid). Contacting...
512 if (kill 0, $otherpid) {
513 $CPAN::Frontend->mydie(qq{Other job is running.
514 You may want to kill it and delete the lockfile, maybe. On UNIX try:
518 } elsif (-w $lockfile) {
520 ExtUtils::MakeMaker::prompt
521 (qq{Other job not responding. Shall I overwrite }.
522 qq{the lockfile? (Y/N)},"y");
523 $CPAN::Frontend->myexit("Ok, bye\n")
524 unless $ans =~ /^y/i;
527 qq{Lockfile $lockfile not writeable by you. }.
528 qq{Cannot proceed.\n}.
531 qq{ and then rerun us.\n}
535 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
536 "reports other process with ID ".
537 "$otherpid. Cannot proceed.\n"));
540 my $dotcpan = $CPAN::Config->{cpan_home};
541 eval { File::Path::mkpath($dotcpan);};
543 # A special case at least for Jarkko.
548 $symlinkcpan = readlink $dotcpan;
549 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
550 eval { File::Path::mkpath($symlinkcpan); };
554 $CPAN::Frontend->mywarn(qq{
555 Working directory $symlinkcpan created.
559 unless (-d $dotcpan) {
561 Your configuration suggests "$dotcpan" as your
562 CPAN.pm working directory. I could not create this directory due
563 to this error: $firsterror\n};
565 As "$dotcpan" is a symlink to "$symlinkcpan",
566 I tried to create that, but I failed with this error: $seconderror
569 Please make sure the directory exists and is writable.
571 $CPAN::Frontend->mydie($diemess);
575 unless ($fh = FileHandle->new(">$lockfile")) {
576 if ($! =~ /Permission/) {
577 my $incc = $INC{'CPAN/Config.pm'};
578 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
579 $CPAN::Frontend->myprint(qq{
581 Your configuration suggests that CPAN.pm should use a working
583 $CPAN::Config->{cpan_home}
584 Unfortunately we could not create the lock file
586 due to permission problems.
588 Please make sure that the configuration variable
589 \$CPAN::Config->{cpan_home}
590 points to a directory where you can write a .lock file. You can set
591 this variable in either
598 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
600 $fh->print($$, "\n");
601 $fh->print(hostname(), "\n");
602 $self->{LOCK} = $lockfile;
606 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
611 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
612 print "Caught SIGINT\n";
616 # From: Larry Wall <larry@wall.org>
617 # Subject: Re: deprecating SIGDIE
618 # To: perl5-porters@perl.org
619 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
621 # The original intent of __DIE__ was only to allow you to substitute one
622 # kind of death for another on an application-wide basis without respect
623 # to whether you were in an eval or not. As a global backstop, it should
624 # not be used any more lightly (or any more heavily :-) than class
625 # UNIVERSAL. Any attempt to build a general exception model on it should
626 # be politely squashed. Any bug that causes every eval {} to have to be
627 # modified should be not so politely squashed.
629 # Those are my current opinions. It is also my optinion that polite
630 # arguments degenerate to personal arguments far too frequently, and that
631 # when they do, it's because both people wanted it to, or at least didn't
632 # sufficiently want it not to.
636 # global backstop to cleanup if we should really die
637 $SIG{__DIE__} = \&cleanup;
638 $self->debug("Signal handler set.") if $CPAN::DEBUG;
641 #-> sub CPAN::DESTROY ;
643 &cleanup; # need an eval?
646 #-> sub CPAN::anycwd ;
649 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
654 sub cwd {Cwd::cwd();}
656 #-> sub CPAN::getcwd ;
657 sub getcwd {Cwd::getcwd();}
659 #-> sub CPAN::find_perl ;
661 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
662 my $pwd = CPAN::anycwd();
663 my $candidate = File::Spec->catfile($pwd,$^X);
664 $perl ||= $candidate if MM->maybe_command($candidate);
667 my ($component,$perl_name);
668 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
669 PATH_COMPONENT: foreach $component (File::Spec->path(),
670 $Config::Config{'binexp'}) {
671 next unless defined($component) && $component;
672 my($abs) = File::Spec->catfile($component,$perl_name);
673 if (MM->maybe_command($abs)) {
685 #-> sub CPAN::exists ;
687 my($mgr,$class,$id) = @_;
688 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
690 ### Carp::croak "exists called without class argument" unless $class;
692 $id =~ s/:+/::/g if $class eq "CPAN::Module";
693 exists $META->{readonly}{$class}{$id} or
694 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
697 #-> sub CPAN::delete ;
699 my($mgr,$class,$id) = @_;
700 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
701 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
704 #-> sub CPAN::has_usable
705 # has_inst is sometimes too optimistic, we should replace it with this
706 # has_usable whenever a case is given
708 my($self,$mod,$message) = @_;
709 return 1 if $HAS_USABLE->{$mod};
710 my $has_inst = $self->has_inst($mod,$message);
711 return unless $has_inst;
714 LWP => [ # we frequently had "Can't locate object
715 # method "new" via package "LWP::UserAgent" at
716 # (eval 69) line 2006
718 sub {require LWP::UserAgent},
719 sub {require HTTP::Request},
720 sub {require URI::URL},
723 sub {require Net::FTP},
724 sub {require Net::Config},
727 if ($usable->{$mod}) {
728 for my $c (0..$#{$usable->{$mod}}) {
729 my $code = $usable->{$mod}[$c];
730 my $ret = eval { &$code() };
732 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
737 return $HAS_USABLE->{$mod} = 1;
740 #-> sub CPAN::has_inst
742 my($self,$mod,$message) = @_;
743 Carp::croak("CPAN->has_inst() called without an argument")
745 if (defined $message && $message eq "no"
747 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
749 exists $CPAN::Config->{dontload_hash}{$mod}
751 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
759 # checking %INC is wrong, because $INC{LWP} may be true
760 # although $INC{"URI/URL.pm"} may have failed. But as
761 # I really want to say "bla loaded OK", I have to somehow
763 ### warn "$file in %INC"; #debug
765 } elsif (eval { require $file }) {
766 # eval is good: if we haven't yet read the database it's
767 # perfect and if we have installed the module in the meantime,
768 # it tries again. The second require is only a NOOP returning
769 # 1 if we had success, otherwise it's retrying
771 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
772 if ($mod eq "CPAN::WAIT") {
773 push @CPAN::Shell::ISA, 'CPAN::WAIT';
776 } elsif ($mod eq "Net::FTP") {
777 $CPAN::Frontend->mywarn(qq{
778 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
780 install Bundle::libnet
782 }) unless $Have_warned->{"Net::FTP"}++;
784 } elsif ($mod eq "Digest::SHA"){
785 $CPAN::Frontend->myprint(qq{
786 CPAN: checksum security checks disabled because Digest::SHA not installed.
787 Please consider installing the Digest::SHA module.
791 } elsif ($mod eq "Module::Signature"){
792 unless ($Have_warned->{"Module::Signature"}++) {
793 # No point in complaining unless the user can
794 # reasonably install and use it.
795 if (eval { require Crypt::OpenPGP; 1 } ||
796 defined $CPAN::Config->{'gpg'}) {
797 $CPAN::Frontend->myprint(qq{
798 CPAN: Module::Signature security checks disabled because Module::Signature
799 not installed. Please consider installing the Module::Signature module.
800 You may also need to be able to connect over the Internet to the public
801 keyservers like pgp.mit.edu (port 11371).
808 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
813 #-> sub CPAN::instance ;
815 my($mgr,$class,$id) = @_;
818 # unsafe meta access, ok?
819 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
820 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
828 #-> sub CPAN::cleanup ;
830 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
831 local $SIG{__DIE__} = '';
836 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
838 $subroutine eq '(eval)';
840 return if $ineval && !$CPAN::End;
841 return unless defined $META->{LOCK};
842 return unless -f $META->{LOCK};
844 unlink $META->{LOCK};
846 # Carp::cluck("DEBUGGING");
847 $CPAN::Frontend->mywarn("Lockfile removed.\n");
850 #-> sub CPAN::savehist
853 my($histfile,$histsize);
854 unless ($histfile = $CPAN::Config->{'histfile'}){
855 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
858 $histsize = $CPAN::Config->{'histsize'} || 100;
860 unless ($CPAN::term->can("GetHistory")) {
861 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
867 my @h = $CPAN::term->GetHistory;
868 splice @h, 0, @h-$histsize if @h>$histsize;
869 my($fh) = FileHandle->new;
870 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
871 local $\ = local $, = "\n";
877 my($self,$what) = @_;
878 $self->{is_tested}{$what} = 1;
882 my($self,$what) = @_;
883 delete $self->{is_tested}{$what};
888 $self->{is_tested} ||= {};
889 return unless %{$self->{is_tested}};
890 my $env = $ENV{PERL5LIB};
891 $env = $ENV{PERLLIB} unless defined $env;
893 push @env, $env if defined $env and length $env;
894 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
895 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
896 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
899 package CPAN::CacheMgr;
902 #-> sub CPAN::CacheMgr::as_string ;
904 eval { require Data::Dumper };
906 return shift->SUPER::as_string;
908 return Data::Dumper::Dumper(shift);
912 #-> sub CPAN::CacheMgr::cachesize ;
917 #-> sub CPAN::CacheMgr::tidyup ;
920 return unless -d $self->{ID};
921 while ($self->{DU} > $self->{'MAX'} ) {
922 my($toremove) = shift @{$self->{FIFO}};
923 $CPAN::Frontend->myprint(sprintf(
924 "Deleting from cache".
925 ": $toremove (%.1f>%.1f MB)\n",
926 $self->{DU}, $self->{'MAX'})
928 return if $CPAN::Signal;
929 $self->force_clean_cache($toremove);
930 return if $CPAN::Signal;
934 #-> sub CPAN::CacheMgr::dir ;
939 #-> sub CPAN::CacheMgr::entries ;
942 return unless defined $dir;
943 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
944 $dir ||= $self->{ID};
945 my($cwd) = CPAN::anycwd();
946 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
947 my $dh = DirHandle->new(File::Spec->curdir)
948 or Carp::croak("Couldn't opendir $dir: $!");
951 next if $_ eq "." || $_ eq "..";
953 push @entries, File::Spec->catfile($dir,$_);
955 push @entries, File::Spec->catdir($dir,$_);
957 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
960 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
961 sort { -M $b <=> -M $a} @entries;
964 #-> sub CPAN::CacheMgr::disk_usage ;
967 return if exists $self->{SIZE}{$dir};
968 return if $CPAN::Signal;
972 $File::Find::prune++ if $CPAN::Signal;
974 if ($^O eq 'MacOS') {
976 my $cat = Mac::Files::FSpGetCatInfo($_);
977 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
984 return if $CPAN::Signal;
985 $self->{SIZE}{$dir} = $Du/1024/1024;
986 push @{$self->{FIFO}}, $dir;
987 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
988 $self->{DU} += $Du/1024/1024;
992 #-> sub CPAN::CacheMgr::force_clean_cache ;
993 sub force_clean_cache {
995 return unless -e $dir;
996 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
998 File::Path::rmtree($dir);
999 $self->{DU} -= $self->{SIZE}{$dir};
1000 delete $self->{SIZE}{$dir};
1003 #-> sub CPAN::CacheMgr::new ;
1010 ID => $CPAN::Config->{'build_dir'},
1011 MAX => $CPAN::Config->{'build_cache'},
1012 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1015 File::Path::mkpath($self->{ID});
1016 my $dh = DirHandle->new($self->{ID});
1017 bless $self, $class;
1020 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1022 CPAN->debug($debug) if $CPAN::DEBUG;
1026 #-> sub CPAN::CacheMgr::scan_cache ;
1029 return if $self->{SCAN} eq 'never';
1030 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1031 unless $self->{SCAN} eq 'atstart';
1032 $CPAN::Frontend->myprint(
1033 sprintf("Scanning cache %s for sizes\n",
1036 for $e ($self->entries($self->{ID})) {
1037 next if $e eq ".." || $e eq ".";
1038 $self->disk_usage($e);
1039 return if $CPAN::Signal;
1044 package CPAN::Shell;
1047 #-> sub CPAN::Shell::h ;
1049 my($class,$about) = @_;
1050 if (defined $about) {
1051 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1053 $CPAN::Frontend->myprint(q{
1055 command argument description
1056 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1057 i WORD or /REGEXP/ about any of the above
1058 r NONE report updatable modules
1059 ls AUTHOR about files in the author's directory
1060 (with WORD being a module, bundle or author name or a distribution
1061 name of the form AUTHOR/DISTRIBUTION)
1063 Download, Test, Make, Install...
1064 get download clean make clean
1065 make make (implies get) look open subshell in dist directory
1066 test make test (implies make) readme display these README files
1067 install make install (implies test) perldoc display POD documentation
1070 force COMMAND unconditionally do command
1071 notest COMMAND skip testing
1074 h,? display this menu ! perl-code eval a perl command
1075 o conf [opt] set and query options q quit the cpan shell
1076 reload cpan load CPAN.pm again reload index load newer indices
1077 autobundle Snapshot recent latest CPAN uploads});
1083 #-> sub CPAN::Shell::a ;
1085 my($self,@arg) = @_;
1086 # authors are always UPPERCASE
1088 $_ = uc $_ unless /=/;
1090 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1093 #-> sub CPAN::Shell::ls ;
1095 my($self,@arg) = @_;
1096 my(@accept,@preexpand);
1097 for my $arg (@arg) {
1098 if ($arg =~ /[\*\?\/]/) {
1099 if ($CPAN::META->has_inst("Text::Glob")) {
1100 if (my($au,$pathglob) = $arg =~ m|(.*?)/(.*)|) {
1101 my $rau = Text::Glob::glob_to_regex(uc $au);
1102 $self->debug("au[$au]pathglob[$pathglob]rau[$rau]") if $CPAN::DEBUG;
1103 push @preexpand, map { $_->id . "/" . $pathglob }
1104 $self->expand_by_method('CPAN::Author',['id'],"/$rau/");
1106 my $rau = Text::Glob::glob_to_regex(uc $arg);
1107 push @preexpand, map { $_->id } $self->expand_by_method('CPAN::Author',
1112 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1115 push @preexpand, uc $arg;
1119 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1120 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1125 my $silent = @accept>1;
1126 my $last_alpha = "";
1127 for my $a (@accept){
1128 my($author,$pathglob);
1129 if ($a =~ m|(.*?)/(.*)|) {
1132 $author = $self->expand_by_method('CPAN::Author',
1134 $a2) or die "No author found for $a2";
1136 $author = $self->expand_by_method('CPAN::Author',
1138 $a) or die "No author found for $a";
1141 my $alpha = substr $author->id, 0, 1;
1143 if ($alpha eq $last_alpha) {
1147 $last_alpha = $alpha;
1149 $CPAN::Frontend->myprint($ad);
1151 $author->ls($pathglob,$silent); # silent if more than one author
1155 #-> sub CPAN::Shell::local_bundles ;
1157 my($self,@which) = @_;
1158 my($incdir,$bdir,$dh);
1159 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1160 my @bbase = "Bundle";
1161 while (my $bbase = shift @bbase) {
1162 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1163 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1164 if ($dh = DirHandle->new($bdir)) { # may fail
1166 for $entry ($dh->read) {
1167 next if $entry =~ /^\./;
1168 if (-d File::Spec->catdir($bdir,$entry)){
1169 push @bbase, "$bbase\::$entry";
1171 next unless $entry =~ s/\.pm(?!\n)\Z//;
1172 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1180 #-> sub CPAN::Shell::b ;
1182 my($self,@which) = @_;
1183 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1184 $self->local_bundles;
1185 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1188 #-> sub CPAN::Shell::d ;
1189 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1191 #-> sub CPAN::Shell::m ;
1192 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1194 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1197 #-> sub CPAN::Shell::i ;
1201 @args = '/./' unless @args;
1203 for my $type (qw/Bundle Distribution Module/) {
1204 push @result, $self->expand($type,@args);
1206 # Authors are always uppercase.
1207 push @result, $self->expand("Author", map { uc $_ } @args);
1209 my $result = @result == 1 ?
1210 $result[0]->as_string :
1212 "No objects found of any type for argument @args\n" :
1214 (map {$_->as_glimpse} @result),
1215 scalar @result, " items found\n",
1217 $CPAN::Frontend->myprint($result);
1220 #-> sub CPAN::Shell::o ;
1222 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1223 # should have been called set and 'o debug' maybe 'set debug'
1225 my($self,$o_type,@o_what) = @_;
1227 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1228 if ($o_type eq 'conf') {
1229 shift @o_what if @o_what && $o_what[0] eq 'help';
1230 if (!@o_what) { # print all things, "o conf"
1232 $CPAN::Frontend->myprint("CPAN::Config options");
1233 if (exists $INC{'CPAN/Config.pm'}) {
1234 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1236 if (exists $INC{'CPAN/MyConfig.pm'}) {
1237 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1239 $CPAN::Frontend->myprint(":\n");
1240 for $k (sort keys %CPAN::HandleConfig::can) {
1241 $v = $CPAN::HandleConfig::can{$k};
1242 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1244 $CPAN::Frontend->myprint("\n");
1245 for $k (sort keys %$CPAN::Config) {
1246 CPAN::HandleConfig->prettyprint($k);
1248 $CPAN::Frontend->myprint("\n");
1249 } elsif (!CPAN::HandleConfig->edit(@o_what)) {
1250 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1251 qq{edit options\n\n});
1253 } elsif ($o_type eq 'debug') {
1255 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1258 my($what) = shift @o_what;
1259 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1260 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1263 if ( exists $CPAN::DEBUG{$what} ) {
1264 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1265 } elsif ($what =~ /^\d/) {
1266 $CPAN::DEBUG = $what;
1267 } elsif (lc $what eq 'all') {
1269 for (values %CPAN::DEBUG) {
1272 $CPAN::DEBUG = $max;
1275 for (keys %CPAN::DEBUG) {
1276 next unless lc($_) eq lc($what);
1277 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1280 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1285 my $raw = "Valid options for debug are ".
1286 join(", ",sort(keys %CPAN::DEBUG), 'all').
1287 qq{ or a number. Completion works on the options. }.
1288 qq{Case is ignored.};
1290 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1291 $CPAN::Frontend->myprint("\n\n");
1294 $CPAN::Frontend->myprint("Options set for debugging:\n");
1296 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1297 $v = $CPAN::DEBUG{$k};
1298 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1299 if $v & $CPAN::DEBUG;
1302 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1305 $CPAN::Frontend->myprint(qq{
1307 conf set or get configuration variables
1308 debug set or get debugging options
1313 sub paintdots_onreload {
1316 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1320 # $CPAN::Frontend->myprint(".($subr)");
1321 $CPAN::Frontend->myprint(".");
1328 #-> sub CPAN::Shell::reload ;
1330 my($self,$command,@arg) = @_;
1332 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1333 if ($command =~ /cpan/i) {
1335 for my $f (qw(CPAN.pm CPAN/HandleConfig.pm CPAN/FirstTime.pm CPAN/Tarzip.pm
1336 CPAN/Debug.pm CPAN/Version.pm)) {
1337 next unless $INC{$f};
1338 my $pwd = CPAN::anycwd();
1339 CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
1341 my $fh = FileHandle->new($INC{$f});
1344 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1346 CPAN->debug("evaling '$eval'")
1351 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1352 } elsif ($command =~ /index/) {
1353 CPAN::Index->force_reload;
1355 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1356 index re-reads the index files\n});
1360 #-> sub CPAN::Shell::_binary_extensions ;
1361 sub _binary_extensions {
1362 my($self) = shift @_;
1363 my(@result,$module,%seen,%need,$headerdone);
1364 for $module ($self->expand('Module','/./')) {
1365 my $file = $module->cpan_file;
1366 next if $file eq "N/A";
1367 next if $file =~ /^Contact Author/;
1368 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1369 next if $dist->isa_perl;
1370 next unless $module->xs_file;
1372 $CPAN::Frontend->myprint(".");
1373 push @result, $module;
1375 # print join " | ", @result;
1376 $CPAN::Frontend->myprint("\n");
1380 #-> sub CPAN::Shell::recompile ;
1382 my($self) = shift @_;
1383 my($module,@module,$cpan_file,%dist);
1384 @module = $self->_binary_extensions();
1385 for $module (@module){ # we force now and compile later, so we
1387 $cpan_file = $module->cpan_file;
1388 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1390 $dist{$cpan_file}++;
1392 for $cpan_file (sort keys %dist) {
1393 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1394 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1396 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1397 # stop a package from recompiling,
1398 # e.g. IO-1.12 when we have perl5.003_10
1402 #-> sub CPAN::Shell::_u_r_common ;
1404 my($self) = shift @_;
1405 my($what) = shift @_;
1406 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1407 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1408 $what && $what =~ /^[aru]$/;
1410 @args = '/./' unless @args;
1411 my(@result,$module,%seen,%need,$headerdone,
1412 $version_undefs,$version_zeroes);
1413 $version_undefs = $version_zeroes = 0;
1414 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1415 my @expand = $self->expand('Module',@args);
1416 my $expand = scalar @expand;
1417 if (0) { # Looks like noise to me, was very useful for debugging
1418 # for metadata cache
1419 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1421 MODULE: for $module (@expand) {
1422 my $file = $module->cpan_file;
1423 next MODULE unless defined $file; # ??
1424 $file =~ s|^./../||;
1425 my($latest) = $module->cpan_version;
1426 my($inst_file) = $module->inst_file;
1428 return if $CPAN::Signal;
1431 $have = $module->inst_version;
1432 } elsif ($what eq "r") {
1433 $have = $module->inst_version;
1435 if ($have eq "undef"){
1437 } elsif ($have == 0){
1440 next MODULE unless CPAN::Version->vgt($latest, $have);
1441 # to be pedantic we should probably say:
1442 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1443 # to catch the case where CPAN has a version 0 and we have a version undef
1444 } elsif ($what eq "u") {
1450 } elsif ($what eq "r") {
1452 } elsif ($what eq "u") {
1456 return if $CPAN::Signal; # this is sometimes lengthy
1459 push @result, sprintf "%s %s\n", $module->id, $have;
1460 } elsif ($what eq "r") {
1461 push @result, $module->id;
1462 next MODULE if $seen{$file}++;
1463 } elsif ($what eq "u") {
1464 push @result, $module->id;
1465 next MODULE if $seen{$file}++;
1466 next MODULE if $file =~ /^Contact/;
1468 unless ($headerdone++){
1469 $CPAN::Frontend->myprint("\n");
1470 $CPAN::Frontend->myprint(sprintf(
1473 "Package namespace",
1485 $CPAN::META->has_inst("Term::ANSIColor")
1487 $module->{RO}{description}
1489 $color_on = Term::ANSIColor::color("green");
1490 $color_off = Term::ANSIColor::color("reset");
1492 $CPAN::Frontend->myprint(sprintf $sprintf,
1499 $need{$module->id}++;
1503 $CPAN::Frontend->myprint("No modules found for @args\n");
1504 } elsif ($what eq "r") {
1505 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1509 if ($version_zeroes) {
1510 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1511 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1512 qq{a version number of 0\n});
1514 if ($version_undefs) {
1515 my $s_has = $version_undefs > 1 ? "s have" : " has";
1516 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1517 qq{parseable version number\n});
1523 #-> sub CPAN::Shell::r ;
1525 shift->_u_r_common("r",@_);
1528 #-> sub CPAN::Shell::u ;
1530 shift->_u_r_common("u",@_);
1533 #-> sub CPAN::Shell::autobundle ;
1536 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1537 my(@bundle) = $self->_u_r_common("a",@_);
1538 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1539 File::Path::mkpath($todir);
1540 unless (-d $todir) {
1541 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1544 my($y,$m,$d) = (localtime)[5,4,3];
1548 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1549 my($to) = File::Spec->catfile($todir,"$me.pm");
1551 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1552 $to = File::Spec->catfile($todir,"$me.pm");
1554 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1556 "package Bundle::$me;\n\n",
1557 "\$VERSION = '0.01';\n\n",
1561 "Bundle::$me - Snapshot of installation on ",
1562 $Config::Config{'myhostname'},
1565 "\n\n=head1 SYNOPSIS\n\n",
1566 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1567 "=head1 CONTENTS\n\n",
1568 join("\n", @bundle),
1569 "\n\n=head1 CONFIGURATION\n\n",
1571 "\n\n=head1 AUTHOR\n\n",
1572 "This Bundle has been generated automatically ",
1573 "by the autobundle routine in CPAN.pm.\n",
1576 $CPAN::Frontend->myprint("\nWrote bundle file
1580 #-> sub CPAN::Shell::expandany ;
1583 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1584 if ($s =~ m|/|) { # looks like a file
1585 $s = CPAN::Distribution->normalize($s);
1586 return $CPAN::META->instance('CPAN::Distribution',$s);
1587 # Distributions spring into existence, not expand
1588 } elsif ($s =~ m|^Bundle::|) {
1589 $self->local_bundles; # scanning so late for bundles seems
1590 # both attractive and crumpy: always
1591 # current state but easy to forget
1593 return $self->expand('Bundle',$s);
1595 return $self->expand('Module',$s)
1596 if $CPAN::META->exists('CPAN::Module',$s);
1601 #-> sub CPAN::Shell::expand ;
1604 my($type,@args) = @_;
1605 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1606 my $class = "CPAN::$type";
1607 my $methods = ['id'];
1608 for my $meth (qw(name)) {
1609 next if $] < 5.00303; # no "can"
1610 next unless $class->can($meth);
1611 push @$methods, $meth;
1613 $self->expand_by_method($class,$methods,@args);
1616 sub expand_by_method {
1618 my($class,$methods,@args) = @_;
1621 my($regex,$command);
1622 if ($arg =~ m|^/(.*)/$|) {
1624 } elsif ($arg =~ m/=/) {
1628 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1630 defined $regex ? $regex : "UNDEFINED",
1631 defined $command ? $command : "UNDEFINED",
1633 if (defined $regex) {
1635 $CPAN::META->all_objects($class)
1638 # BUG, we got an empty object somewhere
1639 require Data::Dumper;
1640 CPAN->debug(sprintf(
1641 "Bug in CPAN: Empty id on obj[%s][%s]",
1643 Data::Dumper::Dumper($obj)
1647 for my $method (@$methods) {
1648 if ($obj->$method() =~ /$regex/i) {
1654 } elsif ($command) {
1655 die "equal sign in command disabled (immature interface), ".
1657 ! \$CPAN::Shell::ADVANCED_QUERY=1
1658 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1659 that may go away anytime.\n"
1660 unless $ADVANCED_QUERY;
1661 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1662 my($matchcrit) = $criterion =~ m/^~(.+)/;
1666 $CPAN::META->all_objects($class)
1668 my $lhs = $self->$method() or next; # () for 5.00503
1670 push @m, $self if $lhs =~ m/$matchcrit/;
1672 push @m, $self if $lhs eq $criterion;
1677 if ( $class eq 'CPAN::Bundle' ) {
1678 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1679 } elsif ($class eq "CPAN::Distribution") {
1680 $xarg = CPAN::Distribution->normalize($arg);
1684 if ($CPAN::META->exists($class,$xarg)) {
1685 $obj = $CPAN::META->instance($class,$xarg);
1686 } elsif ($CPAN::META->exists($class,$arg)) {
1687 $obj = $CPAN::META->instance($class,$arg);
1694 @m = sort {$a->id cmp $b->id} @m;
1695 if ( $CPAN::DEBUG ) {
1696 my $wantarray = wantarray;
1697 my $join_m = join ",", map {$_->id} @m;
1698 $self->debug("wantarray[$wantarray]join_m[$join_m]");
1700 return wantarray ? @m : $m[0];
1703 #-> sub CPAN::Shell::format_result ;
1706 my($type,@args) = @_;
1707 @args = '/./' unless @args;
1708 my(@result) = $self->expand($type,@args);
1709 my $result = @result == 1 ?
1710 $result[0]->as_string :
1712 "No objects of type $type found for argument @args\n" :
1714 (map {$_->as_glimpse} @result),
1715 scalar @result, " items found\n",
1720 #-> sub CPAN::Shell::report_fh ;
1722 my $installation_report_fh;
1723 my $previously_noticed = 0;
1726 return $installation_report_fh if $installation_report_fh;
1727 $installation_report_fh = File::Temp->new(
1728 template => 'cpan_install_XXXX',
1732 unless ( $installation_report_fh ) {
1733 warn("Couldn't open installation report file; " .
1734 "no report file will be generated."
1735 ) unless $previously_noticed++;
1741 # The only reason for this method is currently to have a reliable
1742 # debugging utility that reveals which output is going through which
1743 # channel. No, I don't like the colors ;-)
1745 #-> sub CPAN::Shell::print_ornameted ;
1746 sub print_ornamented {
1747 my($self,$what,$ornament) = @_;
1749 return unless defined $what;
1751 local $| = 1; # Flush immediately
1752 if ( $CPAN::Be_Silent ) {
1753 print {report_fh()} $what;
1757 if ($CPAN::Config->{term_is_latin}){
1760 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1762 if ($PRINT_ORNAMENTING) {
1763 unless (defined &color) {
1764 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1765 import Term::ANSIColor "color";
1767 *color = sub { return "" };
1771 for $line (split /\n/, $what) {
1772 $longest = length($line) if length($line) > $longest;
1774 my $sprintf = "%-" . $longest . "s";
1776 $what =~ s/(.*\n?)//m;
1779 my($nl) = chomp $line ? "\n" : "";
1780 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1781 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1785 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
1791 my($self,$what) = @_;
1793 $self->print_ornamented($what, 'bold blue on_yellow');
1797 my($self,$what) = @_;
1798 $self->myprint($what);
1803 my($self,$what) = @_;
1804 $self->print_ornamented($what, 'bold red on_yellow');
1808 my($self,$what) = @_;
1809 $self->print_ornamented($what, 'bold red on_white');
1810 Carp::confess "died";
1814 my($self,$what) = @_;
1815 $self->print_ornamented($what, 'bold red on_white');
1820 return if -t STDOUT;
1821 my $odef = select STDERR;
1828 #-> sub CPAN::Shell::rematein ;
1829 # RE-adme||MA-ke||TE-st||IN-stall
1832 my($meth,@some) = @_;
1834 while($meth =~ /^(force|notest)$/) {
1835 push @pragma, $meth;
1836 $meth = shift @some;
1839 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
1841 # Here is the place to set "test_count" on all involved parties to
1842 # 0. We then can pass this counter on to the involved
1843 # distributions and those can refuse to test if test_count > X. In
1844 # the first stab at it we could use a 1 for "X".
1846 # But when do I reset the distributions to start with 0 again?
1847 # Jost suggested to have a random or cycling interaction ID that
1848 # we pass through. But the ID is something that is just left lying
1849 # around in addition to the counter, so I'd prefer to set the
1850 # counter to 0 now, and repeat at the end of the loop. But what
1851 # about dependencies? They appear later and are not reset, they
1852 # enter the queue but not its copy. How do they get a sensible
1855 # construct the queue
1857 foreach $s (@some) {
1860 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1862 } elsif ($s =~ m|^/|) { # looks like a regexp
1863 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1868 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1869 $obj = CPAN::Shell->expandany($s);
1872 $obj->color_cmd_tmps(0,1);
1873 CPAN::Queue->new($obj->id);
1875 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
1876 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
1877 if ($meth =~ /^(dump|ls)$/) {
1880 $CPAN::Frontend->myprint(
1882 "Don't be silly, you can't $meth ",
1890 ->myprint(qq{Warning: Cannot $meth $s, }.
1891 qq{don\'t know what it is.
1896 to find objects with matching identifiers.
1902 # queuerunner (please be warned: when I started to change the
1903 # queue to hold objects instead of names, I made one or two
1904 # mistakes and never found which. I reverted back instead)
1905 while ($s = CPAN::Queue->first) {
1908 $obj = $s; # I do not believe, we would survive if this happened
1910 $obj = CPAN::Shell->expandany($s);
1912 for my $pragma (@pragma) {
1915 ($] < 5.00303 || $obj->can($pragma))){
1916 ### compatibility with 5.003
1917 $obj->$pragma($meth); # the pragma "force" in
1918 # "CPAN::Distribution" must know
1919 # what we are intending
1922 if ($]>=5.00303 && $obj->can('called_for')) {
1923 $obj->called_for($s);
1926 qq{pragma[@pragma]meth[$meth]obj[$obj]as_string\[}.
1932 CPAN::Queue->delete($s);
1934 CPAN->debug("failed");
1938 CPAN::Queue->delete_first($s);
1940 for my $obj (@qcopy) {
1941 $obj->color_cmd_tmps(0,0);
1942 delete $obj->{incommandcolor};
1946 #-> sub CPAN::Shell::recent ;
1950 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
1955 # set up the dispatching methods
1957 for my $command (qw(
1958 clean cvs_import dump force get install look
1959 make notest perldoc readme test
1961 *$command = sub { shift->rematein($command, @_); };
1965 package CPAN::LWP::UserAgent;
1969 return if $SETUPDONE;
1970 if ($CPAN::META->has_usable('LWP::UserAgent')) {
1971 require LWP::UserAgent;
1972 @ISA = qw(Exporter LWP::UserAgent);
1975 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
1979 sub get_basic_credentials {
1980 my($self, $realm, $uri, $proxy) = @_;
1981 return unless $proxy;
1982 if ($USER && $PASSWD) {
1983 } elsif (defined $CPAN::Config->{proxy_user} &&
1984 defined $CPAN::Config->{proxy_pass}) {
1985 $USER = $CPAN::Config->{proxy_user};
1986 $PASSWD = $CPAN::Config->{proxy_pass};
1988 require ExtUtils::MakeMaker;
1989 ExtUtils::MakeMaker->import(qw(prompt));
1990 $USER = prompt("Proxy authentication needed!
1991 (Note: to permanently configure username and password run
1992 o conf proxy_user your_username
1993 o conf proxy_pass your_password
1995 if ($CPAN::META->has_inst("Term::ReadKey")) {
1996 Term::ReadKey::ReadMode("noecho");
1998 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2000 $PASSWD = prompt("Password:");
2001 if ($CPAN::META->has_inst("Term::ReadKey")) {
2002 Term::ReadKey::ReadMode("restore");
2004 $CPAN::Frontend->myprint("\n\n");
2006 return($USER,$PASSWD);
2009 # mirror(): Its purpose is to deal with proxy authentication. When we
2010 # call SUPER::mirror, we relly call the mirror method in
2011 # LWP::UserAgent. LWP::UserAgent will then call
2012 # $self->get_basic_credentials or some equivalent and this will be
2013 # $self->dispatched to our own get_basic_credentials method.
2015 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2017 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2018 # although we have gone through our get_basic_credentials, the proxy
2019 # server refuses to connect. This could be a case where the username or
2020 # password has changed in the meantime, so I'm trying once again without
2021 # $USER and $PASSWD to give the get_basic_credentials routine another
2022 # chance to set $USER and $PASSWD.
2024 # mirror(): Its purpose is to deal with proxy authentication. When we
2025 # call SUPER::mirror, we relly call the mirror method in
2026 # LWP::UserAgent. LWP::UserAgent will then call
2027 # $self->get_basic_credentials or some equivalent and this will be
2028 # $self->dispatched to our own get_basic_credentials method.
2030 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2032 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2033 # although we have gone through our get_basic_credentials, the proxy
2034 # server refuses to connect. This could be a case where the username or
2035 # password has changed in the meantime, so I'm trying once again without
2036 # $USER and $PASSWD to give the get_basic_credentials routine another
2037 # chance to set $USER and $PASSWD.
2040 my($self,$url,$aslocal) = @_;
2041 my $result = $self->SUPER::mirror($url,$aslocal);
2042 if ($result->code == 407) {
2045 $result = $self->SUPER::mirror($url,$aslocal);
2053 #-> sub CPAN::FTP::ftp_get ;
2055 my($class,$host,$dir,$file,$target) = @_;
2057 qq[Going to fetch file [$file] from dir [$dir]
2058 on host [$host] as local [$target]\n]
2060 my $ftp = Net::FTP->new($host);
2061 return 0 unless defined $ftp;
2062 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2063 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2064 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2065 warn "Couldn't login on $host";
2068 unless ( $ftp->cwd($dir) ){
2069 warn "Couldn't cwd $dir";
2073 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2074 unless ( $ftp->get($file,$target) ){
2075 warn "Couldn't fetch $file from $host\n";
2078 $ftp->quit; # it's ok if this fails
2082 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2084 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2085 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2087 # > *** 1562,1567 ****
2088 # > --- 1562,1580 ----
2089 # > return 1 if substr($url,0,4) eq "file";
2090 # > return 1 unless $url =~ m|://([^/]+)|;
2092 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2094 # > + $proxy =~ m|://([^/:]+)|;
2096 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2097 # > + if ($noproxy) {
2098 # > + if ($host !~ /$noproxy$/) {
2099 # > + $host = $proxy;
2102 # > + $host = $proxy;
2105 # > require Net::Ping;
2106 # > return 1 unless $Net::Ping::VERSION >= 2;
2110 #-> sub CPAN::FTP::localize ;
2112 my($self,$file,$aslocal,$force) = @_;
2114 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2115 unless defined $aslocal;
2116 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2119 if ($^O eq 'MacOS') {
2120 # Comment by AK on 2000-09-03: Uniq short filenames would be
2121 # available in CHECKSUMS file
2122 my($name, $path) = File::Basename::fileparse($aslocal, '');
2123 if (length($name) > 31) {
2134 my $size = 31 - length($suf);
2135 while (length($name) > $size) {
2139 $aslocal = File::Spec->catfile($path, $name);
2143 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2146 rename $aslocal, "$aslocal.bak";
2150 my($aslocal_dir) = File::Basename::dirname($aslocal);
2151 File::Path::mkpath($aslocal_dir);
2152 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2153 qq{directory "$aslocal_dir".
2154 I\'ll continue, but if you encounter problems, they may be due
2155 to insufficient permissions.\n}) unless -w $aslocal_dir;
2157 # Inheritance is not easier to manage than a few if/else branches
2158 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2160 CPAN::LWP::UserAgent->config;
2161 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2163 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2167 $Ua->proxy('ftp', $var)
2168 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2169 $Ua->proxy('http', $var)
2170 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2173 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2175 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2176 # > use ones that require basic autorization.
2178 # > Example of when I use it manually in my own stuff:
2180 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2181 # > $req->proxy_authorization_basic("username","password");
2182 # > $res = $ua->request($req);
2186 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2190 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2191 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2194 # Try the list of urls for each single object. We keep a record
2195 # where we did get a file from
2196 my(@reordered,$last);
2197 $CPAN::Config->{urllist} ||= [];
2198 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2199 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2201 $last = $#{$CPAN::Config->{urllist}};
2202 if ($force & 2) { # local cpans probably out of date, don't reorder
2203 @reordered = (0..$last);
2207 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2209 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2220 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2222 @levels = qw/easy hard hardest/;
2224 @levels = qw/easy/ if $^O eq 'MacOS';
2226 for $levelno (0..$#levels) {
2227 my $level = $levels[$levelno];
2228 my $method = "host$level";
2229 my @host_seq = $level eq "easy" ?
2230 @reordered : 0..$last; # reordered has CDROM up front
2231 @host_seq = (0) unless @host_seq;
2232 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2234 $Themethod = $level;
2236 # utime $now, $now, $aslocal; # too bad, if we do that, we
2237 # might alter a local mirror
2238 $self->debug("level[$level]") if $CPAN::DEBUG;
2242 last if $CPAN::Signal; # need to cleanup
2245 unless ($CPAN::Signal) {
2248 qq{Please check, if the URLs I found in your configuration file \(}.
2249 join(", ", @{$CPAN::Config->{urllist}}).
2250 qq{\) are valid. The urllist can be edited.},
2251 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2252 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2254 $CPAN::Frontend->myprint("Could not fetch $file\n");
2257 rename "$aslocal.bak", $aslocal;
2258 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2259 $self->ls($aslocal));
2266 my($self,$host_seq,$file,$aslocal) = @_;
2268 HOSTEASY: for $i (@$host_seq) {
2269 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2270 $url .= "/" unless substr($url,-1) eq "/";
2272 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2273 if ($url =~ /^file:/) {
2275 if ($CPAN::META->has_inst('URI::URL')) {
2276 my $u = URI::URL->new($url);
2278 } else { # works only on Unix, is poorly constructed, but
2279 # hopefully better than nothing.
2280 # RFC 1738 says fileurl BNF is
2281 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2282 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2284 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2285 $l =~ s|^file:||; # assume they
2288 $l =~ s|^/||s unless -f $l; # e.g. /P:
2289 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2291 if ( -f $l && -r _) {
2295 # Maybe mirror has compressed it?
2297 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2298 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
2305 if ($CPAN::META->has_usable('LWP')) {
2306 $CPAN::Frontend->myprint("Fetching with LWP:
2310 CPAN::LWP::UserAgent->config;
2311 eval { $Ua = CPAN::LWP::UserAgent->new; };
2313 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2316 my $res = $Ua->mirror($url, $aslocal);
2317 if ($res->is_success) {
2320 utime $now, $now, $aslocal; # download time is more
2321 # important than upload time
2323 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2324 my $gzurl = "$url.gz";
2325 $CPAN::Frontend->myprint("Fetching with LWP:
2328 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2329 if ($res->is_success &&
2330 CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
2336 $CPAN::Frontend->myprint(sprintf(
2337 "LWP failed with code[%s] message[%s]\n",
2341 # Alan Burlison informed me that in firewall environments
2342 # Net::FTP can still succeed where LWP fails. So we do not
2343 # skip Net::FTP anymore when LWP is available.
2346 $CPAN::Frontend->myprint("LWP not available\n");
2348 return if $CPAN::Signal;
2349 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2350 # that's the nice and easy way thanks to Graham
2351 my($host,$dir,$getfile) = ($1,$2,$3);
2352 if ($CPAN::META->has_usable('Net::FTP')) {
2354 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2357 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2358 "aslocal[$aslocal]") if $CPAN::DEBUG;
2359 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2363 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2364 my $gz = "$aslocal.gz";
2365 $CPAN::Frontend->myprint("Fetching with Net::FTP
2368 if (CPAN::FTP->ftp_get($host,
2372 CPAN::Tarzip->new($gz)->gunzip($aslocal)
2381 return if $CPAN::Signal;
2386 my($self,$host_seq,$file,$aslocal) = @_;
2388 # Came back if Net::FTP couldn't establish connection (or
2389 # failed otherwise) Maybe they are behind a firewall, but they
2390 # gave us a socksified (or other) ftp program...
2393 my($devnull) = $CPAN::Config->{devnull} || "";
2395 my($aslocal_dir) = File::Basename::dirname($aslocal);
2396 File::Path::mkpath($aslocal_dir);
2397 HOSTHARD: for $i (@$host_seq) {
2398 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2399 $url .= "/" unless substr($url,-1) eq "/";
2401 my($proto,$host,$dir,$getfile);
2403 # Courtesy Mark Conty mark_conty@cargill.com change from
2404 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2406 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2407 # proto not yet used
2408 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2410 next HOSTHARD; # who said, we could ftp anything except ftp?
2412 next HOSTHARD if $proto eq "file"; # file URLs would have had
2413 # success above. Likely a bogus URL
2415 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2417 # Try the most capable first and leave ncftp* for last as it only
2419 for my $f (qw(curl wget lynx ncftpget ncftp)) {
2420 my $funkyftp = $CPAN::Config->{$f};
2421 next unless defined $funkyftp;
2422 next if $funkyftp =~ /^\s*$/;
2424 my($asl_ungz, $asl_gz);
2425 ($asl_ungz = $aslocal) =~ s/\.gz//;
2426 $asl_gz = "$asl_ungz.gz";
2428 my($src_switch) = "";
2430 my($stdout_redir) = " > $asl_ungz";
2432 $src_switch = " -source";
2433 } elsif ($f eq "ncftp"){
2434 $src_switch = " -c";
2435 } elsif ($f eq "wget"){
2436 $src_switch = " -O $asl_ungz";
2438 } elsif ($f eq 'curl'){
2439 $src_switch = ' -L';
2442 if ($f eq "ncftpget"){
2443 $chdir = "cd $aslocal_dir && ";
2446 $CPAN::Frontend->myprint(
2448 Trying with "$funkyftp$src_switch" to get
2452 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2453 $self->debug("system[$system]") if $CPAN::DEBUG;
2455 if (($wstatus = system($system)) == 0
2458 -s $asl_ungz # lynx returns 0 when it fails somewhere
2464 } elsif ($asl_ungz ne $aslocal) {
2465 # test gzip integrity
2466 if (CPAN::Tarzip->new($asl_ungz)->gtest) {
2467 # e.g. foo.tar is gzipped --> foo.tar.gz
2468 rename $asl_ungz, $aslocal;
2470 CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
2475 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2477 -f $asl_ungz && -s _ == 0;
2478 my $gz = "$aslocal.gz";
2479 my $gzurl = "$url.gz";
2480 $CPAN::Frontend->myprint(
2482 Trying with "$funkyftp$src_switch" to get
2485 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2486 $self->debug("system[$system]") if $CPAN::DEBUG;
2488 if (($wstatus = system($system)) == 0
2492 # test gzip integrity
2493 my $ct = CPAN::Tarzip->new($asl_gz);
2495 $ct->gunzip($aslocal);
2497 # somebody uncompressed file for us?
2498 rename $asl_ungz, $aslocal;
2503 unlink $asl_gz if -f $asl_gz;
2506 my $estatus = $wstatus >> 8;
2507 my $size = -f $aslocal ?
2508 ", left\n$aslocal with size ".-s _ :
2509 "\nWarning: expected file [$aslocal] doesn't exist";
2510 $CPAN::Frontend->myprint(qq{
2511 System call "$system"
2512 returned status $estatus (wstat $wstatus)$size
2515 return if $CPAN::Signal;
2516 } # transfer programs
2521 my($self,$host_seq,$file,$aslocal) = @_;
2524 my($aslocal_dir) = File::Basename::dirname($aslocal);
2525 File::Path::mkpath($aslocal_dir);
2526 my $ftpbin = $CPAN::Config->{ftp};
2527 HOSTHARDEST: for $i (@$host_seq) {
2528 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2529 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2532 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2533 $url .= "/" unless substr($url,-1) eq "/";
2535 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2536 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2539 my($host,$dir,$getfile) = ($1,$2,$3);
2541 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2542 $ctime,$blksize,$blocks) = stat($aslocal);
2543 $timestamp = $mtime ||= 0;
2544 my($netrc) = CPAN::FTP::netrc->new;
2545 my($netrcfile) = $netrc->netrc;
2546 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2547 my $targetfile = File::Basename::basename($aslocal);
2553 map("cd $_", split /\//, $dir), # RFC 1738
2555 "get $getfile $targetfile",
2559 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2560 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2561 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2563 $netrc->contains($host))) if $CPAN::DEBUG;
2564 if ($netrc->protected) {
2565 $CPAN::Frontend->myprint(qq{
2566 Trying with external ftp to get
2568 As this requires some features that are not thoroughly tested, we\'re
2569 not sure, that we get it right....
2573 $self->talk_ftp("$ftpbin$verbose $host",
2575 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2576 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2578 if ($mtime > $timestamp) {
2579 $CPAN::Frontend->myprint("GOT $aslocal\n");
2583 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2585 return if $CPAN::Signal;
2587 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2588 qq{correctly protected.\n});
2591 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2592 nor does it have a default entry\n");
2595 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2596 # then and login manually to host, using e-mail as
2598 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2602 "user anonymous $Config::Config{'cf_email'}"
2604 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2605 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2606 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2608 if ($mtime > $timestamp) {
2609 $CPAN::Frontend->myprint("GOT $aslocal\n");
2613 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2615 return if $CPAN::Signal;
2616 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2622 my($self,$command,@dialog) = @_;
2623 my $fh = FileHandle->new;
2624 $fh->open("|$command") or die "Couldn't open ftp: $!";
2625 foreach (@dialog) { $fh->print("$_\n") }
2626 $fh->close; # Wait for process to complete
2628 my $estatus = $wstatus >> 8;
2629 $CPAN::Frontend->myprint(qq{
2630 Subprocess "|$command"
2631 returned status $estatus (wstat $wstatus)
2635 # find2perl needs modularization, too, all the following is stolen
2639 my($self,$name) = @_;
2640 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2641 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2643 my($perms,%user,%group);
2647 $blocks = int(($blocks + 1) / 2);
2650 $blocks = int(($sizemm + 1023) / 1024);
2653 if (-f _) { $perms = '-'; }
2654 elsif (-d _) { $perms = 'd'; }
2655 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2656 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2657 elsif (-p _) { $perms = 'p'; }
2658 elsif (-S _) { $perms = 's'; }
2659 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2661 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2662 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2663 my $tmpmode = $mode;
2664 my $tmp = $rwx[$tmpmode & 7];
2666 $tmp = $rwx[$tmpmode & 7] . $tmp;
2668 $tmp = $rwx[$tmpmode & 7] . $tmp;
2669 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2670 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2671 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2674 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2675 my $group = $group{$gid} || $gid;
2677 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2679 my($moname) = $moname[$mon];
2680 if (-M _ > 365.25 / 2) {
2681 $timeyear = $year + 1900;
2684 $timeyear = sprintf("%02d:%02d", $hour, $min);
2687 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2701 package CPAN::FTP::netrc;
2706 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2708 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2709 $atime,$mtime,$ctime,$blksize,$blocks)
2714 my($fh,@machines,$hasdefault);
2716 $fh = FileHandle->new or die "Could not create a filehandle";
2718 if($fh->open($file)){
2719 $protected = ($mode & 077) == 0;
2721 NETRC: while (<$fh>) {
2722 my(@tokens) = split " ", $_;
2723 TOKEN: while (@tokens) {
2724 my($t) = shift @tokens;
2725 if ($t eq "default"){
2729 last TOKEN if $t eq "macdef";
2730 if ($t eq "machine") {
2731 push @machines, shift @tokens;
2736 $file = $hasdefault = $protected = "";
2740 'mach' => [@machines],
2742 'hasdefault' => $hasdefault,
2743 'protected' => $protected,
2747 # CPAN::FTP::hasdefault;
2748 sub hasdefault { shift->{'hasdefault'} }
2749 sub netrc { shift->{'netrc'} }
2750 sub protected { shift->{'protected'} }
2752 my($self,$mach) = @_;
2753 for ( @{$self->{'mach'}} ) {
2754 return 1 if $_ eq $mach;
2759 package CPAN::Complete;
2763 my($text, $line, $start, $end) = @_;
2764 my(@perlret) = cpl($text, $line, $start);
2765 # find longest common match. Can anybody show me how to peruse
2766 # T::R::Gnu to have this done automatically? Seems expensive.
2767 return () unless @perlret;
2768 my($newtext) = $text;
2769 for (my $i = length($text)+1;;$i++) {
2770 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2771 my $try = substr($perlret[0],0,$i);
2772 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2773 # warn "try[$try]tries[@tries]";
2774 if (@tries == @perlret) {
2780 ($newtext,@perlret);
2783 #-> sub CPAN::Complete::cpl ;
2785 my($word,$line,$pos) = @_;
2789 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2791 if ($line =~ s/^(force\s*)//) {
2796 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2797 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2799 } elsif ($line =~ /^(a|ls)\s/) {
2800 @return = cplx('CPAN::Author',uc($word));
2801 } elsif ($line =~ /^b\s/) {
2802 CPAN::Shell->local_bundles;
2803 @return = cplx('CPAN::Bundle',$word);
2804 } elsif ($line =~ /^d\s/) {
2805 @return = cplx('CPAN::Distribution',$word);
2806 } elsif ($line =~ m/^(
2807 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
2809 if ($word =~ /^Bundle::/) {
2810 CPAN::Shell->local_bundles;
2812 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2813 } elsif ($line =~ /^i\s/) {
2814 @return = cpl_any($word);
2815 } elsif ($line =~ /^reload\s/) {
2816 @return = cpl_reload($word,$line,$pos);
2817 } elsif ($line =~ /^o\s/) {
2818 @return = cpl_option($word,$line,$pos);
2819 } elsif ($line =~ m/^\S+\s/ ) {
2820 # fallback for future commands and what we have forgotten above
2821 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2828 #-> sub CPAN::Complete::cplx ;
2830 my($class, $word) = @_;
2831 # I believed for many years that this was sorted, today I
2832 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2833 # make it sorted again. Maybe sort was dropped when GNU-readline
2834 # support came in? The RCS file is difficult to read on that:-(
2835 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2838 #-> sub CPAN::Complete::cpl_any ;
2842 cplx('CPAN::Author',$word),
2843 cplx('CPAN::Bundle',$word),
2844 cplx('CPAN::Distribution',$word),
2845 cplx('CPAN::Module',$word),
2849 #-> sub CPAN::Complete::cpl_reload ;
2851 my($word,$line,$pos) = @_;
2853 my(@words) = split " ", $line;
2854 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2855 my(@ok) = qw(cpan index);
2856 return @ok if @words == 1;
2857 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2860 #-> sub CPAN::Complete::cpl_option ;
2862 my($word,$line,$pos) = @_;
2864 my(@words) = split " ", $line;
2865 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2866 my(@ok) = qw(conf debug);
2867 return @ok if @words == 1;
2868 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2870 } elsif ($words[1] eq 'index') {
2872 } elsif ($words[1] eq 'conf') {
2873 return CPAN::HandleConfig::cpl(@_);
2874 } elsif ($words[1] eq 'debug') {
2875 return sort grep /^\Q$word\E/,
2876 sort keys %CPAN::DEBUG, 'all';
2880 package CPAN::Index;
2883 #-> sub CPAN::Index::force_reload ;
2886 $CPAN::Index::LAST_TIME = 0;
2890 #-> sub CPAN::Index::reload ;
2892 my($cl,$force) = @_;
2895 # XXX check if a newer one is available. (We currently read it
2896 # from time to time)
2897 for ($CPAN::Config->{index_expire}) {
2898 $_ = 0.001 unless $_ && $_ > 0.001;
2900 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2901 # debug here when CPAN doesn't seem to read the Metadata
2903 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2905 unless ($CPAN::META->{PROTOCOL}) {
2906 $cl->read_metadata_cache;
2907 $CPAN::META->{PROTOCOL} ||= "1.0";
2909 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
2910 # warn "Setting last_time to 0";
2911 $LAST_TIME = 0; # No warning necessary
2913 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
2916 # IFF we are developing, it helps to wipe out the memory
2917 # between reloads, otherwise it is not what a user expects.
2918 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2919 $CPAN::META = CPAN->new;
2923 local $LAST_TIME = $time;
2924 local $CPAN::META->{PROTOCOL} = PROTOCOL;
2926 my $needshort = $^O eq "dos";
2928 $cl->rd_authindex($cl
2930 "authors/01mailrc.txt.gz",
2932 File::Spec->catfile('authors', '01mailrc.gz') :
2933 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2936 $debug = "timing reading 01[".($t2 - $time)."]";
2938 return if $CPAN::Signal; # this is sometimes lengthy
2939 $cl->rd_modpacks($cl
2941 "modules/02packages.details.txt.gz",
2943 File::Spec->catfile('modules', '02packag.gz') :
2944 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2947 $debug .= "02[".($t2 - $time)."]";
2949 return if $CPAN::Signal; # this is sometimes lengthy
2952 "modules/03modlist.data.gz",
2954 File::Spec->catfile('modules', '03mlist.gz') :
2955 File::Spec->catfile('modules', '03modlist.data.gz'),
2957 $cl->write_metadata_cache;
2959 $debug .= "03[".($t2 - $time)."]";
2961 CPAN->debug($debug) if $CPAN::DEBUG;
2964 $CPAN::META->{PROTOCOL} = PROTOCOL;
2967 #-> sub CPAN::Index::reload_x ;
2969 my($cl,$wanted,$localname,$force) = @_;
2970 $force |= 2; # means we're dealing with an index here
2971 CPAN::HandleConfig->load; # we should guarantee loading wherever we rely
2973 $localname ||= $wanted;
2974 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
2978 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2981 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2982 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2983 qq{day$s. I\'ll use that.});
2986 $force |= 1; # means we're quite serious about it.
2988 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2991 #-> sub CPAN::Index::rd_authindex ;
2993 my($cl, $index_target) = @_;
2995 return unless defined $index_target;
2996 $CPAN::Frontend->myprint("Going to read $index_target\n");
2998 tie *FH, 'CPAN::Tarzip', $index_target;
3001 push @lines, split /\012/ while <FH>;
3003 my($userid,$fullname,$email) =
3004 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3005 next unless $userid && $fullname && $email;
3007 # instantiate an author object
3008 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3009 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3010 return if $CPAN::Signal;
3015 my($self,$dist) = @_;
3016 $dist = $self->{'id'} unless defined $dist;
3017 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3021 #-> sub CPAN::Index::rd_modpacks ;
3023 my($self, $index_target) = @_;
3025 return unless defined $index_target;
3026 $CPAN::Frontend->myprint("Going to read $index_target\n");
3027 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3030 while ($_ = $fh->READLINE) {
3032 my @ls = map {"$_\n"} split /\n/, $_;
3033 unshift @ls, "\n" x length($1) if /^(\n+)/;
3037 my($line_count,$last_updated);
3039 my $shift = shift(@lines);
3040 last if $shift =~ /^\s*$/;
3041 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3042 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3044 if (not defined $line_count) {
3046 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3047 Please check the validity of the index file by comparing it to more
3048 than one CPAN mirror. I'll continue but problems seem likely to
3053 } elsif ($line_count != scalar @lines) {
3055 warn sprintf qq{Warning: Your %s
3056 contains a Line-Count header of %d but I see %d lines there. Please
3057 check the validity of the index file by comparing it to more than one
3058 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3059 $index_target, $line_count, scalar(@lines);
3062 if (not defined $last_updated) {
3064 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3065 Please check the validity of the index file by comparing it to more
3066 than one CPAN mirror. I'll continue but problems seem likely to
3074 ->myprint(sprintf qq{ Database was generated on %s\n},
3076 $DATE_OF_02 = $last_updated;
3078 if ($CPAN::META->has_inst('HTTP::Date')) {
3080 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3085 qq{Warning: This index file is %d days old.
3086 Please check the host you chose as your CPAN mirror for staleness.
3087 I'll continue but problems seem likely to happen.\a\n},
3092 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3097 # A necessity since we have metadata_cache: delete what isn't
3099 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3100 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3104 # before 1.56 we split into 3 and discarded the rest. From
3105 # 1.57 we assign remaining text to $comment thus allowing to
3106 # influence isa_perl
3107 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3108 my($bundle,$id,$userid);
3110 if ($mod eq 'CPAN' &&
3112 CPAN::Queue->exists('Bundle::CPAN') ||
3113 CPAN::Queue->exists('CPAN')
3117 if ($version > $CPAN::VERSION){
3118 $CPAN::Frontend->myprint(qq{
3119 There's a new CPAN.pm version (v$version) available!
3120 [Current version is v$CPAN::VERSION]
3121 You might want to try
3122 install Bundle::CPAN
3124 without quitting the current session. It should be a seamless upgrade
3125 while we are running...
3128 $CPAN::Frontend->myprint(qq{\n});
3130 last if $CPAN::Signal;
3131 } elsif ($mod =~ /^Bundle::(.*)/) {
3136 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3137 # Let's make it a module too, because bundles have so much
3138 # in common with modules.
3140 # Changed in 1.57_63: seems like memory bloat now without
3141 # any value, so commented out
3143 # $CPAN::META->instance('CPAN::Module',$mod);
3147 # instantiate a module object
3148 $id = $CPAN::META->instance('CPAN::Module',$mod);
3152 # Although CPAN prohibits same name with different version the
3153 # indexer may have changed the version for the same distro
3154 # since the last time ("Force Reindexing" feature)
3155 if ($id->cpan_file ne $dist
3157 $id->cpan_version ne $version
3159 $userid = $id->userid || $self->userid($dist);
3161 'CPAN_USERID' => $userid,
3162 'CPAN_VERSION' => $version,
3163 'CPAN_FILE' => $dist,
3167 # instantiate a distribution object
3168 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3169 # we do not need CONTAINSMODS unless we do something with
3170 # this dist, so we better produce it on demand.
3172 ## my $obj = $CPAN::META->instance(
3173 ## 'CPAN::Distribution' => $dist
3175 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3177 $CPAN::META->instance(
3178 'CPAN::Distribution' => $dist
3180 'CPAN_USERID' => $userid,
3181 'CPAN_COMMENT' => $comment,
3185 for my $name ($mod,$dist) {
3186 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3187 $exists{$name} = undef;
3190 return if $CPAN::Signal;
3194 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3195 for my $o ($CPAN::META->all_objects($class)) {
3196 next if exists $exists{$o->{ID}};
3197 $CPAN::META->delete($class,$o->{ID});
3198 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3205 #-> sub CPAN::Index::rd_modlist ;
3207 my($cl,$index_target) = @_;
3208 return unless defined $index_target;
3209 $CPAN::Frontend->myprint("Going to read $index_target\n");
3210 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3214 while ($_ = $fh->READLINE) {
3216 my @ls = map {"$_\n"} split /\n/, $_;
3217 unshift @ls, "\n" x length($1) if /^(\n+)/;
3221 my $shift = shift(@eval);
3222 if ($shift =~ /^Date:\s+(.*)/){
3223 return if $DATE_OF_03 eq $1;
3226 last if $shift =~ /^\s*$/;
3229 push @eval, q{CPAN::Modulelist->data;};
3231 my($comp) = Safe->new("CPAN::Safe1");
3232 my($eval) = join("", @eval);
3233 my $ret = $comp->reval($eval);
3234 Carp::confess($@) if $@;
3235 return if $CPAN::Signal;
3237 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3238 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3239 $obj->set(%{$ret->{$_}});
3240 return if $CPAN::Signal;
3244 #-> sub CPAN::Index::write_metadata_cache ;
3245 sub write_metadata_cache {
3247 return unless $CPAN::Config->{'cache_metadata'};
3248 return unless $CPAN::META->has_usable("Storable");
3250 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3251 CPAN::Distribution)) {
3252 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3254 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3255 $cache->{last_time} = $LAST_TIME;
3256 $cache->{DATE_OF_02} = $DATE_OF_02;
3257 $cache->{PROTOCOL} = PROTOCOL;
3258 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3259 eval { Storable::nstore($cache, $metadata_file) };
3260 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3263 #-> sub CPAN::Index::read_metadata_cache ;
3264 sub read_metadata_cache {
3266 return unless $CPAN::Config->{'cache_metadata'};
3267 return unless $CPAN::META->has_usable("Storable");
3268 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3269 return unless -r $metadata_file and -f $metadata_file;
3270 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3272 eval { $cache = Storable::retrieve($metadata_file) };
3273 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3274 if (!$cache || ref $cache ne 'HASH'){
3278 if (exists $cache->{PROTOCOL}) {
3279 if (PROTOCOL > $cache->{PROTOCOL}) {
3280 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3281 "with protocol v%s, requiring v%s\n",
3288 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3289 "with protocol v1.0\n");
3294 while(my($class,$v) = each %$cache) {
3295 next unless $class =~ /^CPAN::/;
3296 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3297 while (my($id,$ro) = each %$v) {
3298 $CPAN::META->{readwrite}{$class}{$id} ||=
3299 $class->new(ID=>$id, RO=>$ro);
3304 unless ($clcnt) { # sanity check
3305 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3308 if ($idcnt < 1000) {
3309 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3310 "in $metadata_file\n");
3313 $CPAN::META->{PROTOCOL} ||=
3314 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3315 # does initialize to some protocol
3316 $LAST_TIME = $cache->{last_time};
3317 $DATE_OF_02 = $cache->{DATE_OF_02};
3318 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3319 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3323 package CPAN::InfoObj;
3329 $self->{RO}{CPAN_USERID}
3332 sub id { shift->{ID}; }
3334 #-> sub CPAN::InfoObj::new ;
3336 my $this = bless {}, shift;
3341 # The set method may only be used by code that reads index data or
3342 # otherwise "objective" data from the outside world. All session
3343 # related material may do anything else with instance variables but
3344 # must not touch the hash under the RO attribute. The reason is that
3345 # the RO hash gets written to Metadata file and is thus persistent.
3347 #-> sub CPAN::InfoObj::set ;
3349 my($self,%att) = @_;
3350 my $class = ref $self;
3352 # This must be ||=, not ||, because only if we write an empty
3353 # reference, only then the set method will write into the readonly
3354 # area. But for Distributions that spring into existence, maybe
3355 # because of a typo, we do not like it that they are written into
3356 # the readonly area and made permanent (at least for a while) and
3357 # that is why we do not "allow" other places to call ->set.
3358 unless ($self->id) {
3359 CPAN->debug("Bug? Empty ID, rejecting");
3362 my $ro = $self->{RO} =
3363 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3365 while (my($k,$v) = each %att) {
3370 #-> sub CPAN::InfoObj::as_glimpse ;
3374 my $class = ref($self);
3375 $class =~ s/^CPAN:://;
3376 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3380 #-> sub CPAN::InfoObj::as_string ;
3384 my $class = ref($self);
3385 $class =~ s/^CPAN:://;
3386 push @m, $class, " id = $self->{ID}\n";
3387 for (sort keys %{$self->{RO}}) {
3388 # next if m/^(ID|RO)$/;
3390 if ($_ eq "CPAN_USERID") {
3391 $extra .= " (".$self->author;
3392 my $email; # old perls!
3393 if ($email = $CPAN::META->instance("CPAN::Author",
3396 $extra .= " <$email>";
3398 $extra .= " <no email>";
3401 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3402 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3405 next unless defined $self->{RO}{$_};
3406 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3408 for (sort keys %$self) {
3409 next if m/^(ID|RO)$/;
3410 if (ref($self->{$_}) eq "ARRAY") {
3411 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3412 } elsif (ref($self->{$_}) eq "HASH") {
3416 join(" ",keys %{$self->{$_}}),
3419 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3425 #-> sub CPAN::InfoObj::author ;
3428 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3431 #-> sub CPAN::InfoObj::dump ;
3434 require Data::Dumper;
3435 print Data::Dumper::Dumper($self);
3438 package CPAN::Author;
3441 #-> sub CPAN::Author::id
3444 my $id = $self->{ID};
3445 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3449 #-> sub CPAN::Author::as_glimpse ;
3453 my $class = ref($self);
3454 $class =~ s/^CPAN:://;
3455 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3463 #-> sub CPAN::Author::fullname ;
3465 shift->{RO}{FULLNAME};
3469 #-> sub CPAN::Author::email ;
3470 sub email { shift->{RO}{EMAIL}; }
3472 #-> sub CPAN::Author::ls ;
3475 my $glob = shift || "";
3476 my $silent = shift || 0;
3479 # adapted from CPAN::Distribution::verifyCHECKSUM ;
3480 my(@csf); # chksumfile
3481 @csf = $self->id =~ /(.)(.)(.*)/;
3482 $csf[1] = join "", @csf[0,1];
3483 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
3485 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
3486 unless (grep {$_->[2] eq $csf[1]} @dl) {
3487 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
3490 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
3491 unless (grep {$_->[2] eq $csf[2]} @dl) {
3492 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
3495 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
3497 my $rglob = Text::Glob::glob_to_regex($glob);
3498 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
3500 $CPAN::Frontend->myprint(join "", map {
3501 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3502 } sort { $a->[2] cmp $b->[2] } @dl);
3505 # returns an array of arrays, the latter contain (size,mtime,filename)
3506 #-> sub CPAN::Author::dir_listing ;
3509 my $chksumfile = shift;
3510 my $recursive = shift;
3511 my $may_ftp = shift;
3513 File::Spec->catfile($CPAN::Config->{keep_source_where},
3514 "authors", "id", @$chksumfile);
3518 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
3519 # hazard. (Without GPG installed they are not that much better,
3521 $fh = FileHandle->new;
3522 if (open($fh, $lc_want)) {
3523 my $line = <$fh>; close $fh;
3524 unlink($lc_want) unless $line =~ /PGP/;
3528 # connect "force" argument with "index_expire".
3530 if (my @stat = stat $lc_want) {
3531 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3535 $lc_file = CPAN::FTP->localize(
3536 "authors/id/@$chksumfile",
3541 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3542 $chksumfile->[-1] .= ".gz";
3543 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3546 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3547 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
3553 $lc_file = $lc_want;
3554 # we *could* second-guess and if the user has a file: URL,
3555 # then we could look there. But on the other hand, if they do
3556 # have a file: URL, wy did they choose to set
3557 # $CPAN::Config->{show_upload_date} to false?
3560 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
3561 $fh = FileHandle->new;
3563 if (open $fh, $lc_file){
3566 $eval =~ s/\015?\012/\n/g;
3568 my($comp) = Safe->new();
3569 $cksum = $comp->reval($eval);
3571 rename $lc_file, "$lc_file.bad";
3572 Carp::confess($@) if $@;
3574 } elsif ($may_ftp) {
3575 Carp::carp "Could not open $lc_file for reading.";
3577 # Maybe should warn: "You may want to set show_upload_date to a true value"
3581 for $f (sort keys %$cksum) {
3582 if (exists $cksum->{$f}{isdir}) {
3584 my(@dir) = @$chksumfile;
3586 push @dir, $f, "CHECKSUMS";
3588 [$_->[0], $_->[1], "$f/$_->[2]"]
3589 } $self->dir_listing(\@dir,1,$may_ftp);
3591 push @result, [ 0, "-", $f ];
3595 ($cksum->{$f}{"size"}||0),
3596 $cksum->{$f}{"mtime"}||"---",
3604 package CPAN::Distribution;
3608 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3612 delete $self->{later};
3615 # CPAN::Distribution::normalize
3618 $s = $self->id unless defined $s;
3622 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3624 return $s if $s =~ m:^N/A|^Contact Author: ;
3625 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3626 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3627 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3632 # mark as dirty/clean
3633 #-> sub CPAN::Distribution::color_cmd_tmps ;
3634 sub color_cmd_tmps {
3636 my($depth) = shift || 0;
3637 my($color) = shift || 0;
3638 my($ancestors) = shift || [];
3639 # a distribution needs to recurse into its prereq_pms
3641 return if exists $self->{incommandcolor}
3642 && $self->{incommandcolor}==$color;
3644 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3646 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3647 my $prereq_pm = $self->prereq_pm;
3648 if (defined $prereq_pm) {
3649 for my $pre (keys %$prereq_pm) {
3650 my $premo = CPAN::Shell->expand("Module",$pre);
3651 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3655 delete $self->{sponsored_mods};
3656 delete $self->{badtestcnt};
3658 $self->{incommandcolor} = $color;
3661 #-> sub CPAN::Distribution::as_string ;
3664 $self->containsmods;
3666 $self->SUPER::as_string(@_);
3669 #-> sub CPAN::Distribution::containsmods ;
3672 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3673 my $dist_id = $self->{ID};
3674 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3675 my $mod_file = $mod->cpan_file or next;
3676 my $mod_id = $mod->{ID} or next;
3677 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3679 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3681 keys %{$self->{CONTAINSMODS}};
3684 #-> sub CPAN::Distribution::upload_date ;
3687 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
3688 my(@local_wanted) = split(/\//,$self->id);
3689 my $filename = pop @local_wanted;
3690 push @local_wanted, "CHECKSUMS";
3691 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
3692 return unless $author;
3693 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
3695 my($dirent) = grep { $_->[2] eq $filename } @dl;
3696 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
3697 return unless $dirent->[1];
3698 return $self->{UPLOAD_DATE} = $dirent->[1];
3701 #-> sub CPAN::Distribution::uptodate ;
3705 foreach $c ($self->containsmods) {
3706 my $obj = CPAN::Shell->expandany($c);
3707 return 0 unless $obj->uptodate;
3712 #-> sub CPAN::Distribution::called_for ;
3715 $self->{CALLED_FOR} = $id if defined $id;
3716 return $self->{CALLED_FOR};
3719 #-> sub CPAN::Distribution::safe_chdir ;
3721 my($self,$todir) = @_;
3722 # we die if we cannot chdir and we are debuggable
3723 Carp::confess("safe_chdir called without todir argument")
3724 unless defined $todir and length $todir;
3726 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3729 my $cwd = CPAN::anycwd();
3730 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3731 qq{to todir[$todir]: $!});
3735 #-> sub CPAN::Distribution::get ;
3740 exists $self->{'build_dir'} and push @e,
3741 "Is already unwrapped into directory $self->{'build_dir'}";
3742 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3744 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3747 # Get the file on local disk
3752 File::Spec->catfile(
3753 $CPAN::Config->{keep_source_where},
3756 split(/\//,$self->id)
3759 $self->debug("Doing localize") if $CPAN::DEBUG;
3760 unless ($local_file =
3761 CPAN::FTP->localize("authors/id/$self->{ID}",
3764 if ($CPAN::Index::DATE_OF_02) {
3765 $note = "Note: Current database in memory was generated ".
3766 "on $CPAN::Index::DATE_OF_02\n";
3768 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3770 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3771 $self->{localfile} = $local_file;
3772 return if $CPAN::Signal;
3777 if ($CPAN::META->has_inst("Digest::SHA")) {
3778 $self->debug("Digest::SHA is installed, verifying");
3779 $self->verifyCHECKSUM;
3781 $self->debug("Digest::SHA is NOT installed");
3783 return if $CPAN::Signal;
3786 # Create a clean room and go there
3788 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3789 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3790 $self->safe_chdir($builddir);
3791 $self->debug("Removing tmp") if $CPAN::DEBUG;
3792 File::Path::rmtree("tmp");
3793 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3795 $self->safe_chdir($sub_wd);
3798 $self->safe_chdir("tmp");
3803 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3804 my $ct = CPAN::Tarzip->new($local_file);
3805 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
3806 $self->{was_uncompressed}++ unless $ct->gtest();
3807 $self->untar_me($ct);
3808 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3809 $self->unzip_me($ct);
3810 } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
3811 $self->{was_uncompressed}++ unless $ct->gtest();
3812 $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
3813 $self->pm2dir_me($local_file);
3815 $self->{archived} = "NO";
3816 $self->safe_chdir($sub_wd);
3820 # we are still in the tmp directory!
3821 # Let's check if the package has its own directory.
3822 my $dh = DirHandle->new(File::Spec->curdir)
3823 or Carp::croak("Couldn't opendir .: $!");
3824 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3826 my ($distdir,$packagedir);
3827 if (@readdir == 1 && -d $readdir[0]) {
3828 $distdir = $readdir[0];
3829 $packagedir = File::Spec->catdir($builddir,$distdir);
3830 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3832 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3834 File::Path::rmtree($packagedir);
3835 File::Copy::move($distdir,$packagedir) or
3836 Carp::confess("Couldn't move $distdir to $packagedir: $!");
3837 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3844 my $userid = $self->cpan_userid;
3846 CPAN->debug("no userid? self[$self]");
3849 my $pragmatic_dir = $userid . '000';
3850 $pragmatic_dir =~ s/\W_//g;
3851 $pragmatic_dir++ while -d "../$pragmatic_dir";
3852 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3853 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3854 File::Path::mkpath($packagedir);
3856 for $f (@readdir) { # is already without "." and ".."
3857 my $to = File::Spec->catdir($packagedir,$f);
3858 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
3862 $self->safe_chdir($sub_wd);
3866 $self->{'build_dir'} = $packagedir;
3867 $self->safe_chdir($builddir);
3868 File::Path::rmtree("tmp");
3870 $self->safe_chdir($packagedir);
3871 if ($CPAN::META->has_inst("Module::Signature")) {
3872 if (-f "SIGNATURE") {
3873 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
3874 my $rv = Module::Signature::verify();
3875 if ($rv != Module::Signature::SIGNATURE_OK() and
3876 $rv != Module::Signature::SIGNATURE_MISSING()) {
3877 $CPAN::Frontend->myprint(
3878 qq{\nSignature invalid for }.
3879 qq{distribution file. }.
3880 qq{Please investigate.\n\n}.
3882 $CPAN::META->instance(
3888 my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
3889 is invalid. Maybe you have configured your 'urllist' with
3890 a bad URL. Please check this array with 'o conf urllist', and
3892 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
3895 $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
3898 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
3900 $self->safe_chdir($builddir);
3901 return if $CPAN::Signal;
3904 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3905 my($mpl_exists) = -f $mpl;
3906 unless ($mpl_exists) {
3907 # NFS has been reported to have racing problems after the
3908 # renaming of a directory in some environments.
3911 my $mpldh = DirHandle->new($packagedir)
3912 or Carp::croak("Couldn't opendir $packagedir: $!");
3913 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3916 my $prefer_installer = "eumm"; # eumm|mb
3917 if (-f File::Spec->catfile($packagedir,"Build.PL")) {
3918 if ($mpl_exists) { # they *can* choose
3919 if ($CPAN::META->has_inst("Module::Build")) {
3920 $prefer_installer = $CPAN::Config->{prefer_installer};
3923 $prefer_installer = "mb";
3926 if (lc($prefer_installer) eq "mb") {
3927 $self->{modulebuild} = "YES";
3928 } elsif (! $mpl_exists) {
3929 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3933 my($configure) = File::Spec->catfile($packagedir,"Configure");
3934 if (-f $configure) {
3935 # do we have anything to do?
3936 $self->{'configure'} = $configure;
3937 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
3938 $CPAN::Frontend->myprint(qq{
3939 Package comes with a Makefile and without a Makefile.PL.
3940 We\'ll try to build it with that Makefile then.
3942 $self->{writemakefile} = "YES";
3945 my $cf = $self->called_for || "unknown";
3950 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3951 $cf = "unknown" unless length($cf);
3952 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3953 (The test -f "$mpl" returned false.)
3954 Writing one on our own (setting NAME to $cf)\a\n});
3955 $self->{had_no_makefile_pl}++;
3958 # Writing our own Makefile.PL
3960 my $fh = FileHandle->new;
3962 or Carp::croak("Could not open >$mpl: $!");
3964 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3965 # because there was no Makefile.PL supplied.
3966 # Autogenerated on: }.scalar localtime().qq{
3968 use ExtUtils::MakeMaker;
3969 WriteMakefile(NAME => q[$cf]);
3979 # CPAN::Distribution::untar_me ;
3982 $self->{archived} = "tar";
3984 $self->{unwrapped} = "YES";
3986 $self->{unwrapped} = "NO";
3990 # CPAN::Distribution::unzip_me ;
3993 $self->{archived} = "zip";
3995 $self->{unwrapped} = "YES";
3997 $self->{unwrapped} = "NO";
4003 my($self,$local_file) = @_;
4004 $self->{archived} = "pm";
4005 my $to = File::Basename::basename($local_file);
4006 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4007 if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
4008 $self->{unwrapped} = "YES";
4010 $self->{unwrapped} = "NO";
4013 File::Copy::cp($local_file,".");
4014 $self->{unwrapped} = "YES";
4018 #-> sub CPAN::Distribution::new ;
4020 my($class,%att) = @_;
4022 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4024 my $this = { %att };
4025 return bless $this, $class;
4028 #-> sub CPAN::Distribution::look ;
4032 if ($^O eq 'MacOS') {
4033 $self->Mac::BuildTools::look;
4037 if ( $CPAN::Config->{'shell'} ) {
4038 $CPAN::Frontend->myprint(qq{
4039 Trying to open a subshell in the build directory...
4042 $CPAN::Frontend->myprint(qq{
4043 Your configuration does not define a value for subshells.
4044 Please define it with "o conf shell <your shell>"
4048 my $dist = $self->id;
4050 unless ($dir = $self->dir) {
4053 unless ($dir ||= $self->dir) {
4054 $CPAN::Frontend->mywarn(qq{
4055 Could not determine which directory to use for looking at $dist.
4059 my $pwd = CPAN::anycwd();
4060 $self->safe_chdir($dir);
4061 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4062 unless (system($CPAN::Config->{'shell'}) == 0) {
4064 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4066 $self->safe_chdir($pwd);
4069 # CPAN::Distribution::cvs_import ;
4073 my $dir = $self->dir;
4075 my $package = $self->called_for;
4076 my $module = $CPAN::META->instance('CPAN::Module', $package);
4077 my $version = $module->cpan_version;
4079 my $userid = $self->cpan_userid;
4081 my $cvs_dir = (split /\//, $dir)[-1];
4082 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4084 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4086 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4087 if ($cvs_site_perl) {
4088 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4090 my $cvs_log = qq{"imported $package $version sources"};
4091 $version =~ s/\./_/g;
4092 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4093 "$cvs_dir", $userid, "v$version");
4095 my $pwd = CPAN::anycwd();
4096 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4098 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4100 $CPAN::Frontend->myprint(qq{@cmd\n});
4101 system(@cmd) == 0 or
4102 $CPAN::Frontend->mydie("cvs import failed");
4103 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4106 #-> sub CPAN::Distribution::readme ;
4109 my($dist) = $self->id;
4110 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4111 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4114 File::Spec->catfile(
4115 $CPAN::Config->{keep_source_where},
4118 split(/\//,"$sans.readme"),
4120 $self->debug("Doing localize") if $CPAN::DEBUG;
4121 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4123 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4125 if ($^O eq 'MacOS') {
4126 Mac::BuildTools::launch_file($local_file);
4130 my $fh_pager = FileHandle->new;
4131 local($SIG{PIPE}) = "IGNORE";
4132 $fh_pager->open("|$CPAN::Config->{'pager'}")
4133 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4134 my $fh_readme = FileHandle->new;
4135 $fh_readme->open($local_file)
4136 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4137 $CPAN::Frontend->myprint(qq{
4140 with pager "$CPAN::Config->{'pager'}"
4143 $fh_pager->print(<$fh_readme>);
4147 #-> sub CPAN::Distribution::verifyCHECKSUM ;
4148 sub verifyCHECKSUM {
4152 $self->{CHECKSUM_STATUS} ||= "";
4153 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
4154 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4156 my($lc_want,$lc_file,@local,$basename);
4157 @local = split(/\//,$self->id);
4159 push @local, "CHECKSUMS";
4161 File::Spec->catfile($CPAN::Config->{keep_source_where},
4162 "authors", "id", @local);
4167 $self->CHECKSUM_check_file($lc_want)
4169 return $self->{CHECKSUM_STATUS} = "OK";
4171 $lc_file = CPAN::FTP->localize("authors/id/@local",
4174 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4175 $local[-1] .= ".gz";
4176 $lc_file = CPAN::FTP->localize("authors/id/@local",
4179 $lc_file =~ s/\.gz(?!\n)\Z//;
4180 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4185 $self->CHECKSUM_check_file($lc_file);
4188 sub SIG_check_file {
4189 my($self,$chk_file) = @_;
4190 my $rv = eval { Module::Signature::_verify($chk_file) };
4192 if ($rv == Module::Signature::SIGNATURE_OK()) {
4193 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
4194 return $self->{SIG_STATUS} = "OK";
4196 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
4197 qq{distribution file. }.
4198 qq{Please investigate.\n\n}.
4200 $CPAN::META->instance(
4205 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
4206 is invalid. Maybe you have configured your 'urllist' with
4207 a bad URL. Please check this array with 'o conf urllist', and
4210 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4214 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
4215 sub CHECKSUM_check_file {
4216 my($self,$chk_file) = @_;
4217 my($cksum,$file,$basename);
4219 if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
4220 $self->debug("Module::Signature is installed, verifying");
4221 $self->SIG_check_file($chk_file);
4223 $self->debug("Module::Signature is NOT installed");
4226 $file = $self->{localfile};
4227 $basename = File::Basename::basename($file);
4228 my $fh = FileHandle->new;
4229 if (open $fh, $chk_file){
4232 $eval =~ s/\015?\012/\n/g;
4234 my($comp) = Safe->new();
4235 $cksum = $comp->reval($eval);
4237 rename $chk_file, "$chk_file.bad";
4238 Carp::confess($@) if $@;
4241 Carp::carp "Could not open $chk_file for reading";
4244 if (exists $cksum->{$basename}{sha256}) {
4245 $self->debug("Found checksum for $basename:" .
4246 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
4250 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
4252 $fh = CPAN::Tarzip->TIEHANDLE($file);
4255 my $dg = Digest::SHA->new(256);
4258 while ($fh->READ($ref, 4096) > 0){
4261 my $hexdigest = $dg->hexdigest;
4262 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
4266 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4267 return $self->{CHECKSUM_STATUS} = "OK";
4269 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4270 qq{distribution file. }.
4271 qq{Please investigate.\n\n}.
4273 $CPAN::META->instance(
4278 my $wrap = qq{I\'d recommend removing $file. Its
4279 checksum is incorrect. Maybe you have configured your 'urllist' with
4280 a bad URL. Please check this array with 'o conf urllist', and
4283 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4285 # former versions just returned here but this seems a
4286 # serious threat that deserves a die
4288 # $CPAN::Frontend->myprint("\n\n");
4292 # close $fh if fileno($fh);
4294 $self->{CHECKSUM_STATUS} ||= "";
4295 if ($self->{CHECKSUM_STATUS} eq "NIL") {
4296 $CPAN::Frontend->mywarn(qq{
4297 Warning: No checksum for $basename in $chk_file.
4299 The cause for this may be that the file is very new and the checksum
4300 has not yet been calculated, but it may also be that something is
4301 going awry right now.
4303 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4304 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4306 $self->{CHECKSUM_STATUS} = "NIL";
4311 #-> sub CPAN::Distribution::eq_CHECKSUM ;
4313 my($self,$fh,$expect) = @_;
4314 my $dg = Digest::SHA->new(256);
4316 while (read($fh, $data, 4096)){
4319 my $hexdigest = $dg->hexdigest;
4320 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4321 $hexdigest eq $expect;
4324 #-> sub CPAN::Distribution::force ;
4326 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
4327 # effect by autoinspection, not by inspecting a global variable. One
4328 # of the reason why this was chosen to work that way was the treatment
4329 # of dependencies. They should not automatically inherit the force
4330 # status. But this has the downside that ^C and die() will return to
4331 # the prompt but will not be able to reset the force_update
4332 # attributes. We try to correct for it currently in the read_metadata
4333 # routine, and immediately before we check for a Signal. I hope this
4334 # works out in one of v1.57_53ff
4337 my($self, $method) = @_;
4339 CHECKSUM_STATUS archived build_dir localfile make install unwrapped
4342 delete $self->{$att};
4344 if ($method && $method eq "install") {
4345 $self->{"force_update"}++; # name should probably have been force_install
4350 my($self, $method) = @_;
4351 # warn "XDEBUG: set notest for $self $method";
4352 $self->{"notest"}++; # name should probably have been force_install
4357 # warn "XDEBUG: deleting notest";
4358 delete $self->{'notest'};
4361 #-> sub CPAN::Distribution::unforce ;
4364 delete $self->{'force_update'};
4367 #-> sub CPAN::Distribution::isa_perl ;
4370 my $file = File::Basename::basename($self->id);
4371 if ($file =~ m{ ^ perl
4384 } elsif ($self->cpan_comment
4386 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4392 #-> sub CPAN::Distribution::perl ;
4398 #-> sub CPAN::Distribution::make ;
4401 my $make = $self->{modulebuild} ? "Build" : "make";
4402 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
4403 # Emergency brake if they said install Pippi and get newest perl
4404 if ($self->isa_perl) {
4406 $self->called_for ne $self->id &&
4407 ! $self->{force_update}
4409 # if we die here, we break bundles
4410 $CPAN::Frontend->mywarn(sprintf qq{
4411 The most recent version "%s" of the module "%s"
4412 comes with the current version of perl (%s).
4413 I\'ll build that only if you ask for something like
4418 $CPAN::META->instance(
4432 $self->{archived} eq "NO" and push @e,
4433 "Is neither a tar nor a zip archive.";
4435 $self->{unwrapped} eq "NO" and push @e,
4436 "had problems unarchiving. Please build manually";
4438 exists $self->{writemakefile} &&
4439 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4440 $1 || "Had some problem writing Makefile";
4442 defined $self->{'make'} and push @e,
4443 "Has already been processed within this session";
4445 exists $self->{later} and length($self->{later}) and
4446 push @e, $self->{later};
4448 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4450 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4451 my $builddir = $self->dir;
4452 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4453 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4455 if ($^O eq 'MacOS') {
4456 Mac::BuildTools::make($self);
4461 if ($self->{'configure'}) {
4462 $system = $self->{'configure'};
4463 } elsif ($self->{modulebuild}) {
4464 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4465 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
4467 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4469 # This needs a handler that can be turned on or off:
4470 # $switch = "-MExtUtils::MakeMaker ".
4471 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4473 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4475 unless (exists $self->{writemakefile}) {
4476 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4479 if ($CPAN::Config->{inactivity_timeout}) {
4481 alarm $CPAN::Config->{inactivity_timeout};
4482 local $SIG{CHLD}; # = sub { wait };
4483 if (defined($pid = fork)) {
4488 # note, this exec isn't necessary if
4489 # inactivity_timeout is 0. On the Mac I'd
4490 # suggest, we set it always to 0.
4494 $CPAN::Frontend->myprint("Cannot fork: $!");
4502 $CPAN::Frontend->myprint($@);
4503 $self->{writemakefile} = "NO $@";
4508 $ret = system($system);
4510 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4514 if (-f "Makefile" || -f "Build") {
4515 $self->{writemakefile} = "YES";
4516 delete $self->{make_clean}; # if cleaned before, enable next
4518 $self->{writemakefile} =
4519 qq{NO Makefile.PL refused to write a Makefile.};
4520 # It's probably worth it to record the reason, so let's retry
4522 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4523 # $self->{writemakefile} .= <$fh>;
4527 delete $self->{force_update};
4530 if (my @prereq = $self->unsat_prereq){
4531 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4533 if ($self->{modulebuild}) {
4534 $system = "./Build $CPAN::Config->{mbuild_arg}";
4536 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4538 if (system($system) == 0) {
4539 $CPAN::Frontend->myprint(" $system -- OK\n");
4540 $self->{'make'} = "YES";
4542 $self->{writemakefile} ||= "YES";
4543 $self->{'make'} = "NO";
4544 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4548 sub follow_prereqs {
4550 my(@prereq) = grep {$_ ne "perl"} @_;
4551 return unless @prereq;
4553 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4554 "during [$id] -----\n");
4556 for my $p (@prereq) {
4557 $CPAN::Frontend->myprint(" $p\n");
4560 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4562 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4563 require ExtUtils::MakeMaker;
4564 my $answer = ExtUtils::MakeMaker::prompt(
4565 "Shall I follow them and prepend them to the queue
4566 of modules we are processing right now?", "yes");
4567 $follow = $answer =~ /^\s*y/i;
4571 myprint(" Ignoring dependencies on modules @prereq\n");
4574 # color them as dirty
4575 for my $p (@prereq) {
4576 # warn "calling color_cmd_tmps(0,1)";
4577 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4579 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4580 $self->{later} = "Delayed until after prerequisites";
4581 return 1; # signal success to the queuerunner
4585 #-> sub CPAN::Distribution::unsat_prereq ;
4588 my $prereq_pm = $self->prereq_pm or return;
4590 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4591 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4592 # we were too demanding:
4593 next if $nmo->uptodate;
4595 # if they have not specified a version, we accept any installed one
4596 if (not defined $need_version or
4597 $need_version eq "0" or
4598 $need_version eq "undef") {
4599 next if defined $nmo->inst_file;
4602 # We only want to install prereqs if either they're not installed
4603 # or if the installed version is too old. We cannot omit this
4604 # check, because if 'force' is in effect, nobody else will check.
4605 if (defined $nmo->inst_file) {
4606 my(@all_requirements) = split /\s*,\s*/, $need_version;
4609 RQ: for my $rq (@all_requirements) {
4610 if ($rq =~ s|>=\s*||) {
4611 } elsif ($rq =~ s|>\s*||) {
4613 if (CPAN::Version->vgt($nmo->inst_version,$rq)){
4617 } elsif ($rq =~ s|!=\s*||) {
4619 if (CPAN::Version->vcmp($nmo->inst_version,$rq)){
4625 } elsif ($rq =~ m|<=?\s*|) {
4627 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
4631 if (! CPAN::Version->vgt($rq, $nmo->inst_version)){
4634 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]rq[%s]ok[%d]",
4638 CPAN::Version->readable($rq),
4642 next NEED if $ok == @all_requirements;
4645 if ($self->{sponsored_mods}{$need_module}++){
4646 # We have already sponsored it and for some reason it's still
4647 # not available. So we do nothing. Or what should we do?
4648 # if we push it again, we have a potential infinite loop
4651 push @need, $need_module;
4656 #-> sub CPAN::Distribution::read_yaml ;
4659 return $self->{yaml_content} if exists $self->{yaml_content};
4660 my $build_dir = $self->{build_dir};
4661 my $yaml = File::Spec->catfile($build_dir,"META.yml");
4662 return unless -f $yaml;
4663 if ($CPAN::META->has_inst("YAML")) {
4664 eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
4666 $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
4670 return $self->{yaml_content};
4673 #-> sub CPAN::Distribution::prereq_pm ;
4676 return $self->{prereq_pm} if
4677 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4678 return unless $self->{writemakefile} # no need to have succeeded
4679 # but we must have run it
4680 || $self->{mudulebuild};
4682 if (my $yaml = $self->read_yaml) {
4683 $req = $yaml->{requires};
4684 undef $req unless ref $req eq "HASH" && %$req;
4686 if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
4687 my $eummv = do { local $^W = 0; $1+0; };
4688 if ($eummv < 6.2501) {
4689 # thanks to Slaven for digging that out: MM before
4690 # that could be wrong because it could reflect a
4697 while (my($k,$v) = each %$req) {
4700 } elsif ($k =~ /[A-Za-z]/ &&
4702 $CPAN::META->exists("Module",$v)
4704 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
4705 "requires hash: $k => $v; I'll take both ".
4706 "key and value as a module name\n");
4713 $req = $areq if $do_replace;
4716 delete $req->{perl};
4720 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4721 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4725 $fh = FileHandle->new("<$makefile\0")) {
4728 last if /MakeMaker post_initialize section/;
4730 \s+PREREQ_PM\s+=>\s+(.+)
4733 # warn "Found prereq expr[$p]";
4735 # Regexp modified by A.Speer to remember actual version of file
4736 # PREREQ_PM hash key wants, then add to
4737 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4738 # In case a prereq is mentioned twice, complain.
4739 if ( defined $req->{$1} ) {
4740 warn "Warning: PREREQ_PM mentions $1 more than once, ".
4741 "last mention wins";
4749 $self->{prereq_pm_detected}++;
4750 return $self->{prereq_pm} = $req;
4753 #-> sub CPAN::Distribution::test ;
4758 delete $self->{force_update};
4761 # warn "XDEBUG: checking for notest: $self->{notest} $self";
4762 if ($self->{notest}) {
4763 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
4767 my $make = $self->{modulebuild} ? "Build" : "make";
4768 $CPAN::Frontend->myprint("Running $make test\n");
4769 if (my @prereq = $self->unsat_prereq){
4770 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4774 exists $self->{make} or exists $self->{later} or push @e,
4775 "Make had some problems, maybe interrupted? Won't test";
4777 exists $self->{'make'} and
4778 $self->{'make'} eq 'NO' and
4779 push @e, "Can't test without successful make";
4781 exists $self->{build_dir} or push @e, "Has no own directory";
4782 $self->{badtestcnt} ||= 0;
4783 $self->{badtestcnt} > 0 and
4784 push @e, "Won't repeat unsuccessful test during this command";
4786 exists $self->{later} and length($self->{later}) and
4787 push @e, $self->{later};
4789 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4791 chdir $self->{'build_dir'} or
4792 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4793 $self->debug("Changed directory to $self->{'build_dir'}")
4796 if ($^O eq 'MacOS') {
4797 Mac::BuildTools::make_test($self);
4801 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
4803 : ($ENV{PERLLIB} || "");
4805 $CPAN::META->set_perl5lib;
4807 if ($self->{modulebuild}) {
4808 $system = "./Build test";
4810 $system = join " ", $CPAN::Config->{'make'}, "test";
4812 if (system($system) == 0) {
4813 $CPAN::Frontend->myprint(" $system -- OK\n");
4814 $CPAN::META->is_tested($self->{'build_dir'});
4815 $self->{make_test} = "YES";
4817 $self->{make_test} = "NO";
4818 $self->{badtestcnt}++;
4819 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4823 #-> sub CPAN::Distribution::clean ;
4826 my $make = $self->{modulebuild} ? "Build" : "make";
4827 $CPAN::Frontend->myprint("Running $make clean\n");
4828 unless (exists $self->{build_dir}) {
4829 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
4834 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4835 push @e, "make clean already called once";
4836 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4838 chdir $self->{'build_dir'} or
4839 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4840 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4842 if ($^O eq 'MacOS') {
4843 Mac::BuildTools::make_clean($self);
4848 if ($self->{modulebuild}) {
4849 $system = "./Build clean";
4851 $system = join " ", $CPAN::Config->{'make'}, "clean";
4853 if (system($system) == 0) {
4854 $CPAN::Frontend->myprint(" $system -- OK\n");
4858 # Jost Krieger pointed out that this "force" was wrong because
4859 # it has the effect that the next "install" on this distribution
4860 # will untar everything again. Instead we should bring the
4861 # object's state back to where it is after untarring.
4872 $self->{make_clean} = "YES";
4875 # Hmmm, what to do if make clean failed?
4877 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4879 make clean did not succeed, marking directory as unusable for further work.
4881 $self->force("make"); # so that this directory won't be used again
4886 #-> sub CPAN::Distribution::install ;
4891 delete $self->{force_update};
4894 my $make = $self->{modulebuild} ? "Build" : "make";
4895 $CPAN::Frontend->myprint("Running $make install\n");
4898 exists $self->{build_dir} or push @e, "Has no own directory";
4900 exists $self->{make} or exists $self->{later} or push @e,
4901 "Make had some problems, maybe interrupted? Won't install";
4903 exists $self->{'make'} and
4904 $self->{'make'} eq 'NO' and
4905 push @e, "make had returned bad status, install seems impossible";
4907 push @e, "make test had returned bad status, ".
4908 "won't install without force"
4909 if exists $self->{'make_test'} and
4910 $self->{'make_test'} eq 'NO' and
4911 ! $self->{'force_update'};
4913 exists $self->{'install'} and push @e,
4914 $self->{'install'} eq "YES" ?
4915 "Already done" : "Already tried without success";
4917 exists $self->{later} and length($self->{later}) and
4918 push @e, $self->{later};
4920 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4922 chdir $self->{'build_dir'} or
4923 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4924 $self->debug("Changed directory to $self->{'build_dir'}")
4927 if ($^O eq 'MacOS') {
4928 Mac::BuildTools::make_install($self);
4933 if ($self->{modulebuild}) {
4934 my($mbuild_install_build_command) = $CPAN::Config->{'mbuild_install_build_command'} ||
4937 $mbuild_install_build_command,
4939 $CPAN::Config->{mbuild_install_arg},
4942 my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
4943 $CPAN::Config->{'make'};
4945 $make_install_make_command,
4947 $CPAN::Config->{make_install_arg},
4951 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4952 my($pipe) = FileHandle->new("$system $stderr |");
4955 $CPAN::Frontend->myprint($_);
4960 $CPAN::Frontend->myprint(" $system -- OK\n");
4961 $CPAN::META->is_installed($self->{'build_dir'});
4962 return $self->{'install'} = "YES";
4964 $self->{'install'} = "NO";
4965 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4967 $makeout =~ /permission/s
4970 ! $CPAN::Config->{make_install_make_command}
4971 || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
4974 $CPAN::Frontend->myprint(
4976 qq{ You may have to su }.
4977 qq{to root to install the package\n}.
4978 qq{ (Or you may want to run something like\n}.
4979 qq{ o conf make_install_make_command 'sudo make'\n}.
4980 qq{ to raise your permissions.}
4984 delete $self->{force_update};
4987 #-> sub CPAN::Distribution::dir ;
4989 shift->{'build_dir'};
4992 #-> sub CPAN::Distribution::perldoc ;
4996 my($dist) = $self->id;
4997 my $package = $self->called_for;
4999 $self->_display_url( $CPAN::Defaultdocs . $package );
5002 #-> sub CPAN::Distribution::_check_binary ;
5004 my ($dist,$shell,$binary) = @_;
5005 my ($pid,$readme,$out);
5007 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
5010 $pid = open $readme, "which $binary|"
5011 or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
5015 close $readme or die "Could not run 'which $binary': $!";
5017 $CPAN::Frontend->myprint(qq{ + $out \n})
5018 if $CPAN::DEBUG && $out;
5023 #-> sub CPAN::Distribution::_display_url ;
5025 my($self,$url) = @_;
5026 my($res,$saved_file,$pid,$readme,$out);
5028 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
5031 # should we define it in the config instead?
5032 my $html_converter = "html2text";
5034 my $web_browser = $CPAN::Config->{'lynx'} || undef;
5035 my $web_browser_out = $web_browser
5036 ? CPAN::Distribution->_check_binary($self,$web_browser)
5039 my ($tmpout,$tmperr);
5040 if (not $web_browser_out) {
5041 # web browser not found, let's try text only
5042 my $html_converter_out =
5043 CPAN::Distribution->_check_binary($self,$html_converter);
5045 if ($html_converter_out ) {
5046 # html2text found, run it
5047 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
5048 $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
5049 unless defined($saved_file);
5051 $pid = open $readme, "$html_converter $saved_file |"
5052 or $CPAN::Frontend->mydie(qq{
5053 Could not fork '$html_converter $saved_file': $!});
5054 my $fh = File::Temp->new(
5055 template => 'cpan_htmlconvert_XXXX',
5063 or $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
5064 my $tmpin = $fh->filename;
5065 $CPAN::Frontend->myprint(sprintf(qq{
5067 saved output to %s\n},
5072 close $fh; undef $fh;
5074 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
5075 my $fh_pager = FileHandle->new;
5076 local($SIG{PIPE}) = "IGNORE";
5077 $fh_pager->open("|$CPAN::Config->{'pager'}")
5078 or $CPAN::Frontend->mydie(qq{
5079 Could not open pager $CPAN::Config->{'pager'}: $!});
5080 $CPAN::Frontend->myprint(qq{
5083 with pager "$CPAN::Config->{'pager'}"
5086 $fh_pager->print(<$fh>);
5089 # coldn't find the web browser or html converter
5090 $CPAN::Frontend->myprint(qq{
5091 You need to install lynx or $html_converter to use this feature.});
5094 # web browser found, run the action
5095 my $browser = $CPAN::Config->{'lynx'};
5096 $CPAN::Frontend->myprint(qq{system[$browser $url]})
5098 $CPAN::Frontend->myprint(qq{
5101 with browser $browser
5104 system("$browser $url");
5105 if ($saved_file) { 1 while unlink($saved_file) }
5109 #-> sub CPAN::Distribution::_getsave_url ;
5111 my($dist, $shell, $url) = @_;
5113 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
5116 my $fh = File::Temp->new(
5117 template => "cpan_getsave_url_XXXX",
5121 my $tmpin = $fh->filename;
5122 if ($CPAN::META->has_usable('LWP')) {
5123 $CPAN::Frontend->myprint("Fetching with LWP:
5127 CPAN::LWP::UserAgent->config;
5128 eval { $Ua = CPAN::LWP::UserAgent->new; };
5130 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
5134 $Ua->proxy('http', $var)
5135 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
5137 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
5140 my $req = HTTP::Request->new(GET => $url);
5141 $req->header('Accept' => 'text/html');
5142 my $res = $Ua->request($req);
5143 if ($res->is_success) {
5144 $CPAN::Frontend->myprint(" + request successful.\n")
5146 print $fh $res->content;
5148 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
5152 $CPAN::Frontend->myprint(sprintf(
5153 "LWP failed with code[%s], message[%s]\n",
5160 $CPAN::Frontend->myprint("LWP not available\n");
5165 package CPAN::Bundle;
5170 $CPAN::Frontend->myprint($self->as_string);
5175 delete $self->{later};
5176 for my $c ( $self->contains ) {
5177 my $obj = CPAN::Shell->expandany($c) or next;
5182 # mark as dirty/clean
5183 #-> sub CPAN::Bundle::color_cmd_tmps ;
5184 sub color_cmd_tmps {
5186 my($depth) = shift || 0;
5187 my($color) = shift || 0;
5188 my($ancestors) = shift || [];
5189 # a module needs to recurse to its cpan_file, a distribution needs
5190 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
5192 return if exists $self->{incommandcolor}
5193 && $self->{incommandcolor}==$color;
5195 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5197 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5199 for my $c ( $self->contains ) {
5200 my $obj = CPAN::Shell->expandany($c) or next;
5201 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
5202 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5205 delete $self->{badtestcnt};
5207 $self->{incommandcolor} = $color;
5210 #-> sub CPAN::Bundle::as_string ;
5214 # following line must be "=", not "||=" because we have a moving target
5215 $self->{INST_VERSION} = $self->inst_version;
5216 return $self->SUPER::as_string;
5219 #-> sub CPAN::Bundle::contains ;
5222 my($inst_file) = $self->inst_file || "";
5223 my($id) = $self->id;
5224 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
5225 unless ($inst_file) {
5226 # Try to get at it in the cpan directory
5227 $self->debug("no inst_file") if $CPAN::DEBUG;
5229 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
5230 $cpan_file = $self->cpan_file;
5231 if ($cpan_file eq "N/A") {
5232 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
5233 Maybe stale symlink? Maybe removed during session? Giving up.\n");
5235 my $dist = $CPAN::META->instance('CPAN::Distribution',
5238 $self->debug($dist->as_string) if $CPAN::DEBUG;
5239 my($todir) = $CPAN::Config->{'cpan_home'};
5240 my(@me,$from,$to,$me);
5241 @me = split /::/, $self->id;
5243 $me = File::Spec->catfile(@me);
5244 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5245 $to = File::Spec->catfile($todir,$me);
5246 File::Path::mkpath(File::Basename::dirname($to));
5247 File::Copy::copy($from, $to)
5248 or Carp::confess("Couldn't copy $from to $to: $!");
5252 my $fh = FileHandle->new;
5254 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
5256 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
5258 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
5259 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
5260 next unless $in_cont;
5265 push @result, (split " ", $_, 2)[0];
5268 delete $self->{STATUS};
5269 $self->{CONTAINS} = \@result;
5270 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5272 $CPAN::Frontend->mywarn(qq{
5273 The bundle file "$inst_file" may be a broken
5274 bundlefile. It seems not to contain any bundle definition.
5275 Please check the file and if it is bogus, please delete it.
5276 Sorry for the inconvenience.
5282 #-> sub CPAN::Bundle::find_bundle_file
5283 sub find_bundle_file {
5284 my($self,$where,$what) = @_;
5285 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5286 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5287 ### my $bu = File::Spec->catfile($where,$what);
5288 ### return $bu if -f $bu;
5289 my $manifest = File::Spec->catfile($where,"MANIFEST");
5290 unless (-f $manifest) {
5291 require ExtUtils::Manifest;
5292 my $cwd = CPAN::anycwd();
5293 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5294 ExtUtils::Manifest::mkmanifest();
5295 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5297 my $fh = FileHandle->new($manifest)
5298 or Carp::croak("Couldn't open $manifest: $!");
5301 if ($^O eq 'MacOS') {
5304 $what2 =~ s/:Bundle://;
5307 $what2 =~ s|Bundle[/\\]||;
5312 my($file) = /(\S+)/;
5313 if ($file =~ m|\Q$what\E$|) {
5315 # return File::Spec->catfile($where,$bu); # bad
5318 # retry if she managed to
5319 # have no Bundle directory
5320 $bu = $file if $file =~ m|\Q$what2\E$|;
5322 $bu =~ tr|/|:| if $^O eq 'MacOS';
5323 return File::Spec->catfile($where, $bu) if $bu;
5324 Carp::croak("Couldn't find a Bundle file in $where");
5327 # needs to work quite differently from Module::inst_file because of
5328 # cpan_home/Bundle/ directory and the possibility that we have
5329 # shadowing effect. As it makes no sense to take the first in @INC for
5330 # Bundles, we parse them all for $VERSION and take the newest.
5332 #-> sub CPAN::Bundle::inst_file ;
5337 @me = split /::/, $self->id;
5340 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5341 my $bfile = File::Spec->catfile($incdir, @me);
5342 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5343 next unless -f $bfile;
5344 my $foundv = MM->parse_version($bfile);
5345 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5346 $self->{INST_FILE} = $bfile;
5347 $self->{INST_VERSION} = $bestv = $foundv;
5353 #-> sub CPAN::Bundle::inst_version ;
5356 $self->inst_file; # finds INST_VERSION as side effect
5357 $self->{INST_VERSION};
5360 #-> sub CPAN::Bundle::rematein ;
5362 my($self,$meth) = @_;
5363 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5364 my($id) = $self->id;
5365 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5366 unless $self->inst_file || $self->cpan_file;
5368 for $s ($self->contains) {
5369 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5370 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5371 if ($type eq 'CPAN::Distribution') {
5372 $CPAN::Frontend->mywarn(qq{
5373 The Bundle }.$self->id.qq{ contains
5374 explicitly a file $s.
5378 # possibly noisy action:
5379 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5380 my $obj = $CPAN::META->instance($type,$s);
5382 if ($obj->isa('CPAN::Bundle')
5384 exists $obj->{install_failed}
5386 ref($obj->{install_failed}) eq "HASH"
5388 for (keys %{$obj->{install_failed}}) {
5389 $self->{install_failed}{$_} = undef; # propagate faiure up
5392 $fail{$s} = 1; # the bundle itself may have succeeded but
5397 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5398 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5400 delete $self->{install_failed}{$s};
5407 # recap with less noise
5408 if ( $meth eq "install" ) {
5411 my $raw = sprintf(qq{Bundle summary:
5412 The following items in bundle %s had installation problems:},
5415 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5416 $CPAN::Frontend->myprint("\n");
5419 for $s ($self->contains) {
5421 $paragraph .= "$s ";
5422 $self->{install_failed}{$s} = undef;
5423 $reported{$s} = undef;
5426 my $report_propagated;
5427 for $s (sort keys %{$self->{install_failed}}) {
5428 next if exists $reported{$s};
5429 $paragraph .= "and the following items had problems
5430 during recursive bundle calls: " unless $report_propagated++;
5431 $paragraph .= "$s ";
5433 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5434 $CPAN::Frontend->myprint("\n");
5436 $self->{'install'} = 'YES';
5441 #sub CPAN::Bundle::xs_file
5443 # If a bundle contains another that contains an xs_file we have
5444 # here, we just don't bother I suppose
5448 #-> sub CPAN::Bundle::force ;
5449 sub force { shift->rematein('force',@_); }
5450 #-> sub CPAN::Bundle::notest ;
5451 sub notest { shift->rematein('notest',@_); }
5452 #-> sub CPAN::Bundle::get ;
5453 sub get { shift->rematein('get',@_); }
5454 #-> sub CPAN::Bundle::make ;
5455 sub make { shift->rematein('make',@_); }
5456 #-> sub CPAN::Bundle::test ;
5459 $self->{badtestcnt} ||= 0;
5460 $self->rematein('test',@_);
5462 #-> sub CPAN::Bundle::install ;
5465 $self->rematein('install',@_);
5467 #-> sub CPAN::Bundle::clean ;
5468 sub clean { shift->rematein('clean',@_); }
5470 #-> sub CPAN::Bundle::uptodate ;
5473 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5475 foreach $c ($self->contains) {
5476 my $obj = CPAN::Shell->expandany($c);
5477 return 0 unless $obj->uptodate;
5482 #-> sub CPAN::Bundle::readme ;
5485 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5486 No File found for bundle } . $self->id . qq{\n}), return;
5487 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5488 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5491 package CPAN::Module;
5495 # sub CPAN::Module::userid
5498 return unless exists $self->{RO}; # should never happen
5499 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5501 # sub CPAN::Module::description
5502 sub description { shift->{RO}{description} }
5506 delete $self->{later};
5507 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5512 # mark as dirty/clean
5513 #-> sub CPAN::Module::color_cmd_tmps ;
5514 sub color_cmd_tmps {
5516 my($depth) = shift || 0;
5517 my($color) = shift || 0;
5518 my($ancestors) = shift || [];
5519 # a module needs to recurse to its cpan_file
5521 return if exists $self->{incommandcolor}
5522 && $self->{incommandcolor}==$color;
5523 return if $depth>=1 && $self->uptodate;
5525 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5527 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5529 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5530 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5533 delete $self->{badtestcnt};
5535 $self->{incommandcolor} = $color;
5538 #-> sub CPAN::Module::as_glimpse ;
5542 my $class = ref($self);
5543 $class =~ s/^CPAN:://;
5547 $CPAN::Shell::COLOR_REGISTERED
5549 $CPAN::META->has_inst("Term::ANSIColor")
5551 $self->{RO}{description}
5553 $color_on = Term::ANSIColor::color("green");
5554 $color_off = Term::ANSIColor::color("reset");
5556 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5565 #-> sub CPAN::Module::as_string ;
5569 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5570 my $class = ref($self);
5571 $class =~ s/^CPAN:://;
5573 push @m, $class, " id = $self->{ID}\n";
5574 my $sprintf = " %-12s %s\n";
5575 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5576 if $self->description;
5577 my $sprintf2 = " %-12s %s (%s)\n";
5579 $userid = $self->userid;
5582 if ($author = CPAN::Shell->expand('Author',$userid)) {
5585 if ($m = $author->email) {
5592 $author->fullname . $email
5596 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5597 if $self->cpan_version;
5598 if (my $cpan_file = $self->cpan_file){
5599 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
5600 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
5601 my $upload_date = $dist->upload_date;
5603 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
5607 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5608 my(%statd,%stats,%statl,%stati);
5609 @statd{qw,? i c a b R M S,} = qw,unknown idea
5610 pre-alpha alpha beta released mature standard,;
5611 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5612 developer comp.lang.perl.* none abandoned,;
5613 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5614 @stati{qw,? f r O h,} = qw,unknown functions
5615 references+ties object-oriented hybrid,;
5616 $statd{' '} = 'unknown';
5617 $stats{' '} = 'unknown';
5618 $statl{' '} = 'unknown';
5619 $stati{' '} = 'unknown';
5627 $statd{$self->{RO}{statd}},
5628 $stats{$self->{RO}{stats}},
5629 $statl{$self->{RO}{statl}},
5630 $stati{$self->{RO}{stati}}
5631 ) if $self->{RO}{statd};
5632 my $local_file = $self->inst_file;
5633 unless ($self->{MANPAGE}) {
5635 $self->{MANPAGE} = $self->manpage_headline($local_file);
5637 # If we have already untarred it, we should look there
5638 my $dist = $CPAN::META->instance('CPAN::Distribution',
5640 # warn "dist[$dist]";
5641 # mff=manifest file; mfh=manifest handle
5646 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5648 $mfh = FileHandle->new($mff)
5650 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5651 my $lfre = $self->id; # local file RE
5654 my($lfl); # local file file
5656 my(@mflines) = <$mfh>;
5661 while (length($lfre)>5 and !$lfl) {
5662 ($lfl) = grep /$lfre/, @mflines;
5663 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5666 $lfl =~ s/\s.*//; # remove comments
5667 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5668 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5669 # warn "lfl_abs[$lfl_abs]";
5671 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5677 for $item (qw/MANPAGE/) {
5678 push @m, sprintf($sprintf, $item, $self->{$item})
5679 if exists $self->{$item};
5681 for $item (qw/CONTAINS/) {
5682 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5683 if exists $self->{$item} && @{$self->{$item}};
5685 push @m, sprintf($sprintf, 'INST_FILE',
5686 $local_file || "(not installed)");
5687 push @m, sprintf($sprintf, 'INST_VERSION',
5688 $self->inst_version) if $local_file;
5692 sub manpage_headline {
5693 my($self,$local_file) = @_;
5694 my(@local_file) = $local_file;
5695 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5696 push @local_file, $local_file;
5698 for $locf (@local_file) {
5699 next unless -f $locf;
5700 my $fh = FileHandle->new($locf)
5701 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5705 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5706 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5719 #-> sub CPAN::Module::cpan_file ;
5720 # Note: also inherited by CPAN::Bundle
5723 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5724 unless (defined $self->{RO}{CPAN_FILE}) {
5725 CPAN::Index->reload;
5727 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5728 return $self->{RO}{CPAN_FILE};
5730 my $userid = $self->userid;
5732 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5733 my $author = $CPAN::META->instance("CPAN::Author",
5735 my $fullname = $author->fullname;
5736 my $email = $author->email;
5737 unless (defined $fullname && defined $email) {
5738 return sprintf("Contact Author %s",
5742 return "Contact Author $fullname <$email>";
5744 return "Contact Author $userid (Email address not available)";
5752 #-> sub CPAN::Module::cpan_version ;
5756 $self->{RO}{CPAN_VERSION} = 'undef'
5757 unless defined $self->{RO}{CPAN_VERSION};
5758 # I believe this is always a bug in the index and should be reported
5759 # as such, but usually I find out such an error and do not want to
5760 # provoke too many bugreports
5762 $self->{RO}{CPAN_VERSION};
5765 #-> sub CPAN::Module::force ;
5768 $self->{'force_update'}++;
5773 # warn "XDEBUG: set notest for Module";
5774 $self->{'notest'}++;
5777 #-> sub CPAN::Module::rematein ;
5779 my($self,$meth) = @_;
5780 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5783 my $cpan_file = $self->cpan_file;
5784 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5785 $CPAN::Frontend->mywarn(sprintf qq{
5786 The module %s isn\'t available on CPAN.
5788 Either the module has not yet been uploaded to CPAN, or it is
5789 temporary unavailable. Please contact the author to find out
5790 more about the status. Try 'i %s'.
5797 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5798 $pack->called_for($self->id);
5799 $pack->force($meth) if exists $self->{'force_update'};
5800 $pack->notest($meth) if exists $self->{'notest'};
5805 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5806 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
5807 delete $self->{'force_update'};
5808 delete $self->{'notest'};
5814 #-> sub CPAN::Module::perldoc ;
5815 sub perldoc { shift->rematein('perldoc') }
5816 #-> sub CPAN::Module::readme ;
5817 sub readme { shift->rematein('readme') }
5818 #-> sub CPAN::Module::look ;
5819 sub look { shift->rematein('look') }
5820 #-> sub CPAN::Module::cvs_import ;
5821 sub cvs_import { shift->rematein('cvs_import') }
5822 #-> sub CPAN::Module::get ;
5823 sub get { shift->rematein('get',@_) }
5824 #-> sub CPAN::Module::make ;
5825 sub make { shift->rematein('make') }
5826 #-> sub CPAN::Module::test ;
5829 $self->{badtestcnt} ||= 0;
5830 $self->rematein('test',@_);
5832 #-> sub CPAN::Module::uptodate ;
5835 my($latest) = $self->cpan_version;
5837 my($inst_file) = $self->inst_file;
5839 if (defined $inst_file) {
5840 $have = $self->inst_version;
5845 ! CPAN::Version->vgt($latest, $have)
5847 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5848 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5853 #-> sub CPAN::Module::install ;
5859 not exists $self->{'force_update'}
5861 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5865 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
5866 $CPAN::Frontend->mywarn(qq{
5867 \n\n\n ***WARNING***
5868 The module $self->{ID} has no active maintainer.\n\n\n
5872 $self->rematein('install') if $doit;
5874 #-> sub CPAN::Module::clean ;
5875 sub clean { shift->rematein('clean') }
5877 #-> sub CPAN::Module::inst_file ;
5881 @packpath = split /::/, $self->{ID};
5882 $packpath[-1] .= ".pm";
5883 foreach $dir (@INC) {
5884 my $pmfile = File::Spec->catfile($dir,@packpath);
5892 #-> sub CPAN::Module::xs_file ;
5896 @packpath = split /::/, $self->{ID};
5897 push @packpath, $packpath[-1];
5898 $packpath[-1] .= "." . $Config::Config{'dlext'};
5899 foreach $dir (@INC) {
5900 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5908 #-> sub CPAN::Module::inst_version ;
5911 my $parsefile = $self->inst_file or return;
5912 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5915 # there was a bug in 5.6.0 that let lots of unini warnings out of
5916 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5917 # the following workaround after 5.6.1 is out.
5918 local($SIG{__WARN__}) = sub { my $w = shift;
5919 return if $w =~ /uninitialized/i;
5923 $have = MM->parse_version($parsefile) || "undef";
5924 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5925 $have =~ s/ $//; # trailing whitespace happens all the time
5927 # My thoughts about why %vd processing should happen here
5929 # Alt1 maintain it as string with leading v:
5930 # read index files do nothing
5931 # compare it use utility for compare
5932 # print it do nothing
5934 # Alt2 maintain it as what it is
5935 # read index files convert
5936 # compare it use utility because there's still a ">" vs "gt" issue
5937 # print it use CPAN::Version for print
5939 # Seems cleaner to hold it in memory as a string starting with a "v"
5941 # If the author of this module made a mistake and wrote a quoted
5942 # "v1.13" instead of v1.13, we simply leave it at that with the
5943 # effect that *we* will treat it like a v-tring while the rest of
5944 # perl won't. Seems sensible when we consider that any action we
5945 # could take now would just add complexity.
5947 $have = CPAN::Version->readable($have);
5949 $have =~ s/\s*//g; # stringify to float around floating point issues
5950 $have; # no stringify needed, \s* above matches always
5962 CPAN - query, download and build perl modules from CPAN sites
5968 perl -MCPAN -e shell;
5974 autobundle, clean, install, make, recompile, test
5978 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
5979 of a modern rewrite from ground up with greater extensibility and more
5980 features but no full compatibility. If you're new to CPAN.pm, you
5981 probably should investigate if CPANPLUS is the better choice for you.
5982 If you're already used to CPAN.pm you're welcome to continue using it,
5983 if you accept that its development is mostly (though not completely)
5988 The CPAN module is designed to automate the make and install of perl
5989 modules and extensions. It includes some primitive searching capabilities and
5990 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5991 to fetch the raw data from the net.
5993 Modules are fetched from one or more of the mirrored CPAN
5994 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5997 The CPAN module also supports the concept of named and versioned
5998 I<bundles> of modules. Bundles simplify the handling of sets of
5999 related modules. See Bundles below.
6001 The package contains a session manager and a cache manager. There is
6002 no status retained between sessions. The session manager keeps track
6003 of what has been fetched, built and installed in the current
6004 session. The cache manager keeps track of the disk space occupied by
6005 the make processes and deletes excess space according to a simple FIFO
6008 For extended searching capabilities there's a plugin for CPAN available,
6009 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6010 that indexes all documents available in CPAN authors directories. If
6011 C<CPAN::WAIT> is installed on your system, the interactive shell of
6012 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6013 which send queries to the WAIT server that has been configured for your
6016 All other methods provided are accessible in a programmer style and in an
6017 interactive shell style.
6019 =head2 Interactive Mode
6021 The interactive mode is entered by running
6023 perl -MCPAN -e shell
6025 which puts you into a readline interface. You will have the most fun if
6026 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6029 Once you are on the command line, type 'h' and the rest should be
6032 The function call C<shell> takes two optional arguments, one is the
6033 prompt, the second is the default initial command line (the latter
6034 only works if a real ReadLine interface module is installed).
6036 The most common uses of the interactive modes are
6040 =item Searching for authors, bundles, distribution files and modules
6042 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6043 for each of the four categories and another, C<i> for any of the
6044 mentioned four. Each of the four entities is implemented as a class
6045 with slightly differing methods for displaying an object.
6047 Arguments you pass to these commands are either strings exactly matching
6048 the identification string of an object or regular expressions that are
6049 then matched case-insensitively against various attributes of the
6050 objects. The parser recognizes a regular expression only if you
6051 enclose it between two slashes.
6053 The principle is that the number of found objects influences how an
6054 item is displayed. If the search finds one item, the result is
6055 displayed with the rather verbose method C<as_string>, but if we find
6056 more than one, we display each object with the terse method
6059 =item make, test, install, clean modules or distributions
6061 These commands take any number of arguments and investigate what is
6062 necessary to perform the action. If the argument is a distribution
6063 file name (recognized by embedded slashes), it is processed. If it is
6064 a module, CPAN determines the distribution file in which this module
6065 is included and processes that, following any dependencies named in
6066 the module's META.yml or Makefile.PL (this behavior is controlled by
6067 I<prerequisites_policy>.)
6069 Any C<make> or C<test> are run unconditionally. An
6071 install <distribution_file>
6073 also is run unconditionally. But for
6077 CPAN checks if an install is actually needed for it and prints
6078 I<module up to date> in the case that the distribution file containing
6079 the module doesn't need to be updated.
6081 CPAN also keeps track of what it has done within the current session
6082 and doesn't try to build a package a second time regardless if it
6083 succeeded or not. The C<force> pragma may precede another command
6084 (currently: C<make>, C<test>, or C<install>) and executes the
6085 command from scratch.
6089 cpan> install OpenGL
6090 OpenGL is up to date.
6091 cpan> force install OpenGL
6094 OpenGL-0.4/COPYRIGHT
6097 The C<notest> pragma may be set to skip the test part in the build
6102 cpan> notest install Tk
6104 A C<clean> command results in a
6108 being executed within the distribution file's working directory.
6110 =item get, readme, perldoc, look module or distribution
6112 C<get> downloads a distribution file without further action. C<readme>
6113 displays the README file of the associated distribution. C<Look> gets
6114 and untars (if not yet done) the distribution file, changes to the
6115 appropriate directory and opens a subshell process in that directory.
6116 C<perldoc> displays the pod documentation of the module in html or
6121 =item ls globbing_expresion
6123 The first form lists all distribution files in and below an author's
6124 CPAN directory as they are stored in the CHECKUMS files distrbute on
6127 The second form allows to limit or expand the output with shell
6128 globbing as in the following examples:
6134 The last example is very slow and outputs extra progress indicators
6135 that break the alignment of the result.
6139 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6140 in the cpan-shell it is intended that you can press C<^C> anytime and
6141 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6142 to clean up and leave the shell loop. You can emulate the effect of a
6143 SIGTERM by sending two consecutive SIGINTs, which usually means by
6144 pressing C<^C> twice.
6146 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6147 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
6148 Build.PL> subprocess.
6154 The commands that are available in the shell interface are methods in
6155 the package CPAN::Shell. If you enter the shell command, all your
6156 input is split by the Text::ParseWords::shellwords() routine which
6157 acts like most shells do. The first word is being interpreted as the
6158 method to be called and the rest of the words are treated as arguments
6159 to this method. Continuation lines are supported if a line ends with a
6164 C<autobundle> writes a bundle file into the
6165 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6166 a list of all modules that are both available from CPAN and currently
6167 installed within @INC. The name of the bundle file is based on the
6168 current date and a counter.
6172 recompile() is a very special command in that it takes no argument and
6173 runs the make/test/install cycle with brute force over all installed
6174 dynamically loadable extensions (aka XS modules) with 'force' in
6175 effect. The primary purpose of this command is to finish a network
6176 installation. Imagine, you have a common source tree for two different
6177 architectures. You decide to do a completely independent fresh
6178 installation. You start on one architecture with the help of a Bundle
6179 file produced earlier. CPAN installs the whole Bundle for you, but
6180 when you try to repeat the job on the second architecture, CPAN
6181 responds with a C<"Foo up to date"> message for all modules. So you
6182 invoke CPAN's recompile on the second architecture and you're done.
6184 Another popular use for C<recompile> is to act as a rescue in case your
6185 perl breaks binary compatibility. If one of the modules that CPAN uses
6186 is in turn depending on binary compatibility (so you cannot run CPAN
6187 commands), then you should try the CPAN::Nox module for recovery.
6189 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6191 Although it may be considered internal, the class hierarchy does matter
6192 for both users and programmer. CPAN.pm deals with above mentioned four
6193 classes, and all those classes share a set of methods. A classical
6194 single polymorphism is in effect. A metaclass object registers all
6195 objects of all kinds and indexes them with a string. The strings
6196 referencing objects have a separated namespace (well, not completely
6201 words containing a "/" (slash) Distribution
6202 words starting with Bundle:: Bundle
6203 everything else Module or Author
6205 Modules know their associated Distribution objects. They always refer
6206 to the most recent official release. Developers may mark their releases
6207 as unstable development versions (by inserting an underbar into the
6208 module version number which will also be reflected in the distribution
6209 name when you run 'make dist'), so the really hottest and newest
6210 distribution is not always the default. If a module Foo circulates
6211 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6212 way to install version 1.23 by saying
6216 This would install the complete distribution file (say
6217 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6218 like to install version 1.23_90, you need to know where the
6219 distribution file resides on CPAN relative to the authors/id/
6220 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6221 so you would have to say
6223 install BAR/Foo-1.23_90.tar.gz
6225 The first example will be driven by an object of the class
6226 CPAN::Module, the second by an object of class CPAN::Distribution.
6228 =head2 Programmer's interface
6230 If you do not enter the shell, the available shell commands are both
6231 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6232 functions in the calling package (C<install(...)>).
6234 There's currently only one class that has a stable interface -
6235 CPAN::Shell. All commands that are available in the CPAN shell are
6236 methods of the class CPAN::Shell. Each of the commands that produce
6237 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6238 the IDs of all modules within the list.
6242 =item expand($type,@things)
6244 The IDs of all objects available within a program are strings that can
6245 be expanded to the corresponding real objects with the
6246 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6247 list of CPAN::Module objects according to the C<@things> arguments
6248 given. In scalar context it only returns the first element of the
6251 =item expandany(@things)
6253 Like expand, but returns objects of the appropriate type, i.e.
6254 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6255 CPAN::Distribution objects fro distributions.
6257 =item Programming Examples
6259 This enables the programmer to do operations that combine
6260 functionalities that are available in the shell.
6262 # install everything that is outdated on my disk:
6263 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6265 # install my favorite programs if necessary:
6266 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
6267 my $obj = CPAN::Shell->expand('Module',$mod);
6271 # list all modules on my disk that have no VERSION number
6272 for $mod (CPAN::Shell->expand("Module","/./")){
6273 next unless $mod->inst_file;
6274 # MakeMaker convention for undefined $VERSION:
6275 next unless $mod->inst_version eq "undef";
6276 print "No VERSION in ", $mod->id, "\n";
6279 # find out which distribution on CPAN contains a module:
6280 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6282 Or if you want to write a cronjob to watch The CPAN, you could list
6283 all modules that need updating. First a quick and dirty way:
6285 perl -e 'use CPAN; CPAN::Shell->r;'
6287 If you don't want to get any output in the case that all modules are
6288 up to date, you can parse the output of above command for the regular
6289 expression //modules are up to date// and decide to mail the output
6290 only if it doesn't match. Ick?
6292 If you prefer to do it more in a programmer style in one single
6293 process, maybe something like this suits you better:
6295 # list all modules on my disk that have newer versions on CPAN
6296 for $mod (CPAN::Shell->expand("Module","/./")){
6297 next unless $mod->inst_file;
6298 next if $mod->uptodate;
6299 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6300 $mod->id, $mod->inst_version, $mod->cpan_version;
6303 If that gives you too much output every day, you maybe only want to
6304 watch for three modules. You can write
6306 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6308 as the first line instead. Or you can combine some of the above
6311 # watch only for a new mod_perl module
6312 $mod = CPAN::Shell->expand("Module","mod_perl");
6313 exit if $mod->uptodate;
6314 # new mod_perl arrived, let me know all update recommendations
6319 =head2 Methods in the other Classes
6321 The programming interface for the classes CPAN::Module,
6322 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6323 beta and partially even alpha. In the following paragraphs only those
6324 methods are documented that have proven useful over a longer time and
6325 thus are unlikely to change.
6329 =item CPAN::Author::as_glimpse()
6331 Returns a one-line description of the author
6333 =item CPAN::Author::as_string()
6335 Returns a multi-line description of the author
6337 =item CPAN::Author::email()
6339 Returns the author's email address
6341 =item CPAN::Author::fullname()
6343 Returns the author's name
6345 =item CPAN::Author::name()
6347 An alias for fullname
6349 =item CPAN::Bundle::as_glimpse()
6351 Returns a one-line description of the bundle
6353 =item CPAN::Bundle::as_string()
6355 Returns a multi-line description of the bundle
6357 =item CPAN::Bundle::clean()
6359 Recursively runs the C<clean> method on all items contained in the bundle.
6361 =item CPAN::Bundle::contains()
6363 Returns a list of objects' IDs contained in a bundle. The associated
6364 objects may be bundles, modules or distributions.
6366 =item CPAN::Bundle::force($method,@args)
6368 Forces CPAN to perform a task that normally would have failed. Force
6369 takes as arguments a method name to be called and any number of
6370 additional arguments that should be passed to the called method. The
6371 internals of the object get the needed changes so that CPAN.pm does
6372 not refuse to take the action. The C<force> is passed recursively to
6373 all contained objects.
6375 =item CPAN::Bundle::get()
6377 Recursively runs the C<get> method on all items contained in the bundle
6379 =item CPAN::Bundle::inst_file()
6381 Returns the highest installed version of the bundle in either @INC or
6382 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6383 CPAN::Module::inst_file.
6385 =item CPAN::Bundle::inst_version()
6387 Like CPAN::Bundle::inst_file, but returns the $VERSION
6389 =item CPAN::Bundle::uptodate()
6391 Returns 1 if the bundle itself and all its members are uptodate.
6393 =item CPAN::Bundle::install()
6395 Recursively runs the C<install> method on all items contained in the bundle
6397 =item CPAN::Bundle::make()
6399 Recursively runs the C<make> method on all items contained in the bundle
6401 =item CPAN::Bundle::readme()
6403 Recursively runs the C<readme> method on all items contained in the bundle
6405 =item CPAN::Bundle::test()
6407 Recursively runs the C<test> method on all items contained in the bundle
6409 =item CPAN::Distribution::as_glimpse()
6411 Returns a one-line description of the distribution
6413 =item CPAN::Distribution::as_string()
6415 Returns a multi-line description of the distribution
6417 =item CPAN::Distribution::clean()
6419 Changes to the directory where the distribution has been unpacked and
6420 runs C<make clean> there.
6422 =item CPAN::Distribution::containsmods()
6424 Returns a list of IDs of modules contained in a distribution file.
6425 Only works for distributions listed in the 02packages.details.txt.gz
6426 file. This typically means that only the most recent version of a
6427 distribution is covered.
6429 =item CPAN::Distribution::cvs_import()
6431 Changes to the directory where the distribution has been unpacked and
6434 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6438 =item CPAN::Distribution::dir()
6440 Returns the directory into which this distribution has been unpacked.
6442 =item CPAN::Distribution::force($method,@args)
6444 Forces CPAN to perform a task that normally would have failed. Force
6445 takes as arguments a method name to be called and any number of
6446 additional arguments that should be passed to the called method. The
6447 internals of the object get the needed changes so that CPAN.pm does
6448 not refuse to take the action.
6450 =item CPAN::Distribution::get()
6452 Downloads the distribution from CPAN and unpacks it. Does nothing if
6453 the distribution has already been downloaded and unpacked within the
6456 =item CPAN::Distribution::install()
6458 Changes to the directory where the distribution has been unpacked and
6459 runs the external command C<make install> there. If C<make> has not
6460 yet been run, it will be run first. A C<make test> will be issued in
6461 any case and if this fails, the install will be canceled. The
6462 cancellation can be avoided by letting C<force> run the C<install> for
6465 =item CPAN::Distribution::isa_perl()
6467 Returns 1 if this distribution file seems to be a perl distribution.
6468 Normally this is derived from the file name only, but the index from
6469 CPAN can contain a hint to achieve a return value of true for other
6472 =item CPAN::Distribution::look()
6474 Changes to the directory where the distribution has been unpacked and
6475 opens a subshell there. Exiting the subshell returns.
6477 =item CPAN::Distribution::make()
6479 First runs the C<get> method to make sure the distribution is
6480 downloaded and unpacked. Changes to the directory where the
6481 distribution has been unpacked and runs the external commands C<perl
6482 Makefile.PL> or C<perl Build.PL> and C<make> there.
6484 =item CPAN::Distribution::prereq_pm()
6486 Returns the hash reference that has been announced by a distribution
6487 as the C<requires> element of the META.yml or the C<PREREQ_PM> hash in
6488 the C<Makefile.PL>. Note: works only after an attempt has been made to
6489 C<make> the distribution. Returns undef otherwise.
6491 =item CPAN::Distribution::readme()
6493 Downloads the README file associated with a distribution and runs it
6494 through the pager specified in C<$CPAN::Config->{pager}>.
6496 =item CPAN::Distribution::perldoc()
6498 Downloads the pod documentation of the file associated with a
6499 distribution (in html format) and runs it through the external
6500 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
6501 isn't available, it converts it to plain text with external
6502 command html2text and runs it through the pager specified
6503 in C<$CPAN::Config->{pager}>
6505 =item CPAN::Distribution::test()
6507 Changes to the directory where the distribution has been unpacked and
6508 runs C<make test> there.
6510 =item CPAN::Distribution::uptodate()
6512 Returns 1 if all the modules contained in the distribution are
6513 uptodate. Relies on containsmods.
6515 =item CPAN::Index::force_reload()
6517 Forces a reload of all indices.
6519 =item CPAN::Index::reload()
6521 Reloads all indices if they have been read more than
6522 C<$CPAN::Config->{index_expire}> days.
6524 =item CPAN::InfoObj::dump()
6526 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6527 inherit this method. It prints the data structure associated with an
6528 object. Useful for debugging. Note: the data structure is considered
6529 internal and thus subject to change without notice.
6531 =item CPAN::Module::as_glimpse()
6533 Returns a one-line description of the module
6535 =item CPAN::Module::as_string()
6537 Returns a multi-line description of the module
6539 =item CPAN::Module::clean()
6541 Runs a clean on the distribution associated with this module.
6543 =item CPAN::Module::cpan_file()
6545 Returns the filename on CPAN that is associated with the module.
6547 =item CPAN::Module::cpan_version()
6549 Returns the latest version of this module available on CPAN.
6551 =item CPAN::Module::cvs_import()
6553 Runs a cvs_import on the distribution associated with this module.
6555 =item CPAN::Module::description()
6557 Returns a 44 character description of this module. Only available for
6558 modules listed in The Module List (CPAN/modules/00modlist.long.html
6559 or 00modlist.long.txt.gz)
6561 =item CPAN::Module::force($method,@args)
6563 Forces CPAN to perform a task that normally would have failed. Force
6564 takes as arguments a method name to be called and any number of
6565 additional arguments that should be passed to the called method. The
6566 internals of the object get the needed changes so that CPAN.pm does
6567 not refuse to take the action.
6569 =item CPAN::Module::get()
6571 Runs a get on the distribution associated with this module.
6573 =item CPAN::Module::inst_file()
6575 Returns the filename of the module found in @INC. The first file found
6576 is reported just like perl itself stops searching @INC when it finds a
6579 =item CPAN::Module::inst_version()
6581 Returns the version number of the module in readable format.
6583 =item CPAN::Module::install()
6585 Runs an C<install> on the distribution associated with this module.
6587 =item CPAN::Module::look()
6589 Changes to the directory where the distribution associated with this
6590 module has been unpacked and opens a subshell there. Exiting the
6593 =item CPAN::Module::make()
6595 Runs a C<make> on the distribution associated with this module.
6597 =item CPAN::Module::manpage_headline()
6599 If module is installed, peeks into the module's manpage, reads the
6600 headline and returns it. Moreover, if the module has been downloaded
6601 within this session, does the equivalent on the downloaded module even
6602 if it is not installed.
6604 =item CPAN::Module::readme()
6606 Runs a C<readme> on the distribution associated with this module.
6608 =item CPAN::Module::perldoc()
6610 Runs a C<perldoc> on this module.
6612 =item CPAN::Module::test()
6614 Runs a C<test> on the distribution associated with this module.
6616 =item CPAN::Module::uptodate()
6618 Returns 1 if the module is installed and up-to-date.
6620 =item CPAN::Module::userid()
6622 Returns the author's ID of the module.
6626 =head2 Cache Manager
6628 Currently the cache manager only keeps track of the build directory
6629 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6630 deletes complete directories below C<build_dir> as soon as the size of
6631 all directories there gets bigger than $CPAN::Config->{build_cache}
6632 (in MB). The contents of this cache may be used for later
6633 re-installations that you intend to do manually, but will never be
6634 trusted by CPAN itself. This is due to the fact that the user might
6635 use these directories for building modules on different architectures.
6637 There is another directory ($CPAN::Config->{keep_source_where}) where
6638 the original distribution files are kept. This directory is not
6639 covered by the cache manager and must be controlled by the user. If
6640 you choose to have the same directory as build_dir and as
6641 keep_source_where directory, then your sources will be deleted with
6642 the same fifo mechanism.
6646 A bundle is just a perl module in the namespace Bundle:: that does not
6647 define any functions or methods. It usually only contains documentation.
6649 It starts like a perl module with a package declaration and a $VERSION
6650 variable. After that the pod section looks like any other pod with the
6651 only difference being that I<one special pod section> exists starting with
6656 In this pod section each line obeys the format
6658 Module_Name [Version_String] [- optional text]
6660 The only required part is the first field, the name of a module
6661 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6662 of the line is optional. The comment part is delimited by a dash just
6663 as in the man page header.
6665 The distribution of a bundle should follow the same convention as
6666 other distributions.
6668 Bundles are treated specially in the CPAN package. If you say 'install
6669 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6670 the modules in the CONTENTS section of the pod. You can install your
6671 own Bundles locally by placing a conformant Bundle file somewhere into
6672 your @INC path. The autobundle() command which is available in the
6673 shell interface does that for you by including all currently installed
6674 modules in a snapshot bundle file.
6676 =head2 Prerequisites
6678 If you have a local mirror of CPAN and can access all files with
6679 "file:" URLs, then you only need a perl better than perl5.003 to run
6680 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6681 required for non-UNIX systems or if your nearest CPAN site is
6682 associated with a URL that is not C<ftp:>.
6684 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6685 implemented for an external ftp command or for an external lynx
6688 =head2 Finding packages and VERSION
6690 This module presumes that all packages on CPAN
6696 declare their $VERSION variable in an easy to parse manner. This
6697 prerequisite can hardly be relaxed because it consumes far too much
6698 memory to load all packages into the running program just to determine
6699 the $VERSION variable. Currently all programs that are dealing with
6700 version use something like this
6702 perl -MExtUtils::MakeMaker -le \
6703 'print MM->parse_version(shift)' filename
6705 If you are author of a package and wonder if your $VERSION can be
6706 parsed, please try the above method.
6710 come as compressed or gzipped tarfiles or as zip files and contain a
6711 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
6712 without much enthusiasm).
6718 The debugging of this module is a bit complex, because we have
6719 interferences of the software producing the indices on CPAN, of the
6720 mirroring process on CPAN, of packaging, of configuration, of
6721 synchronicity, and of bugs within CPAN.pm.
6723 For code debugging in interactive mode you can try "o debug" which
6724 will list options for debugging the various parts of the code. You
6725 should know that "o debug" has built-in completion support.
6727 For data debugging there is the C<dump> command which takes the same
6728 arguments as make/test/install and outputs the object's Data::Dumper
6731 =head2 Floppy, Zip, Offline Mode
6733 CPAN.pm works nicely without network too. If you maintain machines
6734 that are not networked at all, you should consider working with file:
6735 URLs. Of course, you have to collect your modules somewhere first. So
6736 you might use CPAN.pm to put together all you need on a networked
6737 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6738 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6739 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6740 with this floppy. See also below the paragraph about CD-ROM support.
6742 =head1 CONFIGURATION
6744 When the CPAN module is used for the first time, a configuration
6745 dialog tries to determine a couple of site specific options. The
6746 result of the dialog is stored in a hash reference C< $CPAN::Config >
6747 in a file CPAN/Config.pm.
6749 The default values defined in the CPAN/Config.pm file can be
6750 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6751 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6752 added to the search path of the CPAN module before the use() or
6753 require() statements.
6755 The configuration dialog can be started any time later again by
6756 issuing the command C< o conf init > in the CPAN shell.
6758 Currently the following keys in the hash reference $CPAN::Config are
6761 build_cache size of cache for directories to build modules
6762 build_dir locally accessible directory to build modules
6763 index_expire after this many days refetch index files
6764 cache_metadata use serializer to cache metadata
6765 cpan_home local directory reserved for this package
6766 dontload_hash anonymous hash: modules in the keys will not be
6767 loaded by the CPAN::has_inst() routine
6768 gzip location of external program gzip
6769 histfile file to maintain history between sessions
6770 histsize maximum number of lines to keep in histfile
6771 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
6772 after this many seconds inactivity. Set to 0 to
6774 inhibit_startup_message
6775 if true, does not print the startup message
6776 keep_source_where directory in which to keep the source (if we do)
6777 make location of external make program
6778 make_arg arguments that should always be passed to 'make'
6779 make_install_make_command
6780 the make command for running 'make install', for
6782 make_install_arg same as make_arg for 'make install'
6783 makepl_arg arguments passed to 'perl Makefile.PL'
6784 mbuild_arg arguments passed to './Build'
6785 mbuild_install_arg arguments passed to './Build install'
6786 mbuild_install_build_command
6787 command to use instead of './Build' when we are
6788 in the install stage, for example 'sudo ./Build'
6789 mbuildpl_arg arguments passed to 'perl Build.PL'
6790 pager location of external program more (or any pager)
6791 prefer_installer legal values are MB and EUMM: if a module
6792 comes with both a Makefile.PL and a Build.PL, use
6793 the former (EUMM) or the latter (MB)
6794 prerequisites_policy
6795 what to do if you are missing module prerequisites
6796 ('follow' automatically, 'ask' me, or 'ignore')
6797 proxy_user username for accessing an authenticating proxy
6798 proxy_pass password for accessing an authenticating proxy
6799 scan_cache controls scanning of cache ('atstart' or 'never')
6800 tar location of external program tar
6801 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6802 (and nonsense for characters outside latin range)
6803 unzip location of external program unzip
6804 urllist arrayref to nearby CPAN sites (or equivalent locations)
6805 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6806 ftp_proxy, } the three usual variables for configuring
6807 http_proxy, } proxy requests. Both as CPAN::Config variables
6808 no_proxy } and as environment variables configurable.
6810 You can set and query each of these options interactively in the cpan
6811 shell with the command set defined within the C<o conf> command:
6815 =item C<o conf E<lt>scalar optionE<gt>>
6817 prints the current value of the I<scalar option>
6819 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6821 Sets the value of the I<scalar option> to I<value>
6823 =item C<o conf E<lt>list optionE<gt>>
6825 prints the current value of the I<list option> in MakeMaker's
6828 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6830 shifts or pops the array in the I<list option> variable
6832 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6834 works like the corresponding perl commands.
6838 =head2 Note on urllist parameter's format
6840 urllist parameters are URLs according to RFC 1738. We do a little
6841 guessing if your URL is not compliant, but if you have problems with
6842 file URLs, please try the correct format. Either:
6844 file://localhost/whatever/ftp/pub/CPAN/
6848 file:///home/ftp/pub/CPAN/
6850 =head2 urllist parameter has CD-ROM support
6852 The C<urllist> parameter of the configuration table contains a list of
6853 URLs that are to be used for downloading. If the list contains any
6854 C<file> URLs, CPAN always tries to get files from there first. This
6855 feature is disabled for index files. So the recommendation for the
6856 owner of a CD-ROM with CPAN contents is: include your local, possibly
6857 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6859 o conf urllist push file://localhost/CDROM/CPAN
6861 CPAN.pm will then fetch the index files from one of the CPAN sites
6862 that come at the beginning of urllist. It will later check for each
6863 module if there is a local copy of the most recent version.
6865 Another peculiarity of urllist is that the site that we could
6866 successfully fetch the last file from automatically gets a preference
6867 token and is tried as the first site for the next request. So if you
6868 add a new site at runtime it may happen that the previously preferred
6869 site will be tried another time. This means that if you want to disallow
6870 a site for the next transfer, it must be explicitly removed from
6875 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6876 install foreign, unmasked, unsigned code on your machine. We compare
6877 to a checksum that comes from the net just as the distribution file
6878 itself. If somebody has managed to tamper with the distribution file,
6879 they may have as well tampered with the CHECKSUMS file. Future
6880 development will go towards strong authentication.
6884 Most functions in package CPAN are exported per default. The reason
6885 for this is that the primary use is intended for the cpan shell or for
6888 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6890 Populating a freshly installed perl with my favorite modules is pretty
6891 easy if you maintain a private bundle definition file. To get a useful
6892 blueprint of a bundle definition file, the command autobundle can be used
6893 on the CPAN shell command line. This command writes a bundle definition
6894 file for all modules that are installed for the currently running perl
6895 interpreter. It's recommended to run this command only once and from then
6896 on maintain the file manually under a private name, say
6897 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6899 cpan> install Bundle::my_bundle
6901 then answer a few questions and then go out for a coffee.
6903 Maintaining a bundle definition file means keeping track of two
6904 things: dependencies and interactivity. CPAN.pm sometimes fails on
6905 calculating dependencies because not all modules define all MakeMaker
6906 attributes correctly, so a bundle definition file should specify
6907 prerequisites as early as possible. On the other hand, it's a bit
6908 annoying that many distributions need some interactive configuring. So
6909 what I try to accomplish in my private bundle file is to have the
6910 packages that need to be configured early in the file and the gentle
6911 ones later, so I can go out after a few minutes and leave CPAN.pm
6914 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6916 Thanks to Graham Barr for contributing the following paragraphs about
6917 the interaction between perl, and various firewall configurations. For
6918 further information on firewalls, it is recommended to consult the
6919 documentation that comes with the ncftp program. If you are unable to
6920 go through the firewall with a simple Perl setup, it is very likely
6921 that you can configure ncftp so that it works for your firewall.
6923 =head2 Three basic types of firewalls
6925 Firewalls can be categorized into three basic types.
6931 This is where the firewall machine runs a web server and to access the
6932 outside world you must do it via the web server. If you set environment
6933 variables like http_proxy or ftp_proxy to a values beginning with http://
6934 or in your web browser you have to set proxy information then you know
6935 you are running an http firewall.
6937 To access servers outside these types of firewalls with perl (even for
6938 ftp) you will need to use LWP.
6942 This where the firewall machine runs an ftp server. This kind of
6943 firewall will only let you access ftp servers outside the firewall.
6944 This is usually done by connecting to the firewall with ftp, then
6945 entering a username like "user@outside.host.com"
6947 To access servers outside these type of firewalls with perl you
6948 will need to use Net::FTP.
6950 =item One way visibility
6952 I say one way visibility as these firewalls try to make themselves look
6953 invisible to the users inside the firewall. An FTP data connection is
6954 normally created by sending the remote server your IP address and then
6955 listening for the connection. But the remote server will not be able to
6956 connect to you because of the firewall. So for these types of firewall
6957 FTP connections need to be done in a passive mode.
6959 There are two that I can think off.
6965 If you are using a SOCKS firewall you will need to compile perl and link
6966 it with the SOCKS library, this is what is normally called a 'socksified'
6967 perl. With this executable you will be able to connect to servers outside
6968 the firewall as if it is not there.
6972 This is the firewall implemented in the Linux kernel, it allows you to
6973 hide a complete network behind one IP address. With this firewall no
6974 special compiling is needed as you can access hosts directly.
6976 For accessing ftp servers behind such firewalls you may need to set
6977 the environment variable C<FTP_PASSIVE> to a true value, e.g.
6979 env FTP_PASSIVE=1 perl -MCPAN -eshell
6983 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
6990 =head2 Configuring lynx or ncftp for going through a firewall
6992 If you can go through your firewall with e.g. lynx, presumably with a
6995 /usr/local/bin/lynx -pscott:tiger
6997 then you would configure CPAN.pm with the command
6999 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7001 That's all. Similarly for ncftp or ftp, you would configure something
7004 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7006 Your mileage may vary...
7008 =head1 Cryptographically signed modules
7010 Since release 1.77 CPAN.pm has been able to verify cryptographically
7011 signed module distributions using Module::Signature. The CPAN modules
7012 can be signed by their authors, thus giving more security. The simple
7013 unsigned MD5 checksums that were used before by CPAN protect mainly
7014 against accidental file corruption.
7016 You will need to have Module::Signature installed, which in turn
7017 requires that you have at least one of Crypt::OpenPGP module or the
7018 command-line F<gpg> tool installed.
7020 You will also need to be able to connect over the Internet to the public
7021 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
7029 I installed a new version of module X but CPAN keeps saying,
7030 I have the old version installed
7032 Most probably you B<do> have the old version installed. This can
7033 happen if a module installs itself into a different directory in the
7034 @INC path than it was previously installed. This is not really a
7035 CPAN.pm problem, you would have the same problem when installing the
7036 module manually. The easiest way to prevent this behaviour is to add
7037 the argument C<UNINST=1> to the C<make install> call, and that is why
7038 many people add this argument permanently by configuring
7040 o conf make_install_arg UNINST=1
7044 So why is UNINST=1 not the default?
7046 Because there are people who have their precise expectations about who
7047 may install where in the @INC path and who uses which @INC array. In
7048 fine tuned environments C<UNINST=1> can cause damage.
7052 I want to clean up my mess, and install a new perl along with
7053 all modules I have. How do I go about it?
7055 Run the autobundle command for your old perl and optionally rename the
7056 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7057 with the Configure option prefix, e.g.
7059 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7061 Install the bundle file you produced in the first step with something like
7063 cpan> install Bundle::mybundle
7069 When I install bundles or multiple modules with one command
7070 there is too much output to keep track of.
7072 You may want to configure something like
7074 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7075 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7077 so that STDOUT is captured in a file for later inspection.
7082 I am not root, how can I install a module in a personal directory?
7084 First of all, you will want to use your own configuration, not the one
7085 that your root user installed. The following command sequence is a
7088 % mkdir -p $HOME/.cpan/CPAN
7089 % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
7091 [...answer all questions...]
7093 You will most probably like something like this:
7095 o conf makepl_arg "LIB=~/myperl/lib \
7096 INSTALLMAN1DIR=~/myperl/man/man1 \
7097 INSTALLMAN3DIR=~/myperl/man/man3"
7099 You can make this setting permanent like all C<o conf> settings with
7102 You will have to add ~/myperl/man to the MANPATH environment variable
7103 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7106 use lib "$ENV{HOME}/myperl/lib";
7108 or setting the PERL5LIB environment variable.
7110 Another thing you should bear in mind is that the UNINST parameter
7111 should never be set if you are not root.
7115 How to get a package, unwrap it, and make a change before building it?
7117 look Sybase::Sybperl
7121 I installed a Bundle and had a couple of fails. When I
7122 retried, everything resolved nicely. Can this be fixed to work
7125 The reason for this is that CPAN does not know the dependencies of all
7126 modules when it starts out. To decide about the additional items to
7127 install, it just uses data found in the generated Makefile. An
7128 undetected missing piece breaks the process. But it may well be that
7129 your Bundle installs some prerequisite later than some depending item
7130 and thus your second try is able to resolve everything. Please note,
7131 CPAN.pm does not know the dependency tree in advance and cannot sort
7132 the queue of things to install in a topologically correct order. It
7133 resolves perfectly well IFF all modules declare the prerequisites
7134 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7135 fail and you need to install often, it is recommended to sort the Bundle
7136 definition file manually. It is planned to improve the metadata
7137 situation for dependencies on CPAN in general, but this will still
7142 In our intranet we have many modules for internal use. How
7143 can I integrate these modules with CPAN.pm but without uploading
7144 the modules to CPAN?
7146 Have a look at the CPAN::Site module.
7150 When I run CPAN's shell, I get error msg about line 1 to 4,
7151 setting meta input/output via the /etc/inputrc file.
7153 Some versions of readline are picky about capitalization in the
7154 /etc/inputrc file and specifically RedHat 6.2 comes with a
7155 /etc/inputrc that contains the word C<on> in lowercase. Change the
7156 occurrences of C<on> to C<On> and the bug should disappear.
7160 Some authors have strange characters in their names.
7162 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7163 expecting ISO-8859-1 charset, a converter can be activated by setting
7164 term_is_latin to a true value in your config file. One way of doing so
7167 cpan> ! $CPAN::Config->{term_is_latin}=1
7169 Extended support for converters will be made available as soon as perl
7170 becomes stable with regard to charset issues.
7174 When an install fails for some reason and then I correct the error
7175 condition and retry, CPAN.pm refuses to install the module, saying
7176 C<Already tried without success>.
7178 Use the force pragma like so
7180 force install Foo::Bar
7182 This does a bit more than really needed because it untars the
7183 distribution again and runs make and test and only then install.
7189 and then 'make install' directly in the subshell.
7191 Or you leave the CPAN shell and start it again.
7193 Or, if you're not really sure and just want to run some make, test or
7194 install command without this pesky error message, say C<force get
7195 Foo::Bar> first and then continue as always. C<Force get> I<forgets>
7196 previous error conditions.
7198 For the really curious, by accessing internals directly, you I<could>
7200 ! delete CPAN::Shell->expand("Distribution", \
7201 CPAN::Shell->expand("Module","Foo::Bar") \
7202 ->{RO}{CPAN_FILE})->{install}
7204 but this is neither guaranteed to work in the future nor is it a
7211 If a Makefile.PL requires special customization of libraries, prompts
7212 the user for special input, etc. then you may find CPAN is not able to
7213 build the distribution. In that case it is recommended to attempt the
7214 traditional method of building a Perl module package from a shell, for
7215 example by using the 'look' command to open a subshell in the
7216 distribution's own directory.
7220 Andreas Koenig C<< <andk@cpan.org> >>
7224 Kawai,Takanori provides a Japanese translation of this manpage at
7225 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7229 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)