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 require Mac::BuildTools if $^O eq 'MacOS';
30 END { $End++; &cleanup; }
53 $CPAN::Frontend ||= "CPAN::Shell";
54 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
59 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
60 $Revision $Signal $End $Suppress_readline $Frontend
61 $Defaultsite $Have_warned);
63 @CPAN::ISA = qw(CPAN::Debug Exporter);
66 autobundle bundle expand force get cvs_import
67 install make readme recompile shell test clean
70 #-> sub CPAN::AUTOLOAD ;
75 @EXPORT{@EXPORT} = '';
76 CPAN::Config->load unless $CPAN::Config_loaded++;
77 if (exists $EXPORT{$l}){
80 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
89 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
90 CPAN::Config->load unless $CPAN::Config_loaded++;
92 my $oprompt = shift || "cpan> ";
93 my $prompt = $oprompt;
94 my $commandline = shift || "";
97 unless ($Suppress_readline) {
98 require Term::ReadLine;
101 $term->ReadLine eq "Term::ReadLine::Stub"
103 $term = Term::ReadLine->new('CPAN Monitor');
105 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
106 my $attribs = $term->Attribs;
107 $attribs->{attempted_completion_function} = sub {
108 &CPAN::Complete::gnu_cpl;
111 $readline::rl_completion_function =
112 $readline::rl_completion_function = 'CPAN::Complete::cpl';
114 # $term->OUT is autoflushed anyway
115 my $odef = select STDERR;
122 # no strict; # I do not recall why no strict was here (2000-09-03)
124 my $cwd = CPAN::anycwd();
125 my $try_detect_readline;
126 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
127 my $rl_avail = $Suppress_readline ? "suppressed" :
128 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
129 "available (try 'install Bundle::CPAN')";
131 $CPAN::Frontend->myprint(
133 cpan shell -- CPAN exploration and modules installation (v%s%s)
141 unless $CPAN::Config->{'inhibit_startup_message'} ;
142 my($continuation) = "";
143 SHELLCOMMAND: while () {
144 if ($Suppress_readline) {
146 last SHELLCOMMAND unless defined ($_ = <> );
149 last SHELLCOMMAND unless
150 defined ($_ = $term->readline($prompt, $commandline));
152 $_ = "$continuation$_" if $continuation;
154 next SHELLCOMMAND if /^$/;
155 $_ = 'h' if /^\s*\?/;
156 if (/^(?:q(?:uit)?|bye|exit)$/i) {
166 use vars qw($import_done);
167 CPAN->import(':DEFAULT') unless $import_done++;
168 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
175 if ($] < 5.00322) { # parsewords had a bug until recently
178 eval { @line = Text::ParseWords::shellwords($_) };
179 warn($@), next SHELLCOMMAND if $@;
180 warn("Text::Parsewords could not parse the line [$_]"),
181 next SHELLCOMMAND unless @line;
183 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
184 my $command = shift @line;
185 eval { CPAN::Shell->$command(@line) };
187 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
188 $CPAN::Frontend->myprint("\n");
193 $commandline = ""; # I do want to be able to pass a default to
194 # shell, but on the second command I see no
197 CPAN::Queue->nullify_queue;
198 if ($try_detect_readline) {
199 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
201 $CPAN::META->has_inst("Term::ReadLine::Perl")
203 delete $INC{"Term/ReadLine.pm"};
205 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
206 require Term::ReadLine;
207 $CPAN::Frontend->myprint("\n$redef subroutines in ".
208 "Term::ReadLine redefined\n");
214 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
217 package CPAN::CacheMgr;
218 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
221 package CPAN::Config;
222 use vars qw(%can $dot_cpan);
225 'commit' => "Commit changes to disk",
226 'defaults' => "Reload defaults from disk",
227 'init' => "Interactive setting of all options",
231 use vars qw($Ua $Thesite $Themethod);
232 @CPAN::FTP::ISA = qw(CPAN::Debug);
234 package CPAN::LWP::UserAgent;
235 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
236 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
238 package CPAN::Complete;
239 @CPAN::Complete::ISA = qw(CPAN::Debug);
240 @CPAN::Complete::COMMANDS = sort qw(
241 ! a b d h i m o q r u autobundle clean dump
242 make test install force readme reload look
244 ) unless @CPAN::Complete::COMMANDS;
247 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
248 @CPAN::Index::ISA = qw(CPAN::Debug);
251 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
254 package CPAN::InfoObj;
255 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
257 package CPAN::Author;
258 @CPAN::Author::ISA = qw(CPAN::InfoObj);
260 package CPAN::Distribution;
261 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
263 package CPAN::Bundle;
264 @CPAN::Bundle::ISA = qw(CPAN::Module);
266 package CPAN::Module;
267 @CPAN::Module::ISA = qw(CPAN::InfoObj);
270 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
271 @CPAN::Shell::ISA = qw(CPAN::Debug);
272 $COLOR_REGISTERED ||= 0;
273 $PRINT_ORNAMENTING ||= 0;
275 #-> sub CPAN::Shell::AUTOLOAD ;
277 my($autoload) = $AUTOLOAD;
278 my $class = shift(@_);
279 # warn "autoload[$autoload] class[$class]";
280 $autoload =~ s/.*:://;
281 if ($autoload =~ /^w/) {
282 if ($CPAN::META->has_inst('CPAN::WAIT')) {
283 CPAN::WAIT->$autoload(@_);
285 $CPAN::Frontend->mywarn(qq{
286 Commands starting with "w" require CPAN::WAIT to be installed.
287 Please consider installing CPAN::WAIT to use the fulltext index.
288 For this you just need to type
293 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
299 package CPAN::Tarzip;
300 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
301 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
302 $BUGHUNTING = 0; # released code must have turned off
306 # One use of the queue is to determine if we should or shouldn't
307 # announce the availability of a new CPAN module
309 # Now we try to use it for dependency tracking. For that to happen
310 # we need to draw a dependency tree and do the leaves first. This can
311 # easily be reached by running CPAN.pm recursively, but we don't want
312 # to waste memory and run into deep recursion. So what we can do is
315 # CPAN::Queue is the package where the queue is maintained. Dependencies
316 # often have high priority and must be brought to the head of the queue,
317 # possibly by jumping the queue if they are already there. My first code
318 # attempt tried to be extremely correct. Whenever a module needed
319 # immediate treatment, I either unshifted it to the front of the queue,
320 # or, if it was already in the queue, I spliced and let it bypass the
321 # others. This became a too correct model that made it impossible to put
322 # an item more than once into the queue. Why would you need that? Well,
323 # you need temporary duplicates as the manager of the queue is a loop
326 # (1) looks at the first item in the queue without shifting it off
328 # (2) cares for the item
330 # (3) removes the item from the queue, *even if its agenda failed and
331 # even if the item isn't the first in the queue anymore* (that way
332 # protecting against never ending queues)
334 # So if an item has prerequisites, the installation fails now, but we
335 # want to retry later. That's easy if we have it twice in the queue.
337 # I also expect insane dependency situations where an item gets more
338 # than two lives in the queue. Simplest example is triggered by 'install
339 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
340 # get in the way. I wanted the queue manager to be a dumb servant, not
341 # one that knows everything.
343 # Who would I tell in this model that the user wants to be asked before
344 # processing? I can't attach that information to the module object,
345 # because not modules are installed but distributions. So I'd have to
346 # tell the distribution object that it should ask the user before
347 # processing. Where would the question be triggered then? Most probably
348 # in CPAN::Distribution::rematein.
349 # Hope that makes sense, my head is a bit off:-) -- AK
356 my $self = bless { qmod => $s }, $class;
361 # CPAN::Queue::first ;
367 # CPAN::Queue::delete_first ;
369 my($class,$what) = @_;
371 for my $i (0..$#All) {
372 if ( $All[$i]->{qmod} eq $what ) {
379 # CPAN::Queue::jumpqueue ;
383 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
384 join(",",map {$_->{qmod}} @All),
387 WHAT: for my $what (reverse @what) {
389 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
390 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
391 if ($All[$i]->{qmod} eq $what){
393 if ($jumped > 100) { # one's OK if e.g. just
394 # processing now; more are OK if
395 # user typed it several times
396 $CPAN::Frontend->mywarn(
397 qq{Object [$what] queued more than 100 times, ignoring}
403 my $obj = bless { qmod => $what }, $class;
406 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
407 join(",",map {$_->{qmod}} @All),
412 # CPAN::Queue::exists ;
414 my($self,$what) = @_;
415 my @all = map { $_->{qmod} } @All;
416 my $exists = grep { $_->{qmod} eq $what } @All;
417 # warn "in exists what[$what] all[@all] exists[$exists]";
421 # CPAN::Queue::delete ;
424 @All = grep { $_->{qmod} ne $mod } @All;
427 # CPAN::Queue::nullify_queue ;
436 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
438 # from here on only subs.
439 ################################################################################
441 #-> sub CPAN::all_objects ;
443 my($mgr,$class) = @_;
444 CPAN::Config->load unless $CPAN::Config_loaded++;
445 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
447 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
449 *all = \&all_objects;
451 # Called by shell, not in batch mode. In batch mode I see no risk in
452 # having many processes updating something as installations are
453 # continually checked at runtime. In shell mode I suspect it is
454 # unintentional to open more than one shell at a time
456 #-> sub CPAN::checklock ;
459 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
460 if (-f $lockfile && -M _ > 0) {
461 my $fh = FileHandle->new($lockfile) or
462 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
465 if (defined $other && $other) {
467 return if $$==$other; # should never happen
468 $CPAN::Frontend->mywarn(
470 There seems to be running another CPAN process ($other). Contacting...
472 if (kill 0, $other) {
473 $CPAN::Frontend->mydie(qq{Other job is running.
474 You may want to kill it and delete the lockfile, maybe. On UNIX try:
478 } elsif (-w $lockfile) {
480 ExtUtils::MakeMaker::prompt
481 (qq{Other job not responding. Shall I overwrite }.
482 qq{the lockfile? (Y/N)},"y");
483 $CPAN::Frontend->myexit("Ok, bye\n")
484 unless $ans =~ /^y/i;
487 qq{Lockfile $lockfile not writeable by you. }.
488 qq{Cannot proceed.\n}.
491 qq{ and then rerun us.\n}
495 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
496 "reports other process with ID ".
497 "$other. Cannot proceed.\n"));
500 my $dotcpan = $CPAN::Config->{cpan_home};
501 eval { File::Path::mkpath($dotcpan);};
503 # A special case at least for Jarkko.
508 $symlinkcpan = readlink $dotcpan;
509 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
510 eval { File::Path::mkpath($symlinkcpan); };
514 $CPAN::Frontend->mywarn(qq{
515 Working directory $symlinkcpan created.
519 unless (-d $dotcpan) {
521 Your configuration suggests "$dotcpan" as your
522 CPAN.pm working directory. I could not create this directory due
523 to this error: $firsterror\n};
525 As "$dotcpan" is a symlink to "$symlinkcpan",
526 I tried to create that, but I failed with this error: $seconderror
529 Please make sure the directory exists and is writable.
531 $CPAN::Frontend->mydie($diemess);
535 unless ($fh = FileHandle->new(">$lockfile")) {
536 if ($! =~ /Permission/) {
537 my $incc = $INC{'CPAN/Config.pm'};
538 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
539 $CPAN::Frontend->myprint(qq{
541 Your configuration suggests that CPAN.pm should use a working
543 $CPAN::Config->{cpan_home}
544 Unfortunately we could not create the lock file
546 due to permission problems.
548 Please make sure that the configuration variable
549 \$CPAN::Config->{cpan_home}
550 points to a directory where you can write a .lock file. You can set
551 this variable in either
558 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
560 $fh->print($$, "\n");
561 $self->{LOCK} = $lockfile;
565 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
570 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
571 print "Caught SIGINT\n";
575 # From: Larry Wall <larry@wall.org>
576 # Subject: Re: deprecating SIGDIE
577 # To: perl5-porters@perl.org
578 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
580 # The original intent of __DIE__ was only to allow you to substitute one
581 # kind of death for another on an application-wide basis without respect
582 # to whether you were in an eval or not. As a global backstop, it should
583 # not be used any more lightly (or any more heavily :-) than class
584 # UNIVERSAL. Any attempt to build a general exception model on it should
585 # be politely squashed. Any bug that causes every eval {} to have to be
586 # modified should be not so politely squashed.
588 # Those are my current opinions. It is also my optinion that polite
589 # arguments degenerate to personal arguments far too frequently, and that
590 # when they do, it's because both people wanted it to, or at least didn't
591 # sufficiently want it not to.
595 # global backstop to cleanup if we should really die
596 $SIG{__DIE__} = \&cleanup;
597 $self->debug("Signal handler set.") if $CPAN::DEBUG;
600 #-> sub CPAN::DESTROY ;
602 &cleanup; # need an eval?
605 #-> sub CPAN::anycwd ;
608 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
613 sub cwd {Cwd::cwd();}
615 #-> sub CPAN::getcwd ;
616 sub getcwd {Cwd::getcwd();}
618 #-> sub CPAN::exists ;
620 my($mgr,$class,$id) = @_;
621 CPAN::Config->load unless $CPAN::Config_loaded++;
623 ### Carp::croak "exists called without class argument" unless $class;
625 exists $META->{readonly}{$class}{$id} or
626 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
629 #-> sub CPAN::delete ;
631 my($mgr,$class,$id) = @_;
632 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
633 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
636 #-> sub CPAN::has_usable
637 # has_inst is sometimes too optimistic, we should replace it with this
638 # has_usable whenever a case is given
640 my($self,$mod,$message) = @_;
641 return 1 if $HAS_USABLE->{$mod};
642 my $has_inst = $self->has_inst($mod,$message);
643 return unless $has_inst;
646 LWP => [ # we frequently had "Can't locate object
647 # method "new" via package "LWP::UserAgent" at
648 # (eval 69) line 2006
650 sub {require LWP::UserAgent},
651 sub {require HTTP::Request},
652 sub {require URI::URL},
655 sub {require Net::FTP},
656 sub {require Net::Config},
659 if ($usable->{$mod}) {
660 for my $c (0..$#{$usable->{$mod}}) {
661 my $code = $usable->{$mod}[$c];
662 my $ret = eval { &$code() };
664 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
669 return $HAS_USABLE->{$mod} = 1;
672 #-> sub CPAN::has_inst
674 my($self,$mod,$message) = @_;
675 Carp::croak("CPAN->has_inst() called without an argument")
677 if (defined $message && $message eq "no"
679 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
681 exists $CPAN::Config->{dontload_hash}{$mod}
683 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
689 $file =~ s|/|\\|g if $^O eq 'MSWin32';
692 # checking %INC is wrong, because $INC{LWP} may be true
693 # although $INC{"URI/URL.pm"} may have failed. But as
694 # I really want to say "bla loaded OK", I have to somehow
696 ### warn "$file in %INC"; #debug
698 } elsif (eval { require $file }) {
699 # eval is good: if we haven't yet read the database it's
700 # perfect and if we have installed the module in the meantime,
701 # it tries again. The second require is only a NOOP returning
702 # 1 if we had success, otherwise it's retrying
704 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
705 if ($mod eq "CPAN::WAIT") {
706 push @CPAN::Shell::ISA, CPAN::WAIT;
709 } elsif ($mod eq "Net::FTP") {
710 $CPAN::Frontend->mywarn(qq{
711 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
713 install Bundle::libnet
715 }) unless $Have_warned->{"Net::FTP"}++;
717 } elsif ($mod eq "Digest::MD5"){
718 $CPAN::Frontend->myprint(qq{
719 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
720 Please consider installing the Digest::MD5 module.
725 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
730 #-> sub CPAN::instance ;
732 my($mgr,$class,$id) = @_;
735 # unsafe meta access, ok?
736 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
737 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
745 #-> sub CPAN::cleanup ;
747 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
748 local $SIG{__DIE__} = '';
753 0 && # disabled, try reload cpan with it
754 $] > 5.004_60 # thereabouts
759 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
761 $subroutine eq '(eval)';
764 return if $ineval && !$End;
765 return unless defined $META->{LOCK}; # unsafe meta access, ok
766 return unless -f $META->{LOCK}; # unsafe meta access, ok
767 unlink $META->{LOCK}; # unsafe meta access, ok
769 # Carp::cluck("DEBUGGING");
770 $CPAN::Frontend->mywarn("Lockfile removed.\n");
773 package CPAN::CacheMgr;
775 #-> sub CPAN::CacheMgr::as_string ;
777 eval { require Data::Dumper };
779 return shift->SUPER::as_string;
781 return Data::Dumper::Dumper(shift);
785 #-> sub CPAN::CacheMgr::cachesize ;
790 #-> sub CPAN::CacheMgr::tidyup ;
793 return unless -d $self->{ID};
794 while ($self->{DU} > $self->{'MAX'} ) {
795 my($toremove) = shift @{$self->{FIFO}};
796 $CPAN::Frontend->myprint(sprintf(
797 "Deleting from cache".
798 ": $toremove (%.1f>%.1f MB)\n",
799 $self->{DU}, $self->{'MAX'})
801 return if $CPAN::Signal;
802 $self->force_clean_cache($toremove);
803 return if $CPAN::Signal;
807 #-> sub CPAN::CacheMgr::dir ;
812 #-> sub CPAN::CacheMgr::entries ;
815 return unless defined $dir;
816 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
817 $dir ||= $self->{ID};
818 my($cwd) = CPAN::anycwd();
819 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
820 my $dh = DirHandle->new(File::Spec->curdir)
821 or Carp::croak("Couldn't opendir $dir: $!");
824 next if $_ eq "." || $_ eq "..";
826 push @entries, File::Spec->catfile($dir,$_);
828 push @entries, File::Spec->catdir($dir,$_);
830 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
833 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
834 sort { -M $b <=> -M $a} @entries;
837 #-> sub CPAN::CacheMgr::disk_usage ;
840 return if exists $self->{SIZE}{$dir};
841 return if $CPAN::Signal;
845 $File::Find::prune++ if $CPAN::Signal;
847 if ($^O eq 'MacOS') {
849 my $cat = Mac::Files::FSpGetCatInfo($_);
850 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
857 return if $CPAN::Signal;
858 $self->{SIZE}{$dir} = $Du/1024/1024;
859 push @{$self->{FIFO}}, $dir;
860 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
861 $self->{DU} += $Du/1024/1024;
865 #-> sub CPAN::CacheMgr::force_clean_cache ;
866 sub force_clean_cache {
868 return unless -e $dir;
869 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
871 File::Path::rmtree($dir);
872 $self->{DU} -= $self->{SIZE}{$dir};
873 delete $self->{SIZE}{$dir};
876 #-> sub CPAN::CacheMgr::new ;
883 ID => $CPAN::Config->{'build_dir'},
884 MAX => $CPAN::Config->{'build_cache'},
885 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
888 File::Path::mkpath($self->{ID});
889 my $dh = DirHandle->new($self->{ID});
893 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
895 CPAN->debug($debug) if $CPAN::DEBUG;
899 #-> sub CPAN::CacheMgr::scan_cache ;
902 return if $self->{SCAN} eq 'never';
903 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
904 unless $self->{SCAN} eq 'atstart';
905 $CPAN::Frontend->myprint(
906 sprintf("Scanning cache %s for sizes\n",
909 for $e ($self->entries($self->{ID})) {
910 next if $e eq ".." || $e eq ".";
911 $self->disk_usage($e);
912 return if $CPAN::Signal;
919 #-> sub CPAN::Debug::debug ;
922 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
923 # Complete, caller(1)
925 ($caller) = caller(0);
927 $arg = "" unless defined $arg;
928 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
929 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
930 if ($arg and ref $arg) {
931 eval { require Data::Dumper };
933 $CPAN::Frontend->myprint($arg->as_string);
935 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
938 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
943 package CPAN::Config;
945 #-> sub CPAN::Config::edit ;
946 # returns true on successful action
948 my($self,@args) = @_;
950 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
951 my($o,$str,$func,$args,$key_exists);
957 CPAN->debug("o[$o]") if $CPAN::DEBUG;
961 CPAN->debug("func[$func]") if $CPAN::DEBUG;
963 # Let's avoid eval, it's easier to comprehend without.
964 if ($func eq "push") {
965 push @{$CPAN::Config->{$o}}, @args;
967 } elsif ($func eq "pop") {
968 pop @{$CPAN::Config->{$o}};
970 } elsif ($func eq "shift") {
971 shift @{$CPAN::Config->{$o}};
973 } elsif ($func eq "unshift") {
974 unshift @{$CPAN::Config->{$o}}, @args;
976 } elsif ($func eq "splice") {
977 splice @{$CPAN::Config->{$o}}, @args;
980 $CPAN::Config->{$o} = [@args];
983 $self->prettyprint($o);
985 if ($o eq "urllist" && $changed) {
986 # reset the cached values
987 undef $CPAN::FTP::Thesite;
988 undef $CPAN::FTP::Themethod;
992 $CPAN::Config->{$o} = $args[0] if defined $args[0];
993 $self->prettyprint($o);
1000 my $v = $CPAN::Config->{$k};
1002 my(@report) = ref $v eq "ARRAY" ?
1004 map { sprintf(" %-18s => %s\n",
1006 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1008 $CPAN::Frontend->myprint(
1015 map {"\t$_\n"} @report
1018 } elsif (defined $v) {
1019 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1021 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1025 #-> sub CPAN::Config::commit ;
1027 my($self,$configpm) = @_;
1028 unless (defined $configpm){
1029 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1030 $configpm ||= $INC{"CPAN/Config.pm"};
1031 $configpm || Carp::confess(q{
1032 CPAN::Config::commit called without an argument.
1033 Please specify a filename where to save the configuration or try
1034 "o conf init" to have an interactive course through configing.
1039 $mode = (stat $configpm)[2];
1040 if ($mode && ! -w _) {
1041 Carp::confess("$configpm is not writable");
1046 $msg = <<EOF unless $configpm =~ /MyConfig/;
1048 # This is CPAN.pm's systemwide configuration file. This file provides
1049 # defaults for users, and the values can be changed in a per-user
1050 # configuration file. The user-config file is being looked for as
1051 # ~/.cpan/CPAN/MyConfig.pm.
1055 my($fh) = FileHandle->new;
1056 rename $configpm, "$configpm~" if -f $configpm;
1057 open $fh, ">$configpm" or
1058 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1059 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1060 foreach (sort keys %$CPAN::Config) {
1063 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1068 $fh->print("};\n1;\n__END__\n");
1071 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1072 #chmod $mode, $configpm;
1073 ###why was that so? $self->defaults;
1074 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1078 *default = \&defaults;
1079 #-> sub CPAN::Config::defaults ;
1089 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1098 # This is a piece of repeated code that is abstracted here for
1099 # maintainability. RMB
1102 my($configpmdir, $configpmtest) = @_;
1103 if (-w $configpmtest) {
1104 return $configpmtest;
1105 } elsif (-w $configpmdir) {
1106 #_#_# following code dumped core on me with 5.003_11, a.k.
1107 my $configpm_bak = "$configpmtest.bak";
1108 unlink $configpm_bak if -f $configpm_bak;
1109 if( -f $configpmtest ) {
1110 if( rename $configpmtest, $configpm_bak ) {
1111 $CPAN::Frontend->mywarn(<<END)
1112 Old configuration file $configpmtest
1113 moved to $configpm_bak
1117 my $fh = FileHandle->new;
1118 if ($fh->open(">$configpmtest")) {
1120 return $configpmtest;
1122 # Should never happen
1123 Carp::confess("Cannot open >$configpmtest");
1128 #-> sub CPAN::Config::load ;
1133 eval {require CPAN::Config;}; # We eval because of some
1134 # MakeMaker problems
1135 unless ($dot_cpan++){
1136 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1137 eval {require CPAN::MyConfig;}; # where you can override
1138 # system wide settings
1141 return unless @miss = $self->missing_config_data;
1143 require CPAN::FirstTime;
1144 my($configpm,$fh,$redo,$theycalled);
1146 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1147 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1148 $configpm = $INC{"CPAN/Config.pm"};
1150 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1151 $configpm = $INC{"CPAN/MyConfig.pm"};
1154 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1155 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1156 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1157 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1158 $configpm = _configpmtest($configpmdir,$configpmtest);
1160 unless ($configpm) {
1161 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1162 File::Path::mkpath($configpmdir);
1163 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1164 $configpm = _configpmtest($configpmdir,$configpmtest);
1165 unless ($configpm) {
1166 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1167 qq{create a configuration file.});
1172 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1173 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1177 $CPAN::Frontend->myprint(qq{
1178 $configpm initialized.
1181 CPAN::FirstTime::init($configpm);
1184 #-> sub CPAN::Config::missing_config_data ;
1185 sub missing_config_data {
1188 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1189 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1191 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1192 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1193 "prerequisites_policy",
1196 push @miss, $_ unless defined $CPAN::Config->{$_};
1201 #-> sub CPAN::Config::unload ;
1203 delete $INC{'CPAN/MyConfig.pm'};
1204 delete $INC{'CPAN/Config.pm'};
1207 #-> sub CPAN::Config::help ;
1209 $CPAN::Frontend->myprint(q[
1211 defaults reload default config values from disk
1212 commit commit session changes to disk
1213 init go through a dialog to set all parameters
1215 You may edit key values in the follow fashion (the "o" is a literal
1218 o conf build_cache 15
1220 o conf build_dir "/foo/bar"
1222 o conf urllist shift
1224 o conf urllist unshift ftp://ftp.foo.bar/
1227 undef; #don't reprint CPAN::Config
1230 #-> sub CPAN::Config::cpl ;
1232 my($word,$line,$pos) = @_;
1234 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1235 my(@words) = split " ", substr($line,0,$pos+1);
1240 $words[2] =~ /list$/ && @words == 3
1242 $words[2] =~ /list$/ && @words == 4 && length($word)
1245 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1246 } elsif (@words >= 4) {
1249 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1250 return grep /^\Q$word\E/, @o_conf;
1253 package CPAN::Shell;
1255 #-> sub CPAN::Shell::h ;
1257 my($class,$about) = @_;
1258 if (defined $about) {
1259 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1261 $CPAN::Frontend->myprint(q{
1263 command argument description
1264 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1265 i WORD or /REGEXP/ about anything of above
1266 r NONE reinstall recommendations
1267 ls AUTHOR about files in the author's directory
1269 Download, Test, Make, Install...
1271 make make (implies get)
1272 test MODULES, make test (implies make)
1273 install DISTS, BUNDLES make install (implies test)
1275 look open subshell in these dists' directories
1276 readme display these dists' README files
1279 h,? display this menu ! perl-code eval a perl command
1280 o conf [opt] set and query options q quit the cpan shell
1281 reload cpan load CPAN.pm again reload index load newer indices
1282 autobundle Snapshot force cmd unconditionally do cmd});
1288 #-> sub CPAN::Shell::a ;
1290 my($self,@arg) = @_;
1291 # authors are always UPPERCASE
1293 $_ = uc $_ unless /=/;
1295 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1298 #-> sub CPAN::Shell::ls ;
1300 my($self,@arg) = @_;
1303 unless (/^[A-Z\-]+$/i) {
1304 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
1307 push @accept, uc $_;
1309 for my $a (@accept){
1310 my $author = $self->expand('Author',$a) or die "No author found for $a";
1315 #-> sub CPAN::Shell::local_bundles ;
1317 my($self,@which) = @_;
1318 my($incdir,$bdir,$dh);
1319 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1320 my @bbase = "Bundle";
1321 while (my $bbase = shift @bbase) {
1322 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1323 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1324 if ($dh = DirHandle->new($bdir)) { # may fail
1326 for $entry ($dh->read) {
1327 next if $entry =~ /^\./;
1328 if (-d File::Spec->catdir($bdir,$entry)){
1329 push @bbase, "$bbase\::$entry";
1331 next unless $entry =~ s/\.pm(?!\n)\Z//;
1332 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1340 #-> sub CPAN::Shell::b ;
1342 my($self,@which) = @_;
1343 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1344 $self->local_bundles;
1345 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1348 #-> sub CPAN::Shell::d ;
1349 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1351 #-> sub CPAN::Shell::m ;
1352 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1353 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1356 #-> sub CPAN::Shell::i ;
1361 @type = qw/Author Bundle Distribution Module/;
1362 @args = '/./' unless @args;
1365 push @result, $self->expand($type,@args);
1367 my $result = @result == 1 ?
1368 $result[0]->as_string :
1370 "No objects found of any type for argument @args\n" :
1372 (map {$_->as_glimpse} @result),
1373 scalar @result, " items found\n",
1375 $CPAN::Frontend->myprint($result);
1378 #-> sub CPAN::Shell::o ;
1380 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1381 # should have been called set and 'o debug' maybe 'set debug'
1383 my($self,$o_type,@o_what) = @_;
1385 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1386 if ($o_type eq 'conf') {
1387 shift @o_what if @o_what && $o_what[0] eq 'help';
1388 if (!@o_what) { # print all things, "o conf"
1390 $CPAN::Frontend->myprint("CPAN::Config options");
1391 if (exists $INC{'CPAN/Config.pm'}) {
1392 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1394 if (exists $INC{'CPAN/MyConfig.pm'}) {
1395 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1397 $CPAN::Frontend->myprint(":\n");
1398 for $k (sort keys %CPAN::Config::can) {
1399 $v = $CPAN::Config::can{$k};
1400 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1402 $CPAN::Frontend->myprint("\n");
1403 for $k (sort keys %$CPAN::Config) {
1404 CPAN::Config->prettyprint($k);
1406 $CPAN::Frontend->myprint("\n");
1407 } elsif (!CPAN::Config->edit(@o_what)) {
1408 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1409 qq{edit options\n\n});
1411 } elsif ($o_type eq 'debug') {
1413 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1416 my($what) = shift @o_what;
1417 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1418 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1421 if ( exists $CPAN::DEBUG{$what} ) {
1422 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1423 } elsif ($what =~ /^\d/) {
1424 $CPAN::DEBUG = $what;
1425 } elsif (lc $what eq 'all') {
1427 for (values %CPAN::DEBUG) {
1430 $CPAN::DEBUG = $max;
1433 for (keys %CPAN::DEBUG) {
1434 next unless lc($_) eq lc($what);
1435 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1438 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1443 my $raw = "Valid options for debug are ".
1444 join(", ",sort(keys %CPAN::DEBUG), 'all').
1445 qq{ or a number. Completion works on the options. }.
1446 qq{Case is ignored.};
1448 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1449 $CPAN::Frontend->myprint("\n\n");
1452 $CPAN::Frontend->myprint("Options set for debugging:\n");
1454 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1455 $v = $CPAN::DEBUG{$k};
1456 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1457 if $v & $CPAN::DEBUG;
1460 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1463 $CPAN::Frontend->myprint(qq{
1465 conf set or get configuration variables
1466 debug set or get debugging options
1471 sub paintdots_onreload {
1474 if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1478 # $CPAN::Frontend->myprint(".($subr)");
1479 $CPAN::Frontend->myprint(".");
1486 #-> sub CPAN::Shell::reload ;
1488 my($self,$command,@arg) = @_;
1490 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1491 if ($command =~ /cpan/i) {
1492 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1493 my $fh = FileHandle->new($INC{'CPAN.pm'});
1496 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1499 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1500 } elsif ($command =~ /index/) {
1501 CPAN::Index->force_reload;
1503 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1504 index re-reads the index files\n});
1508 #-> sub CPAN::Shell::_binary_extensions ;
1509 sub _binary_extensions {
1510 my($self) = shift @_;
1511 my(@result,$module,%seen,%need,$headerdone);
1512 for $module ($self->expand('Module','/./')) {
1513 my $file = $module->cpan_file;
1514 next if $file eq "N/A";
1515 next if $file =~ /^Contact Author/;
1516 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1517 next if $dist->isa_perl;
1518 next unless $module->xs_file;
1520 $CPAN::Frontend->myprint(".");
1521 push @result, $module;
1523 # print join " | ", @result;
1524 $CPAN::Frontend->myprint("\n");
1528 #-> sub CPAN::Shell::recompile ;
1530 my($self) = shift @_;
1531 my($module,@module,$cpan_file,%dist);
1532 @module = $self->_binary_extensions();
1533 for $module (@module){ # we force now and compile later, so we
1535 $cpan_file = $module->cpan_file;
1536 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1538 $dist{$cpan_file}++;
1540 for $cpan_file (sort keys %dist) {
1541 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1542 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1544 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1545 # stop a package from recompiling,
1546 # e.g. IO-1.12 when we have perl5.003_10
1550 #-> sub CPAN::Shell::_u_r_common ;
1552 my($self) = shift @_;
1553 my($what) = shift @_;
1554 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1555 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1556 $what && $what =~ /^[aru]$/;
1558 @args = '/./' unless @args;
1559 my(@result,$module,%seen,%need,$headerdone,
1560 $version_undefs,$version_zeroes);
1561 $version_undefs = $version_zeroes = 0;
1562 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1563 my @expand = $self->expand('Module',@args);
1564 my $expand = scalar @expand;
1565 if (0) { # Looks like noise to me, was very useful for debugging
1566 # for metadata cache
1567 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1569 for $module (@expand) {
1570 my $file = $module->cpan_file;
1571 next unless defined $file; # ??
1572 my($latest) = $module->cpan_version;
1573 my($inst_file) = $module->inst_file;
1575 return if $CPAN::Signal;
1578 $have = $module->inst_version;
1579 } elsif ($what eq "r") {
1580 $have = $module->inst_version;
1582 if ($have eq "undef"){
1584 } elsif ($have == 0){
1587 next unless CPAN::Version->vgt($latest, $have);
1588 # to be pedantic we should probably say:
1589 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1590 # to catch the case where CPAN has a version 0 and we have a version undef
1591 } elsif ($what eq "u") {
1597 } elsif ($what eq "r") {
1599 } elsif ($what eq "u") {
1603 return if $CPAN::Signal; # this is sometimes lengthy
1606 push @result, sprintf "%s %s\n", $module->id, $have;
1607 } elsif ($what eq "r") {
1608 push @result, $module->id;
1609 next if $seen{$file}++;
1610 } elsif ($what eq "u") {
1611 push @result, $module->id;
1612 next if $seen{$file}++;
1613 next if $file =~ /^Contact/;
1615 unless ($headerdone++){
1616 $CPAN::Frontend->myprint("\n");
1617 $CPAN::Frontend->myprint(sprintf(
1620 "Package namespace",
1632 $CPAN::META->has_inst("Term::ANSIColor")
1634 $module->{RO}{description}
1636 $color_on = Term::ANSIColor::color("green");
1637 $color_off = Term::ANSIColor::color("reset");
1639 $CPAN::Frontend->myprint(sprintf $sprintf,
1646 $need{$module->id}++;
1650 $CPAN::Frontend->myprint("No modules found for @args\n");
1651 } elsif ($what eq "r") {
1652 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1656 if ($version_zeroes) {
1657 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1658 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1659 qq{a version number of 0\n});
1661 if ($version_undefs) {
1662 my $s_has = $version_undefs > 1 ? "s have" : " has";
1663 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1664 qq{parseable version number\n});
1670 #-> sub CPAN::Shell::r ;
1672 shift->_u_r_common("r",@_);
1675 #-> sub CPAN::Shell::u ;
1677 shift->_u_r_common("u",@_);
1680 #-> sub CPAN::Shell::autobundle ;
1683 CPAN::Config->load unless $CPAN::Config_loaded++;
1684 my(@bundle) = $self->_u_r_common("a",@_);
1685 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1686 File::Path::mkpath($todir);
1687 unless (-d $todir) {
1688 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1691 my($y,$m,$d) = (localtime)[5,4,3];
1695 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1696 my($to) = File::Spec->catfile($todir,"$me.pm");
1698 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1699 $to = File::Spec->catfile($todir,"$me.pm");
1701 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1703 "package Bundle::$me;\n\n",
1704 "\$VERSION = '0.01';\n\n",
1708 "Bundle::$me - Snapshot of installation on ",
1709 $Config::Config{'myhostname'},
1712 "\n\n=head1 SYNOPSIS\n\n",
1713 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1714 "=head1 CONTENTS\n\n",
1715 join("\n", @bundle),
1716 "\n\n=head1 CONFIGURATION\n\n",
1718 "\n\n=head1 AUTHOR\n\n",
1719 "This Bundle has been generated automatically ",
1720 "by the autobundle routine in CPAN.pm.\n",
1723 $CPAN::Frontend->myprint("\nWrote bundle file
1727 #-> sub CPAN::Shell::expandany ;
1730 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1731 if ($s =~ m|/|) { # looks like a file
1732 $s = CPAN::Distribution->normalize($s);
1733 return $CPAN::META->instance('CPAN::Distribution',$s);
1734 # Distributions spring into existence, not expand
1735 } elsif ($s =~ m|^Bundle::|) {
1736 $self->local_bundles; # scanning so late for bundles seems
1737 # both attractive and crumpy: always
1738 # current state but easy to forget
1740 return $self->expand('Bundle',$s);
1742 return $self->expand('Module',$s)
1743 if $CPAN::META->exists('CPAN::Module',$s);
1748 #-> sub CPAN::Shell::expand ;
1751 my($type,@args) = @_;
1753 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1755 my($regex,$command);
1756 if ($arg =~ m|^/(.*)/$|) {
1758 } elsif ($arg =~ m/=/) {
1761 my $class = "CPAN::$type";
1763 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1765 defined $regex ? $regex : "UNDEFINED",
1766 $command || "UNDEFINED",
1768 if (defined $regex) {
1772 $CPAN::META->all_objects($class)
1775 # BUG, we got an empty object somewhere
1776 require Data::Dumper;
1777 CPAN->debug(sprintf(
1778 "Bug in CPAN: Empty id on obj[%s][%s]",
1780 Data::Dumper::Dumper($obj)
1785 if $obj->id =~ /$regex/i
1789 $] < 5.00303 ### provide sort of
1790 ### compatibility with 5.003
1795 $obj->name =~ /$regex/i
1798 } elsif ($command) {
1799 die "equal sign in command disabled (immature interface), ".
1801 ! \$CPAN::Shell::ADVANCED_QUERY=1
1802 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1803 that may go away anytime.\n"
1804 unless $ADVANCED_QUERY;
1805 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1806 my($matchcrit) = $criterion =~ m/^~(.+)/;
1810 $CPAN::META->all_objects($class)
1812 my $lhs = $self->$method() or next; # () for 5.00503
1814 push @m, $self if $lhs =~ m/$matchcrit/;
1816 push @m, $self if $lhs eq $criterion;
1821 if ( $type eq 'Bundle' ) {
1822 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1823 } elsif ($type eq "Distribution") {
1824 $xarg = CPAN::Distribution->normalize($arg);
1826 if ($CPAN::META->exists($class,$xarg)) {
1827 $obj = $CPAN::META->instance($class,$xarg);
1828 } elsif ($CPAN::META->exists($class,$arg)) {
1829 $obj = $CPAN::META->instance($class,$arg);
1836 return wantarray ? @m : $m[0];
1839 #-> sub CPAN::Shell::format_result ;
1842 my($type,@args) = @_;
1843 @args = '/./' unless @args;
1844 my(@result) = $self->expand($type,@args);
1845 my $result = @result == 1 ?
1846 $result[0]->as_string :
1848 "No objects of type $type found for argument @args\n" :
1850 (map {$_->as_glimpse} @result),
1851 scalar @result, " items found\n",
1856 # The only reason for this method is currently to have a reliable
1857 # debugging utility that reveals which output is going through which
1858 # channel. No, I don't like the colors ;-)
1860 #-> sub CPAN::Shell::print_ornameted ;
1861 sub print_ornamented {
1862 my($self,$what,$ornament) = @_;
1864 return unless defined $what;
1866 if ($CPAN::Config->{term_is_latin}){
1869 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1871 if ($PRINT_ORNAMENTING) {
1872 unless (defined &color) {
1873 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1874 import Term::ANSIColor "color";
1876 *color = sub { return "" };
1880 for $line (split /\n/, $what) {
1881 $longest = length($line) if length($line) > $longest;
1883 my $sprintf = "%-" . $longest . "s";
1885 $what =~ s/(.*\n?)//m;
1888 my($nl) = chomp $line ? "\n" : "";
1889 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1890 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1898 my($self,$what) = @_;
1900 $self->print_ornamented($what, 'bold blue on_yellow');
1904 my($self,$what) = @_;
1905 $self->myprint($what);
1910 my($self,$what) = @_;
1911 $self->print_ornamented($what, 'bold red on_yellow');
1915 my($self,$what) = @_;
1916 $self->print_ornamented($what, 'bold red on_white');
1917 Carp::confess "died";
1921 my($self,$what) = @_;
1922 $self->print_ornamented($what, 'bold red on_white');
1927 return if -t STDOUT;
1928 my $odef = select STDERR;
1935 #-> sub CPAN::Shell::rematein ;
1936 # RE-adme||MA-ke||TE-st||IN-stall
1939 my($meth,@some) = @_;
1941 if ($meth eq 'force') {
1943 $meth = shift @some;
1946 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1948 # Here is the place to set "test_count" on all involved parties to
1949 # 0. We then can pass this counter on to the involved
1950 # distributions and those can refuse to test if test_count > X. In
1951 # the first stab at it we could use a 1 for "X".
1953 # But when do I reset the distributions to start with 0 again?
1954 # Jost suggested to have a random or cycling interaction ID that
1955 # we pass through. But the ID is something that is just left lying
1956 # around in addition to the counter, so I'd prefer to set the
1957 # counter to 0 now, and repeat at the end of the loop. But what
1958 # about dependencies? They appear later and are not reset, they
1959 # enter the queue but not its copy. How do they get a sensible
1962 # construct the queue
1964 foreach $s (@some) {
1967 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1969 } elsif ($s =~ m|^/|) { # looks like a regexp
1970 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1975 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1976 $obj = CPAN::Shell->expandany($s);
1979 $obj->color_cmd_tmps(0,1);
1980 CPAN::Queue->new($obj->id);
1982 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1983 $obj = $CPAN::META->instance('CPAN::Author',$s);
1984 if ($meth eq "dump") {
1987 $CPAN::Frontend->myprint(
1989 "Don't be silly, you can't $meth ",
1997 ->myprint(qq{Warning: Cannot $meth $s, }.
1998 qq{don\'t know what it is.
2003 to find objects with matching identifiers.
2009 # queuerunner (please be warned: when I started to change the
2010 # queue to hold objects instead of names, I made one or two
2011 # mistakes and never found which. I reverted back instead)
2012 while ($s = CPAN::Queue->first) {
2015 $obj = $s; # I do not believe, we would survive if this happened
2017 $obj = CPAN::Shell->expandany($s);
2021 ($] < 5.00303 || $obj->can($pragma))){
2022 ### compatibility with 5.003
2023 $obj->$pragma($meth); # the pragma "force" in
2024 # "CPAN::Distribution" must know
2025 # what we are intending
2027 if ($]>=5.00303 && $obj->can('called_for')) {
2028 $obj->called_for($s);
2031 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2037 CPAN::Queue->delete($s);
2039 CPAN->debug("failed");
2043 CPAN::Queue->delete_first($s);
2045 for my $obj (@qcopy) {
2046 $obj->color_cmd_tmps(0,0);
2050 #-> sub CPAN::Shell::dump ;
2051 sub dump { shift->rematein('dump',@_); }
2052 #-> sub CPAN::Shell::force ;
2053 sub force { shift->rematein('force',@_); }
2054 #-> sub CPAN::Shell::get ;
2055 sub get { shift->rematein('get',@_); }
2056 #-> sub CPAN::Shell::readme ;
2057 sub readme { shift->rematein('readme',@_); }
2058 #-> sub CPAN::Shell::make ;
2059 sub make { shift->rematein('make',@_); }
2060 #-> sub CPAN::Shell::test ;
2061 sub test { shift->rematein('test',@_); }
2062 #-> sub CPAN::Shell::install ;
2063 sub install { shift->rematein('install',@_); }
2064 #-> sub CPAN::Shell::clean ;
2065 sub clean { shift->rematein('clean',@_); }
2066 #-> sub CPAN::Shell::look ;
2067 sub look { shift->rematein('look',@_); }
2068 #-> sub CPAN::Shell::cvs_import ;
2069 sub cvs_import { shift->rematein('cvs_import',@_); }
2071 package CPAN::LWP::UserAgent;
2074 return if $SETUPDONE;
2075 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2076 require LWP::UserAgent;
2077 @ISA = qw(Exporter LWP::UserAgent);
2080 $CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
2084 sub get_basic_credentials {
2085 my($self, $realm, $uri, $proxy) = @_;
2086 return unless $proxy;
2087 if ($USER && $PASSWD) {
2088 } elsif (defined $CPAN::Config->{proxy_user} &&
2089 defined $CPAN::Config->{proxy_pass}) {
2090 $USER = $CPAN::Config->{proxy_user};
2091 $PASSWD = $CPAN::Config->{proxy_pass};
2093 require ExtUtils::MakeMaker;
2094 ExtUtils::MakeMaker->import(qw(prompt));
2095 $USER = prompt("Proxy authentication needed!
2096 (Note: to permanently configure username and password run
2097 o conf proxy_user your_username
2098 o conf proxy_pass your_password
2100 if ($CPAN::META->has_inst("Term::ReadKey")) {
2101 Term::ReadKey::ReadMode("noecho");
2103 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2105 $PASSWD = prompt("Password:");
2106 if ($CPAN::META->has_inst("Term::ReadKey")) {
2107 Term::ReadKey::ReadMode("restore");
2109 $CPAN::Frontend->myprint("\n\n");
2111 return($USER,$PASSWD);
2115 my($self,$url,$aslocal) = @_;
2116 my $result = $self->SUPER::mirror($url,$aslocal);
2117 if ($result->code == 407) {
2120 $result = $self->SUPER::mirror($url,$aslocal);
2127 #-> sub CPAN::FTP::ftp_get ;
2129 my($class,$host,$dir,$file,$target) = @_;
2131 qq[Going to fetch file [$file] from dir [$dir]
2132 on host [$host] as local [$target]\n]
2134 my $ftp = Net::FTP->new($host);
2135 return 0 unless defined $ftp;
2136 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2137 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2138 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2139 warn "Couldn't login on $host";
2142 unless ( $ftp->cwd($dir) ){
2143 warn "Couldn't cwd $dir";
2147 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2148 unless ( $ftp->get($file,$target) ){
2149 warn "Couldn't fetch $file from $host\n";
2152 $ftp->quit; # it's ok if this fails
2156 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2158 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2159 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2161 # > *** 1562,1567 ****
2162 # > --- 1562,1580 ----
2163 # > return 1 if substr($url,0,4) eq "file";
2164 # > return 1 unless $url =~ m|://([^/]+)|;
2166 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2168 # > + $proxy =~ m|://([^/:]+)|;
2170 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2171 # > + if ($noproxy) {
2172 # > + if ($host !~ /$noproxy$/) {
2173 # > + $host = $proxy;
2176 # > + $host = $proxy;
2179 # > require Net::Ping;
2180 # > return 1 unless $Net::Ping::VERSION >= 2;
2184 #-> sub CPAN::FTP::localize ;
2186 my($self,$file,$aslocal,$force) = @_;
2188 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2189 unless defined $aslocal;
2190 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2193 if ($^O eq 'MacOS') {
2194 # Comment by AK on 2000-09-03: Uniq short filenames would be
2195 # available in CHECKSUMS file
2196 my($name, $path) = File::Basename::fileparse($aslocal, '');
2197 if (length($name) > 31) {
2208 my $size = 31 - length($suf);
2209 while (length($name) > $size) {
2213 $aslocal = File::Spec->catfile($path, $name);
2217 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2220 rename $aslocal, "$aslocal.bak";
2224 my($aslocal_dir) = File::Basename::dirname($aslocal);
2225 File::Path::mkpath($aslocal_dir);
2226 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2227 qq{directory "$aslocal_dir".
2228 I\'ll continue, but if you encounter problems, they may be due
2229 to insufficient permissions.\n}) unless -w $aslocal_dir;
2231 # Inheritance is not easier to manage than a few if/else branches
2232 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2234 CPAN::LWP::UserAgent->config;
2235 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2237 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
2241 $Ua->proxy('ftp', $var)
2242 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2243 $Ua->proxy('http', $var)
2244 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2247 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2249 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2250 # > use ones that require basic autorization.
2252 # > Example of when I use it manually in my own stuff:
2254 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2255 # > $req->proxy_authorization_basic("username","password");
2256 # > $res = $ua->request($req);
2260 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2264 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2265 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2266 if $CPAN::Config->{http_proxy};
2267 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2269 # Try the list of urls for each single object. We keep a record
2270 # where we did get a file from
2271 my(@reordered,$last);
2272 $CPAN::Config->{urllist} ||= [];
2273 $last = $#{$CPAN::Config->{urllist}};
2274 if ($force & 2) { # local cpans probably out of date, don't reorder
2275 @reordered = (0..$last);
2279 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2281 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2292 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2294 @levels = qw/easy hard hardest/;
2296 @levels = qw/easy/ if $^O eq 'MacOS';
2298 for $levelno (0..$#levels) {
2299 my $level = $levels[$levelno];
2300 my $method = "host$level";
2301 my @host_seq = $level eq "easy" ?
2302 @reordered : 0..$last; # reordered has CDROM up front
2303 @host_seq = (0) unless @host_seq;
2304 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2306 $Themethod = $level;
2308 # utime $now, $now, $aslocal; # too bad, if we do that, we
2309 # might alter a local mirror
2310 $self->debug("level[$level]") if $CPAN::DEBUG;
2314 last if $CPAN::Signal; # need to cleanup
2317 unless ($CPAN::Signal) {
2320 qq{Please check, if the URLs I found in your configuration file \(}.
2321 join(", ", @{$CPAN::Config->{urllist}}).
2322 qq{\) are valid. The urllist can be edited.},
2323 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2324 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2326 $CPAN::Frontend->myprint("Could not fetch $file\n");
2329 rename "$aslocal.bak", $aslocal;
2330 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2331 $self->ls($aslocal));
2338 my($self,$host_seq,$file,$aslocal) = @_;
2340 HOSTEASY: for $i (@$host_seq) {
2341 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2342 $url .= "/" unless substr($url,-1) eq "/";
2344 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2345 if ($url =~ /^file:/) {
2347 if ($CPAN::META->has_inst('URI::URL')) {
2348 my $u = URI::URL->new($url);
2350 } else { # works only on Unix, is poorly constructed, but
2351 # hopefully better than nothing.
2352 # RFC 1738 says fileurl BNF is
2353 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2354 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2356 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2357 $l =~ s|^file:||; # assume they
2360 $l =~ s|^/||s unless -f $l; # e.g. /P:
2361 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2363 if ( -f $l && -r _) {
2367 # Maybe mirror has compressed it?
2369 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2370 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2377 if ($CPAN::META->has_usable('LWP')) {
2378 $CPAN::Frontend->myprint("Fetching with LWP:
2382 CPAN::LWP::UserAgent->config;
2383 eval { $Ua = CPAN::LWP::UserAgent->new; };
2385 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
2388 my $res = $Ua->mirror($url, $aslocal);
2389 if ($res->is_success) {
2392 utime $now, $now, $aslocal; # download time is more
2393 # important than upload time
2395 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2396 my $gzurl = "$url.gz";
2397 $CPAN::Frontend->myprint("Fetching with LWP:
2400 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2401 if ($res->is_success &&
2402 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2408 $CPAN::Frontend->myprint(sprintf(
2409 "LWP failed with code[%s] message[%s]\n",
2413 # Alan Burlison informed me that in firewall environments
2414 # Net::FTP can still succeed where LWP fails. So we do not
2415 # skip Net::FTP anymore when LWP is available.
2418 $CPAN::Frontend->myprint("LWP not available\n");
2420 return if $CPAN::Signal;
2421 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2422 # that's the nice and easy way thanks to Graham
2423 my($host,$dir,$getfile) = ($1,$2,$3);
2424 if ($CPAN::META->has_usable('Net::FTP')) {
2426 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2429 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2430 "aslocal[$aslocal]") if $CPAN::DEBUG;
2431 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2435 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2436 my $gz = "$aslocal.gz";
2437 $CPAN::Frontend->myprint("Fetching with Net::FTP
2440 if (CPAN::FTP->ftp_get($host,
2444 CPAN::Tarzip->gunzip($gz,$aslocal)
2453 return if $CPAN::Signal;
2458 my($self,$host_seq,$file,$aslocal) = @_;
2460 # Came back if Net::FTP couldn't establish connection (or
2461 # failed otherwise) Maybe they are behind a firewall, but they
2462 # gave us a socksified (or other) ftp program...
2465 my($devnull) = $CPAN::Config->{devnull} || "";
2467 my($aslocal_dir) = File::Basename::dirname($aslocal);
2468 File::Path::mkpath($aslocal_dir);
2469 HOSTHARD: for $i (@$host_seq) {
2470 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2471 $url .= "/" unless substr($url,-1) eq "/";
2473 my($proto,$host,$dir,$getfile);
2475 # Courtesy Mark Conty mark_conty@cargill.com change from
2476 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2478 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2479 # proto not yet used
2480 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2482 next HOSTHARD; # who said, we could ftp anything except ftp?
2484 next HOSTHARD if $proto eq "file"; # file URLs would have had
2485 # success above. Likely a bogus URL
2487 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2489 for $f ('lynx','ncftpget','ncftp','wget') {
2490 next unless exists $CPAN::Config->{$f};
2491 $funkyftp = $CPAN::Config->{$f};
2492 next unless defined $funkyftp;
2493 next if $funkyftp =~ /^\s*$/;
2494 my($asl_ungz, $asl_gz);
2495 ($asl_ungz = $aslocal) =~ s/\.gz//;
2496 $asl_gz = "$asl_ungz.gz";
2497 my($src_switch) = "";
2499 $src_switch = " -source";
2500 } elsif ($f eq "ncftp"){
2501 $src_switch = " -c";
2502 } elsif ($f eq "wget"){
2503 $src_switch = " -O -";
2506 my($stdout_redir) = " > $asl_ungz";
2507 if ($f eq "ncftpget"){
2508 $chdir = "cd $aslocal_dir && ";
2511 $CPAN::Frontend->myprint(
2513 Trying with "$funkyftp$src_switch" to get
2517 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2518 $self->debug("system[$system]") if $CPAN::DEBUG;
2520 if (($wstatus = system($system)) == 0
2523 -s $asl_ungz # lynx returns 0 when it fails somewhere
2529 } elsif ($asl_ungz ne $aslocal) {
2530 # test gzip integrity
2531 if (CPAN::Tarzip->gtest($asl_ungz)) {
2532 # e.g. foo.tar is gzipped --> foo.tar.gz
2533 rename $asl_ungz, $aslocal;
2535 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2540 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2542 -f $asl_ungz && -s _ == 0;
2543 my $gz = "$aslocal.gz";
2544 my $gzurl = "$url.gz";
2545 $CPAN::Frontend->myprint(
2547 Trying with "$funkyftp$src_switch" to get
2550 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2551 $self->debug("system[$system]") if $CPAN::DEBUG;
2553 if (($wstatus = system($system)) == 0
2557 # test gzip integrity
2558 if (CPAN::Tarzip->gtest($asl_gz)) {
2559 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2561 # somebody uncompressed file for us?
2562 rename $asl_ungz, $aslocal;
2567 unlink $asl_gz if -f $asl_gz;
2570 my $estatus = $wstatus >> 8;
2571 my $size = -f $aslocal ?
2572 ", left\n$aslocal with size ".-s _ :
2573 "\nWarning: expected file [$aslocal] doesn't exist";
2574 $CPAN::Frontend->myprint(qq{
2575 System call "$system"
2576 returned status $estatus (wstat $wstatus)$size
2579 return if $CPAN::Signal;
2580 } # lynx,ncftpget,ncftp
2585 my($self,$host_seq,$file,$aslocal) = @_;
2588 my($aslocal_dir) = File::Basename::dirname($aslocal);
2589 File::Path::mkpath($aslocal_dir);
2590 HOSTHARDEST: for $i (@$host_seq) {
2591 unless (length $CPAN::Config->{'ftp'}) {
2592 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2595 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2596 $url .= "/" unless substr($url,-1) eq "/";
2598 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2599 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2602 my($host,$dir,$getfile) = ($1,$2,$3);
2604 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2605 $ctime,$blksize,$blocks) = stat($aslocal);
2606 $timestamp = $mtime ||= 0;
2607 my($netrc) = CPAN::FTP::netrc->new;
2608 my($netrcfile) = $netrc->netrc;
2609 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2610 my $targetfile = File::Basename::basename($aslocal);
2616 map("cd $_", split "/", $dir), # RFC 1738
2618 "get $getfile $targetfile",
2622 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2623 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2624 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2626 $netrc->contains($host))) if $CPAN::DEBUG;
2627 if ($netrc->protected) {
2628 $CPAN::Frontend->myprint(qq{
2629 Trying with external ftp to get
2631 As this requires some features that are not thoroughly tested, we\'re
2632 not sure, that we get it right....
2636 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2638 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2639 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2641 if ($mtime > $timestamp) {
2642 $CPAN::Frontend->myprint("GOT $aslocal\n");
2646 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2648 return if $CPAN::Signal;
2650 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2651 qq{correctly protected.\n});
2654 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2655 nor does it have a default entry\n");
2658 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2659 # then and login manually to host, using e-mail as
2661 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2665 "user anonymous $Config::Config{'cf_email'}"
2667 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2668 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2669 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2671 if ($mtime > $timestamp) {
2672 $CPAN::Frontend->myprint("GOT $aslocal\n");
2676 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2678 return if $CPAN::Signal;
2679 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2685 my($self,$command,@dialog) = @_;
2686 my $fh = FileHandle->new;
2687 $fh->open("|$command") or die "Couldn't open ftp: $!";
2688 foreach (@dialog) { $fh->print("$_\n") }
2689 $fh->close; # Wait for process to complete
2691 my $estatus = $wstatus >> 8;
2692 $CPAN::Frontend->myprint(qq{
2693 Subprocess "|$command"
2694 returned status $estatus (wstat $wstatus)
2698 # find2perl needs modularization, too, all the following is stolen
2702 my($self,$name) = @_;
2703 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2704 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2706 my($perms,%user,%group);
2710 $blocks = int(($blocks + 1) / 2);
2713 $blocks = int(($sizemm + 1023) / 1024);
2716 if (-f _) { $perms = '-'; }
2717 elsif (-d _) { $perms = 'd'; }
2718 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2719 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2720 elsif (-p _) { $perms = 'p'; }
2721 elsif (-S _) { $perms = 's'; }
2722 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2724 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2725 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2726 my $tmpmode = $mode;
2727 my $tmp = $rwx[$tmpmode & 7];
2729 $tmp = $rwx[$tmpmode & 7] . $tmp;
2731 $tmp = $rwx[$tmpmode & 7] . $tmp;
2732 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2733 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2734 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2737 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2738 my $group = $group{$gid} || $gid;
2740 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2742 my($moname) = $moname[$mon];
2743 if (-M _ > 365.25 / 2) {
2744 $timeyear = $year + 1900;
2747 $timeyear = sprintf("%02d:%02d", $hour, $min);
2750 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2764 package CPAN::FTP::netrc;
2768 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2770 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2771 $atime,$mtime,$ctime,$blksize,$blocks)
2776 my($fh,@machines,$hasdefault);
2778 $fh = FileHandle->new or die "Could not create a filehandle";
2780 if($fh->open($file)){
2781 $protected = ($mode & 077) == 0;
2783 NETRC: while (<$fh>) {
2784 my(@tokens) = split " ", $_;
2785 TOKEN: while (@tokens) {
2786 my($t) = shift @tokens;
2787 if ($t eq "default"){
2791 last TOKEN if $t eq "macdef";
2792 if ($t eq "machine") {
2793 push @machines, shift @tokens;
2798 $file = $hasdefault = $protected = "";
2802 'mach' => [@machines],
2804 'hasdefault' => $hasdefault,
2805 'protected' => $protected,
2809 # CPAN::FTP::hasdefault;
2810 sub hasdefault { shift->{'hasdefault'} }
2811 sub netrc { shift->{'netrc'} }
2812 sub protected { shift->{'protected'} }
2814 my($self,$mach) = @_;
2815 for ( @{$self->{'mach'}} ) {
2816 return 1 if $_ eq $mach;
2821 package CPAN::Complete;
2824 my($text, $line, $start, $end) = @_;
2825 my(@perlret) = cpl($text, $line, $start);
2826 # find longest common match. Can anybody show me how to peruse
2827 # T::R::Gnu to have this done automatically? Seems expensive.
2828 return () unless @perlret;
2829 my($newtext) = $text;
2830 for (my $i = length($text)+1;;$i++) {
2831 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2832 my $try = substr($perlret[0],0,$i);
2833 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2834 # warn "try[$try]tries[@tries]";
2835 if (@tries == @perlret) {
2841 ($newtext,@perlret);
2844 #-> sub CPAN::Complete::cpl ;
2846 my($word,$line,$pos) = @_;
2850 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2852 if ($line =~ s/^(force\s*)//) {
2857 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2858 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2860 } elsif ($line =~ /^(a|ls)\s/) {
2861 @return = cplx('CPAN::Author',uc($word));
2862 } elsif ($line =~ /^b\s/) {
2863 CPAN::Shell->local_bundles;
2864 @return = cplx('CPAN::Bundle',$word);
2865 } elsif ($line =~ /^d\s/) {
2866 @return = cplx('CPAN::Distribution',$word);
2867 } elsif ($line =~ m/^(
2868 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2870 if ($word =~ /^Bundle::/) {
2871 CPAN::Shell->local_bundles;
2873 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2874 } elsif ($line =~ /^i\s/) {
2875 @return = cpl_any($word);
2876 } elsif ($line =~ /^reload\s/) {
2877 @return = cpl_reload($word,$line,$pos);
2878 } elsif ($line =~ /^o\s/) {
2879 @return = cpl_option($word,$line,$pos);
2880 } elsif ($line =~ m/^\S+\s/ ) {
2881 # fallback for future commands and what we have forgotten above
2882 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2889 #-> sub CPAN::Complete::cplx ;
2891 my($class, $word) = @_;
2892 # I believed for many years that this was sorted, today I
2893 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2894 # make it sorted again. Maybe sort was dropped when GNU-readline
2895 # support came in? The RCS file is difficult to read on that:-(
2896 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2899 #-> sub CPAN::Complete::cpl_any ;
2903 cplx('CPAN::Author',$word),
2904 cplx('CPAN::Bundle',$word),
2905 cplx('CPAN::Distribution',$word),
2906 cplx('CPAN::Module',$word),
2910 #-> sub CPAN::Complete::cpl_reload ;
2912 my($word,$line,$pos) = @_;
2914 my(@words) = split " ", $line;
2915 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2916 my(@ok) = qw(cpan index);
2917 return @ok if @words == 1;
2918 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2921 #-> sub CPAN::Complete::cpl_option ;
2923 my($word,$line,$pos) = @_;
2925 my(@words) = split " ", $line;
2926 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2927 my(@ok) = qw(conf debug);
2928 return @ok if @words == 1;
2929 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2931 } elsif ($words[1] eq 'index') {
2933 } elsif ($words[1] eq 'conf') {
2934 return CPAN::Config::cpl(@_);
2935 } elsif ($words[1] eq 'debug') {
2936 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2940 package CPAN::Index;
2942 #-> sub CPAN::Index::force_reload ;
2945 $CPAN::Index::LAST_TIME = 0;
2949 #-> sub CPAN::Index::reload ;
2951 my($cl,$force) = @_;
2954 # XXX check if a newer one is available. (We currently read it
2955 # from time to time)
2956 for ($CPAN::Config->{index_expire}) {
2957 $_ = 0.001 unless $_ && $_ > 0.001;
2959 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2960 # debug here when CPAN doesn't seem to read the Metadata
2962 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2964 unless ($CPAN::META->{PROTOCOL}) {
2965 $cl->read_metadata_cache;
2966 $CPAN::META->{PROTOCOL} ||= "1.0";
2968 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
2969 # warn "Setting last_time to 0";
2970 $LAST_TIME = 0; # No warning necessary
2972 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
2975 # IFF we are developing, it helps to wipe out the memory
2976 # between reloads, otherwise it is not what a user expects.
2977 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2978 $CPAN::META = CPAN->new;
2982 local $LAST_TIME = $time;
2983 local $CPAN::META->{PROTOCOL} = PROTOCOL;
2985 my $needshort = $^O eq "dos";
2987 $cl->rd_authindex($cl
2989 "authors/01mailrc.txt.gz",
2991 File::Spec->catfile('authors', '01mailrc.gz') :
2992 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2995 $debug = "timing reading 01[".($t2 - $time)."]";
2997 return if $CPAN::Signal; # this is sometimes lengthy
2998 $cl->rd_modpacks($cl
3000 "modules/02packages.details.txt.gz",
3002 File::Spec->catfile('modules', '02packag.gz') :
3003 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3006 $debug .= "02[".($t2 - $time)."]";
3008 return if $CPAN::Signal; # this is sometimes lengthy
3011 "modules/03modlist.data.gz",
3013 File::Spec->catfile('modules', '03mlist.gz') :
3014 File::Spec->catfile('modules', '03modlist.data.gz'),
3016 $cl->write_metadata_cache;
3018 $debug .= "03[".($t2 - $time)."]";
3020 CPAN->debug($debug) if $CPAN::DEBUG;
3023 $CPAN::META->{PROTOCOL} = PROTOCOL;
3026 #-> sub CPAN::Index::reload_x ;
3028 my($cl,$wanted,$localname,$force) = @_;
3029 $force |= 2; # means we're dealing with an index here
3030 CPAN::Config->load; # we should guarantee loading wherever we rely
3032 $localname ||= $wanted;
3033 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3037 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3040 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3041 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3042 qq{day$s. I\'ll use that.});
3045 $force |= 1; # means we're quite serious about it.
3047 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3050 #-> sub CPAN::Index::rd_authindex ;
3052 my($cl, $index_target) = @_;
3054 return unless defined $index_target;
3055 $CPAN::Frontend->myprint("Going to read $index_target\n");
3057 tie *FH, CPAN::Tarzip, $index_target;
3059 push @lines, split /\012/ while <FH>;
3061 my($userid,$fullname,$email) =
3062 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3063 next unless $userid && $fullname && $email;
3065 # instantiate an author object
3066 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3067 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3068 return if $CPAN::Signal;
3073 my($self,$dist) = @_;
3074 $dist = $self->{'id'} unless defined $dist;
3075 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3079 #-> sub CPAN::Index::rd_modpacks ;
3081 my($self, $index_target) = @_;
3083 return unless defined $index_target;
3084 $CPAN::Frontend->myprint("Going to read $index_target\n");
3085 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3087 while ($_ = $fh->READLINE) {
3089 my @ls = map {"$_\n"} split /\n/, $_;
3090 unshift @ls, "\n" x length($1) if /^(\n+)/;
3094 my($line_count,$last_updated);
3096 my $shift = shift(@lines);
3097 last if $shift =~ /^\s*$/;
3098 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3099 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3101 if (not defined $line_count) {
3103 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3104 Please check the validity of the index file by comparing it to more
3105 than one CPAN mirror. I'll continue but problems seem likely to
3110 } elsif ($line_count != scalar @lines) {
3112 warn sprintf qq{Warning: Your %s
3113 contains a Line-Count header of %d but I see %d lines there. Please
3114 check the validity of the index file by comparing it to more than one
3115 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3116 $index_target, $line_count, scalar(@lines);
3119 if (not defined $last_updated) {
3121 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3122 Please check the validity of the index file by comparing it to more
3123 than one CPAN mirror. I'll continue but problems seem likely to
3131 ->myprint(sprintf qq{ Database was generated on %s\n},
3133 $DATE_OF_02 = $last_updated;
3135 if ($CPAN::META->has_inst(HTTP::Date)) {
3137 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3142 qq{Warning: This index file is %d days old.
3143 Please check the host you chose as your CPAN mirror for staleness.
3144 I'll continue but problems seem likely to happen.\a\n},
3149 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3154 # A necessity since we have metadata_cache: delete what isn't
3156 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3157 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3161 # before 1.56 we split into 3 and discarded the rest. From
3162 # 1.57 we assign remaining text to $comment thus allowing to
3163 # influence isa_perl
3164 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3165 my($bundle,$id,$userid);
3167 if ($mod eq 'CPAN' &&
3169 CPAN::Queue->exists('Bundle::CPAN') ||
3170 CPAN::Queue->exists('CPAN')
3174 if ($version > $CPAN::VERSION){
3175 $CPAN::Frontend->myprint(qq{
3176 There's a new CPAN.pm version (v$version) available!
3177 [Current version is v$CPAN::VERSION]
3178 You might want to try
3179 install Bundle::CPAN
3181 without quitting the current session. It should be a seamless upgrade
3182 while we are running...
3185 $CPAN::Frontend->myprint(qq{\n});
3187 last if $CPAN::Signal;
3188 } elsif ($mod =~ /^Bundle::(.*)/) {
3193 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3194 # Let's make it a module too, because bundles have so much
3195 # in common with modules.
3197 # Changed in 1.57_63: seems like memory bloat now without
3198 # any value, so commented out
3200 # $CPAN::META->instance('CPAN::Module',$mod);
3204 # instantiate a module object
3205 $id = $CPAN::META->instance('CPAN::Module',$mod);
3209 if ($id->cpan_file ne $dist){ # update only if file is
3210 # different. CPAN prohibits same
3211 # name with different version
3212 $userid = $self->userid($dist);
3214 'CPAN_USERID' => $userid,
3215 'CPAN_VERSION' => $version,
3216 'CPAN_FILE' => $dist,
3220 # instantiate a distribution object
3221 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3222 # we do not need CONTAINSMODS unless we do something with
3223 # this dist, so we better produce it on demand.
3225 ## my $obj = $CPAN::META->instance(
3226 ## 'CPAN::Distribution' => $dist
3228 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3230 $CPAN::META->instance(
3231 'CPAN::Distribution' => $dist
3233 'CPAN_USERID' => $userid,
3234 'CPAN_COMMENT' => $comment,
3238 for my $name ($mod,$dist) {
3239 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3240 $exists{$name} = undef;
3243 return if $CPAN::Signal;
3247 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3248 for my $o ($CPAN::META->all_objects($class)) {
3249 next if exists $exists{$o->{ID}};
3250 $CPAN::META->delete($class,$o->{ID});
3251 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3258 #-> sub CPAN::Index::rd_modlist ;
3260 my($cl,$index_target) = @_;
3261 return unless defined $index_target;
3262 $CPAN::Frontend->myprint("Going to read $index_target\n");
3263 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3266 while ($_ = $fh->READLINE) {
3268 my @ls = map {"$_\n"} split /\n/, $_;
3269 unshift @ls, "\n" x length($1) if /^(\n+)/;
3273 my $shift = shift(@eval);
3274 if ($shift =~ /^Date:\s+(.*)/){
3275 return if $DATE_OF_03 eq $1;
3278 last if $shift =~ /^\s*$/;
3281 push @eval, q{CPAN::Modulelist->data;};
3283 my($comp) = Safe->new("CPAN::Safe1");
3284 my($eval) = join("", @eval);
3285 my $ret = $comp->reval($eval);
3286 Carp::confess($@) if $@;
3287 return if $CPAN::Signal;
3289 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3290 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3291 $obj->set(%{$ret->{$_}});
3292 return if $CPAN::Signal;
3296 #-> sub CPAN::Index::write_metadata_cache ;
3297 sub write_metadata_cache {
3299 return unless $CPAN::Config->{'cache_metadata'};
3300 return unless $CPAN::META->has_usable("Storable");
3302 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3303 CPAN::Distribution)) {
3304 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3306 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3307 $cache->{last_time} = $LAST_TIME;
3308 $cache->{DATE_OF_02} = $DATE_OF_02;
3309 $cache->{PROTOCOL} = PROTOCOL;
3310 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3311 eval { Storable::nstore($cache, $metadata_file) };
3312 $CPAN::Frontend->mywarn($@) if $@;
3315 #-> sub CPAN::Index::read_metadata_cache ;
3316 sub read_metadata_cache {
3318 return unless $CPAN::Config->{'cache_metadata'};
3319 return unless $CPAN::META->has_usable("Storable");
3320 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3321 return unless -r $metadata_file and -f $metadata_file;
3322 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3324 eval { $cache = Storable::retrieve($metadata_file) };
3325 $CPAN::Frontend->mywarn($@) if $@;
3326 if (!$cache || ref $cache ne 'HASH'){
3330 if (exists $cache->{PROTOCOL}) {
3331 if (PROTOCOL > $cache->{PROTOCOL}) {
3332 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3333 "with protocol v%s, requiring v%s",
3340 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3341 "with protocol v1.0");
3346 while(my($class,$v) = each %$cache) {
3347 next unless $class =~ /^CPAN::/;
3348 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3349 while (my($id,$ro) = each %$v) {
3350 $CPAN::META->{readwrite}{$class}{$id} ||=
3351 $class->new(ID=>$id, RO=>$ro);
3356 unless ($clcnt) { # sanity check
3357 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3360 if ($idcnt < 1000) {
3361 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3362 "in $metadata_file\n");
3365 $CPAN::META->{PROTOCOL} ||=
3366 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3367 # does initialize to some protocol
3368 $LAST_TIME = $cache->{last_time};
3369 $DATE_OF_02 = $cache->{DATE_OF_02};
3370 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3371 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3375 package CPAN::InfoObj;
3378 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3379 sub id { shift->{ID}; }
3381 #-> sub CPAN::InfoObj::new ;
3383 my $this = bless {}, shift;
3388 # The set method may only be used by code that reads index data or
3389 # otherwise "objective" data from the outside world. All session
3390 # related material may do anything else with instance variables but
3391 # must not touch the hash under the RO attribute. The reason is that
3392 # the RO hash gets written to Metadata file and is thus persistent.
3394 #-> sub CPAN::InfoObj::set ;
3396 my($self,%att) = @_;
3397 my $class = ref $self;
3399 # This must be ||=, not ||, because only if we write an empty
3400 # reference, only then the set method will write into the readonly
3401 # area. But for Distributions that spring into existence, maybe
3402 # because of a typo, we do not like it that they are written into
3403 # the readonly area and made permanent (at least for a while) and
3404 # that is why we do not "allow" other places to call ->set.
3405 unless ($self->id) {
3406 CPAN->debug("Bug? Empty ID, rejecting");
3409 my $ro = $self->{RO} =
3410 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3412 while (my($k,$v) = each %att) {
3417 #-> sub CPAN::InfoObj::as_glimpse ;
3421 my $class = ref($self);
3422 $class =~ s/^CPAN:://;
3423 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3427 #-> sub CPAN::InfoObj::as_string ;
3431 my $class = ref($self);
3432 $class =~ s/^CPAN:://;
3433 push @m, $class, " id = $self->{ID}\n";
3434 for (sort keys %{$self->{RO}}) {
3435 # next if m/^(ID|RO)$/;
3437 if ($_ eq "CPAN_USERID") {
3438 $extra .= " (".$self->author;
3439 my $email; # old perls!
3440 if ($email = $CPAN::META->instance("CPAN::Author",
3443 $extra .= " <$email>";
3445 $extra .= " <no email>";
3448 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3449 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3452 next unless defined $self->{RO}{$_};
3453 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3455 for (sort keys %$self) {
3456 next if m/^(ID|RO)$/;
3457 if (ref($self->{$_}) eq "ARRAY") {
3458 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3459 } elsif (ref($self->{$_}) eq "HASH") {
3463 join(" ",keys %{$self->{$_}}),
3466 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3472 #-> sub CPAN::InfoObj::author ;
3475 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3478 #-> sub CPAN::InfoObj::dump ;
3481 require Data::Dumper;
3482 print Data::Dumper::Dumper($self);
3485 package CPAN::Author;
3487 #-> sub CPAN::Author::id
3490 my $id = $self->{ID};
3491 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3495 #-> sub CPAN::Author::as_glimpse ;
3499 my $class = ref($self);
3500 $class =~ s/^CPAN:://;
3501 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3509 #-> sub CPAN::Author::fullname ;
3511 shift->{RO}{FULLNAME};
3515 #-> sub CPAN::Author::email ;
3516 sub email { shift->{RO}{EMAIL}; }
3518 #-> sub CPAN::Author::ls ;
3523 # adapted from CPAN::Distribution::verifyMD5 ;
3524 my(@csf); # chksumfile
3525 @csf = $self->id =~ /(.)(.)(.*)/;
3526 $csf[1] = join "", @csf[0,1];
3527 $csf[2] = join "", @csf[1,2];
3529 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3530 unless (grep {$_->[2] eq $csf[1]} @dl) {
3531 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3534 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3535 unless (grep {$_->[2] eq $csf[2]} @dl) {
3536 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3539 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3540 $CPAN::Frontend->myprint(join "", map {
3541 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3542 } sort { $a->[2] cmp $b->[2] } @dl);
3545 # returns an array of arrays, the latter contain (size,mtime,filename)
3546 #-> sub CPAN::Author::dir_listing ;
3549 my $chksumfile = shift;
3550 my $recursive = shift;
3552 File::Spec->catfile($CPAN::Config->{keep_source_where},
3553 "authors", "id", @$chksumfile);
3555 # connect "force" argument with "index_expire".
3557 if (my @stat = stat $lc_want) {
3558 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3560 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3563 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3564 $chksumfile->[-1] .= ".gz";
3565 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3568 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3569 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3575 # adapted from CPAN::Distribution::MD5_check_file ;
3576 my $fh = FileHandle->new;
3578 if (open $fh, $lc_file){
3581 $eval =~ s/\015?\012/\n/g;
3583 my($comp) = Safe->new();
3584 $cksum = $comp->reval($eval);
3586 rename $lc_file, "$lc_file.bad";
3587 Carp::confess($@) if $@;
3590 Carp::carp "Could not open $lc_file for reading";
3593 for $f (sort keys %$cksum) {
3594 if (exists $cksum->{$f}{isdir}) {
3596 my(@dir) = @$chksumfile;
3598 push @dir, $f, "CHECKSUMS";
3600 [$_->[0], $_->[1], "$f/$_->[2]"]
3601 } $self->dir_listing(\@dir,1);
3603 push @result, [ 0, "-", $f ];
3607 ($cksum->{$f}{"size"}||0),
3608 $cksum->{$f}{"mtime"}||"---",
3616 package CPAN::Distribution;
3619 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3623 delete $self->{later};
3626 # CPAN::Distribution::normalize
3629 $s = $self->id unless defined $s;
3633 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3635 return $s if $s =~ m:^N/A|^Contact Author: ;
3636 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3637 $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3638 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3643 #-> sub CPAN::Distribution::color_cmd_tmps ;
3644 sub color_cmd_tmps {
3646 my($depth) = shift || 0;
3647 my($color) = shift || 0;
3648 # a distribution needs to recurse into its prereq_pms
3650 return if exists $self->{incommandcolor}
3651 && $self->{incommandcolor}==$color;
3652 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3653 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3658 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3659 my $prereq_pm = $self->prereq_pm;
3660 if (defined $prereq_pm) {
3661 for my $pre (keys %$prereq_pm) {
3662 my $premo = CPAN::Shell->expand("Module",$pre);
3663 $premo->color_cmd_tmps($depth+1,$color);
3667 delete $self->{sponsored_mods};
3668 delete $self->{badtestcnt};
3670 $self->{incommandcolor} = $color;
3673 #-> sub CPAN::Distribution::as_string ;
3676 $self->containsmods;
3677 $self->SUPER::as_string(@_);
3680 #-> sub CPAN::Distribution::containsmods ;
3683 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3684 my $dist_id = $self->{ID};
3685 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3686 my $mod_file = $mod->cpan_file or next;
3687 my $mod_id = $mod->{ID} or next;
3688 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3690 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3692 keys %{$self->{CONTAINSMODS}};
3695 #-> sub CPAN::Distribution::uptodate ;
3699 foreach $c ($self->containsmods) {
3700 my $obj = CPAN::Shell->expandany($c);
3701 return 0 unless $obj->uptodate;
3706 #-> sub CPAN::Distribution::called_for ;
3709 $self->{CALLED_FOR} = $id if defined $id;
3710 return $self->{CALLED_FOR};
3713 #-> sub CPAN::Distribution::safe_chdir ;
3715 my($self,$todir) = @_;
3716 # we die if we cannot chdir and we are debuggable
3717 Carp::confess("safe_chdir called without todir argument")
3718 unless defined $todir and length $todir;
3720 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3723 my $cwd = CPAN::anycwd();
3724 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3725 qq{to todir[$todir]: $!});
3729 #-> sub CPAN::Distribution::get ;
3734 exists $self->{'build_dir'} and push @e,
3735 "Is already unwrapped into directory $self->{'build_dir'}";
3736 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3738 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3741 # Get the file on local disk
3746 File::Spec->catfile(
3747 $CPAN::Config->{keep_source_where},
3750 split("/",$self->id)
3753 $self->debug("Doing localize") if $CPAN::DEBUG;
3754 unless ($local_file =
3755 CPAN::FTP->localize("authors/id/$self->{ID}",
3758 if ($CPAN::Index::DATE_OF_02) {
3759 $note = "Note: Current database in memory was generated ".
3760 "on $CPAN::Index::DATE_OF_02\n";
3762 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3764 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3765 $self->{localfile} = $local_file;
3766 return if $CPAN::Signal;
3771 if ($CPAN::META->has_inst("Digest::MD5")) {
3772 $self->debug("Digest::MD5 is installed, verifying");
3775 $self->debug("Digest::MD5 is NOT installed");
3777 return if $CPAN::Signal;
3780 # Create a clean room and go there
3782 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3783 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3784 $self->safe_chdir($builddir);
3785 $self->debug("Removing tmp") if $CPAN::DEBUG;
3786 File::Path::rmtree("tmp");
3787 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3789 $self->safe_chdir($sub_wd);
3792 $self->safe_chdir("tmp");
3797 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3798 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3799 $self->untar_me($local_file);
3800 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3801 $self->unzip_me($local_file);
3802 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3803 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3804 $self->pm2dir_me($local_file);
3806 $self->{archived} = "NO";
3807 $self->safe_chdir($sub_wd);
3811 # we are still in the tmp directory!
3812 # Let's check if the package has its own directory.
3813 my $dh = DirHandle->new(File::Spec->curdir)
3814 or Carp::croak("Couldn't opendir .: $!");
3815 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3817 my ($distdir,$packagedir);
3818 if (@readdir == 1 && -d $readdir[0]) {
3819 $distdir = $readdir[0];
3820 $packagedir = File::Spec->catdir($builddir,$distdir);
3821 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3823 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3825 File::Path::rmtree($packagedir);
3826 rename($distdir,$packagedir) or
3827 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3828 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3835 my $userid = $self->cpan_userid;
3837 CPAN->debug("no userid? self[$self]");
3840 my $pragmatic_dir = $userid . '000';
3841 $pragmatic_dir =~ s/\W_//g;
3842 $pragmatic_dir++ while -d "../$pragmatic_dir";
3843 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3844 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3845 File::Path::mkpath($packagedir);
3847 for $f (@readdir) { # is already without "." and ".."
3848 my $to = File::Spec->catdir($packagedir,$f);
3849 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3853 $self->safe_chdir($sub_wd);
3857 $self->{'build_dir'} = $packagedir;
3858 $self->safe_chdir(File::Spec->updir);
3859 File::Path::rmtree("tmp");
3861 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3862 my($mpl_exists) = -f $mpl;
3863 unless ($mpl_exists) {
3864 # NFS has been reported to have racing problems after the
3865 # renaming of a directory in some environments.
3868 my $mpldh = DirHandle->new($packagedir)
3869 or Carp::croak("Couldn't opendir $packagedir: $!");
3870 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3873 unless ($mpl_exists) {
3874 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3878 my($configure) = File::Spec->catfile($packagedir,"Configure");
3879 if (-f $configure) {
3880 # do we have anything to do?
3881 $self->{'configure'} = $configure;
3882 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
3883 $CPAN::Frontend->myprint(qq{
3884 Package comes with a Makefile and without a Makefile.PL.
3885 We\'ll try to build it with that Makefile then.
3887 $self->{writemakefile} = "YES";
3890 my $cf = $self->called_for || "unknown";
3895 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3896 $cf = "unknown" unless length($cf);
3897 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3898 (The test -f "$mpl" returned false.)
3899 Writing one on our own (setting NAME to $cf)\a\n});
3900 $self->{had_no_makefile_pl}++;
3903 # Writing our own Makefile.PL
3905 my $fh = FileHandle->new;
3907 or Carp::croak("Could not open >$mpl: $!");
3909 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3910 # because there was no Makefile.PL supplied.
3911 # Autogenerated on: }.scalar localtime().qq{
3913 use ExtUtils::MakeMaker;
3914 WriteMakefile(NAME => q[$cf]);
3924 # CPAN::Distribution::untar_me ;
3926 my($self,$local_file) = @_;
3927 $self->{archived} = "tar";
3928 if (CPAN::Tarzip->untar($local_file)) {
3929 $self->{unwrapped} = "YES";
3931 $self->{unwrapped} = "NO";
3935 # CPAN::Distribution::unzip_me ;
3937 my($self,$local_file) = @_;
3938 $self->{archived} = "zip";
3939 if (CPAN::Tarzip->unzip($local_file)) {
3940 $self->{unwrapped} = "YES";
3942 $self->{unwrapped} = "NO";
3948 my($self,$local_file) = @_;
3949 $self->{archived} = "pm";
3950 my $to = File::Basename::basename($local_file);
3951 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3952 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3953 $self->{unwrapped} = "YES";
3955 $self->{unwrapped} = "NO";
3959 #-> sub CPAN::Distribution::new ;
3961 my($class,%att) = @_;
3963 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3965 my $this = { %att };
3966 return bless $this, $class;
3969 #-> sub CPAN::Distribution::look ;
3973 if ($^O eq 'MacOS') {
3974 $self->Mac::BuildTools::look;
3978 if ( $CPAN::Config->{'shell'} ) {
3979 $CPAN::Frontend->myprint(qq{
3980 Trying to open a subshell in the build directory...
3983 $CPAN::Frontend->myprint(qq{
3984 Your configuration does not define a value for subshells.
3985 Please define it with "o conf shell <your shell>"
3989 my $dist = $self->id;
3991 unless ($dir = $self->dir) {
3994 unless ($dir ||= $self->dir) {
3995 $CPAN::Frontend->mywarn(qq{
3996 Could not determine which directory to use for looking at $dist.
4000 my $pwd = CPAN::anycwd();
4001 $self->safe_chdir($dir);
4002 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4003 system($CPAN::Config->{'shell'}) == 0
4004 or $CPAN::Frontend->mydie("Subprocess shell error");
4005 $self->safe_chdir($pwd);
4008 # CPAN::Distribution::cvs_import ;
4012 my $dir = $self->dir;
4014 my $package = $self->called_for;
4015 my $module = $CPAN::META->instance('CPAN::Module', $package);
4016 my $version = $module->cpan_version;
4018 my $userid = $self->cpan_userid;
4020 my $cvs_dir = (split '/', $dir)[-1];
4021 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4023 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4025 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4026 if ($cvs_site_perl) {
4027 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4029 my $cvs_log = qq{"imported $package $version sources"};
4030 $version =~ s/\./_/g;
4031 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4032 "$cvs_dir", $userid, "v$version");
4034 my $pwd = CPAN::anycwd();
4035 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4037 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4039 $CPAN::Frontend->myprint(qq{@cmd\n});
4040 system(@cmd) == 0 or
4041 $CPAN::Frontend->mydie("cvs import failed");
4042 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4045 #-> sub CPAN::Distribution::readme ;
4048 my($dist) = $self->id;
4049 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4050 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4053 File::Spec->catfile(
4054 $CPAN::Config->{keep_source_where},
4057 split("/","$sans.readme"),
4059 $self->debug("Doing localize") if $CPAN::DEBUG;
4060 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4062 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4064 if ($^O eq 'MacOS') {
4065 Mac::BuildTools::launch_file($local_file);
4069 my $fh_pager = FileHandle->new;
4070 local($SIG{PIPE}) = "IGNORE";
4071 $fh_pager->open("|$CPAN::Config->{'pager'}")
4072 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4073 my $fh_readme = FileHandle->new;
4074 $fh_readme->open($local_file)
4075 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4076 $CPAN::Frontend->myprint(qq{
4079 with pager "$CPAN::Config->{'pager'}"
4082 $fh_pager->print(<$fh_readme>);
4085 #-> sub CPAN::Distribution::verifyMD5 ;
4090 $self->{MD5_STATUS} ||= "";
4091 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4092 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4094 my($lc_want,$lc_file,@local,$basename);
4095 @local = split("/",$self->id);
4097 push @local, "CHECKSUMS";
4099 File::Spec->catfile($CPAN::Config->{keep_source_where},
4100 "authors", "id", @local);
4105 $self->MD5_check_file($lc_want)
4107 return $self->{MD5_STATUS} = "OK";
4109 $lc_file = CPAN::FTP->localize("authors/id/@local",
4112 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4113 $local[-1] .= ".gz";
4114 $lc_file = CPAN::FTP->localize("authors/id/@local",
4117 $lc_file =~ s/\.gz(?!\n)\Z//;
4118 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4123 $self->MD5_check_file($lc_file);
4126 #-> sub CPAN::Distribution::MD5_check_file ;
4127 sub MD5_check_file {
4128 my($self,$chk_file) = @_;
4129 my($cksum,$file,$basename);
4130 $file = $self->{localfile};
4131 $basename = File::Basename::basename($file);
4132 my $fh = FileHandle->new;
4133 if (open $fh, $chk_file){
4136 $eval =~ s/\015?\012/\n/g;
4138 my($comp) = Safe->new();
4139 $cksum = $comp->reval($eval);
4141 rename $chk_file, "$chk_file.bad";
4142 Carp::confess($@) if $@;
4145 Carp::carp "Could not open $chk_file for reading";
4148 if (exists $cksum->{$basename}{md5}) {
4149 $self->debug("Found checksum for $basename:" .
4150 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4154 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4156 $fh = CPAN::Tarzip->TIEHANDLE($file);
4159 # had to inline it, when I tied it, the tiedness got lost on
4160 # the call to eq_MD5. (Jan 1998)
4161 my $md5 = Digest::MD5->new;
4164 while ($fh->READ($ref, 4096) > 0){
4167 my $hexdigest = $md5->hexdigest;
4168 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4172 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4173 return $self->{MD5_STATUS} = "OK";
4175 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4176 qq{distribution file. }.
4177 qq{Please investigate.\n\n}.
4179 $CPAN::META->instance(
4184 my $wrap = qq{I\'d recommend removing $file. Its MD5
4185 checksum is incorrect. Maybe you have configured your 'urllist' with
4186 a bad URL. Please check this array with 'o conf urllist', and
4189 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4191 # former versions just returned here but this seems a
4192 # serious threat that deserves a die
4194 # $CPAN::Frontend->myprint("\n\n");
4198 # close $fh if fileno($fh);
4200 $self->{MD5_STATUS} ||= "";
4201 if ($self->{MD5_STATUS} eq "NIL") {
4202 $CPAN::Frontend->mywarn(qq{
4203 Warning: No md5 checksum for $basename in $chk_file.
4205 The cause for this may be that the file is very new and the checksum
4206 has not yet been calculated, but it may also be that something is
4207 going awry right now.
4209 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4210 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4212 $self->{MD5_STATUS} = "NIL";
4217 #-> sub CPAN::Distribution::eq_MD5 ;
4219 my($self,$fh,$expectMD5) = @_;
4220 my $md5 = Digest::MD5->new;
4222 while (read($fh, $data, 4096)){
4225 # $md5->addfile($fh);
4226 my $hexdigest = $md5->hexdigest;
4227 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4228 $hexdigest eq $expectMD5;
4231 #-> sub CPAN::Distribution::force ;
4233 # Both modules and distributions know if "force" is in effect by
4234 # autoinspection, not by inspecting a global variable. One of the
4235 # reason why this was chosen to work that way was the treatment of
4236 # dependencies. They should not autpomatically inherit the force
4237 # status. But this has the downside that ^C and die() will return to
4238 # the prompt but will not be able to reset the force_update
4239 # attributes. We try to correct for it currently in the read_metadata
4240 # routine, and immediately before we check for a Signal. I hope this
4241 # works out in one of v1.57_53ff
4244 my($self, $method) = @_;
4246 MD5_STATUS archived build_dir localfile make install unwrapped
4249 delete $self->{$att};
4251 if ($method && $method eq "install") {
4252 $self->{"force_update"}++; # name should probably have been force_install
4256 #-> sub CPAN::Distribution::unforce ;
4259 delete $self->{'force_update'};
4262 #-> sub CPAN::Distribution::isa_perl ;
4265 my $file = File::Basename::basename($self->id);
4266 if ($file =~ m{ ^ perl
4279 } elsif ($self->cpan_comment
4281 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4286 #-> sub CPAN::Distribution::perl ;
4289 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4290 my $pwd = CPAN::anycwd();
4291 my $candidate = File::Spec->catfile($pwd,$^X);
4292 $perl ||= $candidate if MM->maybe_command($candidate);
4294 my ($component,$perl_name);
4295 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4296 PATH_COMPONENT: foreach $component (File::Spec->path(),
4297 $Config::Config{'binexp'}) {
4298 next unless defined($component) && $component;
4299 my($abs) = File::Spec->catfile($component,$perl_name);
4300 if (MM->maybe_command($abs)) {
4310 #-> sub CPAN::Distribution::make ;
4313 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4314 # Emergency brake if they said install Pippi and get newest perl
4315 if ($self->isa_perl) {
4317 $self->called_for ne $self->id &&
4318 ! $self->{force_update}
4320 # if we die here, we break bundles
4321 $CPAN::Frontend->mywarn(sprintf qq{
4322 The most recent version "%s" of the module "%s"
4323 comes with the current version of perl (%s).
4324 I\'ll build that only if you ask for something like
4329 $CPAN::META->instance(
4343 $self->{archived} eq "NO" and push @e,
4344 "Is neither a tar nor a zip archive.";
4346 $self->{unwrapped} eq "NO" and push @e,
4347 "had problems unarchiving. Please build manually";
4349 exists $self->{writemakefile} &&
4350 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4351 $1 || "Had some problem writing Makefile";
4353 defined $self->{'make'} and push @e,
4354 "Has already been processed within this session";
4356 exists $self->{later} and length($self->{later}) and
4357 push @e, $self->{later};
4359 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4361 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4362 my $builddir = $self->dir;
4363 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4364 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4366 if ($^O eq 'MacOS') {
4367 Mac::BuildTools::make($self);
4372 if ($self->{'configure'}) {
4373 $system = $self->{'configure'};
4375 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4377 # This needs a handler that can be turned on or off:
4378 # $switch = "-MExtUtils::MakeMaker ".
4379 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4381 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4383 unless (exists $self->{writemakefile}) {
4384 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4387 if ($CPAN::Config->{inactivity_timeout}) {
4389 alarm $CPAN::Config->{inactivity_timeout};
4390 local $SIG{CHLD}; # = sub { wait };
4391 if (defined($pid = fork)) {
4396 # note, this exec isn't necessary if
4397 # inactivity_timeout is 0. On the Mac I'd
4398 # suggest, we set it always to 0.
4402 $CPAN::Frontend->myprint("Cannot fork: $!");
4410 $CPAN::Frontend->myprint($@);
4411 $self->{writemakefile} = "NO $@";
4416 $ret = system($system);
4418 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4422 if (-f "Makefile") {
4423 $self->{writemakefile} = "YES";
4424 delete $self->{make_clean}; # if cleaned before, enable next
4426 $self->{writemakefile} =
4427 qq{NO Makefile.PL refused to write a Makefile.};
4428 # It's probably worth it to record the reason, so let's retry
4430 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4431 # $self->{writemakefile} .= <$fh>;
4435 delete $self->{force_update};
4438 if (my @prereq = $self->unsat_prereq){
4439 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4441 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4442 if (system($system) == 0) {
4443 $CPAN::Frontend->myprint(" $system -- OK\n");
4444 $self->{'make'} = "YES";
4446 $self->{writemakefile} ||= "YES";
4447 $self->{'make'} = "NO";
4448 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4452 sub follow_prereqs {
4456 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4457 "during [$id] -----\n");
4459 for my $p (@prereq) {
4460 $CPAN::Frontend->myprint(" $p\n");
4463 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4465 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4466 require ExtUtils::MakeMaker;
4467 my $answer = ExtUtils::MakeMaker::prompt(
4468 "Shall I follow them and prepend them to the queue
4469 of modules we are processing right now?", "yes");
4470 $follow = $answer =~ /^\s*y/i;
4474 myprint(" Ignoring dependencies on modules @prereq\n");
4477 # color them as dirty
4478 for my $p (@prereq) {
4479 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4481 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4482 $self->{later} = "Delayed until after prerequisites";
4483 return 1; # signal success to the queuerunner
4487 #-> sub CPAN::Distribution::unsat_prereq ;
4490 my $prereq_pm = $self->prereq_pm or return;
4492 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4493 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4494 # we were too demanding:
4495 next if $nmo->uptodate;
4497 # if they have not specified a version, we accept any installed one
4498 if (not defined $need_version or
4499 $need_version == 0 or
4500 $need_version eq "undef") {
4501 next if defined $nmo->inst_file;
4504 # We only want to install prereqs if either they're not installed
4505 # or if the installed version is too old. We cannot omit this
4506 # check, because if 'force' is in effect, nobody else will check.
4510 defined $nmo->inst_file &&
4511 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4513 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4517 CPAN::Version->readable($need_version)
4523 if ($self->{sponsored_mods}{$need_module}++){
4524 # We have already sponsored it and for some reason it's still
4525 # not available. So we do nothing. Or what should we do?
4526 # if we push it again, we have a potential infinite loop
4529 push @need, $need_module;
4534 #-> sub CPAN::Distribution::prereq_pm ;
4537 return $self->{prereq_pm} if
4538 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4539 return unless $self->{writemakefile}; # no need to have succeeded
4540 # but we must have run it
4541 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4542 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4547 $fh = FileHandle->new("<$makefile\0")) {
4551 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4553 last if /MakeMaker post_initialize section/;
4555 \s+PREREQ_PM\s+=>\s+(.+)
4558 # warn "Found prereq expr[$p]";
4560 # Regexp modified by A.Speer to remember actual version of file
4561 # PREREQ_PM hash key wants, then add to
4562 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4563 # In case a prereq is mentioned twice, complain.
4564 if ( defined $p{$1} ) {
4565 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4572 $self->{prereq_pm_detected}++;
4573 return $self->{prereq_pm} = \%p;
4576 #-> sub CPAN::Distribution::test ;
4581 delete $self->{force_update};
4584 $CPAN::Frontend->myprint("Running make test\n");
4585 if (my @prereq = $self->unsat_prereq){
4586 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4590 exists $self->{make} or exists $self->{later} or push @e,
4591 "Make had some problems, maybe interrupted? Won't test";
4593 exists $self->{'make'} and
4594 $self->{'make'} eq 'NO' and
4595 push @e, "Can't test without successful make";
4597 exists $self->{build_dir} or push @e, "Has no own directory";
4598 $self->{badtestcnt} ||= 0;
4599 $self->{badtestcnt} > 0 and
4600 push @e, "Won't repeat unsuccessful test during this command";
4602 exists $self->{later} and length($self->{later}) and
4603 push @e, $self->{later};
4605 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4607 chdir $self->{'build_dir'} or
4608 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4609 $self->debug("Changed directory to $self->{'build_dir'}")
4612 if ($^O eq 'MacOS') {
4613 Mac::BuildTools::make_test($self);
4617 my $system = join " ", $CPAN::Config->{'make'}, "test";
4618 if (system($system) == 0) {
4619 $CPAN::Frontend->myprint(" $system -- OK\n");
4620 $self->{make_test} = "YES";
4622 $self->{make_test} = "NO";
4623 $self->{badtestcnt}++;
4624 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4628 #-> sub CPAN::Distribution::clean ;
4631 $CPAN::Frontend->myprint("Running make clean\n");
4634 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4635 push @e, "make clean already called once";
4636 exists $self->{build_dir} or push @e, "Has no own directory";
4637 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4639 chdir $self->{'build_dir'} or
4640 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4641 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4643 if ($^O eq 'MacOS') {
4644 Mac::BuildTools::make_clean($self);
4648 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4649 if (system($system) == 0) {
4650 $CPAN::Frontend->myprint(" $system -- OK\n");
4654 # Jost Krieger pointed out that this "force" was wrong because
4655 # it has the effect that the next "install" on this distribution
4656 # will untar everything again. Instead we should bring the
4657 # object's state back to where it is after untarring.
4659 delete $self->{force_update};
4660 delete $self->{install};
4661 delete $self->{writemakefile};
4662 delete $self->{make};
4663 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4664 $self->{make_clean} = "YES";
4667 # Hmmm, what to do if make clean failed?
4669 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4671 make clean did not succeed, marking directory as unusable for further work.
4673 $self->force("make"); # so that this directory won't be used again
4678 #-> sub CPAN::Distribution::install ;
4683 delete $self->{force_update};
4686 $CPAN::Frontend->myprint("Running make install\n");
4689 exists $self->{build_dir} or push @e, "Has no own directory";
4691 exists $self->{make} or exists $self->{later} or push @e,
4692 "Make had some problems, maybe interrupted? Won't install";
4694 exists $self->{'make'} and
4695 $self->{'make'} eq 'NO' and
4696 push @e, "make had returned bad status, install seems impossible";
4698 push @e, "make test had returned bad status, ".
4699 "won't install without force"
4700 if exists $self->{'make_test'} and
4701 $self->{'make_test'} eq 'NO' and
4702 ! $self->{'force_update'};
4704 exists $self->{'install'} and push @e,
4705 $self->{'install'} eq "YES" ?
4706 "Already done" : "Already tried without success";
4708 exists $self->{later} and length($self->{later}) and
4709 push @e, $self->{later};
4711 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4713 chdir $self->{'build_dir'} or
4714 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4715 $self->debug("Changed directory to $self->{'build_dir'}")
4718 if ($^O eq 'MacOS') {
4719 Mac::BuildTools::make_install($self);
4723 my $system = join(" ", $CPAN::Config->{'make'},
4724 "install", $CPAN::Config->{make_install_arg});
4725 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4726 my($pipe) = FileHandle->new("$system $stderr |");
4729 $CPAN::Frontend->myprint($_);
4734 $CPAN::Frontend->myprint(" $system -- OK\n");
4735 return $self->{'install'} = "YES";
4737 $self->{'install'} = "NO";
4738 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4739 if ($makeout =~ /permission/s && $> > 0) {
4740 $CPAN::Frontend->myprint(qq{ You may have to su }.
4741 qq{to root to install the package\n});
4744 delete $self->{force_update};
4747 #-> sub CPAN::Distribution::dir ;
4749 shift->{'build_dir'};
4752 package CPAN::Bundle;
4756 delete $self->{later};
4757 for my $c ( $self->contains ) {
4758 my $obj = CPAN::Shell->expandany($c) or next;
4763 #-> sub CPAN::Bundle::color_cmd_tmps ;
4764 sub color_cmd_tmps {
4766 my($depth) = shift || 0;
4767 my($color) = shift || 0;
4768 # a module needs to recurse to its cpan_file, a distribution needs
4769 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4771 return if exists $self->{incommandcolor}
4772 && $self->{incommandcolor}==$color;
4773 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4774 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4779 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4781 for my $c ( $self->contains ) {
4782 my $obj = CPAN::Shell->expandany($c) or next;
4783 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4784 $obj->color_cmd_tmps($depth+1,$color);
4787 delete $self->{badtestcnt};
4789 $self->{incommandcolor} = $color;
4792 #-> sub CPAN::Bundle::as_string ;
4796 # following line must be "=", not "||=" because we have a moving target
4797 $self->{INST_VERSION} = $self->inst_version;
4798 return $self->SUPER::as_string;
4801 #-> sub CPAN::Bundle::contains ;
4804 my($inst_file) = $self->inst_file || "";
4805 my($id) = $self->id;
4806 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4807 unless ($inst_file) {
4808 # Try to get at it in the cpan directory
4809 $self->debug("no inst_file") if $CPAN::DEBUG;
4811 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4812 $cpan_file = $self->cpan_file;
4813 if ($cpan_file eq "N/A") {
4814 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4815 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4817 my $dist = $CPAN::META->instance('CPAN::Distribution',
4820 $self->debug($dist->as_string) if $CPAN::DEBUG;
4821 my($todir) = $CPAN::Config->{'cpan_home'};
4822 my(@me,$from,$to,$me);
4823 @me = split /::/, $self->id;
4825 $me = File::Spec->catfile(@me);
4826 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4827 $to = File::Spec->catfile($todir,$me);
4828 File::Path::mkpath(File::Basename::dirname($to));
4829 File::Copy::copy($from, $to)
4830 or Carp::confess("Couldn't copy $from to $to: $!");
4834 my $fh = FileHandle->new;
4836 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4838 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4840 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4841 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4842 next unless $in_cont;
4847 push @result, (split " ", $_, 2)[0];
4850 delete $self->{STATUS};
4851 $self->{CONTAINS} = \@result;
4852 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4854 $CPAN::Frontend->mywarn(qq{
4855 The bundle file "$inst_file" may be a broken
4856 bundlefile. It seems not to contain any bundle definition.
4857 Please check the file and if it is bogus, please delete it.
4858 Sorry for the inconvenience.
4864 #-> sub CPAN::Bundle::find_bundle_file
4865 sub find_bundle_file {
4866 my($self,$where,$what) = @_;
4867 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4868 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4869 ### my $bu = File::Spec->catfile($where,$what);
4870 ### return $bu if -f $bu;
4871 my $manifest = File::Spec->catfile($where,"MANIFEST");
4872 unless (-f $manifest) {
4873 require ExtUtils::Manifest;
4874 my $cwd = CPAN::anycwd();
4875 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4876 ExtUtils::Manifest::mkmanifest();
4877 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4879 my $fh = FileHandle->new($manifest)
4880 or Carp::croak("Couldn't open $manifest: $!");
4883 if ($^O eq 'MacOS') {
4886 $what2 =~ s/:Bundle://;
4889 $what2 =~ s|Bundle[/\\]||;
4894 my($file) = /(\S+)/;
4895 if ($file =~ m|\Q$what\E$|) {
4897 # return File::Spec->catfile($where,$bu); # bad
4900 # retry if she managed to
4901 # have no Bundle directory
4902 $bu = $file if $file =~ m|\Q$what2\E$|;
4904 $bu =~ tr|/|:| if $^O eq 'MacOS';
4905 return File::Spec->catfile($where, $bu) if $bu;
4906 Carp::croak("Couldn't find a Bundle file in $where");
4909 # needs to work quite differently from Module::inst_file because of
4910 # cpan_home/Bundle/ directory and the possibility that we have
4911 # shadowing effect. As it makes no sense to take the first in @INC for
4912 # Bundles, we parse them all for $VERSION and take the newest.
4914 #-> sub CPAN::Bundle::inst_file ;
4919 @me = split /::/, $self->id;
4922 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4923 my $bfile = File::Spec->catfile($incdir, @me);
4924 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4925 next unless -f $bfile;
4926 my $foundv = MM->parse_version($bfile);
4927 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4928 $self->{INST_FILE} = $bfile;
4929 $self->{INST_VERSION} = $bestv = $foundv;
4935 #-> sub CPAN::Bundle::inst_version ;
4938 $self->inst_file; # finds INST_VERSION as side effect
4939 $self->{INST_VERSION};
4942 #-> sub CPAN::Bundle::rematein ;
4944 my($self,$meth) = @_;
4945 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4946 my($id) = $self->id;
4947 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4948 unless $self->inst_file || $self->cpan_file;
4950 for $s ($self->contains) {
4951 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4952 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4953 if ($type eq 'CPAN::Distribution') {
4954 $CPAN::Frontend->mywarn(qq{
4955 The Bundle }.$self->id.qq{ contains
4956 explicitly a file $s.
4960 # possibly noisy action:
4961 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4962 my $obj = $CPAN::META->instance($type,$s);
4964 if ($obj->isa(CPAN::Bundle)
4966 exists $obj->{install_failed}
4968 ref($obj->{install_failed}) eq "HASH"
4970 for (keys %{$obj->{install_failed}}) {
4971 $self->{install_failed}{$_} = undef; # propagate faiure up
4974 $fail{$s} = 1; # the bundle itself may have succeeded but
4979 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4980 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4982 delete $self->{install_failed}{$s};
4989 # recap with less noise
4990 if ( $meth eq "install" ) {
4993 my $raw = sprintf(qq{Bundle summary:
4994 The following items in bundle %s had installation problems:},
4997 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4998 $CPAN::Frontend->myprint("\n");
5001 for $s ($self->contains) {
5003 $paragraph .= "$s ";
5004 $self->{install_failed}{$s} = undef;
5005 $reported{$s} = undef;
5008 my $report_propagated;
5009 for $s (sort keys %{$self->{install_failed}}) {
5010 next if exists $reported{$s};
5011 $paragraph .= "and the following items had problems
5012 during recursive bundle calls: " unless $report_propagated++;
5013 $paragraph .= "$s ";
5015 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5016 $CPAN::Frontend->myprint("\n");
5018 $self->{'install'} = 'YES';
5023 #sub CPAN::Bundle::xs_file
5025 # If a bundle contains another that contains an xs_file we have
5026 # here, we just don't bother I suppose
5030 #-> sub CPAN::Bundle::force ;
5031 sub force { shift->rematein('force',@_); }
5032 #-> sub CPAN::Bundle::get ;
5033 sub get { shift->rematein('get',@_); }
5034 #-> sub CPAN::Bundle::make ;
5035 sub make { shift->rematein('make',@_); }
5036 #-> sub CPAN::Bundle::test ;
5039 $self->{badtestcnt} ||= 0;
5040 $self->rematein('test',@_);
5042 #-> sub CPAN::Bundle::install ;
5045 $self->rematein('install',@_);
5047 #-> sub CPAN::Bundle::clean ;
5048 sub clean { shift->rematein('clean',@_); }
5050 #-> sub CPAN::Bundle::uptodate ;
5053 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5055 foreach $c ($self->contains) {
5056 my $obj = CPAN::Shell->expandany($c);
5057 return 0 unless $obj->uptodate;
5062 #-> sub CPAN::Bundle::readme ;
5065 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5066 No File found for bundle } . $self->id . qq{\n}), return;
5067 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5068 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5071 package CPAN::Module;
5074 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5077 return unless exists $self->{RO}; # should never happen
5078 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5080 sub description { shift->{RO}{description} }
5084 delete $self->{later};
5085 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5090 #-> sub CPAN::Module::color_cmd_tmps ;
5091 sub color_cmd_tmps {
5093 my($depth) = shift || 0;
5094 my($color) = shift || 0;
5095 # a module needs to recurse to its cpan_file
5097 return if exists $self->{incommandcolor}
5098 && $self->{incommandcolor}==$color;
5099 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5100 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5105 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5107 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5108 $dist->color_cmd_tmps($depth+1,$color);
5111 delete $self->{badtestcnt};
5113 $self->{incommandcolor} = $color;
5116 #-> sub CPAN::Module::as_glimpse ;
5120 my $class = ref($self);
5121 $class =~ s/^CPAN:://;
5125 $CPAN::Shell::COLOR_REGISTERED
5127 $CPAN::META->has_inst("Term::ANSIColor")
5129 $self->{RO}{description}
5131 $color_on = Term::ANSIColor::color("green");
5132 $color_off = Term::ANSIColor::color("reset");
5134 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5143 #-> sub CPAN::Module::as_string ;
5147 CPAN->debug($self) if $CPAN::DEBUG;
5148 my $class = ref($self);
5149 $class =~ s/^CPAN:://;
5151 push @m, $class, " id = $self->{ID}\n";
5152 my $sprintf = " %-12s %s\n";
5153 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5154 if $self->description;
5155 my $sprintf2 = " %-12s %s (%s)\n";
5157 if ($userid = $self->cpan_userid || $self->userid){
5159 if ($author = CPAN::Shell->expand('Author',$userid)) {
5162 if ($m = $author->email) {
5169 $author->fullname . $email
5173 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5174 if $self->cpan_version;
5175 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5176 if $self->cpan_file;
5177 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5178 my(%statd,%stats,%statl,%stati);
5179 @statd{qw,? i c a b R M S,} = qw,unknown idea
5180 pre-alpha alpha beta released mature standard,;
5181 @stats{qw,? m d u n,} = qw,unknown mailing-list
5182 developer comp.lang.perl.* none,;
5183 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5184 @stati{qw,? f r O h,} = qw,unknown functions
5185 references+ties object-oriented hybrid,;
5186 $statd{' '} = 'unknown';
5187 $stats{' '} = 'unknown';
5188 $statl{' '} = 'unknown';
5189 $stati{' '} = 'unknown';
5197 $statd{$self->{RO}{statd}},
5198 $stats{$self->{RO}{stats}},
5199 $statl{$self->{RO}{statl}},
5200 $stati{$self->{RO}{stati}}
5201 ) if $self->{RO}{statd};
5202 my $local_file = $self->inst_file;
5203 unless ($self->{MANPAGE}) {
5205 $self->{MANPAGE} = $self->manpage_headline($local_file);
5207 # If we have already untarred it, we should look there
5208 my $dist = $CPAN::META->instance('CPAN::Distribution',
5210 # warn "dist[$dist]";
5211 # mff=manifest file; mfh=manifest handle
5216 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5218 $mfh = FileHandle->new($mff)
5220 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5221 my $lfre = $self->id; # local file RE
5224 my($lfl); # local file file
5226 my(@mflines) = <$mfh>;
5231 while (length($lfre)>5 and !$lfl) {
5232 ($lfl) = grep /$lfre/, @mflines;
5233 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5236 $lfl =~ s/\s.*//; # remove comments
5237 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5238 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5239 # warn "lfl_abs[$lfl_abs]";
5241 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5247 for $item (qw/MANPAGE/) {
5248 push @m, sprintf($sprintf, $item, $self->{$item})
5249 if exists $self->{$item};
5251 for $item (qw/CONTAINS/) {
5252 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5253 if exists $self->{$item} && @{$self->{$item}};
5255 push @m, sprintf($sprintf, 'INST_FILE',
5256 $local_file || "(not installed)");
5257 push @m, sprintf($sprintf, 'INST_VERSION',
5258 $self->inst_version) if $local_file;
5262 sub manpage_headline {
5263 my($self,$local_file) = @_;
5264 my(@local_file) = $local_file;
5265 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5266 push @local_file, $local_file;
5268 for $locf (@local_file) {
5269 next unless -f $locf;
5270 my $fh = FileHandle->new($locf)
5271 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5275 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
5276 m/^=head1\s+NAME/ ? 1 : $inpod;
5289 #-> sub CPAN::Module::cpan_file ;
5290 # Note: also inherited by CPAN::Bundle
5293 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5294 unless (defined $self->{RO}{CPAN_FILE}) {
5295 CPAN::Index->reload;
5297 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5298 return $self->{RO}{CPAN_FILE};
5300 my $userid = $self->userid;
5302 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5303 my $author = $CPAN::META->instance("CPAN::Author",
5305 my $fullname = $author->fullname;
5306 my $email = $author->email;
5307 unless (defined $fullname && defined $email) {
5308 return sprintf("Contact Author %s",
5312 return "Contact Author $fullname <$email>";
5314 return "UserID $userid";
5322 #-> sub CPAN::Module::cpan_version ;
5326 $self->{RO}{CPAN_VERSION} = 'undef'
5327 unless defined $self->{RO}{CPAN_VERSION};
5328 # I believe this is always a bug in the index and should be reported
5329 # as such, but usually I find out such an error and do not want to
5330 # provoke too many bugreports
5332 $self->{RO}{CPAN_VERSION};
5335 #-> sub CPAN::Module::force ;
5338 $self->{'force_update'}++;
5341 #-> sub CPAN::Module::rematein ;
5343 my($self,$meth) = @_;
5344 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5347 my $cpan_file = $self->cpan_file;
5348 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5349 $CPAN::Frontend->mywarn(sprintf qq{
5350 The module %s isn\'t available on CPAN.
5352 Either the module has not yet been uploaded to CPAN, or it is
5353 temporary unavailable. Please contact the author to find out
5354 more about the status. Try 'i %s'.
5361 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5362 $pack->called_for($self->id);
5363 $pack->force($meth) if exists $self->{'force_update'};
5365 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5366 delete $self->{'force_update'};
5369 #-> sub CPAN::Module::readme ;
5370 sub readme { shift->rematein('readme') }
5371 #-> sub CPAN::Module::look ;
5372 sub look { shift->rematein('look') }
5373 #-> sub CPAN::Module::cvs_import ;
5374 sub cvs_import { shift->rematein('cvs_import') }
5375 #-> sub CPAN::Module::get ;
5376 sub get { shift->rematein('get',@_); }
5377 #-> sub CPAN::Module::make ;
5380 $self->rematein('make');
5382 #-> sub CPAN::Module::test ;
5385 $self->{badtestcnt} ||= 0;
5386 $self->rematein('test',@_);
5388 #-> sub CPAN::Module::uptodate ;
5391 my($latest) = $self->cpan_version;
5393 my($inst_file) = $self->inst_file;
5395 if (defined $inst_file) {
5396 $have = $self->inst_version;
5401 ! CPAN::Version->vgt($latest, $have)
5403 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5404 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5409 #-> sub CPAN::Module::install ;
5415 not exists $self->{'force_update'}
5417 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5421 $self->rematein('install') if $doit;
5423 #-> sub CPAN::Module::clean ;
5424 sub clean { shift->rematein('clean') }
5426 #-> sub CPAN::Module::inst_file ;
5430 @packpath = split /::/, $self->{ID};
5431 $packpath[-1] .= ".pm";
5432 foreach $dir (@INC) {
5433 my $pmfile = File::Spec->catfile($dir,@packpath);
5441 #-> sub CPAN::Module::xs_file ;
5445 @packpath = split /::/, $self->{ID};
5446 push @packpath, $packpath[-1];
5447 $packpath[-1] .= "." . $Config::Config{'dlext'};
5448 foreach $dir (@INC) {
5449 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5457 #-> sub CPAN::Module::inst_version ;
5460 my $parsefile = $self->inst_file or return;
5461 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5464 # there was a bug in 5.6.0 that let lots of unini warnings out of
5465 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5466 # the following workaround after 5.6.1 is out.
5467 local($SIG{__WARN__}) = sub { my $w = shift;
5468 return if $w =~ /uninitialized/i;
5472 $have = MM->parse_version($parsefile) || "undef";
5473 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5474 $have =~ s/ $//; # trailing whitespace happens all the time
5476 # My thoughts about why %vd processing should happen here
5478 # Alt1 maintain it as string with leading v:
5479 # read index files do nothing
5480 # compare it use utility for compare
5481 # print it do nothing
5483 # Alt2 maintain it as what it is
5484 # read index files convert
5485 # compare it use utility because there's still a ">" vs "gt" issue
5486 # print it use CPAN::Version for print
5488 # Seems cleaner to hold it in memory as a string starting with a "v"
5490 # If the author of this module made a mistake and wrote a quoted
5491 # "v1.13" instead of v1.13, we simply leave it at that with the
5492 # effect that *we* will treat it like a v-tring while the rest of
5493 # perl won't. Seems sensible when we consider that any action we
5494 # could take now would just add complexity.
5496 $have = CPAN::Version->readable($have);
5498 $have =~ s/\s*//g; # stringify to float around floating point issues
5499 $have; # no stringify needed, \s* above matches always
5502 package CPAN::Tarzip;
5504 # CPAN::Tarzip::gzip
5506 my($class,$read,$write) = @_;
5507 if ($CPAN::META->has_inst("Compress::Zlib")) {
5509 $fhw = FileHandle->new($read)
5510 or $CPAN::Frontend->mydie("Could not open $read: $!");
5511 my $gz = Compress::Zlib::gzopen($write, "wb")
5512 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5513 $gz->gzwrite($buffer)
5514 while read($fhw,$buffer,4096) > 0 ;
5519 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5524 # CPAN::Tarzip::gunzip
5526 my($class,$read,$write) = @_;
5527 if ($CPAN::META->has_inst("Compress::Zlib")) {
5529 $fhw = FileHandle->new(">$write")
5530 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5531 my $gz = Compress::Zlib::gzopen($read, "rb")
5532 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5533 $fhw->print($buffer)
5534 while $gz->gzread($buffer) > 0 ;
5535 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5536 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5541 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5546 # CPAN::Tarzip::gtest
5548 my($class,$read) = @_;
5549 # After I had reread the documentation in zlib.h, I discovered that
5550 # uncompressed files do not lead to an gzerror (anymore?).
5551 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5554 my $gz = Compress::Zlib::gzopen($read, "rb")
5555 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5557 $Compress::Zlib::gzerrno));
5558 while ($gz->gzread($buffer) > 0 ){
5559 $len += length($buffer);
5562 my $err = $gz->gzerror;
5563 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5564 if ($len == -s $read){
5566 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5569 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5572 return system("$CPAN::Config->{gzip} -dt $read")==0;
5577 # CPAN::Tarzip::TIEHANDLE
5579 my($class,$file) = @_;
5581 $class->debug("file[$file]");
5582 if ($CPAN::META->has_inst("Compress::Zlib")) {
5583 my $gz = Compress::Zlib::gzopen($file,"rb") or
5584 die "Could not gzopen $file";
5585 $ret = bless {GZ => $gz}, $class;
5587 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5588 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5590 $ret = bless {FH => $fh}, $class;
5596 # CPAN::Tarzip::READLINE
5599 if (exists $self->{GZ}) {
5600 my $gz = $self->{GZ};
5601 my($line,$bytesread);
5602 $bytesread = $gz->gzreadline($line);
5603 return undef if $bytesread <= 0;
5606 my $fh = $self->{FH};
5607 return scalar <$fh>;
5612 # CPAN::Tarzip::READ
5614 my($self,$ref,$length,$offset) = @_;
5615 die "read with offset not implemented" if defined $offset;
5616 if (exists $self->{GZ}) {
5617 my $gz = $self->{GZ};
5618 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5621 my $fh = $self->{FH};
5622 return read($fh,$$ref,$length);
5627 # CPAN::Tarzip::DESTROY
5630 if (exists $self->{GZ}) {
5631 my $gz = $self->{GZ};
5632 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5633 # to be undef ever. AK, 2000-09
5635 my $fh = $self->{FH};
5636 $fh->close if defined $fh;
5642 # CPAN::Tarzip::untar
5644 my($class,$file) = @_;
5647 if (0) { # makes changing order easier
5648 } elsif ($BUGHUNTING){
5650 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5652 MM->maybe_command($CPAN::Config->{'tar'})) {
5653 # should be default until Archive::Tar is fixed
5656 $CPAN::META->has_inst("Archive::Tar")
5658 $CPAN::META->has_inst("Compress::Zlib") ) {
5661 $CPAN::Frontend->mydie(qq{
5662 CPAN.pm needs either both external programs tar and gzip installed or
5663 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5664 is available. Can\'t continue.
5667 if ($prefer==1) { # 1 => external gzip+tar
5669 my $is_compressed = $class->gtest($file);
5670 if ($is_compressed) {
5671 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5672 "< $file | $CPAN::Config->{tar} xvf -";
5674 $system = "$CPAN::Config->{tar} xvf $file";
5676 if (system($system) != 0) {
5677 # people find the most curious tar binaries that cannot handle
5679 if ($is_compressed) {
5680 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5681 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5682 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5684 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5688 $system = "$CPAN::Config->{tar} xvf $file";
5689 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5690 if (system($system)==0) {
5691 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5693 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5699 } elsif ($prefer==2) { # 2 => modules
5700 my $tar = Archive::Tar->new($file,1);
5701 my $af; # archive file
5704 # RCS 1.337 had this code, it turned out unacceptable slow but
5705 # it revealed a bug in Archive::Tar. Code is only here to hunt
5706 # the bug again. It should never be enabled in published code.
5707 # GDGraph3d-0.53 was an interesting case according to Larry
5709 warn(">>>Bughunting code enabled<<< " x 20);
5710 for $af ($tar->list_files) {
5711 if ($af =~ m!^(/|\.\./)!) {
5712 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5713 "illegal member [$af]");
5715 $CPAN::Frontend->myprint("$af\n");
5716 $tar->extract($af); # slow but effective for finding the bug
5717 return if $CPAN::Signal;
5720 for $af ($tar->list_files) {
5721 if ($af =~ m!^(/|\.\./)!) {
5722 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5723 "illegal member [$af]");
5725 $CPAN::Frontend->myprint("$af\n");
5727 return if $CPAN::Signal;
5732 Mac::BuildTools::convert_files([$tar->list_files], 1)
5733 if ($^O eq 'MacOS');
5740 my($class,$file) = @_;
5741 if ($CPAN::META->has_inst("Archive::Zip")) {
5742 # blueprint of the code from Archive::Zip::Tree::extractTree();
5743 my $zip = Archive::Zip->new();
5745 $status = $zip->read($file);
5746 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5747 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5748 my @members = $zip->members();
5749 for my $member ( @members ) {
5750 my $af = $member->fileName();
5751 if ($af =~ m!^(/|\.\./)!) {
5752 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5753 "illegal member [$af]");
5755 my $status = $member->extractToFileNamed( $af );
5756 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5757 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5758 $status != Archive::Zip::AZ_OK();
5759 return if $CPAN::Signal;
5763 my $unzip = $CPAN::Config->{unzip} or
5764 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5765 my @system = ($unzip, $file);
5766 return system(@system) == 0;
5771 package CPAN::Version;
5772 # CPAN::Version::vcmp courtesy Jost Krieger
5774 my($self,$l,$r) = @_;
5776 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5778 return 0 if $l eq $r; # short circuit for quicker success
5780 if ($l=~/^v/ <=> $r=~/^v/) {
5783 $_ = $self->float2vv($_);
5788 ($l ne "undef") <=> ($r ne "undef") ||
5792 $self->vstring($l) cmp $self->vstring($r)) ||
5798 my($self,$l,$r) = @_;
5799 $self->vcmp($l,$r) > 0;
5804 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5805 pack "U*", split /\./, $n;
5808 # vv => visible vstring
5813 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5814 # architecture influence
5816 $mantissa .= "0" while length($mantissa)%3;
5817 my $ret = "v" . $rev;
5819 $mantissa =~ s/(\d{1,3})// or
5820 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5821 $ret .= ".".int($1);
5823 # warn "n[$n]ret[$ret]";
5829 $n =~ /^([\w\-\+\.]+)/;
5831 return $1 if defined $1 && length($1)>0;
5832 # if the first user reaches version v43, he will be treated as "+".
5833 # We'll have to decide about a new rule here then, depending on what
5834 # will be the prevailing versioning behavior then.
5836 if ($] < 5.006) { # or whenever v-strings were introduced
5837 # we get them wrong anyway, whatever we do, because 5.005 will
5838 # have already interpreted 0.2.4 to be "0.24". So even if he
5839 # indexer sends us something like "v0.2.4" we compare wrongly.
5841 # And if they say v1.2, then the old perl takes it as "v12"
5843 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5846 my $better = sprintf "v%vd", $n;
5847 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5859 CPAN - query, download and build perl modules from CPAN sites
5865 perl -MCPAN -e shell;
5871 autobundle, clean, install, make, recompile, test
5875 The CPAN module is designed to automate the make and install of perl
5876 modules and extensions. It includes some searching capabilities and
5877 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5878 to fetch the raw data from the net.
5880 Modules are fetched from one or more of the mirrored CPAN
5881 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5884 The CPAN module also supports the concept of named and versioned
5885 I<bundles> of modules. Bundles simplify the handling of sets of
5886 related modules. See Bundles below.
5888 The package contains a session manager and a cache manager. There is
5889 no status retained between sessions. The session manager keeps track
5890 of what has been fetched, built and installed in the current
5891 session. The cache manager keeps track of the disk space occupied by
5892 the make processes and deletes excess space according to a simple FIFO
5895 For extended searching capabilities there's a plugin for CPAN available,
5896 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5897 that indexes all documents available in CPAN authors directories. If
5898 C<CPAN::WAIT> is installed on your system, the interactive shell of
5899 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5900 which send queries to the WAIT server that has been configured for your
5903 All other methods provided are accessible in a programmer style and in an
5904 interactive shell style.
5906 =head2 Interactive Mode
5908 The interactive mode is entered by running
5910 perl -MCPAN -e shell
5912 which puts you into a readline interface. You will have the most fun if
5913 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5916 Once you are on the command line, type 'h' and the rest should be
5919 The function call C<shell> takes two optional arguments, one is the
5920 prompt, the second is the default initial command line (the latter
5921 only works if a real ReadLine interface module is installed).
5923 The most common uses of the interactive modes are
5927 =item Searching for authors, bundles, distribution files and modules
5929 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5930 for each of the four categories and another, C<i> for any of the
5931 mentioned four. Each of the four entities is implemented as a class
5932 with slightly differing methods for displaying an object.
5934 Arguments you pass to these commands are either strings exactly matching
5935 the identification string of an object or regular expressions that are
5936 then matched case-insensitively against various attributes of the
5937 objects. The parser recognizes a regular expression only if you
5938 enclose it between two slashes.
5940 The principle is that the number of found objects influences how an
5941 item is displayed. If the search finds one item, the result is
5942 displayed with the rather verbose method C<as_string>, but if we find
5943 more than one, we display each object with the terse method
5946 =item make, test, install, clean modules or distributions
5948 These commands take any number of arguments and investigate what is
5949 necessary to perform the action. If the argument is a distribution
5950 file name (recognized by embedded slashes), it is processed. If it is
5951 a module, CPAN determines the distribution file in which this module
5952 is included and processes that, following any dependencies named in
5953 the module's Makefile.PL (this behavior is controlled by
5954 I<prerequisites_policy>.)
5956 Any C<make> or C<test> are run unconditionally. An
5958 install <distribution_file>
5960 also is run unconditionally. But for
5964 CPAN checks if an install is actually needed for it and prints
5965 I<module up to date> in the case that the distribution file containing
5966 the module doesn't need to be updated.
5968 CPAN also keeps track of what it has done within the current session
5969 and doesn't try to build a package a second time regardless if it
5970 succeeded or not. The C<force> command takes as a first argument the
5971 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5972 command from scratch.
5976 cpan> install OpenGL
5977 OpenGL is up to date.
5978 cpan> force install OpenGL
5981 OpenGL-0.4/COPYRIGHT
5984 A C<clean> command results in a
5988 being executed within the distribution file's working directory.
5990 =item get, readme, look module or distribution
5992 C<get> downloads a distribution file without further action. C<readme>
5993 displays the README file of the associated distribution. C<Look> gets
5994 and untars (if not yet done) the distribution file, changes to the
5995 appropriate directory and opens a subshell process in that directory.
5999 C<ls> lists all distribution files in and below an author's CPAN
6000 directory. Only those files that contain modules are listed and if
6001 there is more than one for any given module, only the most recent one
6006 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6007 in the cpan-shell it is intended that you can press C<^C> anytime and
6008 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6009 to clean up and leave the shell loop. You can emulate the effect of a
6010 SIGTERM by sending two consecutive SIGINTs, which usually means by
6011 pressing C<^C> twice.
6013 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6014 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6020 The commands that are available in the shell interface are methods in
6021 the package CPAN::Shell. If you enter the shell command, all your
6022 input is split by the Text::ParseWords::shellwords() routine which
6023 acts like most shells do. The first word is being interpreted as the
6024 method to be called and the rest of the words are treated as arguments
6025 to this method. Continuation lines are supported if a line ends with a
6030 C<autobundle> writes a bundle file into the
6031 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6032 a list of all modules that are both available from CPAN and currently
6033 installed within @INC. The name of the bundle file is based on the
6034 current date and a counter.
6038 recompile() is a very special command in that it takes no argument and
6039 runs the make/test/install cycle with brute force over all installed
6040 dynamically loadable extensions (aka XS modules) with 'force' in
6041 effect. The primary purpose of this command is to finish a network
6042 installation. Imagine, you have a common source tree for two different
6043 architectures. You decide to do a completely independent fresh
6044 installation. You start on one architecture with the help of a Bundle
6045 file produced earlier. CPAN installs the whole Bundle for you, but
6046 when you try to repeat the job on the second architecture, CPAN
6047 responds with a C<"Foo up to date"> message for all modules. So you
6048 invoke CPAN's recompile on the second architecture and you're done.
6050 Another popular use for C<recompile> is to act as a rescue in case your
6051 perl breaks binary compatibility. If one of the modules that CPAN uses
6052 is in turn depending on binary compatibility (so you cannot run CPAN
6053 commands), then you should try the CPAN::Nox module for recovery.
6055 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6057 Although it may be considered internal, the class hierarchy does matter
6058 for both users and programmer. CPAN.pm deals with above mentioned four
6059 classes, and all those classes share a set of methods. A classical
6060 single polymorphism is in effect. A metaclass object registers all
6061 objects of all kinds and indexes them with a string. The strings
6062 referencing objects have a separated namespace (well, not completely
6067 words containing a "/" (slash) Distribution
6068 words starting with Bundle:: Bundle
6069 everything else Module or Author
6071 Modules know their associated Distribution objects. They always refer
6072 to the most recent official release. Developers may mark their releases
6073 as unstable development versions (by inserting an underbar into the
6074 module version number which will also be reflected in the distribution
6075 name when you run 'make dist'), so the really hottest and newest
6076 distribution is not always the default. If a module Foo circulates
6077 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6078 way to install version 1.23 by saying
6082 This would install the complete distribution file (say
6083 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6084 like to install version 1.23_90, you need to know where the
6085 distribution file resides on CPAN relative to the authors/id/
6086 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6087 so you would have to say
6089 install BAR/Foo-1.23_90.tar.gz
6091 The first example will be driven by an object of the class
6092 CPAN::Module, the second by an object of class CPAN::Distribution.
6094 =head2 Programmer's interface
6096 If you do not enter the shell, the available shell commands are both
6097 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6098 functions in the calling package (C<install(...)>).
6100 There's currently only one class that has a stable interface -
6101 CPAN::Shell. All commands that are available in the CPAN shell are
6102 methods of the class CPAN::Shell. Each of the commands that produce
6103 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6104 the IDs of all modules within the list.
6108 =item expand($type,@things)
6110 The IDs of all objects available within a program are strings that can
6111 be expanded to the corresponding real objects with the
6112 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6113 list of CPAN::Module objects according to the C<@things> arguments
6114 given. In scalar context it only returns the first element of the
6117 =item expandany(@things)
6119 Like expand, but returns objects of the appropriate type, i.e.
6120 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6121 CPAN::Distribution objects fro distributions.
6123 =item Programming Examples
6125 This enables the programmer to do operations that combine
6126 functionalities that are available in the shell.
6128 # install everything that is outdated on my disk:
6129 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6131 # install my favorite programs if necessary:
6132 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6133 my $obj = CPAN::Shell->expand('Module',$mod);
6137 # list all modules on my disk that have no VERSION number
6138 for $mod (CPAN::Shell->expand("Module","/./")){
6139 next unless $mod->inst_file;
6140 # MakeMaker convention for undefined $VERSION:
6141 next unless $mod->inst_version eq "undef";
6142 print "No VERSION in ", $mod->id, "\n";
6145 # find out which distribution on CPAN contains a module:
6146 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6148 Or if you want to write a cronjob to watch The CPAN, you could list
6149 all modules that need updating. First a quick and dirty way:
6151 perl -e 'use CPAN; CPAN::Shell->r;'
6153 If you don't want to get any output in the case that all modules are
6154 up to date, you can parse the output of above command for the regular
6155 expression //modules are up to date// and decide to mail the output
6156 only if it doesn't match. Ick?
6158 If you prefer to do it more in a programmer style in one single
6159 process, maybe something like this suits you better:
6161 # list all modules on my disk that have newer versions on CPAN
6162 for $mod (CPAN::Shell->expand("Module","/./")){
6163 next unless $mod->inst_file;
6164 next if $mod->uptodate;
6165 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6166 $mod->id, $mod->inst_version, $mod->cpan_version;
6169 If that gives you too much output every day, you maybe only want to
6170 watch for three modules. You can write
6172 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6174 as the first line instead. Or you can combine some of the above
6177 # watch only for a new mod_perl module
6178 $mod = CPAN::Shell->expand("Module","mod_perl");
6179 exit if $mod->uptodate;
6180 # new mod_perl arrived, let me know all update recommendations
6185 =head2 Methods in the other Classes
6187 The programming interface for the classes CPAN::Module,
6188 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6189 beta and partially even alpha. In the following paragraphs only those
6190 methods are documented that have proven useful over a longer time and
6191 thus are unlikely to change.
6195 =item CPAN::Author::as_glimpse()
6197 Returns a one-line description of the author
6199 =item CPAN::Author::as_string()
6201 Returns a multi-line description of the author
6203 =item CPAN::Author::email()
6205 Returns the author's email address
6207 =item CPAN::Author::fullname()
6209 Returns the author's name
6211 =item CPAN::Author::name()
6213 An alias for fullname
6215 =item CPAN::Bundle::as_glimpse()
6217 Returns a one-line description of the bundle
6219 =item CPAN::Bundle::as_string()
6221 Returns a multi-line description of the bundle
6223 =item CPAN::Bundle::clean()
6225 Recursively runs the C<clean> method on all items contained in the bundle.
6227 =item CPAN::Bundle::contains()
6229 Returns a list of objects' IDs contained in a bundle. The associated
6230 objects may be bundles, modules or distributions.
6232 =item CPAN::Bundle::force($method,@args)
6234 Forces CPAN to perform a task that normally would have failed. Force
6235 takes as arguments a method name to be called and any number of
6236 additional arguments that should be passed to the called method. The
6237 internals of the object get the needed changes so that CPAN.pm does
6238 not refuse to take the action. The C<force> is passed recursively to
6239 all contained objects.
6241 =item CPAN::Bundle::get()
6243 Recursively runs the C<get> method on all items contained in the bundle
6245 =item CPAN::Bundle::inst_file()
6247 Returns the highest installed version of the bundle in either @INC or
6248 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6249 CPAN::Module::inst_file.
6251 =item CPAN::Bundle::inst_version()
6253 Like CPAN::Bundle::inst_file, but returns the $VERSION
6255 =item CPAN::Bundle::uptodate()
6257 Returns 1 if the bundle itself and all its members are uptodate.
6259 =item CPAN::Bundle::install()
6261 Recursively runs the C<install> method on all items contained in the bundle
6263 =item CPAN::Bundle::make()
6265 Recursively runs the C<make> method on all items contained in the bundle
6267 =item CPAN::Bundle::readme()
6269 Recursively runs the C<readme> method on all items contained in the bundle
6271 =item CPAN::Bundle::test()
6273 Recursively runs the C<test> method on all items contained in the bundle
6275 =item CPAN::Distribution::as_glimpse()
6277 Returns a one-line description of the distribution
6279 =item CPAN::Distribution::as_string()
6281 Returns a multi-line description of the distribution
6283 =item CPAN::Distribution::clean()
6285 Changes to the directory where the distribution has been unpacked and
6286 runs C<make clean> there.
6288 =item CPAN::Distribution::containsmods()
6290 Returns a list of IDs of modules contained in a distribution file.
6291 Only works for distributions listed in the 02packages.details.txt.gz
6292 file. This typically means that only the most recent version of a
6293 distribution is covered.
6295 =item CPAN::Distribution::cvs_import()
6297 Changes to the directory where the distribution has been unpacked and
6300 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6304 =item CPAN::Distribution::dir()
6306 Returns the directory into which this distribution has been unpacked.
6308 =item CPAN::Distribution::force($method,@args)
6310 Forces CPAN to perform a task that normally would have failed. Force
6311 takes as arguments a method name to be called and any number of
6312 additional arguments that should be passed to the called method. The
6313 internals of the object get the needed changes so that CPAN.pm does
6314 not refuse to take the action.
6316 =item CPAN::Distribution::get()
6318 Downloads the distribution from CPAN and unpacks it. Does nothing if
6319 the distribution has already been downloaded and unpacked within the
6322 =item CPAN::Distribution::install()
6324 Changes to the directory where the distribution has been unpacked and
6325 runs the external command C<make install> there. If C<make> has not
6326 yet been run, it will be run first. A C<make test> will be issued in
6327 any case and if this fails, the install will be canceled. The
6328 cancellation can be avoided by letting C<force> run the C<install> for
6331 =item CPAN::Distribution::isa_perl()
6333 Returns 1 if this distribution file seems to be a perl distribution.
6334 Normally this is derived from the file name only, but the index from
6335 CPAN can contain a hint to achieve a return value of true for other
6338 =item CPAN::Distribution::look()
6340 Changes to the directory where the distribution has been unpacked and
6341 opens a subshell there. Exiting the subshell returns.
6343 =item CPAN::Distribution::make()
6345 First runs the C<get> method to make sure the distribution is
6346 downloaded and unpacked. Changes to the directory where the
6347 distribution has been unpacked and runs the external commands C<perl
6348 Makefile.PL> and C<make> there.
6350 =item CPAN::Distribution::prereq_pm()
6352 Returns the hash reference that has been announced by a distribution
6353 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6354 attempt has been made to C<make> the distribution. Returns undef
6357 =item CPAN::Distribution::readme()
6359 Downloads the README file associated with a distribution and runs it
6360 through the pager specified in C<$CPAN::Config->{pager}>.
6362 =item CPAN::Distribution::test()
6364 Changes to the directory where the distribution has been unpacked and
6365 runs C<make test> there.
6367 =item CPAN::Distribution::uptodate()
6369 Returns 1 if all the modules contained in the distribution are
6370 uptodate. Relies on containsmods.
6372 =item CPAN::Index::force_reload()
6374 Forces a reload of all indices.
6376 =item CPAN::Index::reload()
6378 Reloads all indices if they have been read more than
6379 C<$CPAN::Config->{index_expire}> days.
6381 =item CPAN::InfoObj::dump()
6383 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6384 inherit this method. It prints the data structure associated with an
6385 object. Useful for debugging. Note: the data structure is considered
6386 internal and thus subject to change without notice.
6388 =item CPAN::Module::as_glimpse()
6390 Returns a one-line description of the module
6392 =item CPAN::Module::as_string()
6394 Returns a multi-line description of the module
6396 =item CPAN::Module::clean()
6398 Runs a clean on the distribution associated with this module.
6400 =item CPAN::Module::cpan_file()
6402 Returns the filename on CPAN that is associated with the module.
6404 =item CPAN::Module::cpan_version()
6406 Returns the latest version of this module available on CPAN.
6408 =item CPAN::Module::cvs_import()
6410 Runs a cvs_import on the distribution associated with this module.
6412 =item CPAN::Module::description()
6414 Returns a 44 character description of this module. Only available for
6415 modules listed in The Module List (CPAN/modules/00modlist.long.html
6416 or 00modlist.long.txt.gz)
6418 =item CPAN::Module::force($method,@args)
6420 Forces CPAN to perform a task that normally would have failed. Force
6421 takes as arguments a method name to be called and any number of
6422 additional arguments that should be passed to the called method. The
6423 internals of the object get the needed changes so that CPAN.pm does
6424 not refuse to take the action.
6426 =item CPAN::Module::get()
6428 Runs a get on the distribution associated with this module.
6430 =item CPAN::Module::inst_file()
6432 Returns the filename of the module found in @INC. The first file found
6433 is reported just like perl itself stops searching @INC when it finds a
6436 =item CPAN::Module::inst_version()
6438 Returns the version number of the module in readable format.
6440 =item CPAN::Module::install()
6442 Runs an C<install> on the distribution associated with this module.
6444 =item CPAN::Module::look()
6446 Changes to the directory where the distribution associated with this
6447 module has been unpacked and opens a subshell there. Exiting the
6450 =item CPAN::Module::make()
6452 Runs a C<make> on the distribution associated with this module.
6454 =item CPAN::Module::manpage_headline()
6456 If module is installed, peeks into the module's manpage, reads the
6457 headline and returns it. Moreover, if the module has been downloaded
6458 within this session, does the equivalent on the downloaded module even
6459 if it is not installed.
6461 =item CPAN::Module::readme()
6463 Runs a C<readme> on the distribution associated with this module.
6465 =item CPAN::Module::test()
6467 Runs a C<test> on the distribution associated with this module.
6469 =item CPAN::Module::uptodate()
6471 Returns 1 if the module is installed and up-to-date.
6473 =item CPAN::Module::userid()
6475 Returns the author's ID of the module.
6479 =head2 Cache Manager
6481 Currently the cache manager only keeps track of the build directory
6482 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6483 deletes complete directories below C<build_dir> as soon as the size of
6484 all directories there gets bigger than $CPAN::Config->{build_cache}
6485 (in MB). The contents of this cache may be used for later
6486 re-installations that you intend to do manually, but will never be
6487 trusted by CPAN itself. This is due to the fact that the user might
6488 use these directories for building modules on different architectures.
6490 There is another directory ($CPAN::Config->{keep_source_where}) where
6491 the original distribution files are kept. This directory is not
6492 covered by the cache manager and must be controlled by the user. If
6493 you choose to have the same directory as build_dir and as
6494 keep_source_where directory, then your sources will be deleted with
6495 the same fifo mechanism.
6499 A bundle is just a perl module in the namespace Bundle:: that does not
6500 define any functions or methods. It usually only contains documentation.
6502 It starts like a perl module with a package declaration and a $VERSION
6503 variable. After that the pod section looks like any other pod with the
6504 only difference being that I<one special pod section> exists starting with
6509 In this pod section each line obeys the format
6511 Module_Name [Version_String] [- optional text]
6513 The only required part is the first field, the name of a module
6514 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6515 of the line is optional. The comment part is delimited by a dash just
6516 as in the man page header.
6518 The distribution of a bundle should follow the same convention as
6519 other distributions.
6521 Bundles are treated specially in the CPAN package. If you say 'install
6522 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6523 the modules in the CONTENTS section of the pod. You can install your
6524 own Bundles locally by placing a conformant Bundle file somewhere into
6525 your @INC path. The autobundle() command which is available in the
6526 shell interface does that for you by including all currently installed
6527 modules in a snapshot bundle file.
6529 =head2 Prerequisites
6531 If you have a local mirror of CPAN and can access all files with
6532 "file:" URLs, then you only need a perl better than perl5.003 to run
6533 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6534 required for non-UNIX systems or if your nearest CPAN site is
6535 associated with a URL that is not C<ftp:>.
6537 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6538 implemented for an external ftp command or for an external lynx
6541 =head2 Finding packages and VERSION
6543 This module presumes that all packages on CPAN
6549 declare their $VERSION variable in an easy to parse manner. This
6550 prerequisite can hardly be relaxed because it consumes far too much
6551 memory to load all packages into the running program just to determine
6552 the $VERSION variable. Currently all programs that are dealing with
6553 version use something like this
6555 perl -MExtUtils::MakeMaker -le \
6556 'print MM->parse_version(shift)' filename
6558 If you are author of a package and wonder if your $VERSION can be
6559 parsed, please try the above method.
6563 come as compressed or gzipped tarfiles or as zip files and contain a
6564 Makefile.PL (well, we try to handle a bit more, but without much
6571 The debugging of this module is a bit complex, because we have
6572 interferences of the software producing the indices on CPAN, of the
6573 mirroring process on CPAN, of packaging, of configuration, of
6574 synchronicity, and of bugs within CPAN.pm.
6576 For code debugging in interactive mode you can try "o debug" which
6577 will list options for debugging the various parts of the code. You
6578 should know that "o debug" has built-in completion support.
6580 For data debugging there is the C<dump> command which takes the same
6581 arguments as make/test/install and outputs the object's Data::Dumper
6584 =head2 Floppy, Zip, Offline Mode
6586 CPAN.pm works nicely without network too. If you maintain machines
6587 that are not networked at all, you should consider working with file:
6588 URLs. Of course, you have to collect your modules somewhere first. So
6589 you might use CPAN.pm to put together all you need on a networked
6590 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6591 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6592 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6593 with this floppy. See also below the paragraph about CD-ROM support.
6595 =head1 CONFIGURATION
6597 When the CPAN module is installed, a site wide configuration file is
6598 created as CPAN/Config.pm. The default values defined there can be
6599 overridden in another configuration file: CPAN/MyConfig.pm. You can
6600 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6601 $HOME/.cpan is added to the search path of the CPAN module before the
6602 use() or require() statements.
6604 Currently the following keys in the hash reference $CPAN::Config are
6607 build_cache size of cache for directories to build modules
6608 build_dir locally accessible directory to build modules
6609 index_expire after this many days refetch index files
6610 cache_metadata use serializer to cache metadata
6611 cpan_home local directory reserved for this package
6612 dontload_hash anonymous hash: modules in the keys will not be
6613 loaded by the CPAN::has_inst() routine
6614 gzip location of external program gzip
6615 inactivity_timeout breaks interactive Makefile.PLs after this
6616 many seconds inactivity. Set to 0 to never break.
6617 inhibit_startup_message
6618 if true, does not print the startup message
6619 keep_source_where directory in which to keep the source (if we do)
6620 make location of external make program
6621 make_arg arguments that should always be passed to 'make'
6622 make_install_arg same as make_arg for 'make install'
6623 makepl_arg arguments passed to 'perl Makefile.PL'
6624 pager location of external program more (or any pager)
6625 prerequisites_policy
6626 what to do if you are missing module prerequisites
6627 ('follow' automatically, 'ask' me, or 'ignore')
6628 proxy_user username for accessing an authenticating proxy
6629 proxy_pass password for accessing an authenticating proxy
6630 scan_cache controls scanning of cache ('atstart' or 'never')
6631 tar location of external program tar
6632 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6633 (and nonsense for characters outside latin range)
6634 unzip location of external program unzip
6635 urllist arrayref to nearby CPAN sites (or equivalent locations)
6636 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6637 ftp_proxy, } the three usual variables for configuring
6638 http_proxy, } proxy requests. Both as CPAN::Config variables
6639 no_proxy } and as environment variables configurable.
6641 You can set and query each of these options interactively in the cpan
6642 shell with the command set defined within the C<o conf> command:
6646 =item C<o conf E<lt>scalar optionE<gt>>
6648 prints the current value of the I<scalar option>
6650 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6652 Sets the value of the I<scalar option> to I<value>
6654 =item C<o conf E<lt>list optionE<gt>>
6656 prints the current value of the I<list option> in MakeMaker's
6659 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6661 shifts or pops the array in the I<list option> variable
6663 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6665 works like the corresponding perl commands.
6669 =head2 Note on urllist parameter's format
6671 urllist parameters are URLs according to RFC 1738. We do a little
6672 guessing if your URL is not compliant, but if you have problems with
6673 file URLs, please try the correct format. Either:
6675 file://localhost/whatever/ftp/pub/CPAN/
6679 file:///home/ftp/pub/CPAN/
6681 =head2 urllist parameter has CD-ROM support
6683 The C<urllist> parameter of the configuration table contains a list of
6684 URLs that are to be used for downloading. If the list contains any
6685 C<file> URLs, CPAN always tries to get files from there first. This
6686 feature is disabled for index files. So the recommendation for the
6687 owner of a CD-ROM with CPAN contents is: include your local, possibly
6688 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6690 o conf urllist push file://localhost/CDROM/CPAN
6692 CPAN.pm will then fetch the index files from one of the CPAN sites
6693 that come at the beginning of urllist. It will later check for each
6694 module if there is a local copy of the most recent version.
6696 Another peculiarity of urllist is that the site that we could
6697 successfully fetch the last file from automatically gets a preference
6698 token and is tried as the first site for the next request. So if you
6699 add a new site at runtime it may happen that the previously preferred
6700 site will be tried another time. This means that if you want to disallow
6701 a site for the next transfer, it must be explicitly removed from
6706 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6707 install foreign, unmasked, unsigned code on your machine. We compare
6708 to a checksum that comes from the net just as the distribution file
6709 itself. If somebody has managed to tamper with the distribution file,
6710 they may have as well tampered with the CHECKSUMS file. Future
6711 development will go towards strong authentication.
6715 Most functions in package CPAN are exported per default. The reason
6716 for this is that the primary use is intended for the cpan shell or for
6719 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6721 Populating a freshly installed perl with my favorite modules is pretty
6722 easy if you maintain a private bundle definition file. To get a useful
6723 blueprint of a bundle definition file, the command autobundle can be used
6724 on the CPAN shell command line. This command writes a bundle definition
6725 file for all modules that are installed for the currently running perl
6726 interpreter. It's recommended to run this command only once and from then
6727 on maintain the file manually under a private name, say
6728 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6730 cpan> install Bundle::my_bundle
6732 then answer a few questions and then go out for a coffee.
6734 Maintaining a bundle definition file means keeping track of two
6735 things: dependencies and interactivity. CPAN.pm sometimes fails on
6736 calculating dependencies because not all modules define all MakeMaker
6737 attributes correctly, so a bundle definition file should specify
6738 prerequisites as early as possible. On the other hand, it's a bit
6739 annoying that many distributions need some interactive configuring. So
6740 what I try to accomplish in my private bundle file is to have the
6741 packages that need to be configured early in the file and the gentle
6742 ones later, so I can go out after a few minutes and leave CPAN.pm
6745 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6747 Thanks to Graham Barr for contributing the following paragraphs about
6748 the interaction between perl, and various firewall configurations. For
6749 further informations on firewalls, it is recommended to consult the
6750 documentation that comes with the ncftp program. If you are unable to
6751 go through the firewall with a simple Perl setup, it is very likely
6752 that you can configure ncftp so that it works for your firewall.
6754 =head2 Three basic types of firewalls
6756 Firewalls can be categorized into three basic types.
6762 This is where the firewall machine runs a web server and to access the
6763 outside world you must do it via the web server. If you set environment
6764 variables like http_proxy or ftp_proxy to a values beginning with http://
6765 or in your web browser you have to set proxy information then you know
6766 you are running an http firewall.
6768 To access servers outside these types of firewalls with perl (even for
6769 ftp) you will need to use LWP.
6773 This where the firewall machine runs an ftp server. This kind of
6774 firewall will only let you access ftp servers outside the firewall.
6775 This is usually done by connecting to the firewall with ftp, then
6776 entering a username like "user@outside.host.com"
6778 To access servers outside these type of firewalls with perl you
6779 will need to use Net::FTP.
6781 =item One way visibility
6783 I say one way visibility as these firewalls try to make themselves look
6784 invisible to the users inside the firewall. An FTP data connection is
6785 normally created by sending the remote server your IP address and then
6786 listening for the connection. But the remote server will not be able to
6787 connect to you because of the firewall. So for these types of firewall
6788 FTP connections need to be done in a passive mode.
6790 There are two that I can think off.
6796 If you are using a SOCKS firewall you will need to compile perl and link
6797 it with the SOCKS library, this is what is normally called a 'socksified'
6798 perl. With this executable you will be able to connect to servers outside
6799 the firewall as if it is not there.
6803 This is the firewall implemented in the Linux kernel, it allows you to
6804 hide a complete network behind one IP address. With this firewall no
6805 special compiling is needed as you can access hosts directly.
6811 =head2 Configuring lynx or ncftp for going through a firewall
6813 If you can go through your firewall with e.g. lynx, presumably with a
6816 /usr/local/bin/lynx -pscott:tiger
6818 then you would configure CPAN.pm with the command
6820 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6822 That's all. Similarly for ncftp or ftp, you would configure something
6825 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6827 Your mileage may vary...
6835 I installed a new version of module X but CPAN keeps saying,
6836 I have the old version installed
6838 Most probably you B<do> have the old version installed. This can
6839 happen if a module installs itself into a different directory in the
6840 @INC path than it was previously installed. This is not really a
6841 CPAN.pm problem, you would have the same problem when installing the
6842 module manually. The easiest way to prevent this behaviour is to add
6843 the argument C<UNINST=1> to the C<make install> call, and that is why
6844 many people add this argument permanently by configuring
6846 o conf make_install_arg UNINST=1
6850 So why is UNINST=1 not the default?
6852 Because there are people who have their precise expectations about who
6853 may install where in the @INC path and who uses which @INC array. In
6854 fine tuned environments C<UNINST=1> can cause damage.
6858 I want to clean up my mess, and install a new perl along with
6859 all modules I have. How do I go about it?
6861 Run the autobundle command for your old perl and optionally rename the
6862 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6863 with the Configure option prefix, e.g.
6865 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6867 Install the bundle file you produced in the first step with something like
6869 cpan> install Bundle::mybundle
6875 When I install bundles or multiple modules with one command
6876 there is too much output to keep track of.
6878 You may want to configure something like
6880 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6881 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6883 so that STDOUT is captured in a file for later inspection.
6888 I am not root, how can I install a module in a personal directory?
6890 You will most probably like something like this:
6892 o conf makepl_arg "LIB=~/myperl/lib \
6893 INSTALLMAN1DIR=~/myperl/man/man1 \
6894 INSTALLMAN3DIR=~/myperl/man/man3"
6895 install Sybase::Sybperl
6897 You can make this setting permanent like all C<o conf> settings with
6900 You will have to add ~/myperl/man to the MANPATH environment variable
6901 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6904 use lib "$ENV{HOME}/myperl/lib";
6906 or setting the PERL5LIB environment variable.
6908 Another thing you should bear in mind is that the UNINST parameter
6909 should never be set if you are not root.
6913 How to get a package, unwrap it, and make a change before building it?
6915 look Sybase::Sybperl
6919 I installed a Bundle and had a couple of fails. When I
6920 retried, everything resolved nicely. Can this be fixed to work
6923 The reason for this is that CPAN does not know the dependencies of all
6924 modules when it starts out. To decide about the additional items to
6925 install, it just uses data found in the generated Makefile. An
6926 undetected missing piece breaks the process. But it may well be that
6927 your Bundle installs some prerequisite later than some depending item
6928 and thus your second try is able to resolve everything. Please note,
6929 CPAN.pm does not know the dependency tree in advance and cannot sort
6930 the queue of things to install in a topologically correct order. It
6931 resolves perfectly well IFF all modules declare the prerequisites
6932 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6933 fail and you need to install often, it is recommended sort the Bundle
6934 definition file manually. It is planned to improve the metadata
6935 situation for dependencies on CPAN in general, but this will still
6940 In our intranet we have many modules for internal use. How
6941 can I integrate these modules with CPAN.pm but without uploading
6942 the modules to CPAN?
6944 Have a look at the CPAN::Site module.
6948 When I run CPAN's shell, I get error msg about line 1 to 4,
6949 setting meta input/output via the /etc/inputrc file.
6951 Some versions of readline are picky about capitalization in the
6952 /etc/inputrc file and specifically RedHat 6.2 comes with a
6953 /etc/inputrc that contains the word C<on> in lowercase. Change the
6954 occurrences of C<on> to C<On> and the bug should disappear.
6958 Some authors have strange characters in their names.
6960 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
6961 expecting ISO-8859-1 charset, a converter can be activated by setting
6962 term_is_latin to a true value in your config file. One way of doing so
6965 cpan> ! $CPAN::Config->{term_is_latin}=1
6967 Extended support for converters will be made available as soon as perl
6968 becomes stable with regard to charset issues.
6974 We should give coverage for B<all> of the CPAN and not just the PAUSE
6975 part, right? In this discussion CPAN and PAUSE have become equal --
6976 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6977 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6979 Future development should be directed towards a better integration of
6982 If a Makefile.PL requires special customization of libraries, prompts
6983 the user for special input, etc. then you may find CPAN is not able to
6984 build the distribution. In that case, you should attempt the
6985 traditional method of building a Perl module package from a shell.
6989 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
6993 Kawai,Takanori provides a Japanese translation of this manpage at
6994 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
6998 perl(1), CPAN::Nox(3)