1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 # $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $
6 # only used during development:
8 # $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";
15 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
16 use File::Basename ();
22 use Text::ParseWords ();
25 no lib "."; # we need to run chdir all over and we would get at wrong
28 END { $End++; &cleanup; }
51 $CPAN::Frontend ||= "CPAN::Shell";
52 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
57 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
58 $Revision $Signal $End $Suppress_readline $Frontend
59 $Defaultsite $Have_warned);
61 @CPAN::ISA = qw(CPAN::Debug Exporter);
64 autobundle bundle expand force get cvs_import
65 install make readme recompile shell test clean
68 #-> sub CPAN::AUTOLOAD ;
73 @EXPORT{@EXPORT} = '';
74 CPAN::Config->load unless $CPAN::Config_loaded++;
75 if (exists $EXPORT{$l}){
78 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
87 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
88 CPAN::Config->load unless $CPAN::Config_loaded++;
90 my $oprompt = shift || "cpan> ";
91 my $prompt = $oprompt;
92 my $commandline = shift || "";
95 unless ($Suppress_readline) {
96 require Term::ReadLine;
99 $term->ReadLine eq "Term::ReadLine::Stub"
101 $term = Term::ReadLine->new('CPAN Monitor');
103 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
104 my $attribs = $term->Attribs;
105 $attribs->{attempted_completion_function} = sub {
106 &CPAN::Complete::gnu_cpl;
109 $readline::rl_completion_function =
110 $readline::rl_completion_function = 'CPAN::Complete::cpl';
112 # $term->OUT is autoflushed anyway
113 my $odef = select STDERR;
120 # no strict; # I do not recall why no strict was here (2000-09-03)
122 my $cwd = CPAN::anycwd();
123 my $try_detect_readline;
124 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
125 my $rl_avail = $Suppress_readline ? "suppressed" :
126 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
127 "available (try 'install Bundle::CPAN')";
129 $CPAN::Frontend->myprint(
131 cpan shell -- CPAN exploration and modules installation (v%s%s)
139 unless $CPAN::Config->{'inhibit_startup_message'} ;
140 my($continuation) = "";
141 SHELLCOMMAND: while () {
142 if ($Suppress_readline) {
144 last SHELLCOMMAND unless defined ($_ = <> );
147 last SHELLCOMMAND unless
148 defined ($_ = $term->readline($prompt, $commandline));
150 $_ = "$continuation$_" if $continuation;
152 next SHELLCOMMAND if /^$/;
153 $_ = 'h' if /^\s*\?/;
154 if (/^(?:q(?:uit)?|bye|exit)$/i) {
164 use vars qw($import_done);
165 CPAN->import(':DEFAULT') unless $import_done++;
166 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
173 if ($] < 5.00322) { # parsewords had a bug until recently
176 eval { @line = Text::ParseWords::shellwords($_) };
177 warn($@), next SHELLCOMMAND if $@;
178 warn("Text::Parsewords could not parse the line [$_]"),
179 next SHELLCOMMAND unless @line;
181 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
182 my $command = shift @line;
183 eval { CPAN::Shell->$command(@line) };
185 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
186 $CPAN::Frontend->myprint("\n");
191 $commandline = ""; # I do want to be able to pass a default to
192 # shell, but on the second command I see no
195 CPAN::Queue->nullify_queue;
196 if ($try_detect_readline) {
197 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
199 $CPAN::META->has_inst("Term::ReadLine::Perl")
201 delete $INC{"Term/ReadLine.pm"};
203 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
204 require Term::ReadLine;
205 $CPAN::Frontend->myprint("\n$redef subroutines in ".
206 "Term::ReadLine redefined\n");
212 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
215 package CPAN::CacheMgr;
216 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
219 package CPAN::Config;
220 use vars qw(%can $dot_cpan);
223 'commit' => "Commit changes to disk",
224 'defaults' => "Reload defaults from disk",
225 'init' => "Interactive setting of all options",
229 use vars qw($Ua $Thesite $Themethod);
230 @CPAN::FTP::ISA = qw(CPAN::Debug);
232 package CPAN::LWP::UserAgent;
233 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
234 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
236 package CPAN::Complete;
237 @CPAN::Complete::ISA = qw(CPAN::Debug);
238 @CPAN::Complete::COMMANDS = sort qw(
239 ! a b d h i m o q r u autobundle clean dump
240 make test install force readme reload look
242 ) unless @CPAN::Complete::COMMANDS;
245 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
246 @CPAN::Index::ISA = qw(CPAN::Debug);
249 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
252 package CPAN::InfoObj;
253 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
255 package CPAN::Author;
256 @CPAN::Author::ISA = qw(CPAN::InfoObj);
258 package CPAN::Distribution;
259 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
261 package CPAN::Bundle;
262 @CPAN::Bundle::ISA = qw(CPAN::Module);
264 package CPAN::Module;
265 @CPAN::Module::ISA = qw(CPAN::InfoObj);
268 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
269 @CPAN::Shell::ISA = qw(CPAN::Debug);
270 $COLOR_REGISTERED ||= 0;
271 $PRINT_ORNAMENTING ||= 0;
273 #-> sub CPAN::Shell::AUTOLOAD ;
275 my($autoload) = $AUTOLOAD;
276 my $class = shift(@_);
277 # warn "autoload[$autoload] class[$class]";
278 $autoload =~ s/.*:://;
279 if ($autoload =~ /^w/) {
280 if ($CPAN::META->has_inst('CPAN::WAIT')) {
281 CPAN::WAIT->$autoload(@_);
283 $CPAN::Frontend->mywarn(qq{
284 Commands starting with "w" require CPAN::WAIT to be installed.
285 Please consider installing CPAN::WAIT to use the fulltext index.
286 For this you just need to type
291 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
297 package CPAN::Tarzip;
298 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
299 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
300 $BUGHUNTING = 0; # released code must have turned off
304 # One use of the queue is to determine if we should or shouldn't
305 # announce the availability of a new CPAN module
307 # Now we try to use it for dependency tracking. For that to happen
308 # we need to draw a dependency tree and do the leaves first. This can
309 # easily be reached by running CPAN.pm recursively, but we don't want
310 # to waste memory and run into deep recursion. So what we can do is
313 # CPAN::Queue is the package where the queue is maintained. Dependencies
314 # often have high priority and must be brought to the head of the queue,
315 # possibly by jumping the queue if they are already there. My first code
316 # attempt tried to be extremely correct. Whenever a module needed
317 # immediate treatment, I either unshifted it to the front of the queue,
318 # or, if it was already in the queue, I spliced and let it bypass the
319 # others. This became a too correct model that made it impossible to put
320 # an item more than once into the queue. Why would you need that? Well,
321 # you need temporary duplicates as the manager of the queue is a loop
324 # (1) looks at the first item in the queue without shifting it off
326 # (2) cares for the item
328 # (3) removes the item from the queue, *even if its agenda failed and
329 # even if the item isn't the first in the queue anymore* (that way
330 # protecting against never ending queues)
332 # So if an item has prerequisites, the installation fails now, but we
333 # want to retry later. That's easy if we have it twice in the queue.
335 # I also expect insane dependency situations where an item gets more
336 # than two lives in the queue. Simplest example is triggered by 'install
337 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
338 # get in the way. I wanted the queue manager to be a dumb servant, not
339 # one that knows everything.
341 # Who would I tell in this model that the user wants to be asked before
342 # processing? I can't attach that information to the module object,
343 # because not modules are installed but distributions. So I'd have to
344 # tell the distribution object that it should ask the user before
345 # processing. Where would the question be triggered then? Most probably
346 # in CPAN::Distribution::rematein.
347 # Hope that makes sense, my head is a bit off:-) -- AK
354 my $self = bless { qmod => $s }, $class;
359 # CPAN::Queue::first ;
365 # CPAN::Queue::delete_first ;
367 my($class,$what) = @_;
369 for my $i (0..$#All) {
370 if ( $All[$i]->{qmod} eq $what ) {
377 # CPAN::Queue::jumpqueue ;
381 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
382 join(",",map {$_->{qmod}} @All),
385 WHAT: for my $what (reverse @what) {
387 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
388 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
389 if ($All[$i]->{qmod} eq $what){
391 if ($jumped > 100) { # one's OK if e.g. just
392 # processing now; more are OK if
393 # user typed it several times
394 $CPAN::Frontend->mywarn(
395 qq{Object [$what] queued more than 100 times, ignoring}
401 my $obj = bless { qmod => $what }, $class;
404 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
405 join(",",map {$_->{qmod}} @All),
410 # CPAN::Queue::exists ;
412 my($self,$what) = @_;
413 my @all = map { $_->{qmod} } @All;
414 my $exists = grep { $_->{qmod} eq $what } @All;
415 # warn "in exists what[$what] all[@all] exists[$exists]";
419 # CPAN::Queue::delete ;
422 @All = grep { $_->{qmod} ne $mod } @All;
425 # CPAN::Queue::nullify_queue ;
434 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
436 # from here on only subs.
437 ################################################################################
439 #-> sub CPAN::all_objects ;
441 my($mgr,$class) = @_;
442 CPAN::Config->load unless $CPAN::Config_loaded++;
443 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
445 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
447 *all = \&all_objects;
449 # Called by shell, not in batch mode. In batch mode I see no risk in
450 # having many processes updating something as installations are
451 # continually checked at runtime. In shell mode I suspect it is
452 # unintentional to open more than one shell at a time
454 #-> sub CPAN::checklock ;
457 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
458 if (-f $lockfile && -M _ > 0) {
459 my $fh = FileHandle->new($lockfile) or
460 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
463 if (defined $other && $other) {
465 return if $$==$other; # should never happen
466 $CPAN::Frontend->mywarn(
468 There seems to be running another CPAN process ($other). Contacting...
470 if (kill 0, $other) {
471 $CPAN::Frontend->mydie(qq{Other job is running.
472 You may want to kill it and delete the lockfile, maybe. On UNIX try:
476 } elsif (-w $lockfile) {
478 ExtUtils::MakeMaker::prompt
479 (qq{Other job not responding. Shall I overwrite }.
480 qq{the lockfile? (Y/N)},"y");
481 $CPAN::Frontend->myexit("Ok, bye\n")
482 unless $ans =~ /^y/i;
485 qq{Lockfile $lockfile not writeable by you. }.
486 qq{Cannot proceed.\n}.
489 qq{ and then rerun us.\n}
493 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
494 "reports other process with ID ".
495 "$other. Cannot proceed.\n"));
498 my $dotcpan = $CPAN::Config->{cpan_home};
499 eval { File::Path::mkpath($dotcpan);};
501 # A special case at least for Jarkko.
506 $symlinkcpan = readlink $dotcpan;
507 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
508 eval { File::Path::mkpath($symlinkcpan); };
512 $CPAN::Frontend->mywarn(qq{
513 Working directory $symlinkcpan created.
517 unless (-d $dotcpan) {
519 Your configuration suggests "$dotcpan" as your
520 CPAN.pm working directory. I could not create this directory due
521 to this error: $firsterror\n};
523 As "$dotcpan" is a symlink to "$symlinkcpan",
524 I tried to create that, but I failed with this error: $seconderror
527 Please make sure the directory exists and is writable.
529 $CPAN::Frontend->mydie($diemess);
533 unless ($fh = FileHandle->new(">$lockfile")) {
534 if ($! =~ /Permission/) {
535 my $incc = $INC{'CPAN/Config.pm'};
536 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
537 $CPAN::Frontend->myprint(qq{
539 Your configuration suggests that CPAN.pm should use a working
541 $CPAN::Config->{cpan_home}
542 Unfortunately we could not create the lock file
544 due to permission problems.
546 Please make sure that the configuration variable
547 \$CPAN::Config->{cpan_home}
548 points to a directory where you can write a .lock file. You can set
549 this variable in either
556 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
558 $fh->print($$, "\n");
559 $self->{LOCK} = $lockfile;
563 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
568 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
569 print "Caught SIGINT\n";
573 # From: Larry Wall <larry@wall.org>
574 # Subject: Re: deprecating SIGDIE
575 # To: perl5-porters@perl.org
576 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
578 # The original intent of __DIE__ was only to allow you to substitute one
579 # kind of death for another on an application-wide basis without respect
580 # to whether you were in an eval or not. As a global backstop, it should
581 # not be used any more lightly (or any more heavily :-) than class
582 # UNIVERSAL. Any attempt to build a general exception model on it should
583 # be politely squashed. Any bug that causes every eval {} to have to be
584 # modified should be not so politely squashed.
586 # Those are my current opinions. It is also my optinion that polite
587 # arguments degenerate to personal arguments far too frequently, and that
588 # when they do, it's because both people wanted it to, or at least didn't
589 # sufficiently want it not to.
593 # global backstop to cleanup if we should really die
594 $SIG{__DIE__} = \&cleanup;
595 $self->debug("Signal handler set.") if $CPAN::DEBUG;
598 #-> sub CPAN::DESTROY ;
600 &cleanup; # need an eval?
603 #-> sub CPAN::anycwd ;
606 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
611 sub cwd {Cwd::cwd();}
613 #-> sub CPAN::getcwd ;
614 sub getcwd {Cwd::getcwd();}
616 #-> sub CPAN::exists ;
618 my($mgr,$class,$id) = @_;
619 CPAN::Config->load unless $CPAN::Config_loaded++;
621 ### Carp::croak "exists called without class argument" unless $class;
623 exists $META->{readonly}{$class}{$id} or
624 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
627 #-> sub CPAN::delete ;
629 my($mgr,$class,$id) = @_;
630 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
631 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
634 #-> sub CPAN::has_usable
635 # has_inst is sometimes too optimistic, we should replace it with this
636 # has_usable whenever a case is given
638 my($self,$mod,$message) = @_;
639 return 1 if $HAS_USABLE->{$mod};
640 my $has_inst = $self->has_inst($mod,$message);
641 return unless $has_inst;
644 LWP => [ # we frequently had "Can't locate object
645 # method "new" via package "LWP::UserAgent" at
646 # (eval 69) line 2006
648 sub {require LWP::UserAgent},
649 sub {require HTTP::Request},
650 sub {require URI::URL},
653 sub {require Net::FTP},
654 sub {require Net::Config},
657 if ($usable->{$mod}) {
658 for my $c (0..$#{$usable->{$mod}}) {
659 my $code = $usable->{$mod}[$c];
660 my $ret = eval { &$code() };
662 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
667 return $HAS_USABLE->{$mod} = 1;
670 #-> sub CPAN::has_inst
672 my($self,$mod,$message) = @_;
673 Carp::croak("CPAN->has_inst() called without an argument")
675 if (defined $message && $message eq "no"
677 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
679 exists $CPAN::Config->{dontload_hash}{$mod}
681 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
687 $file =~ s|/|\\|g if $^O eq 'MSWin32';
690 # checking %INC is wrong, because $INC{LWP} may be true
691 # although $INC{"URI/URL.pm"} may have failed. But as
692 # I really want to say "bla loaded OK", I have to somehow
694 ### warn "$file in %INC"; #debug
696 } elsif (eval { require $file }) {
697 # eval is good: if we haven't yet read the database it's
698 # perfect and if we have installed the module in the meantime,
699 # it tries again. The second require is only a NOOP returning
700 # 1 if we had success, otherwise it's retrying
702 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
703 if ($mod eq "CPAN::WAIT") {
704 push @CPAN::Shell::ISA, CPAN::WAIT;
707 } elsif ($mod eq "Net::FTP") {
708 $CPAN::Frontend->mywarn(qq{
709 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
711 install Bundle::libnet
713 }) unless $Have_warned->{"Net::FTP"}++;
715 } elsif ($mod eq "MD5"){
716 $CPAN::Frontend->myprint(qq{
717 CPAN: MD5 security checks disabled because MD5 not installed.
718 Please consider installing the MD5 module.
723 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
728 #-> sub CPAN::instance ;
730 my($mgr,$class,$id) = @_;
733 # unsafe meta access, ok?
734 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
735 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
743 #-> sub CPAN::cleanup ;
745 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
746 local $SIG{__DIE__} = '';
751 0 && # disabled, try reload cpan with it
752 $] > 5.004_60 # thereabouts
757 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
759 $subroutine eq '(eval)';
762 return if $ineval && !$End;
763 return unless defined $META->{LOCK}; # unsafe meta access, ok
764 return unless -f $META->{LOCK}; # unsafe meta access, ok
765 unlink $META->{LOCK}; # unsafe meta access, ok
767 # Carp::cluck("DEBUGGING");
768 $CPAN::Frontend->mywarn("Lockfile removed.\n");
771 package CPAN::CacheMgr;
773 #-> sub CPAN::CacheMgr::as_string ;
775 eval { require Data::Dumper };
777 return shift->SUPER::as_string;
779 return Data::Dumper::Dumper(shift);
783 #-> sub CPAN::CacheMgr::cachesize ;
788 #-> sub CPAN::CacheMgr::tidyup ;
791 return unless -d $self->{ID};
792 while ($self->{DU} > $self->{'MAX'} ) {
793 my($toremove) = shift @{$self->{FIFO}};
794 $CPAN::Frontend->myprint(sprintf(
795 "Deleting from cache".
796 ": $toremove (%.1f>%.1f MB)\n",
797 $self->{DU}, $self->{'MAX'})
799 return if $CPAN::Signal;
800 $self->force_clean_cache($toremove);
801 return if $CPAN::Signal;
805 #-> sub CPAN::CacheMgr::dir ;
810 #-> sub CPAN::CacheMgr::entries ;
813 return unless defined $dir;
814 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
815 $dir ||= $self->{ID};
816 my($cwd) = CPAN::anycwd();
817 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
818 my $dh = DirHandle->new(File::Spec->curdir)
819 or Carp::croak("Couldn't opendir $dir: $!");
822 next if $_ eq "." || $_ eq "..";
824 push @entries, MM->catfile($dir,$_);
826 push @entries, MM->catdir($dir,$_);
828 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
831 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
832 sort { -M $b <=> -M $a} @entries;
835 #-> sub CPAN::CacheMgr::disk_usage ;
838 return if exists $self->{SIZE}{$dir};
839 return if $CPAN::Signal;
843 $File::Find::prune++ if $CPAN::Signal;
845 if ($^O eq 'MacOS') {
847 my $cat = Mac::Files::FSpGetCatInfo($_);
848 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
855 return if $CPAN::Signal;
856 $self->{SIZE}{$dir} = $Du/1024/1024;
857 push @{$self->{FIFO}}, $dir;
858 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
859 $self->{DU} += $Du/1024/1024;
863 #-> sub CPAN::CacheMgr::force_clean_cache ;
864 sub force_clean_cache {
866 return unless -e $dir;
867 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
869 File::Path::rmtree($dir);
870 $self->{DU} -= $self->{SIZE}{$dir};
871 delete $self->{SIZE}{$dir};
874 #-> sub CPAN::CacheMgr::new ;
881 ID => $CPAN::Config->{'build_dir'},
882 MAX => $CPAN::Config->{'build_cache'},
883 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
886 File::Path::mkpath($self->{ID});
887 my $dh = DirHandle->new($self->{ID});
891 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
893 CPAN->debug($debug) if $CPAN::DEBUG;
897 #-> sub CPAN::CacheMgr::scan_cache ;
900 return if $self->{SCAN} eq 'never';
901 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
902 unless $self->{SCAN} eq 'atstart';
903 $CPAN::Frontend->myprint(
904 sprintf("Scanning cache %s for sizes\n",
907 for $e ($self->entries($self->{ID})) {
908 next if $e eq ".." || $e eq ".";
909 $self->disk_usage($e);
910 return if $CPAN::Signal;
917 #-> sub CPAN::Debug::debug ;
920 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
921 # Complete, caller(1)
923 ($caller) = caller(0);
925 $arg = "" unless defined $arg;
926 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
927 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
928 if ($arg and ref $arg) {
929 eval { require Data::Dumper };
931 $CPAN::Frontend->myprint($arg->as_string);
933 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
936 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
941 package CPAN::Config;
943 #-> sub CPAN::Config::edit ;
944 # returns true on successful action
946 my($self,@args) = @_;
948 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
949 my($o,$str,$func,$args,$key_exists);
955 CPAN->debug("o[$o]") if $CPAN::DEBUG;
959 CPAN->debug("func[$func]") if $CPAN::DEBUG;
961 # Let's avoid eval, it's easier to comprehend without.
962 if ($func eq "push") {
963 push @{$CPAN::Config->{$o}}, @args;
965 } elsif ($func eq "pop") {
966 pop @{$CPAN::Config->{$o}};
968 } elsif ($func eq "shift") {
969 shift @{$CPAN::Config->{$o}};
971 } elsif ($func eq "unshift") {
972 unshift @{$CPAN::Config->{$o}}, @args;
974 } elsif ($func eq "splice") {
975 splice @{$CPAN::Config->{$o}}, @args;
978 $CPAN::Config->{$o} = [@args];
981 $self->prettyprint($o);
983 if ($o eq "urllist" && $changed) {
984 # reset the cached values
985 undef $CPAN::FTP::Thesite;
986 undef $CPAN::FTP::Themethod;
990 $CPAN::Config->{$o} = $args[0] if defined $args[0];
991 $self->prettyprint($o);
998 my $v = $CPAN::Config->{$k};
1000 my(@report) = ref $v eq "ARRAY" ?
1002 map { sprintf(" %-18s => %s\n",
1004 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1006 $CPAN::Frontend->myprint(
1013 map {"\t$_\n"} @report
1016 } elsif (defined $v) {
1017 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1019 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1023 #-> sub CPAN::Config::commit ;
1025 my($self,$configpm) = @_;
1026 unless (defined $configpm){
1027 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1028 $configpm ||= $INC{"CPAN/Config.pm"};
1029 $configpm || Carp::confess(q{
1030 CPAN::Config::commit called without an argument.
1031 Please specify a filename where to save the configuration or try
1032 "o conf init" to have an interactive course through configing.
1037 $mode = (stat $configpm)[2];
1038 if ($mode && ! -w _) {
1039 Carp::confess("$configpm is not writable");
1044 $msg = <<EOF unless $configpm =~ /MyConfig/;
1046 # This is CPAN.pm's systemwide configuration file. This file provides
1047 # defaults for users, and the values can be changed in a per-user
1048 # configuration file. The user-config file is being looked for as
1049 # ~/.cpan/CPAN/MyConfig.pm.
1053 my($fh) = FileHandle->new;
1054 rename $configpm, "$configpm~" if -f $configpm;
1055 open $fh, ">$configpm" or
1056 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1057 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1058 foreach (sort keys %$CPAN::Config) {
1061 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1066 $fh->print("};\n1;\n__END__\n");
1069 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1070 #chmod $mode, $configpm;
1071 ###why was that so? $self->defaults;
1072 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1076 *default = \&defaults;
1077 #-> sub CPAN::Config::defaults ;
1087 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1096 #-> sub CPAN::Config::load ;
1101 eval {require CPAN::Config;}; # We eval because of some
1102 # MakeMaker problems
1103 unless ($dot_cpan++){
1104 unshift @INC, MM->catdir($ENV{HOME},".cpan");
1105 eval {require CPAN::MyConfig;}; # where you can override
1106 # system wide settings
1109 return unless @miss = $self->missing_config_data;
1111 require CPAN::FirstTime;
1112 my($configpm,$fh,$redo,$theycalled);
1114 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1115 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1116 $configpm = $INC{"CPAN/Config.pm"};
1118 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1119 $configpm = $INC{"CPAN/MyConfig.pm"};
1122 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1123 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1124 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1125 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1126 if (-w $configpmtest) {
1127 $configpm = $configpmtest;
1128 } elsif (-w $configpmdir) {
1129 #_#_# following code dumped core on me with 5.003_11, a.k.
1130 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1131 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1132 my $fh = FileHandle->new;
1133 if ($fh->open(">$configpmtest")) {
1135 $configpm = $configpmtest;
1137 # Should never happen
1138 Carp::confess("Cannot open >$configpmtest");
1142 unless ($configpm) {
1143 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1144 File::Path::mkpath($configpmdir);
1145 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1146 if (-w $configpmtest) {
1147 $configpm = $configpmtest;
1148 } elsif (-w $configpmdir) {
1149 #_#_# following code dumped core on me with 5.003_11, a.k.
1150 my $fh = FileHandle->new;
1151 if ($fh->open(">$configpmtest")) {
1153 $configpm = $configpmtest;
1155 # Should never happen
1156 Carp::confess("Cannot open >$configpmtest");
1159 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1160 qq{create a configuration file.});
1165 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1166 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1170 $CPAN::Frontend->myprint(qq{
1171 $configpm initialized.
1174 CPAN::FirstTime::init($configpm);
1177 #-> sub CPAN::Config::missing_config_data ;
1178 sub missing_config_data {
1181 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1182 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1184 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1185 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1186 "prerequisites_policy",
1189 push @miss, $_ unless defined $CPAN::Config->{$_};
1194 #-> sub CPAN::Config::unload ;
1196 delete $INC{'CPAN/MyConfig.pm'};
1197 delete $INC{'CPAN/Config.pm'};
1200 #-> sub CPAN::Config::help ;
1202 $CPAN::Frontend->myprint(q[
1204 defaults reload default config values from disk
1205 commit commit session changes to disk
1206 init go through a dialog to set all parameters
1208 You may edit key values in the follow fashion (the "o" is a literal
1211 o conf build_cache 15
1213 o conf build_dir "/foo/bar"
1215 o conf urllist shift
1217 o conf urllist unshift ftp://ftp.foo.bar/
1220 undef; #don't reprint CPAN::Config
1223 #-> sub CPAN::Config::cpl ;
1225 my($word,$line,$pos) = @_;
1227 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1228 my(@words) = split " ", substr($line,0,$pos+1);
1233 $words[2] =~ /list$/ && @words == 3
1235 $words[2] =~ /list$/ && @words == 4 && length($word)
1238 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1239 } elsif (@words >= 4) {
1242 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1243 return grep /^\Q$word\E/, @o_conf;
1246 package CPAN::Shell;
1248 #-> sub CPAN::Shell::h ;
1250 my($class,$about) = @_;
1251 if (defined $about) {
1252 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1254 $CPAN::Frontend->myprint(q{
1256 command argument description
1257 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1258 i WORD or /REGEXP/ about anything of above
1259 r NONE reinstall recommendations
1260 ls AUTHOR about files in the author's directory
1262 Download, Test, Make, Install...
1264 make make (implies get)
1265 test MODULES, make test (implies make)
1266 install DISTS, BUNDLES make install (implies test)
1268 look open subshell in these dists' directories
1269 readme display these dists' README files
1272 h,? display this menu ! perl-code eval a perl command
1273 o conf [opt] set and query options q quit the cpan shell
1274 reload cpan load CPAN.pm again reload index load newer indices
1275 autobundle Snapshot force cmd unconditionally do cmd});
1281 #-> sub CPAN::Shell::a ;
1283 my($self,@arg) = @_;
1284 # authors are always UPPERCASE
1286 $_ = uc $_ unless /=/;
1288 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1291 #-> sub CPAN::Shell::ls ;
1293 my($self,@arg) = @_;
1296 unless (/^[A-Z\-]+$/i) {
1297 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
1300 push @accept, uc $_;
1302 for my $a (@accept){
1303 my $author = $self->expand('Author',$a) or die "No author found for $a";
1308 #-> sub CPAN::Shell::local_bundles ;
1310 my($self,@which) = @_;
1311 my($incdir,$bdir,$dh);
1312 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1313 my @bbase = "Bundle";
1314 while (my $bbase = shift @bbase) {
1315 $bdir = MM->catdir($incdir,split /::/, $bbase);
1316 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1317 if ($dh = DirHandle->new($bdir)) { # may fail
1319 for $entry ($dh->read) {
1320 next if $entry =~ /^\./;
1321 if (-d MM->catdir($bdir,$entry)){
1322 push @bbase, "$bbase\::$entry";
1324 next unless $entry =~ s/\.pm(?!\n)\Z//;
1325 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1333 #-> sub CPAN::Shell::b ;
1335 my($self,@which) = @_;
1336 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1337 $self->local_bundles;
1338 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1341 #-> sub CPAN::Shell::d ;
1342 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1344 #-> sub CPAN::Shell::m ;
1345 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1346 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1349 #-> sub CPAN::Shell::i ;
1354 @type = qw/Author Bundle Distribution Module/;
1355 @args = '/./' unless @args;
1358 push @result, $self->expand($type,@args);
1360 my $result = @result == 1 ?
1361 $result[0]->as_string :
1363 "No objects found of any type for argument @args\n" :
1365 (map {$_->as_glimpse} @result),
1366 scalar @result, " items found\n",
1368 $CPAN::Frontend->myprint($result);
1371 #-> sub CPAN::Shell::o ;
1373 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1374 # should have been called set and 'o debug' maybe 'set debug'
1376 my($self,$o_type,@o_what) = @_;
1378 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1379 if ($o_type eq 'conf') {
1380 shift @o_what if @o_what && $o_what[0] eq 'help';
1381 if (!@o_what) { # print all things, "o conf"
1383 $CPAN::Frontend->myprint("CPAN::Config options");
1384 if (exists $INC{'CPAN/Config.pm'}) {
1385 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1387 if (exists $INC{'CPAN/MyConfig.pm'}) {
1388 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1390 $CPAN::Frontend->myprint(":\n");
1391 for $k (sort keys %CPAN::Config::can) {
1392 $v = $CPAN::Config::can{$k};
1393 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1395 $CPAN::Frontend->myprint("\n");
1396 for $k (sort keys %$CPAN::Config) {
1397 CPAN::Config->prettyprint($k);
1399 $CPAN::Frontend->myprint("\n");
1400 } elsif (!CPAN::Config->edit(@o_what)) {
1401 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1402 qq{edit options\n\n});
1404 } elsif ($o_type eq 'debug') {
1406 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1409 my($what) = shift @o_what;
1410 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1411 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1414 if ( exists $CPAN::DEBUG{$what} ) {
1415 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1416 } elsif ($what =~ /^\d/) {
1417 $CPAN::DEBUG = $what;
1418 } elsif (lc $what eq 'all') {
1420 for (values %CPAN::DEBUG) {
1423 $CPAN::DEBUG = $max;
1426 for (keys %CPAN::DEBUG) {
1427 next unless lc($_) eq lc($what);
1428 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1431 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1436 my $raw = "Valid options for debug are ".
1437 join(", ",sort(keys %CPAN::DEBUG), 'all').
1438 qq{ or a number. Completion works on the options. }.
1439 qq{Case is ignored.};
1441 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1442 $CPAN::Frontend->myprint("\n\n");
1445 $CPAN::Frontend->myprint("Options set for debugging:\n");
1447 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1448 $v = $CPAN::DEBUG{$k};
1449 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1450 if $v & $CPAN::DEBUG;
1453 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1456 $CPAN::Frontend->myprint(qq{
1458 conf set or get configuration variables
1459 debug set or get debugging options
1464 sub paintdots_onreload {
1467 if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1471 # $CPAN::Frontend->myprint(".($subr)");
1472 $CPAN::Frontend->myprint(".");
1479 #-> sub CPAN::Shell::reload ;
1481 my($self,$command,@arg) = @_;
1483 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1484 if ($command =~ /cpan/i) {
1485 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1486 my $fh = FileHandle->new($INC{'CPAN.pm'});
1489 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1492 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1493 } elsif ($command =~ /index/) {
1494 CPAN::Index->force_reload;
1496 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1497 index re-reads the index files\n});
1501 #-> sub CPAN::Shell::_binary_extensions ;
1502 sub _binary_extensions {
1503 my($self) = shift @_;
1504 my(@result,$module,%seen,%need,$headerdone);
1505 for $module ($self->expand('Module','/./')) {
1506 my $file = $module->cpan_file;
1507 next if $file eq "N/A";
1508 next if $file =~ /^Contact Author/;
1509 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1510 next if $dist->isa_perl;
1511 next unless $module->xs_file;
1513 $CPAN::Frontend->myprint(".");
1514 push @result, $module;
1516 # print join " | ", @result;
1517 $CPAN::Frontend->myprint("\n");
1521 #-> sub CPAN::Shell::recompile ;
1523 my($self) = shift @_;
1524 my($module,@module,$cpan_file,%dist);
1525 @module = $self->_binary_extensions();
1526 for $module (@module){ # we force now and compile later, so we
1528 $cpan_file = $module->cpan_file;
1529 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1531 $dist{$cpan_file}++;
1533 for $cpan_file (sort keys %dist) {
1534 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1535 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1537 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1538 # stop a package from recompiling,
1539 # e.g. IO-1.12 when we have perl5.003_10
1543 #-> sub CPAN::Shell::_u_r_common ;
1545 my($self) = shift @_;
1546 my($what) = shift @_;
1547 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1548 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1549 $what && $what =~ /^[aru]$/;
1551 @args = '/./' unless @args;
1552 my(@result,$module,%seen,%need,$headerdone,
1553 $version_undefs,$version_zeroes);
1554 $version_undefs = $version_zeroes = 0;
1555 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1556 my @expand = $self->expand('Module',@args);
1557 my $expand = scalar @expand;
1558 if (0) { # Looks like noise to me, was very useful for debugging
1559 # for metadata cache
1560 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1562 for $module (@expand) {
1563 my $file = $module->cpan_file;
1564 next unless defined $file; # ??
1565 my($latest) = $module->cpan_version;
1566 my($inst_file) = $module->inst_file;
1568 return if $CPAN::Signal;
1571 $have = $module->inst_version;
1572 } elsif ($what eq "r") {
1573 $have = $module->inst_version;
1575 if ($have eq "undef"){
1577 } elsif ($have == 0){
1580 next unless CPAN::Version->vgt($latest, $have);
1581 # to be pedantic we should probably say:
1582 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1583 # to catch the case where CPAN has a version 0 and we have a version undef
1584 } elsif ($what eq "u") {
1590 } elsif ($what eq "r") {
1592 } elsif ($what eq "u") {
1596 return if $CPAN::Signal; # this is sometimes lengthy
1599 push @result, sprintf "%s %s\n", $module->id, $have;
1600 } elsif ($what eq "r") {
1601 push @result, $module->id;
1602 next if $seen{$file}++;
1603 } elsif ($what eq "u") {
1604 push @result, $module->id;
1605 next if $seen{$file}++;
1606 next if $file =~ /^Contact/;
1608 unless ($headerdone++){
1609 $CPAN::Frontend->myprint("\n");
1610 $CPAN::Frontend->myprint(sprintf(
1613 "Package namespace",
1625 $CPAN::META->has_inst("Term::ANSIColor")
1627 $module->{RO}{description}
1629 $color_on = Term::ANSIColor::color("green");
1630 $color_off = Term::ANSIColor::color("reset");
1632 $CPAN::Frontend->myprint(sprintf $sprintf,
1639 $need{$module->id}++;
1643 $CPAN::Frontend->myprint("No modules found for @args\n");
1644 } elsif ($what eq "r") {
1645 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1649 if ($version_zeroes) {
1650 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1651 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1652 qq{a version number of 0\n});
1654 if ($version_undefs) {
1655 my $s_has = $version_undefs > 1 ? "s have" : " has";
1656 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1657 qq{parseable version number\n});
1663 #-> sub CPAN::Shell::r ;
1665 shift->_u_r_common("r",@_);
1668 #-> sub CPAN::Shell::u ;
1670 shift->_u_r_common("u",@_);
1673 #-> sub CPAN::Shell::autobundle ;
1676 CPAN::Config->load unless $CPAN::Config_loaded++;
1677 my(@bundle) = $self->_u_r_common("a",@_);
1678 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1679 File::Path::mkpath($todir);
1680 unless (-d $todir) {
1681 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1684 my($y,$m,$d) = (localtime)[5,4,3];
1688 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1689 my($to) = MM->catfile($todir,"$me.pm");
1691 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1692 $to = MM->catfile($todir,"$me.pm");
1694 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1696 "package Bundle::$me;\n\n",
1697 "\$VERSION = '0.01';\n\n",
1701 "Bundle::$me - Snapshot of installation on ",
1702 $Config::Config{'myhostname'},
1705 "\n\n=head1 SYNOPSIS\n\n",
1706 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1707 "=head1 CONTENTS\n\n",
1708 join("\n", @bundle),
1709 "\n\n=head1 CONFIGURATION\n\n",
1711 "\n\n=head1 AUTHOR\n\n",
1712 "This Bundle has been generated automatically ",
1713 "by the autobundle routine in CPAN.pm.\n",
1716 $CPAN::Frontend->myprint("\nWrote bundle file
1720 #-> sub CPAN::Shell::expandany ;
1723 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1724 if ($s =~ m|/|) { # looks like a file
1725 $s = CPAN::Distribution->normalize($s);
1726 return $CPAN::META->instance('CPAN::Distribution',$s);
1727 # Distributions spring into existence, not expand
1728 } elsif ($s =~ m|^Bundle::|) {
1729 $self->local_bundles; # scanning so late for bundles seems
1730 # both attractive and crumpy: always
1731 # current state but easy to forget
1733 return $self->expand('Bundle',$s);
1735 return $self->expand('Module',$s)
1736 if $CPAN::META->exists('CPAN::Module',$s);
1741 #-> sub CPAN::Shell::expand ;
1744 my($type,@args) = @_;
1746 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1748 my($regex,$command);
1749 if ($arg =~ m|^/(.*)/$|) {
1751 } elsif ($arg =~ m/=/) {
1754 my $class = "CPAN::$type";
1756 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1758 defined $regex ? $regex : "UNDEFINED",
1759 $command || "UNDEFINED",
1761 if (defined $regex) {
1765 $CPAN::META->all_objects($class)
1768 # BUG, we got an empty object somewhere
1769 require Data::Dumper;
1770 CPAN->debug(sprintf(
1771 "Bug in CPAN: Empty id on obj[%s][%s]",
1773 Data::Dumper::Dumper($obj)
1778 if $obj->id =~ /$regex/i
1782 $] < 5.00303 ### provide sort of
1783 ### compatibility with 5.003
1788 $obj->name =~ /$regex/i
1791 } elsif ($command) {
1792 die "equal sign in command disabled (immature interface), ".
1794 ! \$CPAN::Shell::ADVANCED_QUERY=1
1795 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1796 that may go away anytime.\n"
1797 unless $ADVANCED_QUERY;
1798 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1799 my($matchcrit) = $criterion =~ m/^~(.+)/;
1803 $CPAN::META->all_objects($class)
1805 my $lhs = $self->$method() or next; # () for 5.00503
1807 push @m, $self if $lhs =~ m/$matchcrit/;
1809 push @m, $self if $lhs eq $criterion;
1814 if ( $type eq 'Bundle' ) {
1815 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1816 } elsif ($type eq "Distribution") {
1817 $xarg = CPAN::Distribution->normalize($arg);
1819 if ($CPAN::META->exists($class,$xarg)) {
1820 $obj = $CPAN::META->instance($class,$xarg);
1821 } elsif ($CPAN::META->exists($class,$arg)) {
1822 $obj = $CPAN::META->instance($class,$arg);
1829 return wantarray ? @m : $m[0];
1832 #-> sub CPAN::Shell::format_result ;
1835 my($type,@args) = @_;
1836 @args = '/./' unless @args;
1837 my(@result) = $self->expand($type,@args);
1838 my $result = @result == 1 ?
1839 $result[0]->as_string :
1841 "No objects of type $type found for argument @args\n" :
1843 (map {$_->as_glimpse} @result),
1844 scalar @result, " items found\n",
1849 # The only reason for this method is currently to have a reliable
1850 # debugging utility that reveals which output is going through which
1851 # channel. No, I don't like the colors ;-)
1853 #-> sub CPAN::Shell::print_ornameted ;
1854 sub print_ornamented {
1855 my($self,$what,$ornament) = @_;
1857 return unless defined $what;
1859 if ($CPAN::Config->{term_is_latin}){
1862 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1864 if ($PRINT_ORNAMENTING) {
1865 unless (defined &color) {
1866 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1867 import Term::ANSIColor "color";
1869 *color = sub { return "" };
1873 for $line (split /\n/, $what) {
1874 $longest = length($line) if length($line) > $longest;
1876 my $sprintf = "%-" . $longest . "s";
1878 $what =~ s/(.*\n?)//m;
1881 my($nl) = chomp $line ? "\n" : "";
1882 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1883 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1891 my($self,$what) = @_;
1893 $self->print_ornamented($what, 'bold blue on_yellow');
1897 my($self,$what) = @_;
1898 $self->myprint($what);
1903 my($self,$what) = @_;
1904 $self->print_ornamented($what, 'bold red on_yellow');
1908 my($self,$what) = @_;
1909 $self->print_ornamented($what, 'bold red on_white');
1910 Carp::confess "died";
1914 my($self,$what) = @_;
1915 $self->print_ornamented($what, 'bold red on_white');
1920 return if -t STDOUT;
1921 my $odef = select STDERR;
1928 #-> sub CPAN::Shell::rematein ;
1929 # RE-adme||MA-ke||TE-st||IN-stall
1932 my($meth,@some) = @_;
1934 if ($meth eq 'force') {
1936 $meth = shift @some;
1939 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1941 # Here is the place to set "test_count" on all involved parties to
1942 # 0. We then can pass this counter on to the involved
1943 # distributions and those can refuse to test if test_count > X. In
1944 # the first stab at it we could use a 1 for "X".
1946 # But when do I reset the distributions to start with 0 again?
1947 # Jost suggested to have a random or cycling interaction ID that
1948 # we pass through. But the ID is something that is just left lying
1949 # around in addition to the counter, so I'd prefer to set the
1950 # counter to 0 now, and repeat at the end of the loop. But what
1951 # about dependencies? They appear later and are not reset, they
1952 # enter the queue but not its copy. How do they get a sensible
1955 # construct the queue
1957 foreach $s (@some) {
1960 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1962 } elsif ($s =~ m|^/|) { # looks like a regexp
1963 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1968 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1969 $obj = CPAN::Shell->expandany($s);
1972 $obj->color_cmd_tmps(0,1);
1973 CPAN::Queue->new($obj->id);
1975 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1976 $obj = $CPAN::META->instance('CPAN::Author',$s);
1977 if ($meth eq "dump") {
1980 $CPAN::Frontend->myprint(
1982 "Don't be silly, you can't $meth ",
1990 ->myprint(qq{Warning: Cannot $meth $s, }.
1991 qq{don\'t know what it is.
1996 to find objects with matching identifiers.
2002 # queuerunner (please be warned: when I started to change the
2003 # queue to hold objects instead of names, I made one or two
2004 # mistakes and never found which. I reverted back instead)
2005 while ($s = CPAN::Queue->first) {
2008 $obj = $s; # I do not believe, we would survive if this happened
2010 $obj = CPAN::Shell->expandany($s);
2014 ($] < 5.00303 || $obj->can($pragma))){
2015 ### compatibility with 5.003
2016 $obj->$pragma($meth); # the pragma "force" in
2017 # "CPAN::Distribution" must know
2018 # what we are intending
2020 if ($]>=5.00303 && $obj->can('called_for')) {
2021 $obj->called_for($s);
2024 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2030 CPAN::Queue->delete($s);
2032 CPAN->debug("failed");
2036 CPAN::Queue->delete_first($s);
2038 for my $obj (@qcopy) {
2039 $obj->color_cmd_tmps(0,0);
2043 #-> sub CPAN::Shell::dump ;
2044 sub dump { shift->rematein('dump',@_); }
2045 #-> sub CPAN::Shell::force ;
2046 sub force { shift->rematein('force',@_); }
2047 #-> sub CPAN::Shell::get ;
2048 sub get { shift->rematein('get',@_); }
2049 #-> sub CPAN::Shell::readme ;
2050 sub readme { shift->rematein('readme',@_); }
2051 #-> sub CPAN::Shell::make ;
2052 sub make { shift->rematein('make',@_); }
2053 #-> sub CPAN::Shell::test ;
2054 sub test { shift->rematein('test',@_); }
2055 #-> sub CPAN::Shell::install ;
2056 sub install { shift->rematein('install',@_); }
2057 #-> sub CPAN::Shell::clean ;
2058 sub clean { shift->rematein('clean',@_); }
2059 #-> sub CPAN::Shell::look ;
2060 sub look { shift->rematein('look',@_); }
2061 #-> sub CPAN::Shell::cvs_import ;
2062 sub cvs_import { shift->rematein('cvs_import',@_); }
2064 package CPAN::LWP::UserAgent;
2067 return if $SETUPDONE;
2068 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2069 require LWP::UserAgent;
2070 @ISA = qw(Exporter LWP::UserAgent);
2073 $CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
2077 sub get_basic_credentials {
2078 my($self, $realm, $uri, $proxy) = @_;
2079 return unless $proxy;
2080 if ($USER && $PASSWD) {
2081 } elsif (defined $CPAN::Config->{proxy_user} &&
2082 defined $CPAN::Config->{proxy_pass}) {
2083 $USER = $CPAN::Config->{proxy_user};
2084 $PASSWD = $CPAN::Config->{proxy_pass};
2086 require ExtUtils::MakeMaker;
2087 ExtUtils::MakeMaker->import(qw(prompt));
2088 $USER = prompt("Proxy authentication needed!
2089 (Note: to permanently configure username and password run
2090 o conf proxy_user your_username
2091 o conf proxy_pass your_password
2093 if ($CPAN::META->has_inst("Term::ReadKey")) {
2094 Term::ReadKey::ReadMode("noecho");
2096 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2098 $PASSWD = prompt("Password:");
2099 if ($CPAN::META->has_inst("Term::ReadKey")) {
2100 Term::ReadKey::ReadMode("restore");
2102 $CPAN::Frontend->myprint("\n\n");
2104 return($USER,$PASSWD);
2108 my($self,$url,$aslocal) = @_;
2109 my $result = $self->SUPER::mirror($url,$aslocal);
2110 if ($result->code == 407) {
2113 $result = $self->SUPER::mirror($url,$aslocal);
2120 #-> sub CPAN::FTP::ftp_get ;
2122 my($class,$host,$dir,$file,$target) = @_;
2124 qq[Going to fetch file [$file] from dir [$dir]
2125 on host [$host] as local [$target]\n]
2127 my $ftp = Net::FTP->new($host);
2128 return 0 unless defined $ftp;
2129 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2130 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2131 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2132 warn "Couldn't login on $host";
2135 unless ( $ftp->cwd($dir) ){
2136 warn "Couldn't cwd $dir";
2140 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2141 unless ( $ftp->get($file,$target) ){
2142 warn "Couldn't fetch $file from $host\n";
2145 $ftp->quit; # it's ok if this fails
2149 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2151 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2152 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2154 # > *** 1562,1567 ****
2155 # > --- 1562,1580 ----
2156 # > return 1 if substr($url,0,4) eq "file";
2157 # > return 1 unless $url =~ m|://([^/]+)|;
2159 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2161 # > + $proxy =~ m|://([^/:]+)|;
2163 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2164 # > + if ($noproxy) {
2165 # > + if ($host !~ /$noproxy$/) {
2166 # > + $host = $proxy;
2169 # > + $host = $proxy;
2172 # > require Net::Ping;
2173 # > return 1 unless $Net::Ping::VERSION >= 2;
2177 #-> sub CPAN::FTP::localize ;
2179 my($self,$file,$aslocal,$force) = @_;
2181 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2182 unless defined $aslocal;
2183 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2186 if ($^O eq 'MacOS') {
2187 # Comment by AK on 2000-09-03: Uniq short filenames would be
2188 # available in CHECKSUMS file
2189 my($name, $path) = File::Basename::fileparse($aslocal, '');
2190 if (length($name) > 31) {
2201 my $size = 31 - length($suf);
2202 while (length($name) > $size) {
2206 $aslocal = File::Spec->catfile($path, $name);
2210 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2213 rename $aslocal, "$aslocal.bak";
2217 my($aslocal_dir) = File::Basename::dirname($aslocal);
2218 File::Path::mkpath($aslocal_dir);
2219 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2220 qq{directory "$aslocal_dir".
2221 I\'ll continue, but if you encounter problems, they may be due
2222 to insufficient permissions.\n}) unless -w $aslocal_dir;
2224 # Inheritance is not easier to manage than a few if/else branches
2225 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2227 CPAN::LWP::UserAgent->config;
2228 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2230 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
2234 $Ua->proxy('ftp', $var)
2235 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2236 $Ua->proxy('http', $var)
2237 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2240 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2242 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2243 # > use ones that require basic autorization.
2245 # > Example of when I use it manually in my own stuff:
2247 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2248 # > $req->proxy_authorization_basic("username","password");
2249 # > $res = $ua->request($req);
2253 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2257 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2258 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2259 if $CPAN::Config->{http_proxy};
2260 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2262 # Try the list of urls for each single object. We keep a record
2263 # where we did get a file from
2264 my(@reordered,$last);
2265 $CPAN::Config->{urllist} ||= [];
2266 $last = $#{$CPAN::Config->{urllist}};
2267 if ($force & 2) { # local cpans probably out of date, don't reorder
2268 @reordered = (0..$last);
2272 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2274 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2285 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2287 @levels = qw/easy hard hardest/;
2289 @levels = qw/easy/ if $^O eq 'MacOS';
2291 for $levelno (0..$#levels) {
2292 my $level = $levels[$levelno];
2293 my $method = "host$level";
2294 my @host_seq = $level eq "easy" ?
2295 @reordered : 0..$last; # reordered has CDROM up front
2296 @host_seq = (0) unless @host_seq;
2297 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2299 $Themethod = $level;
2301 # utime $now, $now, $aslocal; # too bad, if we do that, we
2302 # might alter a local mirror
2303 $self->debug("level[$level]") if $CPAN::DEBUG;
2307 last if $CPAN::Signal; # need to cleanup
2310 unless ($CPAN::Signal) {
2313 qq{Please check, if the URLs I found in your configuration file \(}.
2314 join(", ", @{$CPAN::Config->{urllist}}).
2315 qq{\) are valid. The urllist can be edited.},
2316 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2317 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2319 $CPAN::Frontend->myprint("Could not fetch $file\n");
2322 rename "$aslocal.bak", $aslocal;
2323 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2324 $self->ls($aslocal));
2331 my($self,$host_seq,$file,$aslocal) = @_;
2333 HOSTEASY: for $i (@$host_seq) {
2334 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2335 $url .= "/" unless substr($url,-1) eq "/";
2337 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2338 if ($url =~ /^file:/) {
2340 if ($CPAN::META->has_inst('URI::URL')) {
2341 my $u = URI::URL->new($url);
2343 } else { # works only on Unix, is poorly constructed, but
2344 # hopefully better than nothing.
2345 # RFC 1738 says fileurl BNF is
2346 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2347 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2349 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2350 $l =~ s|^file:||; # assume they
2353 $l =~ s|^/||s unless -f $l; # e.g. /P:
2354 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2356 if ( -f $l && -r _) {
2360 # Maybe mirror has compressed it?
2362 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2363 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2370 if ($CPAN::META->has_usable('LWP')) {
2371 $CPAN::Frontend->myprint("Fetching with LWP:
2375 CPAN::LWP::UserAgent->config;
2376 eval { $Ua = CPAN::LWP::UserAgent->new; };
2378 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
2381 my $res = $Ua->mirror($url, $aslocal);
2382 if ($res->is_success) {
2385 utime $now, $now, $aslocal; # download time is more
2386 # important than upload time
2388 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2389 my $gzurl = "$url.gz";
2390 $CPAN::Frontend->myprint("Fetching with LWP:
2393 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2394 if ($res->is_success &&
2395 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2401 $CPAN::Frontend->myprint(sprintf(
2402 "LWP failed with code[%s] message[%s]\n",
2406 # Alan Burlison informed me that in firewall environments
2407 # Net::FTP can still succeed where LWP fails. So we do not
2408 # skip Net::FTP anymore when LWP is available.
2411 $CPAN::Frontend->myprint("LWP not available\n");
2413 return if $CPAN::Signal;
2414 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2415 # that's the nice and easy way thanks to Graham
2416 my($host,$dir,$getfile) = ($1,$2,$3);
2417 if ($CPAN::META->has_usable('Net::FTP')) {
2419 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2422 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2423 "aslocal[$aslocal]") if $CPAN::DEBUG;
2424 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2428 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2429 my $gz = "$aslocal.gz";
2430 $CPAN::Frontend->myprint("Fetching with Net::FTP
2433 if (CPAN::FTP->ftp_get($host,
2437 CPAN::Tarzip->gunzip($gz,$aslocal)
2446 return if $CPAN::Signal;
2451 my($self,$host_seq,$file,$aslocal) = @_;
2453 # Came back if Net::FTP couldn't establish connection (or
2454 # failed otherwise) Maybe they are behind a firewall, but they
2455 # gave us a socksified (or other) ftp program...
2458 my($devnull) = $CPAN::Config->{devnull} || "";
2460 my($aslocal_dir) = File::Basename::dirname($aslocal);
2461 File::Path::mkpath($aslocal_dir);
2462 HOSTHARD: for $i (@$host_seq) {
2463 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2464 $url .= "/" unless substr($url,-1) eq "/";
2466 my($proto,$host,$dir,$getfile);
2468 # Courtesy Mark Conty mark_conty@cargill.com change from
2469 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2471 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2472 # proto not yet used
2473 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2475 next HOSTHARD; # who said, we could ftp anything except ftp?
2477 next HOSTHARD if $proto eq "file"; # file URLs would have had
2478 # success above. Likely a bogus URL
2480 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2482 for $f ('lynx','ncftpget','ncftp','wget') {
2483 next unless exists $CPAN::Config->{$f};
2484 $funkyftp = $CPAN::Config->{$f};
2485 next unless defined $funkyftp;
2486 next if $funkyftp =~ /^\s*$/;
2487 my($asl_ungz, $asl_gz);
2488 ($asl_ungz = $aslocal) =~ s/\.gz//;
2489 $asl_gz = "$asl_ungz.gz";
2490 my($src_switch) = "";
2492 $src_switch = " -source";
2493 } elsif ($f eq "ncftp"){
2494 $src_switch = " -c";
2495 } elsif ($f eq "wget"){
2496 $src_switch = " -O -";
2499 my($stdout_redir) = " > $asl_ungz";
2500 if ($f eq "ncftpget"){
2501 $chdir = "cd $aslocal_dir && ";
2504 $CPAN::Frontend->myprint(
2506 Trying with "$funkyftp$src_switch" to get
2510 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2511 $self->debug("system[$system]") if $CPAN::DEBUG;
2513 if (($wstatus = system($system)) == 0
2516 -s $asl_ungz # lynx returns 0 when it fails somewhere
2522 } elsif ($asl_ungz ne $aslocal) {
2523 # test gzip integrity
2524 if (CPAN::Tarzip->gtest($asl_ungz)) {
2525 # e.g. foo.tar is gzipped --> foo.tar.gz
2526 rename $asl_ungz, $aslocal;
2528 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2533 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2535 -f $asl_ungz && -s _ == 0;
2536 my $gz = "$aslocal.gz";
2537 my $gzurl = "$url.gz";
2538 $CPAN::Frontend->myprint(
2540 Trying with "$funkyftp$src_switch" to get
2543 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2544 $self->debug("system[$system]") if $CPAN::DEBUG;
2546 if (($wstatus = system($system)) == 0
2550 # test gzip integrity
2551 if (CPAN::Tarzip->gtest($asl_gz)) {
2552 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2554 # somebody uncompressed file for us?
2555 rename $asl_ungz, $aslocal;
2560 unlink $asl_gz if -f $asl_gz;
2563 my $estatus = $wstatus >> 8;
2564 my $size = -f $aslocal ?
2565 ", left\n$aslocal with size ".-s _ :
2566 "\nWarning: expected file [$aslocal] doesn't exist";
2567 $CPAN::Frontend->myprint(qq{
2568 System call "$system"
2569 returned status $estatus (wstat $wstatus)$size
2572 return if $CPAN::Signal;
2573 } # lynx,ncftpget,ncftp
2578 my($self,$host_seq,$file,$aslocal) = @_;
2581 my($aslocal_dir) = File::Basename::dirname($aslocal);
2582 File::Path::mkpath($aslocal_dir);
2583 HOSTHARDEST: for $i (@$host_seq) {
2584 unless (length $CPAN::Config->{'ftp'}) {
2585 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2588 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2589 $url .= "/" unless substr($url,-1) eq "/";
2591 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2592 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2595 my($host,$dir,$getfile) = ($1,$2,$3);
2597 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2598 $ctime,$blksize,$blocks) = stat($aslocal);
2599 $timestamp = $mtime ||= 0;
2600 my($netrc) = CPAN::FTP::netrc->new;
2601 my($netrcfile) = $netrc->netrc;
2602 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2603 my $targetfile = File::Basename::basename($aslocal);
2609 map("cd $_", split "/", $dir), # RFC 1738
2611 "get $getfile $targetfile",
2615 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2616 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2617 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2619 $netrc->contains($host))) if $CPAN::DEBUG;
2620 if ($netrc->protected) {
2621 $CPAN::Frontend->myprint(qq{
2622 Trying with external ftp to get
2624 As this requires some features that are not thoroughly tested, we\'re
2625 not sure, that we get it right....
2629 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2631 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2632 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2634 if ($mtime > $timestamp) {
2635 $CPAN::Frontend->myprint("GOT $aslocal\n");
2639 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2641 return if $CPAN::Signal;
2643 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2644 qq{correctly protected.\n});
2647 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2648 nor does it have a default entry\n");
2651 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2652 # then and login manually to host, using e-mail as
2654 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2658 "user anonymous $Config::Config{'cf_email'}"
2660 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2661 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2662 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2664 if ($mtime > $timestamp) {
2665 $CPAN::Frontend->myprint("GOT $aslocal\n");
2669 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2671 return if $CPAN::Signal;
2672 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2678 my($self,$command,@dialog) = @_;
2679 my $fh = FileHandle->new;
2680 $fh->open("|$command") or die "Couldn't open ftp: $!";
2681 foreach (@dialog) { $fh->print("$_\n") }
2682 $fh->close; # Wait for process to complete
2684 my $estatus = $wstatus >> 8;
2685 $CPAN::Frontend->myprint(qq{
2686 Subprocess "|$command"
2687 returned status $estatus (wstat $wstatus)
2691 # find2perl needs modularization, too, all the following is stolen
2695 my($self,$name) = @_;
2696 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2697 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2699 my($perms,%user,%group);
2703 $blocks = int(($blocks + 1) / 2);
2706 $blocks = int(($sizemm + 1023) / 1024);
2709 if (-f _) { $perms = '-'; }
2710 elsif (-d _) { $perms = 'd'; }
2711 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2712 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2713 elsif (-p _) { $perms = 'p'; }
2714 elsif (-S _) { $perms = 's'; }
2715 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2717 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2718 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2719 my $tmpmode = $mode;
2720 my $tmp = $rwx[$tmpmode & 7];
2722 $tmp = $rwx[$tmpmode & 7] . $tmp;
2724 $tmp = $rwx[$tmpmode & 7] . $tmp;
2725 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2726 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2727 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2730 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2731 my $group = $group{$gid} || $gid;
2733 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2735 my($moname) = $moname[$mon];
2736 if (-M _ > 365.25 / 2) {
2737 $timeyear = $year + 1900;
2740 $timeyear = sprintf("%02d:%02d", $hour, $min);
2743 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2757 package CPAN::FTP::netrc;
2761 my $file = MM->catfile($ENV{HOME},".netrc");
2763 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2764 $atime,$mtime,$ctime,$blksize,$blocks)
2769 my($fh,@machines,$hasdefault);
2771 $fh = FileHandle->new or die "Could not create a filehandle";
2773 if($fh->open($file)){
2774 $protected = ($mode & 077) == 0;
2776 NETRC: while (<$fh>) {
2777 my(@tokens) = split " ", $_;
2778 TOKEN: while (@tokens) {
2779 my($t) = shift @tokens;
2780 if ($t eq "default"){
2784 last TOKEN if $t eq "macdef";
2785 if ($t eq "machine") {
2786 push @machines, shift @tokens;
2791 $file = $hasdefault = $protected = "";
2795 'mach' => [@machines],
2797 'hasdefault' => $hasdefault,
2798 'protected' => $protected,
2802 # CPAN::FTP::hasdefault;
2803 sub hasdefault { shift->{'hasdefault'} }
2804 sub netrc { shift->{'netrc'} }
2805 sub protected { shift->{'protected'} }
2807 my($self,$mach) = @_;
2808 for ( @{$self->{'mach'}} ) {
2809 return 1 if $_ eq $mach;
2814 package CPAN::Complete;
2817 my($text, $line, $start, $end) = @_;
2818 my(@perlret) = cpl($text, $line, $start);
2819 # find longest common match. Can anybody show me how to peruse
2820 # T::R::Gnu to have this done automatically? Seems expensive.
2821 return () unless @perlret;
2822 my($newtext) = $text;
2823 for (my $i = length($text)+1;;$i++) {
2824 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2825 my $try = substr($perlret[0],0,$i);
2826 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2827 # warn "try[$try]tries[@tries]";
2828 if (@tries == @perlret) {
2834 ($newtext,@perlret);
2837 #-> sub CPAN::Complete::cpl ;
2839 my($word,$line,$pos) = @_;
2843 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2845 if ($line =~ s/^(force\s*)//) {
2850 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2851 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2853 } elsif ($line =~ /^(a|ls)\s/) {
2854 @return = cplx('CPAN::Author',uc($word));
2855 } elsif ($line =~ /^b\s/) {
2856 CPAN::Shell->local_bundles;
2857 @return = cplx('CPAN::Bundle',$word);
2858 } elsif ($line =~ /^d\s/) {
2859 @return = cplx('CPAN::Distribution',$word);
2860 } elsif ($line =~ m/^(
2861 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2863 if ($word =~ /^Bundle::/) {
2864 CPAN::Shell->local_bundles;
2866 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2867 } elsif ($line =~ /^i\s/) {
2868 @return = cpl_any($word);
2869 } elsif ($line =~ /^reload\s/) {
2870 @return = cpl_reload($word,$line,$pos);
2871 } elsif ($line =~ /^o\s/) {
2872 @return = cpl_option($word,$line,$pos);
2873 } elsif ($line =~ m/^\S+\s/ ) {
2874 # fallback for future commands and what we have forgotten above
2875 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2882 #-> sub CPAN::Complete::cplx ;
2884 my($class, $word) = @_;
2885 # I believed for many years that this was sorted, today I
2886 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2887 # make it sorted again. Maybe sort was dropped when GNU-readline
2888 # support came in? The RCS file is difficult to read on that:-(
2889 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2892 #-> sub CPAN::Complete::cpl_any ;
2896 cplx('CPAN::Author',$word),
2897 cplx('CPAN::Bundle',$word),
2898 cplx('CPAN::Distribution',$word),
2899 cplx('CPAN::Module',$word),
2903 #-> sub CPAN::Complete::cpl_reload ;
2905 my($word,$line,$pos) = @_;
2907 my(@words) = split " ", $line;
2908 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2909 my(@ok) = qw(cpan index);
2910 return @ok if @words == 1;
2911 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2914 #-> sub CPAN::Complete::cpl_option ;
2916 my($word,$line,$pos) = @_;
2918 my(@words) = split " ", $line;
2919 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2920 my(@ok) = qw(conf debug);
2921 return @ok if @words == 1;
2922 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2924 } elsif ($words[1] eq 'index') {
2926 } elsif ($words[1] eq 'conf') {
2927 return CPAN::Config::cpl(@_);
2928 } elsif ($words[1] eq 'debug') {
2929 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2933 package CPAN::Index;
2935 #-> sub CPAN::Index::force_reload ;
2938 $CPAN::Index::LAST_TIME = 0;
2942 #-> sub CPAN::Index::reload ;
2944 my($cl,$force) = @_;
2947 # XXX check if a newer one is available. (We currently read it
2948 # from time to time)
2949 for ($CPAN::Config->{index_expire}) {
2950 $_ = 0.001 unless $_ && $_ > 0.001;
2952 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2953 # debug here when CPAN doesn't seem to read the Metadata
2955 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2957 unless ($CPAN::META->{PROTOCOL}) {
2958 $cl->read_metadata_cache;
2959 $CPAN::META->{PROTOCOL} ||= "1.0";
2961 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
2962 # warn "Setting last_time to 0";
2963 $LAST_TIME = 0; # No warning necessary
2965 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
2968 # IFF we are developing, it helps to wipe out the memory
2969 # between reloads, otherwise it is not what a user expects.
2970 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2971 $CPAN::META = CPAN->new;
2975 local $LAST_TIME = $time;
2976 local $CPAN::META->{PROTOCOL} = PROTOCOL;
2978 my $needshort = $^O eq "dos";
2980 $cl->rd_authindex($cl
2982 "authors/01mailrc.txt.gz",
2984 File::Spec->catfile('authors', '01mailrc.gz') :
2985 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2988 $debug = "timing reading 01[".($t2 - $time)."]";
2990 return if $CPAN::Signal; # this is sometimes lengthy
2991 $cl->rd_modpacks($cl
2993 "modules/02packages.details.txt.gz",
2995 File::Spec->catfile('modules', '02packag.gz') :
2996 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2999 $debug .= "02[".($t2 - $time)."]";
3001 return if $CPAN::Signal; # this is sometimes lengthy
3004 "modules/03modlist.data.gz",
3006 File::Spec->catfile('modules', '03mlist.gz') :
3007 File::Spec->catfile('modules', '03modlist.data.gz'),
3009 $cl->write_metadata_cache;
3011 $debug .= "03[".($t2 - $time)."]";
3013 CPAN->debug($debug) if $CPAN::DEBUG;
3016 $CPAN::META->{PROTOCOL} = PROTOCOL;
3019 #-> sub CPAN::Index::reload_x ;
3021 my($cl,$wanted,$localname,$force) = @_;
3022 $force |= 2; # means we're dealing with an index here
3023 CPAN::Config->load; # we should guarantee loading wherever we rely
3025 $localname ||= $wanted;
3026 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
3030 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3033 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3034 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3035 qq{day$s. I\'ll use that.});
3038 $force |= 1; # means we're quite serious about it.
3040 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3043 #-> sub CPAN::Index::rd_authindex ;
3045 my($cl, $index_target) = @_;
3047 return unless defined $index_target;
3048 $CPAN::Frontend->myprint("Going to read $index_target\n");
3050 tie *FH, CPAN::Tarzip, $index_target;
3052 push @lines, split /\012/ while <FH>;
3054 my($userid,$fullname,$email) =
3055 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3056 next unless $userid && $fullname && $email;
3058 # instantiate an author object
3059 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3060 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3061 return if $CPAN::Signal;
3066 my($self,$dist) = @_;
3067 $dist = $self->{'id'} unless defined $dist;
3068 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3072 #-> sub CPAN::Index::rd_modpacks ;
3074 my($self, $index_target) = @_;
3076 return unless defined $index_target;
3077 $CPAN::Frontend->myprint("Going to read $index_target\n");
3078 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3080 while ($_ = $fh->READLINE) {
3082 my @ls = map {"$_\n"} split /\n/, $_;
3083 unshift @ls, "\n" x length($1) if /^(\n+)/;
3087 my($line_count,$last_updated);
3089 my $shift = shift(@lines);
3090 last if $shift =~ /^\s*$/;
3091 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3092 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3094 if (not defined $line_count) {
3096 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3097 Please check the validity of the index file by comparing it to more
3098 than one CPAN mirror. I'll continue but problems seem likely to
3103 } elsif ($line_count != scalar @lines) {
3105 warn sprintf qq{Warning: Your %s
3106 contains a Line-Count header of %d but I see %d lines there. Please
3107 check the validity of the index file by comparing it to more than one
3108 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3109 $index_target, $line_count, scalar(@lines);
3112 if (not defined $last_updated) {
3114 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3115 Please check the validity of the index file by comparing it to more
3116 than one CPAN mirror. I'll continue but problems seem likely to
3124 ->myprint(sprintf qq{ Database was generated on %s\n},
3126 $DATE_OF_02 = $last_updated;
3128 if ($CPAN::META->has_inst(HTTP::Date)) {
3130 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3135 qq{Warning: This index file is %d days old.
3136 Please check the host you chose as your CPAN mirror for staleness.
3137 I'll continue but problems seem likely to happen.\a\n},
3142 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3147 # A necessity since we have metadata_cache: delete what isn't
3149 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3150 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3154 # before 1.56 we split into 3 and discarded the rest. From
3155 # 1.57 we assign remaining text to $comment thus allowing to
3156 # influence isa_perl
3157 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3158 my($bundle,$id,$userid);
3160 if ($mod eq 'CPAN' &&
3162 CPAN::Queue->exists('Bundle::CPAN') ||
3163 CPAN::Queue->exists('CPAN')
3167 if ($version > $CPAN::VERSION){
3168 $CPAN::Frontend->myprint(qq{
3169 There's a new CPAN.pm version (v$version) available!
3170 [Current version is v$CPAN::VERSION]
3171 You might want to try
3172 install Bundle::CPAN
3174 without quitting the current session. It should be a seamless upgrade
3175 while we are running...
3178 $CPAN::Frontend->myprint(qq{\n});
3180 last if $CPAN::Signal;
3181 } elsif ($mod =~ /^Bundle::(.*)/) {
3186 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3187 # Let's make it a module too, because bundles have so much
3188 # in common with modules.
3190 # Changed in 1.57_63: seems like memory bloat now without
3191 # any value, so commented out
3193 # $CPAN::META->instance('CPAN::Module',$mod);
3197 # instantiate a module object
3198 $id = $CPAN::META->instance('CPAN::Module',$mod);
3202 if ($id->cpan_file ne $dist){ # update only if file is
3203 # different. CPAN prohibits same
3204 # name with different version
3205 $userid = $self->userid($dist);
3207 'CPAN_USERID' => $userid,
3208 'CPAN_VERSION' => $version,
3209 'CPAN_FILE' => $dist,
3213 # instantiate a distribution object
3214 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3215 # we do not need CONTAINSMODS unless we do something with
3216 # this dist, so we better produce it on demand.
3218 ## my $obj = $CPAN::META->instance(
3219 ## 'CPAN::Distribution' => $dist
3221 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3223 $CPAN::META->instance(
3224 'CPAN::Distribution' => $dist
3226 'CPAN_USERID' => $userid,
3227 'CPAN_COMMENT' => $comment,
3231 for my $name ($mod,$dist) {
3232 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3233 $exists{$name} = undef;
3236 return if $CPAN::Signal;
3240 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3241 for my $o ($CPAN::META->all_objects($class)) {
3242 next if exists $exists{$o->{ID}};
3243 $CPAN::META->delete($class,$o->{ID});
3244 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3251 #-> sub CPAN::Index::rd_modlist ;
3253 my($cl,$index_target) = @_;
3254 return unless defined $index_target;
3255 $CPAN::Frontend->myprint("Going to read $index_target\n");
3256 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3259 while ($_ = $fh->READLINE) {
3261 my @ls = map {"$_\n"} split /\n/, $_;
3262 unshift @ls, "\n" x length($1) if /^(\n+)/;
3266 my $shift = shift(@eval);
3267 if ($shift =~ /^Date:\s+(.*)/){
3268 return if $DATE_OF_03 eq $1;
3271 last if $shift =~ /^\s*$/;
3274 push @eval, q{CPAN::Modulelist->data;};
3276 my($comp) = Safe->new("CPAN::Safe1");
3277 my($eval) = join("", @eval);
3278 my $ret = $comp->reval($eval);
3279 Carp::confess($@) if $@;
3280 return if $CPAN::Signal;
3282 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3283 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3284 $obj->set(%{$ret->{$_}});
3285 return if $CPAN::Signal;
3289 #-> sub CPAN::Index::write_metadata_cache ;
3290 sub write_metadata_cache {
3292 return unless $CPAN::Config->{'cache_metadata'};
3293 return unless $CPAN::META->has_usable("Storable");
3295 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3296 CPAN::Distribution)) {
3297 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3299 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3300 $cache->{last_time} = $LAST_TIME;
3301 $cache->{DATE_OF_02} = $DATE_OF_02;
3302 $cache->{PROTOCOL} = PROTOCOL;
3303 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3304 eval { Storable::nstore($cache, $metadata_file) };
3305 $CPAN::Frontend->mywarn($@) if $@;
3308 #-> sub CPAN::Index::read_metadata_cache ;
3309 sub read_metadata_cache {
3311 return unless $CPAN::Config->{'cache_metadata'};
3312 return unless $CPAN::META->has_usable("Storable");
3313 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3314 return unless -r $metadata_file and -f $metadata_file;
3315 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3317 eval { $cache = Storable::retrieve($metadata_file) };
3318 $CPAN::Frontend->mywarn($@) if $@;
3319 if (!$cache || ref $cache ne 'HASH'){
3323 if (exists $cache->{PROTOCOL}) {
3324 if (PROTOCOL > $cache->{PROTOCOL}) {
3325 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3326 "with protocol v%s, requiring v%s",
3333 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3334 "with protocol v1.0");
3339 while(my($class,$v) = each %$cache) {
3340 next unless $class =~ /^CPAN::/;
3341 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3342 while (my($id,$ro) = each %$v) {
3343 $CPAN::META->{readwrite}{$class}{$id} ||=
3344 $class->new(ID=>$id, RO=>$ro);
3349 unless ($clcnt) { # sanity check
3350 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3353 if ($idcnt < 1000) {
3354 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3355 "in $metadata_file\n");
3358 $CPAN::META->{PROTOCOL} ||=
3359 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3360 # does initialize to some protocol
3361 $LAST_TIME = $cache->{last_time};
3362 $DATE_OF_02 = $cache->{DATE_OF_02};
3363 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3364 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3368 package CPAN::InfoObj;
3371 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3372 sub id { shift->{ID}; }
3374 #-> sub CPAN::InfoObj::new ;
3376 my $this = bless {}, shift;
3381 # The set method may only be used by code that reads index data or
3382 # otherwise "objective" data from the outside world. All session
3383 # related material may do anything else with instance variables but
3384 # must not touch the hash under the RO attribute. The reason is that
3385 # the RO hash gets written to Metadata file and is thus persistent.
3387 #-> sub CPAN::InfoObj::set ;
3389 my($self,%att) = @_;
3390 my $class = ref $self;
3392 # This must be ||=, not ||, because only if we write an empty
3393 # reference, only then the set method will write into the readonly
3394 # area. But for Distributions that spring into existence, maybe
3395 # because of a typo, we do not like it that they are written into
3396 # the readonly area and made permanent (at least for a while) and
3397 # that is why we do not "allow" other places to call ->set.
3398 unless ($self->id) {
3399 CPAN->debug("Bug? Empty ID, rejecting");
3402 my $ro = $self->{RO} =
3403 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3405 while (my($k,$v) = each %att) {
3410 #-> sub CPAN::InfoObj::as_glimpse ;
3414 my $class = ref($self);
3415 $class =~ s/^CPAN:://;
3416 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3420 #-> sub CPAN::InfoObj::as_string ;
3424 my $class = ref($self);
3425 $class =~ s/^CPAN:://;
3426 push @m, $class, " id = $self->{ID}\n";
3427 for (sort keys %{$self->{RO}}) {
3428 # next if m/^(ID|RO)$/;
3430 if ($_ eq "CPAN_USERID") {
3431 $extra .= " (".$self->author;
3432 my $email; # old perls!
3433 if ($email = $CPAN::META->instance("CPAN::Author",
3436 $extra .= " <$email>";
3438 $extra .= " <no email>";
3441 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3442 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3445 next unless defined $self->{RO}{$_};
3446 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3448 for (sort keys %$self) {
3449 next if m/^(ID|RO)$/;
3450 if (ref($self->{$_}) eq "ARRAY") {
3451 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3452 } elsif (ref($self->{$_}) eq "HASH") {
3456 join(" ",keys %{$self->{$_}}),
3459 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3465 #-> sub CPAN::InfoObj::author ;
3468 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3471 #-> sub CPAN::InfoObj::dump ;
3474 require Data::Dumper;
3475 print Data::Dumper::Dumper($self);
3478 package CPAN::Author;
3480 #-> sub CPAN::Author::id
3483 my $id = $self->{ID};
3484 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3488 #-> sub CPAN::Author::as_glimpse ;
3492 my $class = ref($self);
3493 $class =~ s/^CPAN:://;
3494 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3502 #-> sub CPAN::Author::fullname ;
3504 shift->{RO}{FULLNAME};
3508 #-> sub CPAN::Author::email ;
3509 sub email { shift->{RO}{EMAIL}; }
3511 #-> sub CPAN::Author::ls ;
3516 # adapted from CPAN::Distribution::verifyMD5 ;
3517 my(@csf); # chksumfile
3518 @csf = $self->id =~ /(.)(.)(.*)/;
3519 $csf[1] = join "", @csf[0,1];
3520 $csf[2] = join "", @csf[1,2];
3522 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3523 unless (grep {$_->[2] eq $csf[1]} @dl) {
3524 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3527 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3528 unless (grep {$_->[2] eq $csf[2]} @dl) {
3529 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3532 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3533 $CPAN::Frontend->myprint(join "", map {
3534 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3535 } sort { $a->[2] cmp $b->[2] } @dl);
3538 # returns an array of arrays, the latter contain (size,mtime,filename)
3539 #-> sub CPAN::Author::dir_listing ;
3542 my $chksumfile = shift;
3543 my $recursive = shift;
3545 MM->catfile($CPAN::Config->{keep_source_where},
3546 "authors", "id", @$chksumfile);
3548 # connect "force" argument with "index_expire".
3550 if (my @stat = stat $lc_want) {
3551 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3553 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3556 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3557 $chksumfile->[-1] .= ".gz";
3558 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3561 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3562 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3568 # adapted from CPAN::Distribution::MD5_check_file ;
3569 my $fh = FileHandle->new;
3571 if (open $fh, $lc_file){
3574 $eval =~ s/\015?\012/\n/g;
3576 my($comp) = Safe->new();
3577 $cksum = $comp->reval($eval);
3579 rename $lc_file, "$lc_file.bad";
3580 Carp::confess($@) if $@;
3583 Carp::carp "Could not open $lc_file for reading";
3586 for $f (sort keys %$cksum) {
3587 if (exists $cksum->{$f}{isdir}) {
3589 my(@dir) = @$chksumfile;
3591 push @dir, $f, "CHECKSUMS";
3593 [$_->[0], $_->[1], "$f/$_->[2]"]
3594 } $self->dir_listing(\@dir,1);
3596 push @result, [ 0, "-", $f ];
3600 ($cksum->{$f}{"size"}||0),
3601 $cksum->{$f}{"mtime"}||"---",
3609 package CPAN::Distribution;
3612 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3616 delete $self->{later};
3619 # CPAN::Distribution::normalize
3622 $s = $self->id unless defined $s;
3626 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3628 return $s if $s =~ m:^N/A|^Contact Author: ;
3629 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3630 $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3631 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3636 #-> sub CPAN::Distribution::color_cmd_tmps ;
3637 sub color_cmd_tmps {
3639 my($depth) = shift || 0;
3640 my($color) = shift || 0;
3641 # a distribution needs to recurse into its prereq_pms
3643 return if exists $self->{incommandcolor}
3644 && $self->{incommandcolor}==$color;
3645 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3646 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3651 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3652 my $prereq_pm = $self->prereq_pm;
3653 if (defined $prereq_pm) {
3654 for my $pre (keys %$prereq_pm) {
3655 my $premo = CPAN::Shell->expand("Module",$pre);
3656 $premo->color_cmd_tmps($depth+1,$color);
3660 delete $self->{sponsored_mods};
3661 delete $self->{badtestcnt};
3663 $self->{incommandcolor} = $color;
3666 #-> sub CPAN::Distribution::as_string ;
3669 $self->containsmods;
3670 $self->SUPER::as_string(@_);
3673 #-> sub CPAN::Distribution::containsmods ;
3676 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3677 my $dist_id = $self->{ID};
3678 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3679 my $mod_file = $mod->cpan_file or next;
3680 my $mod_id = $mod->{ID} or next;
3681 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3683 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3685 keys %{$self->{CONTAINSMODS}};
3688 #-> sub CPAN::Distribution::uptodate ;
3692 foreach $c ($self->containsmods) {
3693 my $obj = CPAN::Shell->expandany($c);
3694 return 0 unless $obj->uptodate;
3699 #-> sub CPAN::Distribution::called_for ;
3702 $self->{CALLED_FOR} = $id if defined $id;
3703 return $self->{CALLED_FOR};
3706 #-> sub CPAN::Distribution::safe_chdir ;
3708 my($self,$todir) = @_;
3709 # we die if we cannot chdir and we are debuggable
3710 Carp::confess("safe_chdir called without todir argument")
3711 unless defined $todir and length $todir;
3713 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3716 my $cwd = CPAN::anycwd();
3717 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3718 qq{to todir[$todir]: $!});
3722 #-> sub CPAN::Distribution::get ;
3727 exists $self->{'build_dir'} and push @e,
3728 "Is already unwrapped into directory $self->{'build_dir'}";
3729 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3731 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3734 # Get the file on local disk
3740 $CPAN::Config->{keep_source_where},
3743 split("/",$self->id)
3746 $self->debug("Doing localize") if $CPAN::DEBUG;
3747 unless ($local_file =
3748 CPAN::FTP->localize("authors/id/$self->{ID}",
3751 if ($CPAN::Index::DATE_OF_02) {
3752 $note = "Note: Current database in memory was generated ".
3753 "on $CPAN::Index::DATE_OF_02\n";
3755 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3757 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3758 $self->{localfile} = $local_file;
3759 return if $CPAN::Signal;
3764 if ($CPAN::META->has_inst("MD5")) {
3765 $self->debug("MD5 is installed, verifying");
3768 $self->debug("MD5 is NOT installed");
3770 return if $CPAN::Signal;
3773 # Create a clean room and go there
3775 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3776 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3777 $self->safe_chdir($builddir);
3778 $self->debug("Removing tmp") if $CPAN::DEBUG;
3779 File::Path::rmtree("tmp");
3780 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3782 $self->safe_chdir($sub_wd);
3785 $self->safe_chdir("tmp");
3790 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3791 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3792 $self->untar_me($local_file);
3793 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3794 $self->unzip_me($local_file);
3795 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3796 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3797 $self->pm2dir_me($local_file);
3799 $self->{archived} = "NO";
3800 $self->safe_chdir($sub_wd);
3804 # we are still in the tmp directory!
3805 # Let's check if the package has its own directory.
3806 my $dh = DirHandle->new(File::Spec->curdir)
3807 or Carp::croak("Couldn't opendir .: $!");
3808 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3810 my ($distdir,$packagedir);
3811 if (@readdir == 1 && -d $readdir[0]) {
3812 $distdir = $readdir[0];
3813 $packagedir = MM->catdir($builddir,$distdir);
3814 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3816 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3818 File::Path::rmtree($packagedir);
3819 rename($distdir,$packagedir) or
3820 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3821 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3828 my $userid = $self->cpan_userid;
3830 CPAN->debug("no userid? self[$self]");
3833 my $pragmatic_dir = $userid . '000';
3834 $pragmatic_dir =~ s/\W_//g;
3835 $pragmatic_dir++ while -d "../$pragmatic_dir";
3836 $packagedir = MM->catdir($builddir,$pragmatic_dir);
3837 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3838 File::Path::mkpath($packagedir);
3840 for $f (@readdir) { # is already without "." and ".."
3841 my $to = MM->catdir($packagedir,$f);
3842 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3846 $self->safe_chdir($sub_wd);
3850 $self->{'build_dir'} = $packagedir;
3851 $self->safe_chdir(File::Spec->updir);
3852 File::Path::rmtree("tmp");
3854 my($mpl) = MM->catfile($packagedir,"Makefile.PL");
3855 my($mpl_exists) = -f $mpl;
3856 unless ($mpl_exists) {
3857 # NFS has been reported to have racing problems after the
3858 # renaming of a directory in some environments.
3861 my $mpldh = DirHandle->new($packagedir)
3862 or Carp::croak("Couldn't opendir $packagedir: $!");
3863 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3866 unless ($mpl_exists) {
3867 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3871 my($configure) = MM->catfile($packagedir,"Configure");
3872 if (-f $configure) {
3873 # do we have anything to do?
3874 $self->{'configure'} = $configure;
3875 } elsif (-f MM->catfile($packagedir,"Makefile")) {
3876 $CPAN::Frontend->myprint(qq{
3877 Package comes with a Makefile and without a Makefile.PL.
3878 We\'ll try to build it with that Makefile then.
3880 $self->{writemakefile} = "YES";
3883 my $cf = $self->called_for || "unknown";
3888 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3889 $cf = "unknown" unless length($cf);
3890 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3891 (The test -f "$mpl" returned false.)
3892 Writing one on our own (setting NAME to $cf)\a\n});
3893 $self->{had_no_makefile_pl}++;
3896 # Writing our own Makefile.PL
3898 my $fh = FileHandle->new;
3900 or Carp::croak("Could not open >$mpl: $!");
3902 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3903 # because there was no Makefile.PL supplied.
3904 # Autogenerated on: }.scalar localtime().qq{
3906 use ExtUtils::MakeMaker;
3907 WriteMakefile(NAME => q[$cf]);
3917 # CPAN::Distribution::untar_me ;
3919 my($self,$local_file) = @_;
3920 $self->{archived} = "tar";
3921 if (CPAN::Tarzip->untar($local_file)) {
3922 $self->{unwrapped} = "YES";
3924 $self->{unwrapped} = "NO";
3928 # CPAN::Distribution::unzip_me ;
3930 my($self,$local_file) = @_;
3931 $self->{archived} = "zip";
3932 if (CPAN::Tarzip->unzip($local_file)) {
3933 $self->{unwrapped} = "YES";
3935 $self->{unwrapped} = "NO";
3941 my($self,$local_file) = @_;
3942 $self->{archived} = "pm";
3943 my $to = File::Basename::basename($local_file);
3944 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3945 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3946 $self->{unwrapped} = "YES";
3948 $self->{unwrapped} = "NO";
3952 #-> sub CPAN::Distribution::new ;
3954 my($class,%att) = @_;
3956 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3958 my $this = { %att };
3959 return bless $this, $class;
3962 #-> sub CPAN::Distribution::look ;
3966 if ($^O eq 'MacOS') {
3967 $self->ExtUtils::MM_MacOS::look;
3971 if ( $CPAN::Config->{'shell'} ) {
3972 $CPAN::Frontend->myprint(qq{
3973 Trying to open a subshell in the build directory...
3976 $CPAN::Frontend->myprint(qq{
3977 Your configuration does not define a value for subshells.
3978 Please define it with "o conf shell <your shell>"
3982 my $dist = $self->id;
3984 unless ($dir = $self->dir) {
3987 unless ($dir ||= $self->dir) {
3988 $CPAN::Frontend->mywarn(qq{
3989 Could not determine which directory to use for looking at $dist.
3993 my $pwd = CPAN::anycwd();
3994 $self->safe_chdir($dir);
3995 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3996 system($CPAN::Config->{'shell'}) == 0
3997 or $CPAN::Frontend->mydie("Subprocess shell error");
3998 $self->safe_chdir($pwd);
4001 # CPAN::Distribution::cvs_import ;
4005 my $dir = $self->dir;
4007 my $package = $self->called_for;
4008 my $module = $CPAN::META->instance('CPAN::Module', $package);
4009 my $version = $module->cpan_version;
4011 my $userid = $self->cpan_userid;
4013 my $cvs_dir = (split '/', $dir)[-1];
4014 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4016 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4018 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4019 if ($cvs_site_perl) {
4020 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4022 my $cvs_log = qq{"imported $package $version sources"};
4023 $version =~ s/\./_/g;
4024 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4025 "$cvs_dir", $userid, "v$version");
4027 my $pwd = CPAN::anycwd();
4028 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4030 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4032 $CPAN::Frontend->myprint(qq{@cmd\n});
4033 system(@cmd) == 0 or
4034 $CPAN::Frontend->mydie("cvs import failed");
4035 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4038 #-> sub CPAN::Distribution::readme ;
4041 my($dist) = $self->id;
4042 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4043 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4047 $CPAN::Config->{keep_source_where},
4050 split("/","$sans.readme"),
4052 $self->debug("Doing localize") if $CPAN::DEBUG;
4053 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4055 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4057 if ($^O eq 'MacOS') {
4058 ExtUtils::MM_MacOS::launch_file($local_file);
4062 my $fh_pager = FileHandle->new;
4063 local($SIG{PIPE}) = "IGNORE";
4064 $fh_pager->open("|$CPAN::Config->{'pager'}")
4065 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4066 my $fh_readme = FileHandle->new;
4067 $fh_readme->open($local_file)
4068 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4069 $CPAN::Frontend->myprint(qq{
4072 with pager "$CPAN::Config->{'pager'}"
4075 $fh_pager->print(<$fh_readme>);
4078 #-> sub CPAN::Distribution::verifyMD5 ;
4083 $self->{MD5_STATUS} ||= "";
4084 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4085 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4087 my($lc_want,$lc_file,@local,$basename);
4088 @local = split("/",$self->id);
4090 push @local, "CHECKSUMS";
4092 MM->catfile($CPAN::Config->{keep_source_where},
4093 "authors", "id", @local);
4098 $self->MD5_check_file($lc_want)
4100 return $self->{MD5_STATUS} = "OK";
4102 $lc_file = CPAN::FTP->localize("authors/id/@local",
4105 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4106 $local[-1] .= ".gz";
4107 $lc_file = CPAN::FTP->localize("authors/id/@local",
4110 $lc_file =~ s/\.gz(?!\n)\Z//;
4111 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4116 $self->MD5_check_file($lc_file);
4119 #-> sub CPAN::Distribution::MD5_check_file ;
4120 sub MD5_check_file {
4121 my($self,$chk_file) = @_;
4122 my($cksum,$file,$basename);
4123 $file = $self->{localfile};
4124 $basename = File::Basename::basename($file);
4125 my $fh = FileHandle->new;
4126 if (open $fh, $chk_file){
4129 $eval =~ s/\015?\012/\n/g;
4131 my($comp) = Safe->new();
4132 $cksum = $comp->reval($eval);
4134 rename $chk_file, "$chk_file.bad";
4135 Carp::confess($@) if $@;
4138 Carp::carp "Could not open $chk_file for reading";
4141 if (exists $cksum->{$basename}{md5}) {
4142 $self->debug("Found checksum for $basename:" .
4143 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4147 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4149 $fh = CPAN::Tarzip->TIEHANDLE($file);
4152 # had to inline it, when I tied it, the tiedness got lost on
4153 # the call to eq_MD5. (Jan 1998)
4157 while ($fh->READ($ref, 4096) > 0){
4160 my $hexdigest = $md5->hexdigest;
4161 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4165 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4166 return $self->{MD5_STATUS} = "OK";
4168 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4169 qq{distribution file. }.
4170 qq{Please investigate.\n\n}.
4172 $CPAN::META->instance(
4177 my $wrap = qq{I\'d recommend removing $file. Its MD5
4178 checksum is incorrect. Maybe you have configured your 'urllist' with
4179 a bad URL. Please check this array with 'o conf urllist', and
4182 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4184 # former versions just returned here but this seems a
4185 # serious threat that deserves a die
4187 # $CPAN::Frontend->myprint("\n\n");
4191 # close $fh if fileno($fh);
4193 $self->{MD5_STATUS} ||= "";
4194 if ($self->{MD5_STATUS} eq "NIL") {
4195 $CPAN::Frontend->mywarn(qq{
4196 Warning: No md5 checksum for $basename in $chk_file.
4198 The cause for this may be that the file is very new and the checksum
4199 has not yet been calculated, but it may also be that something is
4200 going awry right now.
4202 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4203 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4205 $self->{MD5_STATUS} = "NIL";
4210 #-> sub CPAN::Distribution::eq_MD5 ;
4212 my($self,$fh,$expectMD5) = @_;
4215 while (read($fh, $data, 4096)){
4218 # $md5->addfile($fh);
4219 my $hexdigest = $md5->hexdigest;
4220 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4221 $hexdigest eq $expectMD5;
4224 #-> sub CPAN::Distribution::force ;
4226 # Both modules and distributions know if "force" is in effect by
4227 # autoinspection, not by inspecting a global variable. One of the
4228 # reason why this was chosen to work that way was the treatment of
4229 # dependencies. They should not autpomatically inherit the force
4230 # status. But this has the downside that ^C and die() will return to
4231 # the prompt but will not be able to reset the force_update
4232 # attributes. We try to correct for it currently in the read_metadata
4233 # routine, and immediately before we check for a Signal. I hope this
4234 # works out in one of v1.57_53ff
4237 my($self, $method) = @_;
4239 MD5_STATUS archived build_dir localfile make install unwrapped
4242 delete $self->{$att};
4244 if ($method && $method eq "install") {
4245 $self->{"force_update"}++; # name should probably have been force_install
4249 #-> sub CPAN::Distribution::unforce ;
4252 delete $self->{'force_update'};
4255 #-> sub CPAN::Distribution::isa_perl ;
4258 my $file = File::Basename::basename($self->id);
4259 if ($file =~ m{ ^ perl
4272 } elsif ($self->cpan_comment
4274 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4279 #-> sub CPAN::Distribution::perl ;
4282 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
4283 my $pwd = CPAN::anycwd();
4284 my $candidate = MM->catfile($pwd,$^X);
4285 $perl ||= $candidate if MM->maybe_command($candidate);
4287 my ($component,$perl_name);
4288 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4289 PATH_COMPONENT: foreach $component (MM->path(),
4290 $Config::Config{'binexp'}) {
4291 next unless defined($component) && $component;
4292 my($abs) = MM->catfile($component,$perl_name);
4293 if (MM->maybe_command($abs)) {
4303 #-> sub CPAN::Distribution::make ;
4306 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4307 # Emergency brake if they said install Pippi and get newest perl
4308 if ($self->isa_perl) {
4310 $self->called_for ne $self->id &&
4311 ! $self->{force_update}
4313 # if we die here, we break bundles
4314 $CPAN::Frontend->mywarn(sprintf qq{
4315 The most recent version "%s" of the module "%s"
4316 comes with the current version of perl (%s).
4317 I\'ll build that only if you ask for something like
4322 $CPAN::META->instance(
4336 $self->{archived} eq "NO" and push @e,
4337 "Is neither a tar nor a zip archive.";
4339 $self->{unwrapped} eq "NO" and push @e,
4340 "had problems unarchiving. Please build manually";
4342 exists $self->{writemakefile} &&
4343 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4344 $1 || "Had some problem writing Makefile";
4346 defined $self->{'make'} and push @e,
4347 "Has already been processed within this session";
4349 exists $self->{later} and length($self->{later}) and
4350 push @e, $self->{later};
4352 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4354 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4355 my $builddir = $self->dir;
4356 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4357 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4359 if ($^O eq 'MacOS') {
4360 ExtUtils::MM_MacOS::make($self);
4365 if ($self->{'configure'}) {
4366 $system = $self->{'configure'};
4368 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4370 # This needs a handler that can be turned on or off:
4371 # $switch = "-MExtUtils::MakeMaker ".
4372 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4374 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4376 unless (exists $self->{writemakefile}) {
4377 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4380 if ($CPAN::Config->{inactivity_timeout}) {
4382 alarm $CPAN::Config->{inactivity_timeout};
4383 local $SIG{CHLD}; # = sub { wait };
4384 if (defined($pid = fork)) {
4389 # note, this exec isn't necessary if
4390 # inactivity_timeout is 0. On the Mac I'd
4391 # suggest, we set it always to 0.
4395 $CPAN::Frontend->myprint("Cannot fork: $!");
4403 $CPAN::Frontend->myprint($@);
4404 $self->{writemakefile} = "NO $@";
4409 $ret = system($system);
4411 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4415 if (-f "Makefile") {
4416 $self->{writemakefile} = "YES";
4417 delete $self->{make_clean}; # if cleaned before, enable next
4419 $self->{writemakefile} =
4420 qq{NO Makefile.PL refused to write a Makefile.};
4421 # It's probably worth it to record the reason, so let's retry
4423 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4424 # $self->{writemakefile} .= <$fh>;
4428 delete $self->{force_update};
4431 if (my @prereq = $self->unsat_prereq){
4432 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4434 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4435 if (system($system) == 0) {
4436 $CPAN::Frontend->myprint(" $system -- OK\n");
4437 $self->{'make'} = "YES";
4439 $self->{writemakefile} ||= "YES";
4440 $self->{'make'} = "NO";
4441 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4445 sub follow_prereqs {
4449 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4450 "during [$id] -----\n");
4452 for my $p (@prereq) {
4453 $CPAN::Frontend->myprint(" $p\n");
4456 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4458 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4459 require ExtUtils::MakeMaker;
4460 my $answer = ExtUtils::MakeMaker::prompt(
4461 "Shall I follow them and prepend them to the queue
4462 of modules we are processing right now?", "yes");
4463 $follow = $answer =~ /^\s*y/i;
4467 myprint(" Ignoring dependencies on modules @prereq\n");
4470 # color them as dirty
4471 for my $p (@prereq) {
4472 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4474 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4475 $self->{later} = "Delayed until after prerequisites";
4476 return 1; # signal success to the queuerunner
4480 #-> sub CPAN::Distribution::unsat_prereq ;
4483 my $prereq_pm = $self->prereq_pm or return;
4485 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4486 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4487 # we were too demanding:
4488 next if $nmo->uptodate;
4490 # if they have not specified a version, we accept any installed one
4491 if (not defined $need_version or
4492 $need_version == 0 or
4493 $need_version eq "undef") {
4494 next if defined $nmo->inst_file;
4497 # We only want to install prereqs if either they're not installed
4498 # or if the installed version is too old. We cannot omit this
4499 # check, because if 'force' is in effect, nobody else will check.
4503 defined $nmo->inst_file &&
4504 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4506 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4510 CPAN::Version->readable($need_version)
4516 if ($self->{sponsored_mods}{$need_module}++){
4517 # We have already sponsored it and for some reason it's still
4518 # not available. So we do nothing. Or what should we do?
4519 # if we push it again, we have a potential infinite loop
4522 push @need, $need_module;
4527 #-> sub CPAN::Distribution::prereq_pm ;
4530 return $self->{prereq_pm} if
4531 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4532 return unless $self->{writemakefile}; # no need to have succeeded
4533 # but we must have run it
4534 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4535 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4540 $fh = FileHandle->new("<$makefile\0")) {
4544 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4546 last if /MakeMaker post_initialize section/;
4548 \s+PREREQ_PM\s+=>\s+(.+)
4551 # warn "Found prereq expr[$p]";
4553 # Regexp modified by A.Speer to remember actual version of file
4554 # PREREQ_PM hash key wants, then add to
4555 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4556 # In case a prereq is mentioned twice, complain.
4557 if ( defined $p{$1} ) {
4558 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4565 $self->{prereq_pm_detected}++;
4566 return $self->{prereq_pm} = \%p;
4569 #-> sub CPAN::Distribution::test ;
4574 delete $self->{force_update};
4577 $CPAN::Frontend->myprint("Running make test\n");
4578 if (my @prereq = $self->unsat_prereq){
4579 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4583 exists $self->{make} or exists $self->{later} or push @e,
4584 "Make had some problems, maybe interrupted? Won't test";
4586 exists $self->{'make'} and
4587 $self->{'make'} eq 'NO' and
4588 push @e, "Can't test without successful make";
4590 exists $self->{build_dir} or push @e, "Has no own directory";
4591 $self->{badtestcnt} ||= 0;
4592 $self->{badtestcnt} > 0 and
4593 push @e, "Won't repeat unsuccessful test during this command";
4595 exists $self->{later} and length($self->{later}) and
4596 push @e, $self->{later};
4598 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4600 chdir $self->{'build_dir'} or
4601 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4602 $self->debug("Changed directory to $self->{'build_dir'}")
4605 if ($^O eq 'MacOS') {
4606 ExtUtils::MM_MacOS::make_test($self);
4610 my $system = join " ", $CPAN::Config->{'make'}, "test";
4611 if (system($system) == 0) {
4612 $CPAN::Frontend->myprint(" $system -- OK\n");
4613 $self->{make_test} = "YES";
4615 $self->{make_test} = "NO";
4616 $self->{badtestcnt}++;
4617 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4621 #-> sub CPAN::Distribution::clean ;
4624 $CPAN::Frontend->myprint("Running make clean\n");
4627 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4628 push @e, "make clean already called once";
4629 exists $self->{build_dir} or push @e, "Has no own directory";
4630 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4632 chdir $self->{'build_dir'} or
4633 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4634 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4636 if ($^O eq 'MacOS') {
4637 ExtUtils::MM_MacOS::make_clean($self);
4641 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4642 if (system($system) == 0) {
4643 $CPAN::Frontend->myprint(" $system -- OK\n");
4647 # Jost Krieger pointed out that this "force" was wrong because
4648 # it has the effect that the next "install" on this distribution
4649 # will untar everything again. Instead we should bring the
4650 # object's state back to where it is after untarring.
4652 delete $self->{force_update};
4653 delete $self->{install};
4654 delete $self->{writemakefile};
4655 delete $self->{make};
4656 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4657 $self->{make_clean} = "YES";
4660 # Hmmm, what to do if make clean failed?
4662 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4664 make clean did not succeed, marking directory as unusable for further work.
4666 $self->force("make"); # so that this directory won't be used again
4671 #-> sub CPAN::Distribution::install ;
4676 delete $self->{force_update};
4679 $CPAN::Frontend->myprint("Running make install\n");
4682 exists $self->{build_dir} or push @e, "Has no own directory";
4684 exists $self->{make} or exists $self->{later} or push @e,
4685 "Make had some problems, maybe interrupted? Won't install";
4687 exists $self->{'make'} and
4688 $self->{'make'} eq 'NO' and
4689 push @e, "make had returned bad status, install seems impossible";
4691 push @e, "make test had returned bad status, ".
4692 "won't install without force"
4693 if exists $self->{'make_test'} and
4694 $self->{'make_test'} eq 'NO' and
4695 ! $self->{'force_update'};
4697 exists $self->{'install'} and push @e,
4698 $self->{'install'} eq "YES" ?
4699 "Already done" : "Already tried without success";
4701 exists $self->{later} and length($self->{later}) and
4702 push @e, $self->{later};
4704 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4706 chdir $self->{'build_dir'} or
4707 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4708 $self->debug("Changed directory to $self->{'build_dir'}")
4711 if ($^O eq 'MacOS') {
4712 ExtUtils::MM_MacOS::make_install($self);
4716 my $system = join(" ", $CPAN::Config->{'make'},
4717 "install", $CPAN::Config->{make_install_arg});
4718 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4719 my($pipe) = FileHandle->new("$system $stderr |");
4722 $CPAN::Frontend->myprint($_);
4727 $CPAN::Frontend->myprint(" $system -- OK\n");
4728 return $self->{'install'} = "YES";
4730 $self->{'install'} = "NO";
4731 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4732 if ($makeout =~ /permission/s && $> > 0) {
4733 $CPAN::Frontend->myprint(qq{ You may have to su }.
4734 qq{to root to install the package\n});
4737 delete $self->{force_update};
4740 #-> sub CPAN::Distribution::dir ;
4742 shift->{'build_dir'};
4745 package CPAN::Bundle;
4749 delete $self->{later};
4750 for my $c ( $self->contains ) {
4751 my $obj = CPAN::Shell->expandany($c) or next;
4756 #-> sub CPAN::Bundle::color_cmd_tmps ;
4757 sub color_cmd_tmps {
4759 my($depth) = shift || 0;
4760 my($color) = shift || 0;
4761 # a module needs to recurse to its cpan_file, a distribution needs
4762 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4764 return if exists $self->{incommandcolor}
4765 && $self->{incommandcolor}==$color;
4766 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4767 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4772 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4774 for my $c ( $self->contains ) {
4775 my $obj = CPAN::Shell->expandany($c) or next;
4776 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4777 $obj->color_cmd_tmps($depth+1,$color);
4780 delete $self->{badtestcnt};
4782 $self->{incommandcolor} = $color;
4785 #-> sub CPAN::Bundle::as_string ;
4789 # following line must be "=", not "||=" because we have a moving target
4790 $self->{INST_VERSION} = $self->inst_version;
4791 return $self->SUPER::as_string;
4794 #-> sub CPAN::Bundle::contains ;
4797 my($inst_file) = $self->inst_file || "";
4798 my($id) = $self->id;
4799 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4800 unless ($inst_file) {
4801 # Try to get at it in the cpan directory
4802 $self->debug("no inst_file") if $CPAN::DEBUG;
4804 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4805 $cpan_file = $self->cpan_file;
4806 if ($cpan_file eq "N/A") {
4807 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4808 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4810 my $dist = $CPAN::META->instance('CPAN::Distribution',
4813 $self->debug($dist->as_string) if $CPAN::DEBUG;
4814 my($todir) = $CPAN::Config->{'cpan_home'};
4815 my(@me,$from,$to,$me);
4816 @me = split /::/, $self->id;
4818 $me = MM->catfile(@me);
4819 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4820 $to = MM->catfile($todir,$me);
4821 File::Path::mkpath(File::Basename::dirname($to));
4822 File::Copy::copy($from, $to)
4823 or Carp::confess("Couldn't copy $from to $to: $!");
4827 my $fh = FileHandle->new;
4829 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4831 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4833 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4834 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4835 next unless $in_cont;
4840 push @result, (split " ", $_, 2)[0];
4843 delete $self->{STATUS};
4844 $self->{CONTAINS} = \@result;
4845 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4847 $CPAN::Frontend->mywarn(qq{
4848 The bundle file "$inst_file" may be a broken
4849 bundlefile. It seems not to contain any bundle definition.
4850 Please check the file and if it is bogus, please delete it.
4851 Sorry for the inconvenience.
4857 #-> sub CPAN::Bundle::find_bundle_file
4858 sub find_bundle_file {
4859 my($self,$where,$what) = @_;
4860 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4861 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4862 ### my $bu = MM->catfile($where,$what);
4863 ### return $bu if -f $bu;
4864 my $manifest = MM->catfile($where,"MANIFEST");
4865 unless (-f $manifest) {
4866 require ExtUtils::Manifest;
4867 my $cwd = CPAN::anycwd();
4868 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4869 ExtUtils::Manifest::mkmanifest();
4870 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4872 my $fh = FileHandle->new($manifest)
4873 or Carp::croak("Couldn't open $manifest: $!");
4876 if ($^O eq 'MacOS') {
4879 $what2 =~ s/:Bundle://;
4882 $what2 =~ s|Bundle[/\\]||;
4887 my($file) = /(\S+)/;
4888 if ($file =~ m|\Q$what\E$|) {
4890 # return MM->catfile($where,$bu); # bad
4893 # retry if she managed to
4894 # have no Bundle directory
4895 $bu = $file if $file =~ m|\Q$what2\E$|;
4897 $bu =~ tr|/|:| if $^O eq 'MacOS';
4898 return MM->catfile($where, $bu) if $bu;
4899 Carp::croak("Couldn't find a Bundle file in $where");
4902 # needs to work quite differently from Module::inst_file because of
4903 # cpan_home/Bundle/ directory and the possibility that we have
4904 # shadowing effect. As it makes no sense to take the first in @INC for
4905 # Bundles, we parse them all for $VERSION and take the newest.
4907 #-> sub CPAN::Bundle::inst_file ;
4912 @me = split /::/, $self->id;
4915 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4916 my $bfile = MM->catfile($incdir, @me);
4917 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4918 next unless -f $bfile;
4919 my $foundv = MM->parse_version($bfile);
4920 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4921 $self->{INST_FILE} = $bfile;
4922 $self->{INST_VERSION} = $bestv = $foundv;
4928 #-> sub CPAN::Bundle::inst_version ;
4931 $self->inst_file; # finds INST_VERSION as side effect
4932 $self->{INST_VERSION};
4935 #-> sub CPAN::Bundle::rematein ;
4937 my($self,$meth) = @_;
4938 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4939 my($id) = $self->id;
4940 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4941 unless $self->inst_file || $self->cpan_file;
4943 for $s ($self->contains) {
4944 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4945 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4946 if ($type eq 'CPAN::Distribution') {
4947 $CPAN::Frontend->mywarn(qq{
4948 The Bundle }.$self->id.qq{ contains
4949 explicitly a file $s.
4953 # possibly noisy action:
4954 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4955 my $obj = $CPAN::META->instance($type,$s);
4957 if ($obj->isa(CPAN::Bundle)
4959 exists $obj->{install_failed}
4961 ref($obj->{install_failed}) eq "HASH"
4963 for (keys %{$obj->{install_failed}}) {
4964 $self->{install_failed}{$_} = undef; # propagate faiure up
4967 $fail{$s} = 1; # the bundle itself may have succeeded but
4972 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4973 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4975 delete $self->{install_failed}{$s};
4982 # recap with less noise
4983 if ( $meth eq "install" ) {
4986 my $raw = sprintf(qq{Bundle summary:
4987 The following items in bundle %s had installation problems:},
4990 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4991 $CPAN::Frontend->myprint("\n");
4994 for $s ($self->contains) {
4996 $paragraph .= "$s ";
4997 $self->{install_failed}{$s} = undef;
4998 $reported{$s} = undef;
5001 my $report_propagated;
5002 for $s (sort keys %{$self->{install_failed}}) {
5003 next if exists $reported{$s};
5004 $paragraph .= "and the following items had problems
5005 during recursive bundle calls: " unless $report_propagated++;
5006 $paragraph .= "$s ";
5008 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5009 $CPAN::Frontend->myprint("\n");
5011 $self->{'install'} = 'YES';
5016 #sub CPAN::Bundle::xs_file
5018 # If a bundle contains another that contains an xs_file we have
5019 # here, we just don't bother I suppose
5023 #-> sub CPAN::Bundle::force ;
5024 sub force { shift->rematein('force',@_); }
5025 #-> sub CPAN::Bundle::get ;
5026 sub get { shift->rematein('get',@_); }
5027 #-> sub CPAN::Bundle::make ;
5028 sub make { shift->rematein('make',@_); }
5029 #-> sub CPAN::Bundle::test ;
5032 $self->{badtestcnt} ||= 0;
5033 $self->rematein('test',@_);
5035 #-> sub CPAN::Bundle::install ;
5038 $self->rematein('install',@_);
5040 #-> sub CPAN::Bundle::clean ;
5041 sub clean { shift->rematein('clean',@_); }
5043 #-> sub CPAN::Bundle::uptodate ;
5046 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5048 foreach $c ($self->contains) {
5049 my $obj = CPAN::Shell->expandany($c);
5050 return 0 unless $obj->uptodate;
5055 #-> sub CPAN::Bundle::readme ;
5058 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5059 No File found for bundle } . $self->id . qq{\n}), return;
5060 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5061 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5064 package CPAN::Module;
5067 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5070 return unless exists $self->{RO}; # should never happen
5071 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5073 sub description { shift->{RO}{description} }
5077 delete $self->{later};
5078 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5083 #-> sub CPAN::Module::color_cmd_tmps ;
5084 sub color_cmd_tmps {
5086 my($depth) = shift || 0;
5087 my($color) = shift || 0;
5088 # a module needs to recurse to its cpan_file
5090 return if exists $self->{incommandcolor}
5091 && $self->{incommandcolor}==$color;
5092 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5093 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5098 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5100 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5101 $dist->color_cmd_tmps($depth+1,$color);
5104 delete $self->{badtestcnt};
5106 $self->{incommandcolor} = $color;
5109 #-> sub CPAN::Module::as_glimpse ;
5113 my $class = ref($self);
5114 $class =~ s/^CPAN:://;
5118 $CPAN::Shell::COLOR_REGISTERED
5120 $CPAN::META->has_inst("Term::ANSIColor")
5122 $self->{RO}{description}
5124 $color_on = Term::ANSIColor::color("green");
5125 $color_off = Term::ANSIColor::color("reset");
5127 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5136 #-> sub CPAN::Module::as_string ;
5140 CPAN->debug($self) if $CPAN::DEBUG;
5141 my $class = ref($self);
5142 $class =~ s/^CPAN:://;
5144 push @m, $class, " id = $self->{ID}\n";
5145 my $sprintf = " %-12s %s\n";
5146 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5147 if $self->description;
5148 my $sprintf2 = " %-12s %s (%s)\n";
5150 if ($userid = $self->cpan_userid || $self->userid){
5152 if ($author = CPAN::Shell->expand('Author',$userid)) {
5155 if ($m = $author->email) {
5162 $author->fullname . $email
5166 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5167 if $self->cpan_version;
5168 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5169 if $self->cpan_file;
5170 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5171 my(%statd,%stats,%statl,%stati);
5172 @statd{qw,? i c a b R M S,} = qw,unknown idea
5173 pre-alpha alpha beta released mature standard,;
5174 @stats{qw,? m d u n,} = qw,unknown mailing-list
5175 developer comp.lang.perl.* none,;
5176 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5177 @stati{qw,? f r O h,} = qw,unknown functions
5178 references+ties object-oriented hybrid,;
5179 $statd{' '} = 'unknown';
5180 $stats{' '} = 'unknown';
5181 $statl{' '} = 'unknown';
5182 $stati{' '} = 'unknown';
5190 $statd{$self->{RO}{statd}},
5191 $stats{$self->{RO}{stats}},
5192 $statl{$self->{RO}{statl}},
5193 $stati{$self->{RO}{stati}}
5194 ) if $self->{RO}{statd};
5195 my $local_file = $self->inst_file;
5196 unless ($self->{MANPAGE}) {
5198 $self->{MANPAGE} = $self->manpage_headline($local_file);
5200 # If we have already untarred it, we should look there
5201 my $dist = $CPAN::META->instance('CPAN::Distribution',
5203 # warn "dist[$dist]";
5204 # mff=manifest file; mfh=manifest handle
5209 (-f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")))
5211 $mfh = FileHandle->new($mff)
5213 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5214 my $lfre = $self->id; # local file RE
5217 my($lfl); # local file file
5219 my(@mflines) = <$mfh>;
5224 while (length($lfre)>5 and !$lfl) {
5225 ($lfl) = grep /$lfre/, @mflines;
5226 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5229 $lfl =~ s/\s.*//; # remove comments
5230 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5231 my $lfl_abs = MM->catfile($dist->{build_dir},$lfl);
5232 # warn "lfl_abs[$lfl_abs]";
5234 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5240 for $item (qw/MANPAGE/) {
5241 push @m, sprintf($sprintf, $item, $self->{$item})
5242 if exists $self->{$item};
5244 for $item (qw/CONTAINS/) {
5245 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5246 if exists $self->{$item} && @{$self->{$item}};
5248 push @m, sprintf($sprintf, 'INST_FILE',
5249 $local_file || "(not installed)");
5250 push @m, sprintf($sprintf, 'INST_VERSION',
5251 $self->inst_version) if $local_file;
5255 sub manpage_headline {
5256 my($self,$local_file) = @_;
5257 my(@local_file) = $local_file;
5258 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5259 push @local_file, $local_file;
5261 for $locf (@local_file) {
5262 next unless -f $locf;
5263 my $fh = FileHandle->new($locf)
5264 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5268 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
5269 m/^=head1\s+NAME/ ? 1 : $inpod;
5282 #-> sub CPAN::Module::cpan_file ;
5283 # Note: also inherited by CPAN::Bundle
5286 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5287 unless (defined $self->{RO}{CPAN_FILE}) {
5288 CPAN::Index->reload;
5290 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5291 return $self->{RO}{CPAN_FILE};
5293 my $userid = $self->userid;
5295 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5296 my $author = $CPAN::META->instance("CPAN::Author",
5298 my $fullname = $author->fullname;
5299 my $email = $author->email;
5300 unless (defined $fullname && defined $email) {
5301 return sprintf("Contact Author %s",
5305 return "Contact Author $fullname <$email>";
5307 return "UserID $userid";
5315 #-> sub CPAN::Module::cpan_version ;
5319 $self->{RO}{CPAN_VERSION} = 'undef'
5320 unless defined $self->{RO}{CPAN_VERSION};
5321 # I believe this is always a bug in the index and should be reported
5322 # as such, but usually I find out such an error and do not want to
5323 # provoke too many bugreports
5325 $self->{RO}{CPAN_VERSION};
5328 #-> sub CPAN::Module::force ;
5331 $self->{'force_update'}++;
5334 #-> sub CPAN::Module::rematein ;
5336 my($self,$meth) = @_;
5337 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5340 my $cpan_file = $self->cpan_file;
5341 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5342 $CPAN::Frontend->mywarn(sprintf qq{
5343 The module %s isn\'t available on CPAN.
5345 Either the module has not yet been uploaded to CPAN, or it is
5346 temporary unavailable. Please contact the author to find out
5347 more about the status. Try 'i %s'.
5354 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5355 $pack->called_for($self->id);
5356 $pack->force($meth) if exists $self->{'force_update'};
5358 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5359 delete $self->{'force_update'};
5362 #-> sub CPAN::Module::readme ;
5363 sub readme { shift->rematein('readme') }
5364 #-> sub CPAN::Module::look ;
5365 sub look { shift->rematein('look') }
5366 #-> sub CPAN::Module::cvs_import ;
5367 sub cvs_import { shift->rematein('cvs_import') }
5368 #-> sub CPAN::Module::get ;
5369 sub get { shift->rematein('get',@_); }
5370 #-> sub CPAN::Module::make ;
5373 $self->rematein('make');
5375 #-> sub CPAN::Module::test ;
5378 $self->{badtestcnt} ||= 0;
5379 $self->rematein('test',@_);
5381 #-> sub CPAN::Module::uptodate ;
5384 my($latest) = $self->cpan_version;
5386 my($inst_file) = $self->inst_file;
5388 if (defined $inst_file) {
5389 $have = $self->inst_version;
5394 ! CPAN::Version->vgt($latest, $have)
5396 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5397 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5402 #-> sub CPAN::Module::install ;
5408 not exists $self->{'force_update'}
5410 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5414 $self->rematein('install') if $doit;
5416 #-> sub CPAN::Module::clean ;
5417 sub clean { shift->rematein('clean') }
5419 #-> sub CPAN::Module::inst_file ;
5423 @packpath = split /::/, $self->{ID};
5424 $packpath[-1] .= ".pm";
5425 foreach $dir (@INC) {
5426 my $pmfile = MM->catfile($dir,@packpath);
5434 #-> sub CPAN::Module::xs_file ;
5438 @packpath = split /::/, $self->{ID};
5439 push @packpath, $packpath[-1];
5440 $packpath[-1] .= "." . $Config::Config{'dlext'};
5441 foreach $dir (@INC) {
5442 my $xsfile = MM->catfile($dir,'auto',@packpath);
5450 #-> sub CPAN::Module::inst_version ;
5453 my $parsefile = $self->inst_file or return;
5454 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5457 # there was a bug in 5.6.0 that let lots of unini warnings out of
5458 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5459 # the following workaround after 5.6.1 is out.
5460 local($SIG{__WARN__}) = sub { my $w = shift;
5461 return if $w =~ /uninitialized/i;
5465 $have = MM->parse_version($parsefile) || "undef";
5466 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5467 $have =~ s/ $//; # trailing whitespace happens all the time
5469 # My thoughts about why %vd processing should happen here
5471 # Alt1 maintain it as string with leading v:
5472 # read index files do nothing
5473 # compare it use utility for compare
5474 # print it do nothing
5476 # Alt2 maintain it as what is is
5477 # read index files convert
5478 # compare it use utility because there's still a ">" vs "gt" issue
5479 # print it use CPAN::Version for print
5481 # Seems cleaner to hold it in memory as a string starting with a "v"
5483 # If the author of this module made a mistake and wrote a quoted
5484 # "v1.13" instead of v1.13, we simply leave it at that with the
5485 # effect that *we* will treat it like a v-tring while the rest of
5486 # perl won't. Seems sensible when we consider that any action we
5487 # could take now would just add complexity.
5489 $have = CPAN::Version->readable($have);
5491 $have =~ s/\s*//g; # stringify to float around floating point issues
5492 $have; # no stringify needed, \s* above matches always
5495 package CPAN::Tarzip;
5497 # CPAN::Tarzip::gzip
5499 my($class,$read,$write) = @_;
5500 if ($CPAN::META->has_inst("Compress::Zlib")) {
5502 $fhw = FileHandle->new($read)
5503 or $CPAN::Frontend->mydie("Could not open $read: $!");
5504 my $gz = Compress::Zlib::gzopen($write, "wb")
5505 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5506 $gz->gzwrite($buffer)
5507 while read($fhw,$buffer,4096) > 0 ;
5512 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5517 # CPAN::Tarzip::gunzip
5519 my($class,$read,$write) = @_;
5520 if ($CPAN::META->has_inst("Compress::Zlib")) {
5522 $fhw = FileHandle->new(">$write")
5523 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5524 my $gz = Compress::Zlib::gzopen($read, "rb")
5525 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5526 $fhw->print($buffer)
5527 while $gz->gzread($buffer) > 0 ;
5528 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5529 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5534 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5539 # CPAN::Tarzip::gtest
5541 my($class,$read) = @_;
5542 # After I had reread the documentation in zlib.h, I discovered that
5543 # uncompressed files do not lead to an gzerror (anymore?).
5544 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5547 my $gz = Compress::Zlib::gzopen($read, "rb")
5548 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5550 $Compress::Zlib::gzerrno));
5551 while ($gz->gzread($buffer) > 0 ){
5552 $len += length($buffer);
5555 my $err = $gz->gzerror;
5556 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5557 if ($len == -s $read){
5559 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5562 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5565 return system("$CPAN::Config->{gzip} -dt $read")==0;
5570 # CPAN::Tarzip::TIEHANDLE
5572 my($class,$file) = @_;
5574 $class->debug("file[$file]");
5575 if ($CPAN::META->has_inst("Compress::Zlib")) {
5576 my $gz = Compress::Zlib::gzopen($file,"rb") or
5577 die "Could not gzopen $file";
5578 $ret = bless {GZ => $gz}, $class;
5580 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5581 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5583 $ret = bless {FH => $fh}, $class;
5589 # CPAN::Tarzip::READLINE
5592 if (exists $self->{GZ}) {
5593 my $gz = $self->{GZ};
5594 my($line,$bytesread);
5595 $bytesread = $gz->gzreadline($line);
5596 return undef if $bytesread <= 0;
5599 my $fh = $self->{FH};
5600 return scalar <$fh>;
5605 # CPAN::Tarzip::READ
5607 my($self,$ref,$length,$offset) = @_;
5608 die "read with offset not implemented" if defined $offset;
5609 if (exists $self->{GZ}) {
5610 my $gz = $self->{GZ};
5611 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5614 my $fh = $self->{FH};
5615 return read($fh,$$ref,$length);
5620 # CPAN::Tarzip::DESTROY
5623 if (exists $self->{GZ}) {
5624 my $gz = $self->{GZ};
5625 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5626 # to be undef ever. AK, 2000-09
5628 my $fh = $self->{FH};
5629 $fh->close if defined $fh;
5635 # CPAN::Tarzip::untar
5637 my($class,$file) = @_;
5640 if (0) { # makes changing order easier
5641 } elsif ($BUGHUNTING){
5643 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5645 MM->maybe_command($CPAN::Config->{'tar'})) {
5646 # should be default until Archive::Tar is fixed
5649 $CPAN::META->has_inst("Archive::Tar")
5651 $CPAN::META->has_inst("Compress::Zlib") ) {
5654 $CPAN::Frontend->mydie(qq{
5655 CPAN.pm needs either both external programs tar and gzip installed or
5656 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5657 is available. Can\'t continue.
5660 if ($prefer==1) { # 1 => external gzip+tar
5662 my $is_compressed = $class->gtest($file);
5663 if ($is_compressed) {
5664 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5665 "< $file | $CPAN::Config->{tar} xvf -";
5667 $system = "$CPAN::Config->{tar} xvf $file";
5669 if (system($system) != 0) {
5670 # people find the most curious tar binaries that cannot handle
5672 if ($is_compressed) {
5673 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5674 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5675 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5677 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5681 $system = "$CPAN::Config->{tar} xvf $file";
5682 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5683 if (system($system)==0) {
5684 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5686 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5692 } elsif ($prefer==2) { # 2 => modules
5693 my $tar = Archive::Tar->new($file,1);
5694 my $af; # archive file
5697 # RCS 1.337 had this code, it turned out unacceptable slow but
5698 # it revealed a bug in Archive::Tar. Code is only here to hunt
5699 # the bug again. It should never be enabled in published code.
5700 # GDGraph3d-0.53 was an interesting case according to Larry
5702 warn(">>>Bughunting code enabled<<< " x 20);
5703 for $af ($tar->list_files) {
5704 if ($af =~ m!^(/|\.\./)!) {
5705 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5706 "illegal member [$af]");
5708 $CPAN::Frontend->myprint("$af\n");
5709 $tar->extract($af); # slow but effective for finding the bug
5710 return if $CPAN::Signal;
5713 for $af ($tar->list_files) {
5714 if ($af =~ m!^(/|\.\./)!) {
5715 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5716 "illegal member [$af]");
5718 $CPAN::Frontend->myprint("$af\n");
5720 return if $CPAN::Signal;
5725 ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
5726 if ($^O eq 'MacOS');
5733 my($class,$file) = @_;
5734 if ($CPAN::META->has_inst("Archive::Zip")) {
5735 # blueprint of the code from Archive::Zip::Tree::extractTree();
5736 my $zip = Archive::Zip->new();
5738 $status = $zip->read($file);
5739 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5740 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5741 my @members = $zip->members();
5742 for my $member ( @members ) {
5743 my $af = $member->fileName();
5744 if ($af =~ m!^(/|\.\./)!) {
5745 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5746 "illegal member [$af]");
5748 my $status = $member->extractToFileNamed( $af );
5749 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5750 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5751 $status != Archive::Zip::AZ_OK();
5752 return if $CPAN::Signal;
5756 my $unzip = $CPAN::Config->{unzip} or
5757 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5758 my @system = ($unzip, $file);
5759 return system(@system) == 0;
5764 package CPAN::Version;
5765 # CPAN::Version::vcmp courtesy Jost Krieger
5767 my($self,$l,$r) = @_;
5769 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5771 return 0 if $l eq $r; # short circuit for quicker success
5773 if ($l=~/^v/ <=> $r=~/^v/) {
5776 $_ = $self->float2vv($_);
5781 ($l ne "undef") <=> ($r ne "undef") ||
5785 $self->vstring($l) cmp $self->vstring($r)) ||
5791 my($self,$l,$r) = @_;
5792 $self->vcmp($l,$r) > 0;
5797 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5798 pack "U*", split /\./, $n;
5801 # vv => visible vstring
5806 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5807 # architecture influence
5809 $mantissa .= "0" while length($mantissa)%3;
5810 my $ret = "v" . $rev;
5812 $mantissa =~ s/(\d{1,3})// or
5813 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5814 $ret .= ".".int($1);
5816 # warn "n[$n]ret[$ret]";
5822 $n =~ /^([\w\-\+\.]+)/;
5824 return $1 if defined $1 && length($1)>0;
5825 # if the first user reaches version v43, he will be treated as "+".
5826 # We'll have to decide about a new rule here then, depending on what
5827 # will be the prevailing versioning behavior then.
5829 if ($] < 5.006) { # or whenever v-strings were introduced
5830 # we get them wrong anyway, whatever we do, because 5.005 will
5831 # have already interpreted 0.2.4 to be "0.24". So even if he
5832 # indexer sends us something like "v0.2.4" we compare wrongly.
5834 # And if they say v1.2, then the old perl takes it as "v12"
5836 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5839 my $better = sprintf "v%vd", $n;
5840 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5852 CPAN - query, download and build perl modules from CPAN sites
5858 perl -MCPAN -e shell;
5864 autobundle, clean, install, make, recompile, test
5868 The CPAN module is designed to automate the make and install of perl
5869 modules and extensions. It includes some searching capabilities and
5870 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5871 to fetch the raw data from the net.
5873 Modules are fetched from one or more of the mirrored CPAN
5874 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5877 The CPAN module also supports the concept of named and versioned
5878 I<bundles> of modules. Bundles simplify the handling of sets of
5879 related modules. See Bundles below.
5881 The package contains a session manager and a cache manager. There is
5882 no status retained between sessions. The session manager keeps track
5883 of what has been fetched, built and installed in the current
5884 session. The cache manager keeps track of the disk space occupied by
5885 the make processes and deletes excess space according to a simple FIFO
5888 For extended searching capabilities there's a plugin for CPAN available,
5889 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5890 that indexes all documents available in CPAN authors directories. If
5891 C<CPAN::WAIT> is installed on your system, the interactive shell of
5892 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5893 which send queries to the WAIT server that has been configured for your
5896 All other methods provided are accessible in a programmer style and in an
5897 interactive shell style.
5899 =head2 Interactive Mode
5901 The interactive mode is entered by running
5903 perl -MCPAN -e shell
5905 which puts you into a readline interface. You will have the most fun if
5906 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5909 Once you are on the command line, type 'h' and the rest should be
5912 The function call C<shell> takes two optional arguments, one is the
5913 prompt, the second is the default initial command line (the latter
5914 only works if a real ReadLine interface module is installed).
5916 The most common uses of the interactive modes are
5920 =item Searching for authors, bundles, distribution files and modules
5922 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5923 for each of the four categories and another, C<i> for any of the
5924 mentioned four. Each of the four entities is implemented as a class
5925 with slightly differing methods for displaying an object.
5927 Arguments you pass to these commands are either strings exactly matching
5928 the identification string of an object or regular expressions that are
5929 then matched case-insensitively against various attributes of the
5930 objects. The parser recognizes a regular expression only if you
5931 enclose it between two slashes.
5933 The principle is that the number of found objects influences how an
5934 item is displayed. If the search finds one item, the result is
5935 displayed with the rather verbose method C<as_string>, but if we find
5936 more than one, we display each object with the terse method
5939 =item make, test, install, clean modules or distributions
5941 These commands take any number of arguments and investigate what is
5942 necessary to perform the action. If the argument is a distribution
5943 file name (recognized by embedded slashes), it is processed. If it is
5944 a module, CPAN determines the distribution file in which this module
5945 is included and processes that, following any dependencies named in
5946 the module's Makefile.PL (this behavior is controlled by
5947 I<prerequisites_policy>.)
5949 Any C<make> or C<test> are run unconditionally. An
5951 install <distribution_file>
5953 also is run unconditionally. But for
5957 CPAN checks if an install is actually needed for it and prints
5958 I<module up to date> in the case that the distribution file containing
5959 the module doesn't need to be updated.
5961 CPAN also keeps track of what it has done within the current session
5962 and doesn't try to build a package a second time regardless if it
5963 succeeded or not. The C<force> command takes as a first argument the
5964 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5965 command from scratch.
5969 cpan> install OpenGL
5970 OpenGL is up to date.
5971 cpan> force install OpenGL
5974 OpenGL-0.4/COPYRIGHT
5977 A C<clean> command results in a
5981 being executed within the distribution file's working directory.
5983 =item get, readme, look module or distribution
5985 C<get> downloads a distribution file without further action. C<readme>
5986 displays the README file of the associated distribution. C<Look> gets
5987 and untars (if not yet done) the distribution file, changes to the
5988 appropriate directory and opens a subshell process in that directory.
5992 C<ls> lists all distribution files in and below an author's CPAN
5993 directory. Only those files that contain modules are listed and if
5994 there is more than one for any given module, only the most recent one
5999 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6000 in the cpan-shell it is intended that you can press C<^C> anytime and
6001 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6002 to clean up and leave the shell loop. You can emulate the effect of a
6003 SIGTERM by sending two consecutive SIGINTs, which usually means by
6004 pressing C<^C> twice.
6006 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6007 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6013 The commands that are available in the shell interface are methods in
6014 the package CPAN::Shell. If you enter the shell command, all your
6015 input is split by the Text::ParseWords::shellwords() routine which
6016 acts like most shells do. The first word is being interpreted as the
6017 method to be called and the rest of the words are treated as arguments
6018 to this method. Continuation lines are supported if a line ends with a
6023 C<autobundle> writes a bundle file into the
6024 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6025 a list of all modules that are both available from CPAN and currently
6026 installed within @INC. The name of the bundle file is based on the
6027 current date and a counter.
6031 recompile() is a very special command in that it takes no argument and
6032 runs the make/test/install cycle with brute force over all installed
6033 dynamically loadable extensions (aka XS modules) with 'force' in
6034 effect. The primary purpose of this command is to finish a network
6035 installation. Imagine, you have a common source tree for two different
6036 architectures. You decide to do a completely independent fresh
6037 installation. You start on one architecture with the help of a Bundle
6038 file produced earlier. CPAN installs the whole Bundle for you, but
6039 when you try to repeat the job on the second architecture, CPAN
6040 responds with a C<"Foo up to date"> message for all modules. So you
6041 invoke CPAN's recompile on the second architecture and you're done.
6043 Another popular use for C<recompile> is to act as a rescue in case your
6044 perl breaks binary compatibility. If one of the modules that CPAN uses
6045 is in turn depending on binary compatibility (so you cannot run CPAN
6046 commands), then you should try the CPAN::Nox module for recovery.
6048 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6050 Although it may be considered internal, the class hierarchy does matter
6051 for both users and programmer. CPAN.pm deals with above mentioned four
6052 classes, and all those classes share a set of methods. A classical
6053 single polymorphism is in effect. A metaclass object registers all
6054 objects of all kinds and indexes them with a string. The strings
6055 referencing objects have a separated namespace (well, not completely
6060 words containing a "/" (slash) Distribution
6061 words starting with Bundle:: Bundle
6062 everything else Module or Author
6064 Modules know their associated Distribution objects. They always refer
6065 to the most recent official release. Developers may mark their releases
6066 as unstable development versions (by inserting an underbar into the
6067 module version number which will also be reflected in the distribution
6068 name when you run 'make dist'), so the really hottest and newest
6069 distribution is not always the default. If a module Foo circulates
6070 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6071 way to install version 1.23 by saying
6075 This would install the complete distribution file (say
6076 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6077 like to install version 1.23_90, you need to know where the
6078 distribution file resides on CPAN relative to the authors/id/
6079 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6080 so you would have to say
6082 install BAR/Foo-1.23_90.tar.gz
6084 The first example will be driven by an object of the class
6085 CPAN::Module, the second by an object of class CPAN::Distribution.
6087 =head2 Programmer's interface
6089 If you do not enter the shell, the available shell commands are both
6090 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6091 functions in the calling package (C<install(...)>).
6093 There's currently only one class that has a stable interface -
6094 CPAN::Shell. All commands that are available in the CPAN shell are
6095 methods of the class CPAN::Shell. Each of the commands that produce
6096 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6097 the IDs of all modules within the list.
6101 =item expand($type,@things)
6103 The IDs of all objects available within a program are strings that can
6104 be expanded to the corresponding real objects with the
6105 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6106 list of CPAN::Module objects according to the C<@things> arguments
6107 given. In scalar context it only returns the first element of the
6110 =item expandany(@things)
6112 Like expand, but returns objects of the appropriate type, i.e.
6113 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6114 CPAN::Distribution objects fro distributions.
6116 =item Programming Examples
6118 This enables the programmer to do operations that combine
6119 functionalities that are available in the shell.
6121 # install everything that is outdated on my disk:
6122 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6124 # install my favorite programs if necessary:
6125 for $mod (qw(Net::FTP MD5 Data::Dumper)){
6126 my $obj = CPAN::Shell->expand('Module',$mod);
6130 # list all modules on my disk that have no VERSION number
6131 for $mod (CPAN::Shell->expand("Module","/./")){
6132 next unless $mod->inst_file;
6133 # MakeMaker convention for undefined $VERSION:
6134 next unless $mod->inst_version eq "undef";
6135 print "No VERSION in ", $mod->id, "\n";
6138 # find out which distribution on CPAN contains a module:
6139 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6141 Or if you want to write a cronjob to watch The CPAN, you could list
6142 all modules that need updating. First a quick and dirty way:
6144 perl -e 'use CPAN; CPAN::Shell->r;'
6146 If you don't want to get any output in the case that all modules are
6147 up to date, you can parse the output of above command for the regular
6148 expression //modules are up to date// and decide to mail the output
6149 only if it doesn't match. Ick?
6151 If you prefer to do it more in a programmer style in one single
6152 process, maybe something like this suits you better:
6154 # list all modules on my disk that have newer versions on CPAN
6155 for $mod (CPAN::Shell->expand("Module","/./")){
6156 next unless $mod->inst_file;
6157 next if $mod->uptodate;
6158 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6159 $mod->id, $mod->inst_version, $mod->cpan_version;
6162 If that gives you too much output every day, you maybe only want to
6163 watch for three modules. You can write
6165 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6167 as the first line instead. Or you can combine some of the above
6170 # watch only for a new mod_perl module
6171 $mod = CPAN::Shell->expand("Module","mod_perl");
6172 exit if $mod->uptodate;
6173 # new mod_perl arrived, let me know all update recommendations
6178 =head2 Methods in the other Classes
6180 The programming interface for the classes CPAN::Module,
6181 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6182 beta and partially even alpha. In the following paragraphs only those
6183 methods are documented that have proven useful over a longer time and
6184 thus are unlikely to change.
6188 =item CPAN::Author::as_glimpse()
6190 Returns a one-line description of the author
6192 =item CPAN::Author::as_string()
6194 Returns a multi-line description of the author
6196 =item CPAN::Author::email()
6198 Returns the author's email address
6200 =item CPAN::Author::fullname()
6202 Returns the author's name
6204 =item CPAN::Author::name()
6206 An alias for fullname
6208 =item CPAN::Bundle::as_glimpse()
6210 Returns a one-line description of the bundle
6212 =item CPAN::Bundle::as_string()
6214 Returns a multi-line description of the bundle
6216 =item CPAN::Bundle::clean()
6218 Recursively runs the C<clean> method on all items contained in the bundle.
6220 =item CPAN::Bundle::contains()
6222 Returns a list of objects' IDs contained in a bundle. The associated
6223 objects may be bundles, modules or distributions.
6225 =item CPAN::Bundle::force($method,@args)
6227 Forces CPAN to perform a task that normally would have failed. Force
6228 takes as arguments a method name to be called and any number of
6229 additional arguments that should be passed to the called method. The
6230 internals of the object get the needed changes so that CPAN.pm does
6231 not refuse to take the action. The C<force> is passed recursively to
6232 all contained objects.
6234 =item CPAN::Bundle::get()
6236 Recursively runs the C<get> method on all items contained in the bundle
6238 =item CPAN::Bundle::inst_file()
6240 Returns the highest installed version of the bundle in either @INC or
6241 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6242 CPAN::Module::inst_file.
6244 =item CPAN::Bundle::inst_version()
6246 Like CPAN::Bundle::inst_file, but returns the $VERSION
6248 =item CPAN::Bundle::uptodate()
6250 Returns 1 if the bundle itself and all its members are uptodate.
6252 =item CPAN::Bundle::install()
6254 Recursively runs the C<install> method on all items contained in the bundle
6256 =item CPAN::Bundle::make()
6258 Recursively runs the C<make> method on all items contained in the bundle
6260 =item CPAN::Bundle::readme()
6262 Recursively runs the C<readme> method on all items contained in the bundle
6264 =item CPAN::Bundle::test()
6266 Recursively runs the C<test> method on all items contained in the bundle
6268 =item CPAN::Distribution::as_glimpse()
6270 Returns a one-line description of the distribution
6272 =item CPAN::Distribution::as_string()
6274 Returns a multi-line description of the distribution
6276 =item CPAN::Distribution::clean()
6278 Changes to the directory where the distribution has been unpacked and
6279 runs C<make clean> there.
6281 =item CPAN::Distribution::containsmods()
6283 Returns a list of IDs of modules contained in a distribution file.
6284 Only works for distributions listed in the 02packages.details.txt.gz
6285 file. This typically means that only the most recent version of a
6286 distribution is covered.
6288 =item CPAN::Distribution::cvs_import()
6290 Changes to the directory where the distribution has been unpacked and
6293 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6297 =item CPAN::Distribution::dir()
6299 Returns the directory into which this distribution has been unpacked.
6301 =item CPAN::Distribution::force($method,@args)
6303 Forces CPAN to perform a task that normally would have failed. Force
6304 takes as arguments a method name to be called and any number of
6305 additional arguments that should be passed to the called method. The
6306 internals of the object get the needed changes so that CPAN.pm does
6307 not refuse to take the action.
6309 =item CPAN::Distribution::get()
6311 Downloads the distribution from CPAN and unpacks it. Does nothing if
6312 the distribution has already been downloaded and unpacked within the
6315 =item CPAN::Distribution::install()
6317 Changes to the directory where the distribution has been unpacked and
6318 runs the external command C<make install> there. If C<make> has not
6319 yet been run, it will be run first. A C<make test> will be issued in
6320 any case and if this fails, the install will be cancelled. The
6321 cancellation can be avoided by letting C<force> run the C<install> for
6324 =item CPAN::Distribution::isa_perl()
6326 Returns 1 if this distribution file seems to be a perl distribution.
6327 Normally this is derived from the file name only, but the index from
6328 CPAN can contain a hint to achieve a return value of true for other
6331 =item CPAN::Distribution::look()
6333 Changes to the directory where the distribution has been unpacked and
6334 opens a subshell there. Exiting the subshell returns.
6336 =item CPAN::Distribution::make()
6338 First runs the C<get> method to make sure the distribution is
6339 downloaded and unpacked. Changes to the directory where the
6340 distribution has been unpacked and runs the external commands C<perl
6341 Makefile.PL> and C<make> there.
6343 =item CPAN::Distribution::prereq_pm()
6345 Returns the hash reference that has been announced by a distribution
6346 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6347 attempt has been made to C<make> the distribution. Returns undef
6350 =item CPAN::Distribution::readme()
6352 Downloads the README file associated with a distribution and runs it
6353 through the pager specified in C<$CPAN::Config->{pager}>.
6355 =item CPAN::Distribution::test()
6357 Changes to the directory where the distribution has been unpacked and
6358 runs C<make test> there.
6360 =item CPAN::Distribution::uptodate()
6362 Returns 1 if all the modules contained in the distribution are
6363 uptodate. Relies on containsmods.
6365 =item CPAN::Index::force_reload()
6367 Forces a reload of all indices.
6369 =item CPAN::Index::reload()
6371 Reloads all indices if they have been read more than
6372 C<$CPAN::Config->{index_expire}> days.
6374 =item CPAN::InfoObj::dump()
6376 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6377 inherit this method. It prints the data structure associated with an
6378 object. Useful for debugging. Note: the data structure is considered
6379 internal and thus subject to change without notice.
6381 =item CPAN::Module::as_glimpse()
6383 Returns a one-line description of the module
6385 =item CPAN::Module::as_string()
6387 Returns a multi-line description of the module
6389 =item CPAN::Module::clean()
6391 Runs a clean on the distribution associated with this module.
6393 =item CPAN::Module::cpan_file()
6395 Returns the filename on CPAN that is associated with the module.
6397 =item CPAN::Module::cpan_version()
6399 Returns the latest version of this module available on CPAN.
6401 =item CPAN::Module::cvs_import()
6403 Runs a cvs_import on the distribution associated with this module.
6405 =item CPAN::Module::description()
6407 Returns a 44 chracter description of this module. Only available for
6408 modules listed in The Module List (CPAN/modules/00modlist.long.html
6409 or 00modlist.long.txt.gz)
6411 =item CPAN::Module::force($method,@args)
6413 Forces CPAN to perform a task that normally would have failed. Force
6414 takes as arguments a method name to be called and any number of
6415 additional arguments that should be passed to the called method. The
6416 internals of the object get the needed changes so that CPAN.pm does
6417 not refuse to take the action.
6419 =item CPAN::Module::get()
6421 Runs a get on the distribution associated with this module.
6423 =item CPAN::Module::inst_file()
6425 Returns the filename of the module found in @INC. The first file found
6426 is reported just like perl itself stops searching @INC when it finds a
6429 =item CPAN::Module::inst_version()
6431 Returns the version number of the module in readable format.
6433 =item CPAN::Module::install()
6435 Runs an C<install> on the distribution associated with this module.
6437 =item CPAN::Module::look()
6439 Changes to the directory where the distribution assoicated with this
6440 module has been unpacked and opens a subshell there. Exiting the
6443 =item CPAN::Module::make()
6445 Runs a C<make> on the distribution associated with this module.
6447 =item CPAN::Module::manpage_headline()
6449 If module is installed, peeks into the module's manpage, reads the
6450 headline and returns it. Moreover, if the module has been downloaded
6451 within this session, does the equivalent on the downloaded module even
6452 if it is not installed.
6454 =item CPAN::Module::readme()
6456 Runs a C<readme> on the distribution associated with this module.
6458 =item CPAN::Module::test()
6460 Runs a C<test> on the distribution associated with this module.
6462 =item CPAN::Module::uptodate()
6464 Returns 1 if the module is installed and up-to-date.
6466 =item CPAN::Module::userid()
6468 Returns the author's ID of the module.
6472 =head2 Cache Manager
6474 Currently the cache manager only keeps track of the build directory
6475 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6476 deletes complete directories below C<build_dir> as soon as the size of
6477 all directories there gets bigger than $CPAN::Config->{build_cache}
6478 (in MB). The contents of this cache may be used for later
6479 re-installations that you intend to do manually, but will never be
6480 trusted by CPAN itself. This is due to the fact that the user might
6481 use these directories for building modules on different architectures.
6483 There is another directory ($CPAN::Config->{keep_source_where}) where
6484 the original distribution files are kept. This directory is not
6485 covered by the cache manager and must be controlled by the user. If
6486 you choose to have the same directory as build_dir and as
6487 keep_source_where directory, then your sources will be deleted with
6488 the same fifo mechanism.
6492 A bundle is just a perl module in the namespace Bundle:: that does not
6493 define any functions or methods. It usually only contains documentation.
6495 It starts like a perl module with a package declaration and a $VERSION
6496 variable. After that the pod section looks like any other pod with the
6497 only difference being that I<one special pod section> exists starting with
6502 In this pod section each line obeys the format
6504 Module_Name [Version_String] [- optional text]
6506 The only required part is the first field, the name of a module
6507 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6508 of the line is optional. The comment part is delimited by a dash just
6509 as in the man page header.
6511 The distribution of a bundle should follow the same convention as
6512 other distributions.
6514 Bundles are treated specially in the CPAN package. If you say 'install
6515 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6516 the modules in the CONTENTS section of the pod. You can install your
6517 own Bundles locally by placing a conformant Bundle file somewhere into
6518 your @INC path. The autobundle() command which is available in the
6519 shell interface does that for you by including all currently installed
6520 modules in a snapshot bundle file.
6522 =head2 Prerequisites
6524 If you have a local mirror of CPAN and can access all files with
6525 "file:" URLs, then you only need a perl better than perl5.003 to run
6526 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6527 required for non-UNIX systems or if your nearest CPAN site is
6528 associated with an URL that is not C<ftp:>.
6530 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6531 implemented for an external ftp command or for an external lynx
6534 =head2 Finding packages and VERSION
6536 This module presumes that all packages on CPAN
6542 declare their $VERSION variable in an easy to parse manner. This
6543 prerequisite can hardly be relaxed because it consumes far too much
6544 memory to load all packages into the running program just to determine
6545 the $VERSION variable. Currently all programs that are dealing with
6546 version use something like this
6548 perl -MExtUtils::MakeMaker -le \
6549 'print MM->parse_version(shift)' filename
6551 If you are author of a package and wonder if your $VERSION can be
6552 parsed, please try the above method.
6556 come as compressed or gzipped tarfiles or as zip files and contain a
6557 Makefile.PL (well, we try to handle a bit more, but without much
6564 The debugging of this module is a bit complex, because we have
6565 interferences of the software producing the indices on CPAN, of the
6566 mirroring process on CPAN, of packaging, of configuration, of
6567 synchronicity, and of bugs within CPAN.pm.
6569 For code debugging in interactive mode you can try "o debug" which
6570 will list options for debugging the various parts of the code. You
6571 should know that "o debug" has built-in completion support.
6573 For data debugging there is the C<dump> command which takes the same
6574 arguments as make/test/install and outputs the object's Data::Dumper
6577 =head2 Floppy, Zip, Offline Mode
6579 CPAN.pm works nicely without network too. If you maintain machines
6580 that are not networked at all, you should consider working with file:
6581 URLs. Of course, you have to collect your modules somewhere first. So
6582 you might use CPAN.pm to put together all you need on a networked
6583 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6584 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6585 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6586 with this floppy. See also below the paragraph about CD-ROM support.
6588 =head1 CONFIGURATION
6590 When the CPAN module is installed, a site wide configuration file is
6591 created as CPAN/Config.pm. The default values defined there can be
6592 overridden in another configuration file: CPAN/MyConfig.pm. You can
6593 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6594 $HOME/.cpan is added to the search path of the CPAN module before the
6595 use() or require() statements.
6597 Currently the following keys in the hash reference $CPAN::Config are
6600 build_cache size of cache for directories to build modules
6601 build_dir locally accessible directory to build modules
6602 index_expire after this many days refetch index files
6603 cache_metadata use serializer to cache metadata
6604 cpan_home local directory reserved for this package
6605 dontload_hash anonymous hash: modules in the keys will not be
6606 loaded by the CPAN::has_inst() routine
6607 gzip location of external program gzip
6608 inactivity_timeout breaks interactive Makefile.PLs after this
6609 many seconds inactivity. Set to 0 to never break.
6610 inhibit_startup_message
6611 if true, does not print the startup message
6612 keep_source_where directory in which to keep the source (if we do)
6613 make location of external make program
6614 make_arg arguments that should always be passed to 'make'
6615 make_install_arg same as make_arg for 'make install'
6616 makepl_arg arguments passed to 'perl Makefile.PL'
6617 pager location of external program more (or any pager)
6618 prerequisites_policy
6619 what to do if you are missing module prerequisites
6620 ('follow' automatically, 'ask' me, or 'ignore')
6621 proxy_user username for accessing an authenticating proxy
6622 proxy_pass password for accessing an authenticating proxy
6623 scan_cache controls scanning of cache ('atstart' or 'never')
6624 tar location of external program tar
6625 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6626 (and nonsense for characters outside latin range)
6627 unzip location of external program unzip
6628 urllist arrayref to nearby CPAN sites (or equivalent locations)
6629 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6630 ftp_proxy, } the three usual variables for configuring
6631 http_proxy, } proxy requests. Both as CPAN::Config variables
6632 no_proxy } and as environment variables configurable.
6634 You can set and query each of these options interactively in the cpan
6635 shell with the command set defined within the C<o conf> command:
6639 =item C<o conf E<lt>scalar optionE<gt>>
6641 prints the current value of the I<scalar option>
6643 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6645 Sets the value of the I<scalar option> to I<value>
6647 =item C<o conf E<lt>list optionE<gt>>
6649 prints the current value of the I<list option> in MakeMaker's
6652 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6654 shifts or pops the array in the I<list option> variable
6656 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6658 works like the corresponding perl commands.
6662 =head2 Note on urllist parameter's format
6664 urllist parameters are URLs according to RFC 1738. We do a little
6665 guessing if your URL is not compliant, but if you have problems with
6666 file URLs, please try the correct format. Either:
6668 file://localhost/whatever/ftp/pub/CPAN/
6672 file:///home/ftp/pub/CPAN/
6674 =head2 urllist parameter has CD-ROM support
6676 The C<urllist> parameter of the configuration table contains a list of
6677 URLs that are to be used for downloading. If the list contains any
6678 C<file> URLs, CPAN always tries to get files from there first. This
6679 feature is disabled for index files. So the recommendation for the
6680 owner of a CD-ROM with CPAN contents is: include your local, possibly
6681 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6683 o conf urllist push file://localhost/CDROM/CPAN
6685 CPAN.pm will then fetch the index files from one of the CPAN sites
6686 that come at the beginning of urllist. It will later check for each
6687 module if there is a local copy of the most recent version.
6689 Another peculiarity of urllist is that the site that we could
6690 successfully fetch the last file from automatically gets a preference
6691 token and is tried as the first site for the next request. So if you
6692 add a new site at runtime it may happen that the previously preferred
6693 site will be tried another time. This means that if you want to disallow
6694 a site for the next transfer, it must be explicitly removed from
6699 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6700 install foreign, unmasked, unsigned code on your machine. We compare
6701 to a checksum that comes from the net just as the distribution file
6702 itself. If somebody has managed to tamper with the distribution file,
6703 they may have as well tampered with the CHECKSUMS file. Future
6704 development will go towards strong authentication.
6708 Most functions in package CPAN are exported per default. The reason
6709 for this is that the primary use is intended for the cpan shell or for
6712 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6714 Populating a freshly installed perl with my favorite modules is pretty
6715 easy if you maintain a private bundle definition file. To get a useful
6716 blueprint of a bundle definition file, the command autobundle can be used
6717 on the CPAN shell command line. This command writes a bundle definition
6718 file for all modules that are installed for the currently running perl
6719 interpreter. It's recommended to run this command only once and from then
6720 on maintain the file manually under a private name, say
6721 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6723 cpan> install Bundle::my_bundle
6725 then answer a few questions and then go out for a coffee.
6727 Maintaining a bundle definition file means keeping track of two
6728 things: dependencies and interactivity. CPAN.pm sometimes fails on
6729 calculating dependencies because not all modules define all MakeMaker
6730 attributes correctly, so a bundle definition file should specify
6731 prerequisites as early as possible. On the other hand, it's a bit
6732 annoying that many distributions need some interactive configuring. So
6733 what I try to accomplish in my private bundle file is to have the
6734 packages that need to be configured early in the file and the gentle
6735 ones later, so I can go out after a few minutes and leave CPAN.pm
6738 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6740 Thanks to Graham Barr for contributing the following paragraphs about
6741 the interaction between perl, and various firewall configurations. For
6742 further informations on firewalls, it is recommended to consult the
6743 documentation that comes with the ncftp program. If you are unable to
6744 go through the firewall with a simple Perl setup, it is very likely
6745 that you can configure ncftp so that it works for your firewall.
6747 =head2 Three basic types of firewalls
6749 Firewalls can be categorized into three basic types.
6755 This is where the firewall machine runs a web server and to access the
6756 outside world you must do it via the web server. If you set environment
6757 variables like http_proxy or ftp_proxy to a values beginning with http://
6758 or in your web browser you have to set proxy information then you know
6759 you are running a http firewall.
6761 To access servers outside these types of firewalls with perl (even for
6762 ftp) you will need to use LWP.
6766 This where the firewall machine runs a ftp server. This kind of
6767 firewall will only let you access ftp servers outside the firewall.
6768 This is usually done by connecting to the firewall with ftp, then
6769 entering a username like "user@outside.host.com"
6771 To access servers outside these type of firewalls with perl you
6772 will need to use Net::FTP.
6774 =item One way visibility
6776 I say one way visibility as these firewalls try to make themselve look
6777 invisible to the users inside the firewall. An FTP data connection is
6778 normally created by sending the remote server your IP address and then
6779 listening for the connection. But the remote server will not be able to
6780 connect to you because of the firewall. So for these types of firewall
6781 FTP connections need to be done in a passive mode.
6783 There are two that I can think off.
6789 If you are using a SOCKS firewall you will need to compile perl and link
6790 it with the SOCKS library, this is what is normally called a 'socksified'
6791 perl. With this executable you will be able to connect to servers outside
6792 the firewall as if it is not there.
6796 This is the firewall implemented in the Linux kernel, it allows you to
6797 hide a complete network behind one IP address. With this firewall no
6798 special compiling is needed as you can access hosts directly.
6804 =head2 Configuring lynx or ncftp for going through a firewall
6806 If you can go through your firewall with e.g. lynx, presumably with a
6809 /usr/local/bin/lynx -pscott:tiger
6811 then you would configure CPAN.pm with the command
6813 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6815 That's all. Similarly for ncftp or ftp, you would configure something
6818 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6820 Your milage may vary...
6828 I installed a new version of module X but CPAN keeps saying,
6829 I have the old version installed
6831 Most probably you B<do> have the old version installed. This can
6832 happen if a module installs itself into a different directory in the
6833 @INC path than it was previously installed. This is not really a
6834 CPAN.pm problem, you would have the same problem when installing the
6835 module manually. The easiest way to prevent this behaviour is to add
6836 the argument C<UNINST=1> to the C<make install> call, and that is why
6837 many people add this argument permanently by configuring
6839 o conf make_install_arg UNINST=1
6843 So why is UNINST=1 not the default?
6845 Because there are people who have their precise expectations about who
6846 may install where in the @INC path and who uses which @INC array. In
6847 fine tuned environments C<UNINST=1> can cause damage.
6851 I want to clean up my mess, and install a new perl along with
6852 all modules I have. How do I go about it?
6854 Run the autobundle command for your old perl and optionally rename the
6855 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6856 with the Configure option prefix, e.g.
6858 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6860 Install the bundle file you produced in the first step with something like
6862 cpan> install Bundle::mybundle
6868 When I install bundles or multiple modules with one command
6869 there is too much output to keep track of.
6871 You may want to configure something like
6873 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6874 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6876 so that STDOUT is captured in a file for later inspection.
6881 I am not root, how can I install a module in a personal directory?
6883 You will most probably like something like this:
6885 o conf makepl_arg "LIB=~/myperl/lib \
6886 INSTALLMAN1DIR=~/myperl/man/man1 \
6887 INSTALLMAN3DIR=~/myperl/man/man3"
6888 install Sybase::Sybperl
6890 You can make this setting permanent like all C<o conf> settings with
6893 You will have to add ~/myperl/man to the MANPATH environment variable
6894 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6897 use lib "$ENV{HOME}/myperl/lib";
6899 or setting the PERL5LIB environment variable.
6901 Another thing you should bear in mind is that the UNINST parameter
6902 should never be set if you are not root.
6906 How to get a package, unwrap it, and make a change before building it?
6908 look Sybase::Sybperl
6912 I installed a Bundle and had a couple of fails. When I
6913 retried, everything resolved nicely. Can this be fixed to work
6916 The reason for this is that CPAN does not know the dependencies of all
6917 modules when it starts out. To decide about the additional items to
6918 install, it just uses data found in the generated Makefile. An
6919 undetected missing piece breaks the process. But it may well be that
6920 your Bundle installs some prerequisite later than some depending item
6921 and thus your second try is able to resolve everything. Please note,
6922 CPAN.pm does not know the dependency tree in advance and cannot sort
6923 the queue of things to install in a topologically correct order. It
6924 resolves perfectly well IFF all modules declare the prerequisites
6925 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6926 fail and you need to install often, it is recommended sort the Bundle
6927 definition file manually. It is planned to improve the metadata
6928 situation for dependencies on CPAN in general, but this will still
6933 In our intranet we have many modules for internal use. How
6934 can I integrate these modules with CPAN.pm but without uploading
6935 the modules to CPAN?
6937 Have a look at the CPAN::Site module.
6941 When I run CPAN's shell, I get error msg about line 1 to 4,
6942 setting meta input/output via the /etc/inputrc file.
6944 Some versions of readline are picky about capitalization in the
6945 /etc/inputrc file and specifically RedHat 6.2 comes with a
6946 /etc/inputrc that contains the word C<on> in lowercase. Change the
6947 occurrences of C<on> to C<On> and the bug should disappear.
6951 Some authors have strange characters in their names.
6953 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
6954 expecting ISO-8859-1 charset, a converter can be activated by setting
6955 term_is_latin to a true value in your config file. One way of doing so
6958 cpan> ! $CPAN::Config->{term_is_latin}=1
6960 Extended support for converters will be made available as soon as perl
6961 becomes stable with regard to charset issues.
6967 We should give coverage for B<all> of the CPAN and not just the PAUSE
6968 part, right? In this discussion CPAN and PAUSE have become equal --
6969 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6970 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6972 Future development should be directed towards a better integration of
6975 If a Makefile.PL requires special customization of libraries, prompts
6976 the user for special input, etc. then you may find CPAN is not able to
6977 build the distribution. In that case, you should attempt the
6978 traditional method of building a Perl module package from a shell.
6982 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
6986 Kawai,Takanori provides a Japanese translation of this manpage at
6987 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
6991 perl(1), CPAN::Nox(3)