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 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2274 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2276 $last = $#{$CPAN::Config->{urllist}};
2277 if ($force & 2) { # local cpans probably out of date, don't reorder
2278 @reordered = (0..$last);
2282 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2284 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2295 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2297 @levels = qw/easy hard hardest/;
2299 @levels = qw/easy/ if $^O eq 'MacOS';
2301 for $levelno (0..$#levels) {
2302 my $level = $levels[$levelno];
2303 my $method = "host$level";
2304 my @host_seq = $level eq "easy" ?
2305 @reordered : 0..$last; # reordered has CDROM up front
2306 @host_seq = (0) unless @host_seq;
2307 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2309 $Themethod = $level;
2311 # utime $now, $now, $aslocal; # too bad, if we do that, we
2312 # might alter a local mirror
2313 $self->debug("level[$level]") if $CPAN::DEBUG;
2317 last if $CPAN::Signal; # need to cleanup
2320 unless ($CPAN::Signal) {
2323 qq{Please check, if the URLs I found in your configuration file \(}.
2324 join(", ", @{$CPAN::Config->{urllist}}).
2325 qq{\) are valid. The urllist can be edited.},
2326 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2327 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2329 $CPAN::Frontend->myprint("Could not fetch $file\n");
2332 rename "$aslocal.bak", $aslocal;
2333 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2334 $self->ls($aslocal));
2341 my($self,$host_seq,$file,$aslocal) = @_;
2343 HOSTEASY: for $i (@$host_seq) {
2344 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2345 $url .= "/" unless substr($url,-1) eq "/";
2347 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2348 if ($url =~ /^file:/) {
2350 if ($CPAN::META->has_inst('URI::URL')) {
2351 my $u = URI::URL->new($url);
2353 } else { # works only on Unix, is poorly constructed, but
2354 # hopefully better than nothing.
2355 # RFC 1738 says fileurl BNF is
2356 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2357 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2359 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2360 $l =~ s|^file:||; # assume they
2363 $l =~ s|^/||s unless -f $l; # e.g. /P:
2364 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2366 if ( -f $l && -r _) {
2370 # Maybe mirror has compressed it?
2372 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2373 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2380 if ($CPAN::META->has_usable('LWP')) {
2381 $CPAN::Frontend->myprint("Fetching with LWP:
2385 CPAN::LWP::UserAgent->config;
2386 eval { $Ua = CPAN::LWP::UserAgent->new; };
2388 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
2391 my $res = $Ua->mirror($url, $aslocal);
2392 if ($res->is_success) {
2395 utime $now, $now, $aslocal; # download time is more
2396 # important than upload time
2398 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2399 my $gzurl = "$url.gz";
2400 $CPAN::Frontend->myprint("Fetching with LWP:
2403 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2404 if ($res->is_success &&
2405 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2411 $CPAN::Frontend->myprint(sprintf(
2412 "LWP failed with code[%s] message[%s]\n",
2416 # Alan Burlison informed me that in firewall environments
2417 # Net::FTP can still succeed where LWP fails. So we do not
2418 # skip Net::FTP anymore when LWP is available.
2421 $CPAN::Frontend->myprint("LWP not available\n");
2423 return if $CPAN::Signal;
2424 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2425 # that's the nice and easy way thanks to Graham
2426 my($host,$dir,$getfile) = ($1,$2,$3);
2427 if ($CPAN::META->has_usable('Net::FTP')) {
2429 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2432 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2433 "aslocal[$aslocal]") if $CPAN::DEBUG;
2434 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2438 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2439 my $gz = "$aslocal.gz";
2440 $CPAN::Frontend->myprint("Fetching with Net::FTP
2443 if (CPAN::FTP->ftp_get($host,
2447 CPAN::Tarzip->gunzip($gz,$aslocal)
2456 return if $CPAN::Signal;
2461 my($self,$host_seq,$file,$aslocal) = @_;
2463 # Came back if Net::FTP couldn't establish connection (or
2464 # failed otherwise) Maybe they are behind a firewall, but they
2465 # gave us a socksified (or other) ftp program...
2468 my($devnull) = $CPAN::Config->{devnull} || "";
2470 my($aslocal_dir) = File::Basename::dirname($aslocal);
2471 File::Path::mkpath($aslocal_dir);
2472 HOSTHARD: for $i (@$host_seq) {
2473 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2474 $url .= "/" unless substr($url,-1) eq "/";
2476 my($proto,$host,$dir,$getfile);
2478 # Courtesy Mark Conty mark_conty@cargill.com change from
2479 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2481 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2482 # proto not yet used
2483 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2485 next HOSTHARD; # who said, we could ftp anything except ftp?
2487 next HOSTHARD if $proto eq "file"; # file URLs would have had
2488 # success above. Likely a bogus URL
2490 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2492 for $f ('lynx','ncftpget','ncftp','wget') {
2493 next unless exists $CPAN::Config->{$f};
2494 $funkyftp = $CPAN::Config->{$f};
2495 next unless defined $funkyftp;
2496 next if $funkyftp =~ /^\s*$/;
2497 my($asl_ungz, $asl_gz);
2498 ($asl_ungz = $aslocal) =~ s/\.gz//;
2499 $asl_gz = "$asl_ungz.gz";
2500 my($src_switch) = "";
2502 $src_switch = " -source";
2503 } elsif ($f eq "ncftp"){
2504 $src_switch = " -c";
2505 } elsif ($f eq "wget"){
2506 $src_switch = " -O -";
2509 my($stdout_redir) = " > $asl_ungz";
2510 if ($f eq "ncftpget"){
2511 $chdir = "cd $aslocal_dir && ";
2514 $CPAN::Frontend->myprint(
2516 Trying with "$funkyftp$src_switch" to get
2520 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2521 $self->debug("system[$system]") if $CPAN::DEBUG;
2523 if (($wstatus = system($system)) == 0
2526 -s $asl_ungz # lynx returns 0 when it fails somewhere
2532 } elsif ($asl_ungz ne $aslocal) {
2533 # test gzip integrity
2534 if (CPAN::Tarzip->gtest($asl_ungz)) {
2535 # e.g. foo.tar is gzipped --> foo.tar.gz
2536 rename $asl_ungz, $aslocal;
2538 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2543 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2545 -f $asl_ungz && -s _ == 0;
2546 my $gz = "$aslocal.gz";
2547 my $gzurl = "$url.gz";
2548 $CPAN::Frontend->myprint(
2550 Trying with "$funkyftp$src_switch" to get
2553 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2554 $self->debug("system[$system]") if $CPAN::DEBUG;
2556 if (($wstatus = system($system)) == 0
2560 # test gzip integrity
2561 if (CPAN::Tarzip->gtest($asl_gz)) {
2562 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2564 # somebody uncompressed file for us?
2565 rename $asl_ungz, $aslocal;
2570 unlink $asl_gz if -f $asl_gz;
2573 my $estatus = $wstatus >> 8;
2574 my $size = -f $aslocal ?
2575 ", left\n$aslocal with size ".-s _ :
2576 "\nWarning: expected file [$aslocal] doesn't exist";
2577 $CPAN::Frontend->myprint(qq{
2578 System call "$system"
2579 returned status $estatus (wstat $wstatus)$size
2582 return if $CPAN::Signal;
2583 } # lynx,ncftpget,ncftp
2588 my($self,$host_seq,$file,$aslocal) = @_;
2591 my($aslocal_dir) = File::Basename::dirname($aslocal);
2592 File::Path::mkpath($aslocal_dir);
2593 HOSTHARDEST: for $i (@$host_seq) {
2594 unless (length $CPAN::Config->{'ftp'}) {
2595 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2598 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2599 $url .= "/" unless substr($url,-1) eq "/";
2601 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2602 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2605 my($host,$dir,$getfile) = ($1,$2,$3);
2607 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2608 $ctime,$blksize,$blocks) = stat($aslocal);
2609 $timestamp = $mtime ||= 0;
2610 my($netrc) = CPAN::FTP::netrc->new;
2611 my($netrcfile) = $netrc->netrc;
2612 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2613 my $targetfile = File::Basename::basename($aslocal);
2619 map("cd $_", split "/", $dir), # RFC 1738
2621 "get $getfile $targetfile",
2625 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2626 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2627 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2629 $netrc->contains($host))) if $CPAN::DEBUG;
2630 if ($netrc->protected) {
2631 $CPAN::Frontend->myprint(qq{
2632 Trying with external ftp to get
2634 As this requires some features that are not thoroughly tested, we\'re
2635 not sure, that we get it right....
2639 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2641 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2642 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2644 if ($mtime > $timestamp) {
2645 $CPAN::Frontend->myprint("GOT $aslocal\n");
2649 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2651 return if $CPAN::Signal;
2653 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2654 qq{correctly protected.\n});
2657 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2658 nor does it have a default entry\n");
2661 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2662 # then and login manually to host, using e-mail as
2664 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2668 "user anonymous $Config::Config{'cf_email'}"
2670 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2671 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2672 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2674 if ($mtime > $timestamp) {
2675 $CPAN::Frontend->myprint("GOT $aslocal\n");
2679 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2681 return if $CPAN::Signal;
2682 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2688 my($self,$command,@dialog) = @_;
2689 my $fh = FileHandle->new;
2690 $fh->open("|$command") or die "Couldn't open ftp: $!";
2691 foreach (@dialog) { $fh->print("$_\n") }
2692 $fh->close; # Wait for process to complete
2694 my $estatus = $wstatus >> 8;
2695 $CPAN::Frontend->myprint(qq{
2696 Subprocess "|$command"
2697 returned status $estatus (wstat $wstatus)
2701 # find2perl needs modularization, too, all the following is stolen
2705 my($self,$name) = @_;
2706 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2707 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2709 my($perms,%user,%group);
2713 $blocks = int(($blocks + 1) / 2);
2716 $blocks = int(($sizemm + 1023) / 1024);
2719 if (-f _) { $perms = '-'; }
2720 elsif (-d _) { $perms = 'd'; }
2721 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2722 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2723 elsif (-p _) { $perms = 'p'; }
2724 elsif (-S _) { $perms = 's'; }
2725 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2727 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2728 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2729 my $tmpmode = $mode;
2730 my $tmp = $rwx[$tmpmode & 7];
2732 $tmp = $rwx[$tmpmode & 7] . $tmp;
2734 $tmp = $rwx[$tmpmode & 7] . $tmp;
2735 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2736 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2737 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2740 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2741 my $group = $group{$gid} || $gid;
2743 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2745 my($moname) = $moname[$mon];
2746 if (-M _ > 365.25 / 2) {
2747 $timeyear = $year + 1900;
2750 $timeyear = sprintf("%02d:%02d", $hour, $min);
2753 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2767 package CPAN::FTP::netrc;
2771 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2773 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2774 $atime,$mtime,$ctime,$blksize,$blocks)
2779 my($fh,@machines,$hasdefault);
2781 $fh = FileHandle->new or die "Could not create a filehandle";
2783 if($fh->open($file)){
2784 $protected = ($mode & 077) == 0;
2786 NETRC: while (<$fh>) {
2787 my(@tokens) = split " ", $_;
2788 TOKEN: while (@tokens) {
2789 my($t) = shift @tokens;
2790 if ($t eq "default"){
2794 last TOKEN if $t eq "macdef";
2795 if ($t eq "machine") {
2796 push @machines, shift @tokens;
2801 $file = $hasdefault = $protected = "";
2805 'mach' => [@machines],
2807 'hasdefault' => $hasdefault,
2808 'protected' => $protected,
2812 # CPAN::FTP::hasdefault;
2813 sub hasdefault { shift->{'hasdefault'} }
2814 sub netrc { shift->{'netrc'} }
2815 sub protected { shift->{'protected'} }
2817 my($self,$mach) = @_;
2818 for ( @{$self->{'mach'}} ) {
2819 return 1 if $_ eq $mach;
2824 package CPAN::Complete;
2827 my($text, $line, $start, $end) = @_;
2828 my(@perlret) = cpl($text, $line, $start);
2829 # find longest common match. Can anybody show me how to peruse
2830 # T::R::Gnu to have this done automatically? Seems expensive.
2831 return () unless @perlret;
2832 my($newtext) = $text;
2833 for (my $i = length($text)+1;;$i++) {
2834 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2835 my $try = substr($perlret[0],0,$i);
2836 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2837 # warn "try[$try]tries[@tries]";
2838 if (@tries == @perlret) {
2844 ($newtext,@perlret);
2847 #-> sub CPAN::Complete::cpl ;
2849 my($word,$line,$pos) = @_;
2853 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2855 if ($line =~ s/^(force\s*)//) {
2860 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2861 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2863 } elsif ($line =~ /^(a|ls)\s/) {
2864 @return = cplx('CPAN::Author',uc($word));
2865 } elsif ($line =~ /^b\s/) {
2866 CPAN::Shell->local_bundles;
2867 @return = cplx('CPAN::Bundle',$word);
2868 } elsif ($line =~ /^d\s/) {
2869 @return = cplx('CPAN::Distribution',$word);
2870 } elsif ($line =~ m/^(
2871 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2873 if ($word =~ /^Bundle::/) {
2874 CPAN::Shell->local_bundles;
2876 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2877 } elsif ($line =~ /^i\s/) {
2878 @return = cpl_any($word);
2879 } elsif ($line =~ /^reload\s/) {
2880 @return = cpl_reload($word,$line,$pos);
2881 } elsif ($line =~ /^o\s/) {
2882 @return = cpl_option($word,$line,$pos);
2883 } elsif ($line =~ m/^\S+\s/ ) {
2884 # fallback for future commands and what we have forgotten above
2885 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2892 #-> sub CPAN::Complete::cplx ;
2894 my($class, $word) = @_;
2895 # I believed for many years that this was sorted, today I
2896 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2897 # make it sorted again. Maybe sort was dropped when GNU-readline
2898 # support came in? The RCS file is difficult to read on that:-(
2899 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2902 #-> sub CPAN::Complete::cpl_any ;
2906 cplx('CPAN::Author',$word),
2907 cplx('CPAN::Bundle',$word),
2908 cplx('CPAN::Distribution',$word),
2909 cplx('CPAN::Module',$word),
2913 #-> sub CPAN::Complete::cpl_reload ;
2915 my($word,$line,$pos) = @_;
2917 my(@words) = split " ", $line;
2918 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2919 my(@ok) = qw(cpan index);
2920 return @ok if @words == 1;
2921 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2924 #-> sub CPAN::Complete::cpl_option ;
2926 my($word,$line,$pos) = @_;
2928 my(@words) = split " ", $line;
2929 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2930 my(@ok) = qw(conf debug);
2931 return @ok if @words == 1;
2932 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2934 } elsif ($words[1] eq 'index') {
2936 } elsif ($words[1] eq 'conf') {
2937 return CPAN::Config::cpl(@_);
2938 } elsif ($words[1] eq 'debug') {
2939 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2943 package CPAN::Index;
2945 #-> sub CPAN::Index::force_reload ;
2948 $CPAN::Index::LAST_TIME = 0;
2952 #-> sub CPAN::Index::reload ;
2954 my($cl,$force) = @_;
2957 # XXX check if a newer one is available. (We currently read it
2958 # from time to time)
2959 for ($CPAN::Config->{index_expire}) {
2960 $_ = 0.001 unless $_ && $_ > 0.001;
2962 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2963 # debug here when CPAN doesn't seem to read the Metadata
2965 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2967 unless ($CPAN::META->{PROTOCOL}) {
2968 $cl->read_metadata_cache;
2969 $CPAN::META->{PROTOCOL} ||= "1.0";
2971 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
2972 # warn "Setting last_time to 0";
2973 $LAST_TIME = 0; # No warning necessary
2975 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
2978 # IFF we are developing, it helps to wipe out the memory
2979 # between reloads, otherwise it is not what a user expects.
2980 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2981 $CPAN::META = CPAN->new;
2985 local $LAST_TIME = $time;
2986 local $CPAN::META->{PROTOCOL} = PROTOCOL;
2988 my $needshort = $^O eq "dos";
2990 $cl->rd_authindex($cl
2992 "authors/01mailrc.txt.gz",
2994 File::Spec->catfile('authors', '01mailrc.gz') :
2995 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2998 $debug = "timing reading 01[".($t2 - $time)."]";
3000 return if $CPAN::Signal; # this is sometimes lengthy
3001 $cl->rd_modpacks($cl
3003 "modules/02packages.details.txt.gz",
3005 File::Spec->catfile('modules', '02packag.gz') :
3006 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3009 $debug .= "02[".($t2 - $time)."]";
3011 return if $CPAN::Signal; # this is sometimes lengthy
3014 "modules/03modlist.data.gz",
3016 File::Spec->catfile('modules', '03mlist.gz') :
3017 File::Spec->catfile('modules', '03modlist.data.gz'),
3019 $cl->write_metadata_cache;
3021 $debug .= "03[".($t2 - $time)."]";
3023 CPAN->debug($debug) if $CPAN::DEBUG;
3026 $CPAN::META->{PROTOCOL} = PROTOCOL;
3029 #-> sub CPAN::Index::reload_x ;
3031 my($cl,$wanted,$localname,$force) = @_;
3032 $force |= 2; # means we're dealing with an index here
3033 CPAN::Config->load; # we should guarantee loading wherever we rely
3035 $localname ||= $wanted;
3036 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3040 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3043 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3044 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3045 qq{day$s. I\'ll use that.});
3048 $force |= 1; # means we're quite serious about it.
3050 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3053 #-> sub CPAN::Index::rd_authindex ;
3055 my($cl, $index_target) = @_;
3057 return unless defined $index_target;
3058 $CPAN::Frontend->myprint("Going to read $index_target\n");
3060 tie *FH, CPAN::Tarzip, $index_target;
3062 push @lines, split /\012/ while <FH>;
3064 my($userid,$fullname,$email) =
3065 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3066 next unless $userid && $fullname && $email;
3068 # instantiate an author object
3069 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3070 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3071 return if $CPAN::Signal;
3076 my($self,$dist) = @_;
3077 $dist = $self->{'id'} unless defined $dist;
3078 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3082 #-> sub CPAN::Index::rd_modpacks ;
3084 my($self, $index_target) = @_;
3086 return unless defined $index_target;
3087 $CPAN::Frontend->myprint("Going to read $index_target\n");
3088 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3090 while ($_ = $fh->READLINE) {
3092 my @ls = map {"$_\n"} split /\n/, $_;
3093 unshift @ls, "\n" x length($1) if /^(\n+)/;
3097 my($line_count,$last_updated);
3099 my $shift = shift(@lines);
3100 last if $shift =~ /^\s*$/;
3101 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3102 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3104 if (not defined $line_count) {
3106 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3107 Please check the validity of the index file by comparing it to more
3108 than one CPAN mirror. I'll continue but problems seem likely to
3113 } elsif ($line_count != scalar @lines) {
3115 warn sprintf qq{Warning: Your %s
3116 contains a Line-Count header of %d but I see %d lines there. Please
3117 check the validity of the index file by comparing it to more than one
3118 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3119 $index_target, $line_count, scalar(@lines);
3122 if (not defined $last_updated) {
3124 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3125 Please check the validity of the index file by comparing it to more
3126 than one CPAN mirror. I'll continue but problems seem likely to
3134 ->myprint(sprintf qq{ Database was generated on %s\n},
3136 $DATE_OF_02 = $last_updated;
3138 if ($CPAN::META->has_inst(HTTP::Date)) {
3140 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3145 qq{Warning: This index file is %d days old.
3146 Please check the host you chose as your CPAN mirror for staleness.
3147 I'll continue but problems seem likely to happen.\a\n},
3152 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3157 # A necessity since we have metadata_cache: delete what isn't
3159 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3160 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3164 # before 1.56 we split into 3 and discarded the rest. From
3165 # 1.57 we assign remaining text to $comment thus allowing to
3166 # influence isa_perl
3167 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3168 my($bundle,$id,$userid);
3170 if ($mod eq 'CPAN' &&
3172 CPAN::Queue->exists('Bundle::CPAN') ||
3173 CPAN::Queue->exists('CPAN')
3177 if ($version > $CPAN::VERSION){
3178 $CPAN::Frontend->myprint(qq{
3179 There's a new CPAN.pm version (v$version) available!
3180 [Current version is v$CPAN::VERSION]
3181 You might want to try
3182 install Bundle::CPAN
3184 without quitting the current session. It should be a seamless upgrade
3185 while we are running...
3188 $CPAN::Frontend->myprint(qq{\n});
3190 last if $CPAN::Signal;
3191 } elsif ($mod =~ /^Bundle::(.*)/) {
3196 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3197 # Let's make it a module too, because bundles have so much
3198 # in common with modules.
3200 # Changed in 1.57_63: seems like memory bloat now without
3201 # any value, so commented out
3203 # $CPAN::META->instance('CPAN::Module',$mod);
3207 # instantiate a module object
3208 $id = $CPAN::META->instance('CPAN::Module',$mod);
3212 if ($id->cpan_file ne $dist){ # update only if file is
3213 # different. CPAN prohibits same
3214 # name with different version
3215 $userid = $self->userid($dist);
3217 'CPAN_USERID' => $userid,
3218 'CPAN_VERSION' => $version,
3219 'CPAN_FILE' => $dist,
3223 # instantiate a distribution object
3224 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3225 # we do not need CONTAINSMODS unless we do something with
3226 # this dist, so we better produce it on demand.
3228 ## my $obj = $CPAN::META->instance(
3229 ## 'CPAN::Distribution' => $dist
3231 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3233 $CPAN::META->instance(
3234 'CPAN::Distribution' => $dist
3236 'CPAN_USERID' => $userid,
3237 'CPAN_COMMENT' => $comment,
3241 for my $name ($mod,$dist) {
3242 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3243 $exists{$name} = undef;
3246 return if $CPAN::Signal;
3250 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3251 for my $o ($CPAN::META->all_objects($class)) {
3252 next if exists $exists{$o->{ID}};
3253 $CPAN::META->delete($class,$o->{ID});
3254 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3261 #-> sub CPAN::Index::rd_modlist ;
3263 my($cl,$index_target) = @_;
3264 return unless defined $index_target;
3265 $CPAN::Frontend->myprint("Going to read $index_target\n");
3266 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3269 while ($_ = $fh->READLINE) {
3271 my @ls = map {"$_\n"} split /\n/, $_;
3272 unshift @ls, "\n" x length($1) if /^(\n+)/;
3276 my $shift = shift(@eval);
3277 if ($shift =~ /^Date:\s+(.*)/){
3278 return if $DATE_OF_03 eq $1;
3281 last if $shift =~ /^\s*$/;
3284 push @eval, q{CPAN::Modulelist->data;};
3286 my($comp) = Safe->new("CPAN::Safe1");
3287 my($eval) = join("", @eval);
3288 my $ret = $comp->reval($eval);
3289 Carp::confess($@) if $@;
3290 return if $CPAN::Signal;
3292 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3293 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3294 $obj->set(%{$ret->{$_}});
3295 return if $CPAN::Signal;
3299 #-> sub CPAN::Index::write_metadata_cache ;
3300 sub write_metadata_cache {
3302 return unless $CPAN::Config->{'cache_metadata'};
3303 return unless $CPAN::META->has_usable("Storable");
3305 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3306 CPAN::Distribution)) {
3307 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3309 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3310 $cache->{last_time} = $LAST_TIME;
3311 $cache->{DATE_OF_02} = $DATE_OF_02;
3312 $cache->{PROTOCOL} = PROTOCOL;
3313 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3314 eval { Storable::nstore($cache, $metadata_file) };
3315 $CPAN::Frontend->mywarn($@) if $@;
3318 #-> sub CPAN::Index::read_metadata_cache ;
3319 sub read_metadata_cache {
3321 return unless $CPAN::Config->{'cache_metadata'};
3322 return unless $CPAN::META->has_usable("Storable");
3323 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3324 return unless -r $metadata_file and -f $metadata_file;
3325 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3327 eval { $cache = Storable::retrieve($metadata_file) };
3328 $CPAN::Frontend->mywarn($@) if $@;
3329 if (!$cache || ref $cache ne 'HASH'){
3333 if (exists $cache->{PROTOCOL}) {
3334 if (PROTOCOL > $cache->{PROTOCOL}) {
3335 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3336 "with protocol v%s, requiring v%s",
3343 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3344 "with protocol v1.0");
3349 while(my($class,$v) = each %$cache) {
3350 next unless $class =~ /^CPAN::/;
3351 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3352 while (my($id,$ro) = each %$v) {
3353 $CPAN::META->{readwrite}{$class}{$id} ||=
3354 $class->new(ID=>$id, RO=>$ro);
3359 unless ($clcnt) { # sanity check
3360 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3363 if ($idcnt < 1000) {
3364 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3365 "in $metadata_file\n");
3368 $CPAN::META->{PROTOCOL} ||=
3369 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3370 # does initialize to some protocol
3371 $LAST_TIME = $cache->{last_time};
3372 $DATE_OF_02 = $cache->{DATE_OF_02};
3373 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3374 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3378 package CPAN::InfoObj;
3381 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3382 sub id { shift->{ID}; }
3384 #-> sub CPAN::InfoObj::new ;
3386 my $this = bless {}, shift;
3391 # The set method may only be used by code that reads index data or
3392 # otherwise "objective" data from the outside world. All session
3393 # related material may do anything else with instance variables but
3394 # must not touch the hash under the RO attribute. The reason is that
3395 # the RO hash gets written to Metadata file and is thus persistent.
3397 #-> sub CPAN::InfoObj::set ;
3399 my($self,%att) = @_;
3400 my $class = ref $self;
3402 # This must be ||=, not ||, because only if we write an empty
3403 # reference, only then the set method will write into the readonly
3404 # area. But for Distributions that spring into existence, maybe
3405 # because of a typo, we do not like it that they are written into
3406 # the readonly area and made permanent (at least for a while) and
3407 # that is why we do not "allow" other places to call ->set.
3408 unless ($self->id) {
3409 CPAN->debug("Bug? Empty ID, rejecting");
3412 my $ro = $self->{RO} =
3413 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3415 while (my($k,$v) = each %att) {
3420 #-> sub CPAN::InfoObj::as_glimpse ;
3424 my $class = ref($self);
3425 $class =~ s/^CPAN:://;
3426 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3430 #-> sub CPAN::InfoObj::as_string ;
3434 my $class = ref($self);
3435 $class =~ s/^CPAN:://;
3436 push @m, $class, " id = $self->{ID}\n";
3437 for (sort keys %{$self->{RO}}) {
3438 # next if m/^(ID|RO)$/;
3440 if ($_ eq "CPAN_USERID") {
3441 $extra .= " (".$self->author;
3442 my $email; # old perls!
3443 if ($email = $CPAN::META->instance("CPAN::Author",
3446 $extra .= " <$email>";
3448 $extra .= " <no email>";
3451 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3452 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3455 next unless defined $self->{RO}{$_};
3456 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3458 for (sort keys %$self) {
3459 next if m/^(ID|RO)$/;
3460 if (ref($self->{$_}) eq "ARRAY") {
3461 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3462 } elsif (ref($self->{$_}) eq "HASH") {
3466 join(" ",keys %{$self->{$_}}),
3469 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3475 #-> sub CPAN::InfoObj::author ;
3478 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3481 #-> sub CPAN::InfoObj::dump ;
3484 require Data::Dumper;
3485 print Data::Dumper::Dumper($self);
3488 package CPAN::Author;
3490 #-> sub CPAN::Author::id
3493 my $id = $self->{ID};
3494 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3498 #-> sub CPAN::Author::as_glimpse ;
3502 my $class = ref($self);
3503 $class =~ s/^CPAN:://;
3504 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3512 #-> sub CPAN::Author::fullname ;
3514 shift->{RO}{FULLNAME};
3518 #-> sub CPAN::Author::email ;
3519 sub email { shift->{RO}{EMAIL}; }
3521 #-> sub CPAN::Author::ls ;
3526 # adapted from CPAN::Distribution::verifyMD5 ;
3527 my(@csf); # chksumfile
3528 @csf = $self->id =~ /(.)(.)(.*)/;
3529 $csf[1] = join "", @csf[0,1];
3530 $csf[2] = join "", @csf[1,2];
3532 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3533 unless (grep {$_->[2] eq $csf[1]} @dl) {
3534 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3537 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3538 unless (grep {$_->[2] eq $csf[2]} @dl) {
3539 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3542 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3543 $CPAN::Frontend->myprint(join "", map {
3544 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3545 } sort { $a->[2] cmp $b->[2] } @dl);
3548 # returns an array of arrays, the latter contain (size,mtime,filename)
3549 #-> sub CPAN::Author::dir_listing ;
3552 my $chksumfile = shift;
3553 my $recursive = shift;
3555 File::Spec->catfile($CPAN::Config->{keep_source_where},
3556 "authors", "id", @$chksumfile);
3558 # connect "force" argument with "index_expire".
3560 if (my @stat = stat $lc_want) {
3561 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3563 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3566 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3567 $chksumfile->[-1] .= ".gz";
3568 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3571 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3572 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3578 # adapted from CPAN::Distribution::MD5_check_file ;
3579 my $fh = FileHandle->new;
3581 if (open $fh, $lc_file){
3584 $eval =~ s/\015?\012/\n/g;
3586 my($comp) = Safe->new();
3587 $cksum = $comp->reval($eval);
3589 rename $lc_file, "$lc_file.bad";
3590 Carp::confess($@) if $@;
3593 Carp::carp "Could not open $lc_file for reading";
3596 for $f (sort keys %$cksum) {
3597 if (exists $cksum->{$f}{isdir}) {
3599 my(@dir) = @$chksumfile;
3601 push @dir, $f, "CHECKSUMS";
3603 [$_->[0], $_->[1], "$f/$_->[2]"]
3604 } $self->dir_listing(\@dir,1);
3606 push @result, [ 0, "-", $f ];
3610 ($cksum->{$f}{"size"}||0),
3611 $cksum->{$f}{"mtime"}||"---",
3619 package CPAN::Distribution;
3622 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3626 delete $self->{later};
3629 # CPAN::Distribution::normalize
3632 $s = $self->id unless defined $s;
3636 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3638 return $s if $s =~ m:^N/A|^Contact Author: ;
3639 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3640 $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3641 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3646 #-> sub CPAN::Distribution::color_cmd_tmps ;
3647 sub color_cmd_tmps {
3649 my($depth) = shift || 0;
3650 my($color) = shift || 0;
3651 # a distribution needs to recurse into its prereq_pms
3653 return if exists $self->{incommandcolor}
3654 && $self->{incommandcolor}==$color;
3655 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3656 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3661 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3662 my $prereq_pm = $self->prereq_pm;
3663 if (defined $prereq_pm) {
3664 for my $pre (keys %$prereq_pm) {
3665 my $premo = CPAN::Shell->expand("Module",$pre);
3666 $premo->color_cmd_tmps($depth+1,$color);
3670 delete $self->{sponsored_mods};
3671 delete $self->{badtestcnt};
3673 $self->{incommandcolor} = $color;
3676 #-> sub CPAN::Distribution::as_string ;
3679 $self->containsmods;
3680 $self->SUPER::as_string(@_);
3683 #-> sub CPAN::Distribution::containsmods ;
3686 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3687 my $dist_id = $self->{ID};
3688 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3689 my $mod_file = $mod->cpan_file or next;
3690 my $mod_id = $mod->{ID} or next;
3691 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3693 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3695 keys %{$self->{CONTAINSMODS}};
3698 #-> sub CPAN::Distribution::uptodate ;
3702 foreach $c ($self->containsmods) {
3703 my $obj = CPAN::Shell->expandany($c);
3704 return 0 unless $obj->uptodate;
3709 #-> sub CPAN::Distribution::called_for ;
3712 $self->{CALLED_FOR} = $id if defined $id;
3713 return $self->{CALLED_FOR};
3716 #-> sub CPAN::Distribution::safe_chdir ;
3718 my($self,$todir) = @_;
3719 # we die if we cannot chdir and we are debuggable
3720 Carp::confess("safe_chdir called without todir argument")
3721 unless defined $todir and length $todir;
3723 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3726 my $cwd = CPAN::anycwd();
3727 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3728 qq{to todir[$todir]: $!});
3732 #-> sub CPAN::Distribution::get ;
3737 exists $self->{'build_dir'} and push @e,
3738 "Is already unwrapped into directory $self->{'build_dir'}";
3739 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3741 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3744 # Get the file on local disk
3749 File::Spec->catfile(
3750 $CPAN::Config->{keep_source_where},
3753 split("/",$self->id)
3756 $self->debug("Doing localize") if $CPAN::DEBUG;
3757 unless ($local_file =
3758 CPAN::FTP->localize("authors/id/$self->{ID}",
3761 if ($CPAN::Index::DATE_OF_02) {
3762 $note = "Note: Current database in memory was generated ".
3763 "on $CPAN::Index::DATE_OF_02\n";
3765 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3767 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3768 $self->{localfile} = $local_file;
3769 return if $CPAN::Signal;
3774 if ($CPAN::META->has_inst("Digest::MD5")) {
3775 $self->debug("Digest::MD5 is installed, verifying");
3778 $self->debug("Digest::MD5 is NOT installed");
3780 return if $CPAN::Signal;
3783 # Create a clean room and go there
3785 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3786 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3787 $self->safe_chdir($builddir);
3788 $self->debug("Removing tmp") if $CPAN::DEBUG;
3789 File::Path::rmtree("tmp");
3790 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3792 $self->safe_chdir($sub_wd);
3795 $self->safe_chdir("tmp");
3800 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3801 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3802 $self->untar_me($local_file);
3803 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3804 $self->unzip_me($local_file);
3805 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3806 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3807 $self->pm2dir_me($local_file);
3809 $self->{archived} = "NO";
3810 $self->safe_chdir($sub_wd);
3814 # we are still in the tmp directory!
3815 # Let's check if the package has its own directory.
3816 my $dh = DirHandle->new(File::Spec->curdir)
3817 or Carp::croak("Couldn't opendir .: $!");
3818 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3820 my ($distdir,$packagedir);
3821 if (@readdir == 1 && -d $readdir[0]) {
3822 $distdir = $readdir[0];
3823 $packagedir = File::Spec->catdir($builddir,$distdir);
3824 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3826 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3828 File::Path::rmtree($packagedir);
3829 rename($distdir,$packagedir) or
3830 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3831 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3838 my $userid = $self->cpan_userid;
3840 CPAN->debug("no userid? self[$self]");
3843 my $pragmatic_dir = $userid . '000';
3844 $pragmatic_dir =~ s/\W_//g;
3845 $pragmatic_dir++ while -d "../$pragmatic_dir";
3846 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3847 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3848 File::Path::mkpath($packagedir);
3850 for $f (@readdir) { # is already without "." and ".."
3851 my $to = File::Spec->catdir($packagedir,$f);
3852 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3856 $self->safe_chdir($sub_wd);
3860 $self->{'build_dir'} = $packagedir;
3861 $self->safe_chdir(File::Spec->updir);
3862 File::Path::rmtree("tmp");
3864 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3865 my($mpl_exists) = -f $mpl;
3866 unless ($mpl_exists) {
3867 # NFS has been reported to have racing problems after the
3868 # renaming of a directory in some environments.
3871 my $mpldh = DirHandle->new($packagedir)
3872 or Carp::croak("Couldn't opendir $packagedir: $!");
3873 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3876 unless ($mpl_exists) {
3877 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3881 my($configure) = File::Spec->catfile($packagedir,"Configure");
3882 if (-f $configure) {
3883 # do we have anything to do?
3884 $self->{'configure'} = $configure;
3885 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
3886 $CPAN::Frontend->myprint(qq{
3887 Package comes with a Makefile and without a Makefile.PL.
3888 We\'ll try to build it with that Makefile then.
3890 $self->{writemakefile} = "YES";
3893 my $cf = $self->called_for || "unknown";
3898 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3899 $cf = "unknown" unless length($cf);
3900 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3901 (The test -f "$mpl" returned false.)
3902 Writing one on our own (setting NAME to $cf)\a\n});
3903 $self->{had_no_makefile_pl}++;
3906 # Writing our own Makefile.PL
3908 my $fh = FileHandle->new;
3910 or Carp::croak("Could not open >$mpl: $!");
3912 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3913 # because there was no Makefile.PL supplied.
3914 # Autogenerated on: }.scalar localtime().qq{
3916 use ExtUtils::MakeMaker;
3917 WriteMakefile(NAME => q[$cf]);
3927 # CPAN::Distribution::untar_me ;
3929 my($self,$local_file) = @_;
3930 $self->{archived} = "tar";
3931 if (CPAN::Tarzip->untar($local_file)) {
3932 $self->{unwrapped} = "YES";
3934 $self->{unwrapped} = "NO";
3938 # CPAN::Distribution::unzip_me ;
3940 my($self,$local_file) = @_;
3941 $self->{archived} = "zip";
3942 if (CPAN::Tarzip->unzip($local_file)) {
3943 $self->{unwrapped} = "YES";
3945 $self->{unwrapped} = "NO";
3951 my($self,$local_file) = @_;
3952 $self->{archived} = "pm";
3953 my $to = File::Basename::basename($local_file);
3954 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3955 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3956 $self->{unwrapped} = "YES";
3958 $self->{unwrapped} = "NO";
3962 #-> sub CPAN::Distribution::new ;
3964 my($class,%att) = @_;
3966 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3968 my $this = { %att };
3969 return bless $this, $class;
3972 #-> sub CPAN::Distribution::look ;
3976 if ($^O eq 'MacOS') {
3977 $self->Mac::BuildTools::look;
3981 if ( $CPAN::Config->{'shell'} ) {
3982 $CPAN::Frontend->myprint(qq{
3983 Trying to open a subshell in the build directory...
3986 $CPAN::Frontend->myprint(qq{
3987 Your configuration does not define a value for subshells.
3988 Please define it with "o conf shell <your shell>"
3992 my $dist = $self->id;
3994 unless ($dir = $self->dir) {
3997 unless ($dir ||= $self->dir) {
3998 $CPAN::Frontend->mywarn(qq{
3999 Could not determine which directory to use for looking at $dist.
4003 my $pwd = CPAN::anycwd();
4004 $self->safe_chdir($dir);
4005 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4006 system($CPAN::Config->{'shell'}) == 0
4007 or $CPAN::Frontend->mydie("Subprocess shell error");
4008 $self->safe_chdir($pwd);
4011 # CPAN::Distribution::cvs_import ;
4015 my $dir = $self->dir;
4017 my $package = $self->called_for;
4018 my $module = $CPAN::META->instance('CPAN::Module', $package);
4019 my $version = $module->cpan_version;
4021 my $userid = $self->cpan_userid;
4023 my $cvs_dir = (split '/', $dir)[-1];
4024 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4026 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4028 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4029 if ($cvs_site_perl) {
4030 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4032 my $cvs_log = qq{"imported $package $version sources"};
4033 $version =~ s/\./_/g;
4034 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4035 "$cvs_dir", $userid, "v$version");
4037 my $pwd = CPAN::anycwd();
4038 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4040 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4042 $CPAN::Frontend->myprint(qq{@cmd\n});
4043 system(@cmd) == 0 or
4044 $CPAN::Frontend->mydie("cvs import failed");
4045 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4048 #-> sub CPAN::Distribution::readme ;
4051 my($dist) = $self->id;
4052 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4053 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4056 File::Spec->catfile(
4057 $CPAN::Config->{keep_source_where},
4060 split("/","$sans.readme"),
4062 $self->debug("Doing localize") if $CPAN::DEBUG;
4063 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4065 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4067 if ($^O eq 'MacOS') {
4068 Mac::BuildTools::launch_file($local_file);
4072 my $fh_pager = FileHandle->new;
4073 local($SIG{PIPE}) = "IGNORE";
4074 $fh_pager->open("|$CPAN::Config->{'pager'}")
4075 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4076 my $fh_readme = FileHandle->new;
4077 $fh_readme->open($local_file)
4078 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4079 $CPAN::Frontend->myprint(qq{
4082 with pager "$CPAN::Config->{'pager'}"
4085 $fh_pager->print(<$fh_readme>);
4088 #-> sub CPAN::Distribution::verifyMD5 ;
4093 $self->{MD5_STATUS} ||= "";
4094 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4095 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4097 my($lc_want,$lc_file,@local,$basename);
4098 @local = split("/",$self->id);
4100 push @local, "CHECKSUMS";
4102 File::Spec->catfile($CPAN::Config->{keep_source_where},
4103 "authors", "id", @local);
4108 $self->MD5_check_file($lc_want)
4110 return $self->{MD5_STATUS} = "OK";
4112 $lc_file = CPAN::FTP->localize("authors/id/@local",
4115 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4116 $local[-1] .= ".gz";
4117 $lc_file = CPAN::FTP->localize("authors/id/@local",
4120 $lc_file =~ s/\.gz(?!\n)\Z//;
4121 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4126 $self->MD5_check_file($lc_file);
4129 #-> sub CPAN::Distribution::MD5_check_file ;
4130 sub MD5_check_file {
4131 my($self,$chk_file) = @_;
4132 my($cksum,$file,$basename);
4133 $file = $self->{localfile};
4134 $basename = File::Basename::basename($file);
4135 my $fh = FileHandle->new;
4136 if (open $fh, $chk_file){
4139 $eval =~ s/\015?\012/\n/g;
4141 my($comp) = Safe->new();
4142 $cksum = $comp->reval($eval);
4144 rename $chk_file, "$chk_file.bad";
4145 Carp::confess($@) if $@;
4148 Carp::carp "Could not open $chk_file for reading";
4151 if (exists $cksum->{$basename}{md5}) {
4152 $self->debug("Found checksum for $basename:" .
4153 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4157 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4159 $fh = CPAN::Tarzip->TIEHANDLE($file);
4162 # had to inline it, when I tied it, the tiedness got lost on
4163 # the call to eq_MD5. (Jan 1998)
4164 my $md5 = Digest::MD5->new;
4167 while ($fh->READ($ref, 4096) > 0){
4170 my $hexdigest = $md5->hexdigest;
4171 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4175 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4176 return $self->{MD5_STATUS} = "OK";
4178 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4179 qq{distribution file. }.
4180 qq{Please investigate.\n\n}.
4182 $CPAN::META->instance(
4187 my $wrap = qq{I\'d recommend removing $file. Its MD5
4188 checksum is incorrect. Maybe you have configured your 'urllist' with
4189 a bad URL. Please check this array with 'o conf urllist', and
4192 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4194 # former versions just returned here but this seems a
4195 # serious threat that deserves a die
4197 # $CPAN::Frontend->myprint("\n\n");
4201 # close $fh if fileno($fh);
4203 $self->{MD5_STATUS} ||= "";
4204 if ($self->{MD5_STATUS} eq "NIL") {
4205 $CPAN::Frontend->mywarn(qq{
4206 Warning: No md5 checksum for $basename in $chk_file.
4208 The cause for this may be that the file is very new and the checksum
4209 has not yet been calculated, but it may also be that something is
4210 going awry right now.
4212 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4213 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4215 $self->{MD5_STATUS} = "NIL";
4220 #-> sub CPAN::Distribution::eq_MD5 ;
4222 my($self,$fh,$expectMD5) = @_;
4223 my $md5 = Digest::MD5->new;
4225 while (read($fh, $data, 4096)){
4228 # $md5->addfile($fh);
4229 my $hexdigest = $md5->hexdigest;
4230 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4231 $hexdigest eq $expectMD5;
4234 #-> sub CPAN::Distribution::force ;
4236 # Both modules and distributions know if "force" is in effect by
4237 # autoinspection, not by inspecting a global variable. One of the
4238 # reason why this was chosen to work that way was the treatment of
4239 # dependencies. They should not autpomatically inherit the force
4240 # status. But this has the downside that ^C and die() will return to
4241 # the prompt but will not be able to reset the force_update
4242 # attributes. We try to correct for it currently in the read_metadata
4243 # routine, and immediately before we check for a Signal. I hope this
4244 # works out in one of v1.57_53ff
4247 my($self, $method) = @_;
4249 MD5_STATUS archived build_dir localfile make install unwrapped
4252 delete $self->{$att};
4254 if ($method && $method eq "install") {
4255 $self->{"force_update"}++; # name should probably have been force_install
4259 #-> sub CPAN::Distribution::unforce ;
4262 delete $self->{'force_update'};
4265 #-> sub CPAN::Distribution::isa_perl ;
4268 my $file = File::Basename::basename($self->id);
4269 if ($file =~ m{ ^ perl
4282 } elsif ($self->cpan_comment
4284 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4289 #-> sub CPAN::Distribution::perl ;
4292 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4293 my $pwd = CPAN::anycwd();
4294 my $candidate = File::Spec->catfile($pwd,$^X);
4295 $perl ||= $candidate if MM->maybe_command($candidate);
4297 my ($component,$perl_name);
4298 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4299 PATH_COMPONENT: foreach $component (File::Spec->path(),
4300 $Config::Config{'binexp'}) {
4301 next unless defined($component) && $component;
4302 my($abs) = File::Spec->catfile($component,$perl_name);
4303 if (MM->maybe_command($abs)) {
4313 #-> sub CPAN::Distribution::make ;
4316 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4317 # Emergency brake if they said install Pippi and get newest perl
4318 if ($self->isa_perl) {
4320 $self->called_for ne $self->id &&
4321 ! $self->{force_update}
4323 # if we die here, we break bundles
4324 $CPAN::Frontend->mywarn(sprintf qq{
4325 The most recent version "%s" of the module "%s"
4326 comes with the current version of perl (%s).
4327 I\'ll build that only if you ask for something like
4332 $CPAN::META->instance(
4346 $self->{archived} eq "NO" and push @e,
4347 "Is neither a tar nor a zip archive.";
4349 $self->{unwrapped} eq "NO" and push @e,
4350 "had problems unarchiving. Please build manually";
4352 exists $self->{writemakefile} &&
4353 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4354 $1 || "Had some problem writing Makefile";
4356 defined $self->{'make'} and push @e,
4357 "Has already been processed within this session";
4359 exists $self->{later} and length($self->{later}) and
4360 push @e, $self->{later};
4362 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4364 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4365 my $builddir = $self->dir;
4366 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4367 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4369 if ($^O eq 'MacOS') {
4370 Mac::BuildTools::make($self);
4375 if ($self->{'configure'}) {
4376 $system = $self->{'configure'};
4378 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4380 # This needs a handler that can be turned on or off:
4381 # $switch = "-MExtUtils::MakeMaker ".
4382 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4384 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4386 unless (exists $self->{writemakefile}) {
4387 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4390 if ($CPAN::Config->{inactivity_timeout}) {
4392 alarm $CPAN::Config->{inactivity_timeout};
4393 local $SIG{CHLD}; # = sub { wait };
4394 if (defined($pid = fork)) {
4399 # note, this exec isn't necessary if
4400 # inactivity_timeout is 0. On the Mac I'd
4401 # suggest, we set it always to 0.
4405 $CPAN::Frontend->myprint("Cannot fork: $!");
4413 $CPAN::Frontend->myprint($@);
4414 $self->{writemakefile} = "NO $@";
4419 $ret = system($system);
4421 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4425 if (-f "Makefile") {
4426 $self->{writemakefile} = "YES";
4427 delete $self->{make_clean}; # if cleaned before, enable next
4429 $self->{writemakefile} =
4430 qq{NO Makefile.PL refused to write a Makefile.};
4431 # It's probably worth it to record the reason, so let's retry
4433 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4434 # $self->{writemakefile} .= <$fh>;
4438 delete $self->{force_update};
4441 if (my @prereq = $self->unsat_prereq){
4442 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4444 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4445 if (system($system) == 0) {
4446 $CPAN::Frontend->myprint(" $system -- OK\n");
4447 $self->{'make'} = "YES";
4449 $self->{writemakefile} ||= "YES";
4450 $self->{'make'} = "NO";
4451 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4455 sub follow_prereqs {
4459 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4460 "during [$id] -----\n");
4462 for my $p (@prereq) {
4463 $CPAN::Frontend->myprint(" $p\n");
4466 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4468 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4469 require ExtUtils::MakeMaker;
4470 my $answer = ExtUtils::MakeMaker::prompt(
4471 "Shall I follow them and prepend them to the queue
4472 of modules we are processing right now?", "yes");
4473 $follow = $answer =~ /^\s*y/i;
4477 myprint(" Ignoring dependencies on modules @prereq\n");
4480 # color them as dirty
4481 for my $p (@prereq) {
4482 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4484 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4485 $self->{later} = "Delayed until after prerequisites";
4486 return 1; # signal success to the queuerunner
4490 #-> sub CPAN::Distribution::unsat_prereq ;
4493 my $prereq_pm = $self->prereq_pm or return;
4495 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4496 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4497 # we were too demanding:
4498 next if $nmo->uptodate;
4500 # if they have not specified a version, we accept any installed one
4501 if (not defined $need_version or
4502 $need_version == 0 or
4503 $need_version eq "undef") {
4504 next if defined $nmo->inst_file;
4507 # We only want to install prereqs if either they're not installed
4508 # or if the installed version is too old. We cannot omit this
4509 # check, because if 'force' is in effect, nobody else will check.
4513 defined $nmo->inst_file &&
4514 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4516 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4520 CPAN::Version->readable($need_version)
4526 if ($self->{sponsored_mods}{$need_module}++){
4527 # We have already sponsored it and for some reason it's still
4528 # not available. So we do nothing. Or what should we do?
4529 # if we push it again, we have a potential infinite loop
4532 push @need, $need_module;
4537 #-> sub CPAN::Distribution::prereq_pm ;
4540 return $self->{prereq_pm} if
4541 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4542 return unless $self->{writemakefile}; # no need to have succeeded
4543 # but we must have run it
4544 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4545 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4550 $fh = FileHandle->new("<$makefile\0")) {
4554 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4556 last if /MakeMaker post_initialize section/;
4558 \s+PREREQ_PM\s+=>\s+(.+)
4561 # warn "Found prereq expr[$p]";
4563 # Regexp modified by A.Speer to remember actual version of file
4564 # PREREQ_PM hash key wants, then add to
4565 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4566 # In case a prereq is mentioned twice, complain.
4567 if ( defined $p{$1} ) {
4568 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4575 $self->{prereq_pm_detected}++;
4576 return $self->{prereq_pm} = \%p;
4579 #-> sub CPAN::Distribution::test ;
4584 delete $self->{force_update};
4587 $CPAN::Frontend->myprint("Running make test\n");
4588 if (my @prereq = $self->unsat_prereq){
4589 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4593 exists $self->{make} or exists $self->{later} or push @e,
4594 "Make had some problems, maybe interrupted? Won't test";
4596 exists $self->{'make'} and
4597 $self->{'make'} eq 'NO' and
4598 push @e, "Can't test without successful make";
4600 exists $self->{build_dir} or push @e, "Has no own directory";
4601 $self->{badtestcnt} ||= 0;
4602 $self->{badtestcnt} > 0 and
4603 push @e, "Won't repeat unsuccessful test during this command";
4605 exists $self->{later} and length($self->{later}) and
4606 push @e, $self->{later};
4608 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4610 chdir $self->{'build_dir'} or
4611 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4612 $self->debug("Changed directory to $self->{'build_dir'}")
4615 if ($^O eq 'MacOS') {
4616 Mac::BuildTools::make_test($self);
4620 my $system = join " ", $CPAN::Config->{'make'}, "test";
4621 if (system($system) == 0) {
4622 $CPAN::Frontend->myprint(" $system -- OK\n");
4623 $self->{make_test} = "YES";
4625 $self->{make_test} = "NO";
4626 $self->{badtestcnt}++;
4627 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4631 #-> sub CPAN::Distribution::clean ;
4634 $CPAN::Frontend->myprint("Running make clean\n");
4637 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4638 push @e, "make clean already called once";
4639 exists $self->{build_dir} or push @e, "Has no own directory";
4640 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4642 chdir $self->{'build_dir'} or
4643 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4644 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4646 if ($^O eq 'MacOS') {
4647 Mac::BuildTools::make_clean($self);
4651 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4652 if (system($system) == 0) {
4653 $CPAN::Frontend->myprint(" $system -- OK\n");
4657 # Jost Krieger pointed out that this "force" was wrong because
4658 # it has the effect that the next "install" on this distribution
4659 # will untar everything again. Instead we should bring the
4660 # object's state back to where it is after untarring.
4662 delete $self->{force_update};
4663 delete $self->{install};
4664 delete $self->{writemakefile};
4665 delete $self->{make};
4666 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4667 $self->{make_clean} = "YES";
4670 # Hmmm, what to do if make clean failed?
4672 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4674 make clean did not succeed, marking directory as unusable for further work.
4676 $self->force("make"); # so that this directory won't be used again
4681 #-> sub CPAN::Distribution::install ;
4686 delete $self->{force_update};
4689 $CPAN::Frontend->myprint("Running make install\n");
4692 exists $self->{build_dir} or push @e, "Has no own directory";
4694 exists $self->{make} or exists $self->{later} or push @e,
4695 "Make had some problems, maybe interrupted? Won't install";
4697 exists $self->{'make'} and
4698 $self->{'make'} eq 'NO' and
4699 push @e, "make had returned bad status, install seems impossible";
4701 push @e, "make test had returned bad status, ".
4702 "won't install without force"
4703 if exists $self->{'make_test'} and
4704 $self->{'make_test'} eq 'NO' and
4705 ! $self->{'force_update'};
4707 exists $self->{'install'} and push @e,
4708 $self->{'install'} eq "YES" ?
4709 "Already done" : "Already tried without success";
4711 exists $self->{later} and length($self->{later}) and
4712 push @e, $self->{later};
4714 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4716 chdir $self->{'build_dir'} or
4717 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4718 $self->debug("Changed directory to $self->{'build_dir'}")
4721 if ($^O eq 'MacOS') {
4722 Mac::BuildTools::make_install($self);
4726 my $system = join(" ", $CPAN::Config->{'make'},
4727 "install", $CPAN::Config->{make_install_arg});
4728 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4729 my($pipe) = FileHandle->new("$system $stderr |");
4732 $CPAN::Frontend->myprint($_);
4737 $CPAN::Frontend->myprint(" $system -- OK\n");
4738 return $self->{'install'} = "YES";
4740 $self->{'install'} = "NO";
4741 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4742 if ($makeout =~ /permission/s && $> > 0) {
4743 $CPAN::Frontend->myprint(qq{ You may have to su }.
4744 qq{to root to install the package\n});
4747 delete $self->{force_update};
4750 #-> sub CPAN::Distribution::dir ;
4752 shift->{'build_dir'};
4755 package CPAN::Bundle;
4759 delete $self->{later};
4760 for my $c ( $self->contains ) {
4761 my $obj = CPAN::Shell->expandany($c) or next;
4766 #-> sub CPAN::Bundle::color_cmd_tmps ;
4767 sub color_cmd_tmps {
4769 my($depth) = shift || 0;
4770 my($color) = shift || 0;
4771 # a module needs to recurse to its cpan_file, a distribution needs
4772 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4774 return if exists $self->{incommandcolor}
4775 && $self->{incommandcolor}==$color;
4776 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4777 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4782 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4784 for my $c ( $self->contains ) {
4785 my $obj = CPAN::Shell->expandany($c) or next;
4786 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4787 $obj->color_cmd_tmps($depth+1,$color);
4790 delete $self->{badtestcnt};
4792 $self->{incommandcolor} = $color;
4795 #-> sub CPAN::Bundle::as_string ;
4799 # following line must be "=", not "||=" because we have a moving target
4800 $self->{INST_VERSION} = $self->inst_version;
4801 return $self->SUPER::as_string;
4804 #-> sub CPAN::Bundle::contains ;
4807 my($inst_file) = $self->inst_file || "";
4808 my($id) = $self->id;
4809 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4810 unless ($inst_file) {
4811 # Try to get at it in the cpan directory
4812 $self->debug("no inst_file") if $CPAN::DEBUG;
4814 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4815 $cpan_file = $self->cpan_file;
4816 if ($cpan_file eq "N/A") {
4817 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4818 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4820 my $dist = $CPAN::META->instance('CPAN::Distribution',
4823 $self->debug($dist->as_string) if $CPAN::DEBUG;
4824 my($todir) = $CPAN::Config->{'cpan_home'};
4825 my(@me,$from,$to,$me);
4826 @me = split /::/, $self->id;
4828 $me = File::Spec->catfile(@me);
4829 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4830 $to = File::Spec->catfile($todir,$me);
4831 File::Path::mkpath(File::Basename::dirname($to));
4832 File::Copy::copy($from, $to)
4833 or Carp::confess("Couldn't copy $from to $to: $!");
4837 my $fh = FileHandle->new;
4839 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4841 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4843 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4844 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4845 next unless $in_cont;
4850 push @result, (split " ", $_, 2)[0];
4853 delete $self->{STATUS};
4854 $self->{CONTAINS} = \@result;
4855 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4857 $CPAN::Frontend->mywarn(qq{
4858 The bundle file "$inst_file" may be a broken
4859 bundlefile. It seems not to contain any bundle definition.
4860 Please check the file and if it is bogus, please delete it.
4861 Sorry for the inconvenience.
4867 #-> sub CPAN::Bundle::find_bundle_file
4868 sub find_bundle_file {
4869 my($self,$where,$what) = @_;
4870 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4871 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4872 ### my $bu = File::Spec->catfile($where,$what);
4873 ### return $bu if -f $bu;
4874 my $manifest = File::Spec->catfile($where,"MANIFEST");
4875 unless (-f $manifest) {
4876 require ExtUtils::Manifest;
4877 my $cwd = CPAN::anycwd();
4878 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4879 ExtUtils::Manifest::mkmanifest();
4880 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4882 my $fh = FileHandle->new($manifest)
4883 or Carp::croak("Couldn't open $manifest: $!");
4886 if ($^O eq 'MacOS') {
4889 $what2 =~ s/:Bundle://;
4892 $what2 =~ s|Bundle[/\\]||;
4897 my($file) = /(\S+)/;
4898 if ($file =~ m|\Q$what\E$|) {
4900 # return File::Spec->catfile($where,$bu); # bad
4903 # retry if she managed to
4904 # have no Bundle directory
4905 $bu = $file if $file =~ m|\Q$what2\E$|;
4907 $bu =~ tr|/|:| if $^O eq 'MacOS';
4908 return File::Spec->catfile($where, $bu) if $bu;
4909 Carp::croak("Couldn't find a Bundle file in $where");
4912 # needs to work quite differently from Module::inst_file because of
4913 # cpan_home/Bundle/ directory and the possibility that we have
4914 # shadowing effect. As it makes no sense to take the first in @INC for
4915 # Bundles, we parse them all for $VERSION and take the newest.
4917 #-> sub CPAN::Bundle::inst_file ;
4922 @me = split /::/, $self->id;
4925 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4926 my $bfile = File::Spec->catfile($incdir, @me);
4927 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4928 next unless -f $bfile;
4929 my $foundv = MM->parse_version($bfile);
4930 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4931 $self->{INST_FILE} = $bfile;
4932 $self->{INST_VERSION} = $bestv = $foundv;
4938 #-> sub CPAN::Bundle::inst_version ;
4941 $self->inst_file; # finds INST_VERSION as side effect
4942 $self->{INST_VERSION};
4945 #-> sub CPAN::Bundle::rematein ;
4947 my($self,$meth) = @_;
4948 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4949 my($id) = $self->id;
4950 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4951 unless $self->inst_file || $self->cpan_file;
4953 for $s ($self->contains) {
4954 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4955 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4956 if ($type eq 'CPAN::Distribution') {
4957 $CPAN::Frontend->mywarn(qq{
4958 The Bundle }.$self->id.qq{ contains
4959 explicitly a file $s.
4963 # possibly noisy action:
4964 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4965 my $obj = $CPAN::META->instance($type,$s);
4967 if ($obj->isa(CPAN::Bundle)
4969 exists $obj->{install_failed}
4971 ref($obj->{install_failed}) eq "HASH"
4973 for (keys %{$obj->{install_failed}}) {
4974 $self->{install_failed}{$_} = undef; # propagate faiure up
4977 $fail{$s} = 1; # the bundle itself may have succeeded but
4982 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4983 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4985 delete $self->{install_failed}{$s};
4992 # recap with less noise
4993 if ( $meth eq "install" ) {
4996 my $raw = sprintf(qq{Bundle summary:
4997 The following items in bundle %s had installation problems:},
5000 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5001 $CPAN::Frontend->myprint("\n");
5004 for $s ($self->contains) {
5006 $paragraph .= "$s ";
5007 $self->{install_failed}{$s} = undef;
5008 $reported{$s} = undef;
5011 my $report_propagated;
5012 for $s (sort keys %{$self->{install_failed}}) {
5013 next if exists $reported{$s};
5014 $paragraph .= "and the following items had problems
5015 during recursive bundle calls: " unless $report_propagated++;
5016 $paragraph .= "$s ";
5018 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5019 $CPAN::Frontend->myprint("\n");
5021 $self->{'install'} = 'YES';
5026 #sub CPAN::Bundle::xs_file
5028 # If a bundle contains another that contains an xs_file we have
5029 # here, we just don't bother I suppose
5033 #-> sub CPAN::Bundle::force ;
5034 sub force { shift->rematein('force',@_); }
5035 #-> sub CPAN::Bundle::get ;
5036 sub get { shift->rematein('get',@_); }
5037 #-> sub CPAN::Bundle::make ;
5038 sub make { shift->rematein('make',@_); }
5039 #-> sub CPAN::Bundle::test ;
5042 $self->{badtestcnt} ||= 0;
5043 $self->rematein('test',@_);
5045 #-> sub CPAN::Bundle::install ;
5048 $self->rematein('install',@_);
5050 #-> sub CPAN::Bundle::clean ;
5051 sub clean { shift->rematein('clean',@_); }
5053 #-> sub CPAN::Bundle::uptodate ;
5056 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5058 foreach $c ($self->contains) {
5059 my $obj = CPAN::Shell->expandany($c);
5060 return 0 unless $obj->uptodate;
5065 #-> sub CPAN::Bundle::readme ;
5068 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5069 No File found for bundle } . $self->id . qq{\n}), return;
5070 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5071 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5074 package CPAN::Module;
5077 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5080 return unless exists $self->{RO}; # should never happen
5081 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5083 sub description { shift->{RO}{description} }
5087 delete $self->{later};
5088 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5093 #-> sub CPAN::Module::color_cmd_tmps ;
5094 sub color_cmd_tmps {
5096 my($depth) = shift || 0;
5097 my($color) = shift || 0;
5098 # a module needs to recurse to its cpan_file
5100 return if exists $self->{incommandcolor}
5101 && $self->{incommandcolor}==$color;
5102 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5103 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5108 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5110 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5111 $dist->color_cmd_tmps($depth+1,$color);
5114 delete $self->{badtestcnt};
5116 $self->{incommandcolor} = $color;
5119 #-> sub CPAN::Module::as_glimpse ;
5123 my $class = ref($self);
5124 $class =~ s/^CPAN:://;
5128 $CPAN::Shell::COLOR_REGISTERED
5130 $CPAN::META->has_inst("Term::ANSIColor")
5132 $self->{RO}{description}
5134 $color_on = Term::ANSIColor::color("green");
5135 $color_off = Term::ANSIColor::color("reset");
5137 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5146 #-> sub CPAN::Module::as_string ;
5150 CPAN->debug($self) if $CPAN::DEBUG;
5151 my $class = ref($self);
5152 $class =~ s/^CPAN:://;
5154 push @m, $class, " id = $self->{ID}\n";
5155 my $sprintf = " %-12s %s\n";
5156 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5157 if $self->description;
5158 my $sprintf2 = " %-12s %s (%s)\n";
5160 if ($userid = $self->cpan_userid || $self->userid){
5162 if ($author = CPAN::Shell->expand('Author',$userid)) {
5165 if ($m = $author->email) {
5172 $author->fullname . $email
5176 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5177 if $self->cpan_version;
5178 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5179 if $self->cpan_file;
5180 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5181 my(%statd,%stats,%statl,%stati);
5182 @statd{qw,? i c a b R M S,} = qw,unknown idea
5183 pre-alpha alpha beta released mature standard,;
5184 @stats{qw,? m d u n,} = qw,unknown mailing-list
5185 developer comp.lang.perl.* none,;
5186 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5187 @stati{qw,? f r O h,} = qw,unknown functions
5188 references+ties object-oriented hybrid,;
5189 $statd{' '} = 'unknown';
5190 $stats{' '} = 'unknown';
5191 $statl{' '} = 'unknown';
5192 $stati{' '} = 'unknown';
5200 $statd{$self->{RO}{statd}},
5201 $stats{$self->{RO}{stats}},
5202 $statl{$self->{RO}{statl}},
5203 $stati{$self->{RO}{stati}}
5204 ) if $self->{RO}{statd};
5205 my $local_file = $self->inst_file;
5206 unless ($self->{MANPAGE}) {
5208 $self->{MANPAGE} = $self->manpage_headline($local_file);
5210 # If we have already untarred it, we should look there
5211 my $dist = $CPAN::META->instance('CPAN::Distribution',
5213 # warn "dist[$dist]";
5214 # mff=manifest file; mfh=manifest handle
5219 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5221 $mfh = FileHandle->new($mff)
5223 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5224 my $lfre = $self->id; # local file RE
5227 my($lfl); # local file file
5229 my(@mflines) = <$mfh>;
5234 while (length($lfre)>5 and !$lfl) {
5235 ($lfl) = grep /$lfre/, @mflines;
5236 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5239 $lfl =~ s/\s.*//; # remove comments
5240 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5241 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5242 # warn "lfl_abs[$lfl_abs]";
5244 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5250 for $item (qw/MANPAGE/) {
5251 push @m, sprintf($sprintf, $item, $self->{$item})
5252 if exists $self->{$item};
5254 for $item (qw/CONTAINS/) {
5255 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5256 if exists $self->{$item} && @{$self->{$item}};
5258 push @m, sprintf($sprintf, 'INST_FILE',
5259 $local_file || "(not installed)");
5260 push @m, sprintf($sprintf, 'INST_VERSION',
5261 $self->inst_version) if $local_file;
5265 sub manpage_headline {
5266 my($self,$local_file) = @_;
5267 my(@local_file) = $local_file;
5268 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5269 push @local_file, $local_file;
5271 for $locf (@local_file) {
5272 next unless -f $locf;
5273 my $fh = FileHandle->new($locf)
5274 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5278 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
5279 m/^=head1\s+NAME/ ? 1 : $inpod;
5292 #-> sub CPAN::Module::cpan_file ;
5293 # Note: also inherited by CPAN::Bundle
5296 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5297 unless (defined $self->{RO}{CPAN_FILE}) {
5298 CPAN::Index->reload;
5300 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5301 return $self->{RO}{CPAN_FILE};
5303 my $userid = $self->userid;
5305 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5306 my $author = $CPAN::META->instance("CPAN::Author",
5308 my $fullname = $author->fullname;
5309 my $email = $author->email;
5310 unless (defined $fullname && defined $email) {
5311 return sprintf("Contact Author %s",
5315 return "Contact Author $fullname <$email>";
5317 return "UserID $userid";
5325 #-> sub CPAN::Module::cpan_version ;
5329 $self->{RO}{CPAN_VERSION} = 'undef'
5330 unless defined $self->{RO}{CPAN_VERSION};
5331 # I believe this is always a bug in the index and should be reported
5332 # as such, but usually I find out such an error and do not want to
5333 # provoke too many bugreports
5335 $self->{RO}{CPAN_VERSION};
5338 #-> sub CPAN::Module::force ;
5341 $self->{'force_update'}++;
5344 #-> sub CPAN::Module::rematein ;
5346 my($self,$meth) = @_;
5347 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5350 my $cpan_file = $self->cpan_file;
5351 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5352 $CPAN::Frontend->mywarn(sprintf qq{
5353 The module %s isn\'t available on CPAN.
5355 Either the module has not yet been uploaded to CPAN, or it is
5356 temporary unavailable. Please contact the author to find out
5357 more about the status. Try 'i %s'.
5364 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5365 $pack->called_for($self->id);
5366 $pack->force($meth) if exists $self->{'force_update'};
5368 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5369 delete $self->{'force_update'};
5372 #-> sub CPAN::Module::readme ;
5373 sub readme { shift->rematein('readme') }
5374 #-> sub CPAN::Module::look ;
5375 sub look { shift->rematein('look') }
5376 #-> sub CPAN::Module::cvs_import ;
5377 sub cvs_import { shift->rematein('cvs_import') }
5378 #-> sub CPAN::Module::get ;
5379 sub get { shift->rematein('get',@_); }
5380 #-> sub CPAN::Module::make ;
5383 $self->rematein('make');
5385 #-> sub CPAN::Module::test ;
5388 $self->{badtestcnt} ||= 0;
5389 $self->rematein('test',@_);
5391 #-> sub CPAN::Module::uptodate ;
5394 my($latest) = $self->cpan_version;
5396 my($inst_file) = $self->inst_file;
5398 if (defined $inst_file) {
5399 $have = $self->inst_version;
5404 ! CPAN::Version->vgt($latest, $have)
5406 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5407 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5412 #-> sub CPAN::Module::install ;
5418 not exists $self->{'force_update'}
5420 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5424 $self->rematein('install') if $doit;
5426 #-> sub CPAN::Module::clean ;
5427 sub clean { shift->rematein('clean') }
5429 #-> sub CPAN::Module::inst_file ;
5433 @packpath = split /::/, $self->{ID};
5434 $packpath[-1] .= ".pm";
5435 foreach $dir (@INC) {
5436 my $pmfile = File::Spec->catfile($dir,@packpath);
5444 #-> sub CPAN::Module::xs_file ;
5448 @packpath = split /::/, $self->{ID};
5449 push @packpath, $packpath[-1];
5450 $packpath[-1] .= "." . $Config::Config{'dlext'};
5451 foreach $dir (@INC) {
5452 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5460 #-> sub CPAN::Module::inst_version ;
5463 my $parsefile = $self->inst_file or return;
5464 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5467 # there was a bug in 5.6.0 that let lots of unini warnings out of
5468 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5469 # the following workaround after 5.6.1 is out.
5470 local($SIG{__WARN__}) = sub { my $w = shift;
5471 return if $w =~ /uninitialized/i;
5475 $have = MM->parse_version($parsefile) || "undef";
5476 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5477 $have =~ s/ $//; # trailing whitespace happens all the time
5479 # My thoughts about why %vd processing should happen here
5481 # Alt1 maintain it as string with leading v:
5482 # read index files do nothing
5483 # compare it use utility for compare
5484 # print it do nothing
5486 # Alt2 maintain it as what it is
5487 # read index files convert
5488 # compare it use utility because there's still a ">" vs "gt" issue
5489 # print it use CPAN::Version for print
5491 # Seems cleaner to hold it in memory as a string starting with a "v"
5493 # If the author of this module made a mistake and wrote a quoted
5494 # "v1.13" instead of v1.13, we simply leave it at that with the
5495 # effect that *we* will treat it like a v-tring while the rest of
5496 # perl won't. Seems sensible when we consider that any action we
5497 # could take now would just add complexity.
5499 $have = CPAN::Version->readable($have);
5501 $have =~ s/\s*//g; # stringify to float around floating point issues
5502 $have; # no stringify needed, \s* above matches always
5505 package CPAN::Tarzip;
5507 # CPAN::Tarzip::gzip
5509 my($class,$read,$write) = @_;
5510 if ($CPAN::META->has_inst("Compress::Zlib")) {
5512 $fhw = FileHandle->new($read)
5513 or $CPAN::Frontend->mydie("Could not open $read: $!");
5514 my $gz = Compress::Zlib::gzopen($write, "wb")
5515 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5516 $gz->gzwrite($buffer)
5517 while read($fhw,$buffer,4096) > 0 ;
5522 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5527 # CPAN::Tarzip::gunzip
5529 my($class,$read,$write) = @_;
5530 if ($CPAN::META->has_inst("Compress::Zlib")) {
5532 $fhw = FileHandle->new(">$write")
5533 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5534 my $gz = Compress::Zlib::gzopen($read, "rb")
5535 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5536 $fhw->print($buffer)
5537 while $gz->gzread($buffer) > 0 ;
5538 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5539 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5544 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5549 # CPAN::Tarzip::gtest
5551 my($class,$read) = @_;
5552 # After I had reread the documentation in zlib.h, I discovered that
5553 # uncompressed files do not lead to an gzerror (anymore?).
5554 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5557 my $gz = Compress::Zlib::gzopen($read, "rb")
5558 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5560 $Compress::Zlib::gzerrno));
5561 while ($gz->gzread($buffer) > 0 ){
5562 $len += length($buffer);
5565 my $err = $gz->gzerror;
5566 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5567 if ($len == -s $read){
5569 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5572 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5575 return system("$CPAN::Config->{gzip} -dt $read")==0;
5580 # CPAN::Tarzip::TIEHANDLE
5582 my($class,$file) = @_;
5584 $class->debug("file[$file]");
5585 if ($CPAN::META->has_inst("Compress::Zlib")) {
5586 my $gz = Compress::Zlib::gzopen($file,"rb") or
5587 die "Could not gzopen $file";
5588 $ret = bless {GZ => $gz}, $class;
5590 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5591 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5593 $ret = bless {FH => $fh}, $class;
5599 # CPAN::Tarzip::READLINE
5602 if (exists $self->{GZ}) {
5603 my $gz = $self->{GZ};
5604 my($line,$bytesread);
5605 $bytesread = $gz->gzreadline($line);
5606 return undef if $bytesread <= 0;
5609 my $fh = $self->{FH};
5610 return scalar <$fh>;
5615 # CPAN::Tarzip::READ
5617 my($self,$ref,$length,$offset) = @_;
5618 die "read with offset not implemented" if defined $offset;
5619 if (exists $self->{GZ}) {
5620 my $gz = $self->{GZ};
5621 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5624 my $fh = $self->{FH};
5625 return read($fh,$$ref,$length);
5630 # CPAN::Tarzip::DESTROY
5633 if (exists $self->{GZ}) {
5634 my $gz = $self->{GZ};
5635 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5636 # to be undef ever. AK, 2000-09
5638 my $fh = $self->{FH};
5639 $fh->close if defined $fh;
5645 # CPAN::Tarzip::untar
5647 my($class,$file) = @_;
5650 if (0) { # makes changing order easier
5651 } elsif ($BUGHUNTING){
5653 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5655 MM->maybe_command($CPAN::Config->{'tar'})) {
5656 # should be default until Archive::Tar is fixed
5659 $CPAN::META->has_inst("Archive::Tar")
5661 $CPAN::META->has_inst("Compress::Zlib") ) {
5664 $CPAN::Frontend->mydie(qq{
5665 CPAN.pm needs either both external programs tar and gzip installed or
5666 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5667 is available. Can\'t continue.
5670 if ($prefer==1) { # 1 => external gzip+tar
5672 my $is_compressed = $class->gtest($file);
5673 if ($is_compressed) {
5674 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5675 "< $file | $CPAN::Config->{tar} xvf -";
5677 $system = "$CPAN::Config->{tar} xvf $file";
5679 if (system($system) != 0) {
5680 # people find the most curious tar binaries that cannot handle
5682 if ($is_compressed) {
5683 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5684 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5685 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5687 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5691 $system = "$CPAN::Config->{tar} xvf $file";
5692 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5693 if (system($system)==0) {
5694 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5696 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5702 } elsif ($prefer==2) { # 2 => modules
5703 my $tar = Archive::Tar->new($file,1);
5704 my $af; # archive file
5707 # RCS 1.337 had this code, it turned out unacceptable slow but
5708 # it revealed a bug in Archive::Tar. Code is only here to hunt
5709 # the bug again. It should never be enabled in published code.
5710 # GDGraph3d-0.53 was an interesting case according to Larry
5712 warn(">>>Bughunting code enabled<<< " x 20);
5713 for $af ($tar->list_files) {
5714 if ($af =~ m!^(/|\.\./)!) {
5715 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5716 "illegal member [$af]");
5718 $CPAN::Frontend->myprint("$af\n");
5719 $tar->extract($af); # slow but effective for finding the bug
5720 return if $CPAN::Signal;
5723 for $af ($tar->list_files) {
5724 if ($af =~ m!^(/|\.\./)!) {
5725 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5726 "illegal member [$af]");
5728 $CPAN::Frontend->myprint("$af\n");
5730 return if $CPAN::Signal;
5735 Mac::BuildTools::convert_files([$tar->list_files], 1)
5736 if ($^O eq 'MacOS');
5743 my($class,$file) = @_;
5744 if ($CPAN::META->has_inst("Archive::Zip")) {
5745 # blueprint of the code from Archive::Zip::Tree::extractTree();
5746 my $zip = Archive::Zip->new();
5748 $status = $zip->read($file);
5749 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5750 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5751 my @members = $zip->members();
5752 for my $member ( @members ) {
5753 my $af = $member->fileName();
5754 if ($af =~ m!^(/|\.\./)!) {
5755 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5756 "illegal member [$af]");
5758 my $status = $member->extractToFileNamed( $af );
5759 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5760 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5761 $status != Archive::Zip::AZ_OK();
5762 return if $CPAN::Signal;
5766 my $unzip = $CPAN::Config->{unzip} or
5767 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5768 my @system = ($unzip, $file);
5769 return system(@system) == 0;
5774 package CPAN::Version;
5775 # CPAN::Version::vcmp courtesy Jost Krieger
5777 my($self,$l,$r) = @_;
5779 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5781 return 0 if $l eq $r; # short circuit for quicker success
5783 if ($l=~/^v/ <=> $r=~/^v/) {
5786 $_ = $self->float2vv($_);
5791 ($l ne "undef") <=> ($r ne "undef") ||
5795 $self->vstring($l) cmp $self->vstring($r)) ||
5801 my($self,$l,$r) = @_;
5802 $self->vcmp($l,$r) > 0;
5807 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5808 pack "U*", split /\./, $n;
5811 # vv => visible vstring
5816 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5817 # architecture influence
5819 $mantissa .= "0" while length($mantissa)%3;
5820 my $ret = "v" . $rev;
5822 $mantissa =~ s/(\d{1,3})// or
5823 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5824 $ret .= ".".int($1);
5826 # warn "n[$n]ret[$ret]";
5832 $n =~ /^([\w\-\+\.]+)/;
5834 return $1 if defined $1 && length($1)>0;
5835 # if the first user reaches version v43, he will be treated as "+".
5836 # We'll have to decide about a new rule here then, depending on what
5837 # will be the prevailing versioning behavior then.
5839 if ($] < 5.006) { # or whenever v-strings were introduced
5840 # we get them wrong anyway, whatever we do, because 5.005 will
5841 # have already interpreted 0.2.4 to be "0.24". So even if he
5842 # indexer sends us something like "v0.2.4" we compare wrongly.
5844 # And if they say v1.2, then the old perl takes it as "v12"
5846 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5849 my $better = sprintf "v%vd", $n;
5850 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5862 CPAN - query, download and build perl modules from CPAN sites
5868 perl -MCPAN -e shell;
5874 autobundle, clean, install, make, recompile, test
5878 The CPAN module is designed to automate the make and install of perl
5879 modules and extensions. It includes some searching capabilities and
5880 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5881 to fetch the raw data from the net.
5883 Modules are fetched from one or more of the mirrored CPAN
5884 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5887 The CPAN module also supports the concept of named and versioned
5888 I<bundles> of modules. Bundles simplify the handling of sets of
5889 related modules. See Bundles below.
5891 The package contains a session manager and a cache manager. There is
5892 no status retained between sessions. The session manager keeps track
5893 of what has been fetched, built and installed in the current
5894 session. The cache manager keeps track of the disk space occupied by
5895 the make processes and deletes excess space according to a simple FIFO
5898 For extended searching capabilities there's a plugin for CPAN available,
5899 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5900 that indexes all documents available in CPAN authors directories. If
5901 C<CPAN::WAIT> is installed on your system, the interactive shell of
5902 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5903 which send queries to the WAIT server that has been configured for your
5906 All other methods provided are accessible in a programmer style and in an
5907 interactive shell style.
5909 =head2 Interactive Mode
5911 The interactive mode is entered by running
5913 perl -MCPAN -e shell
5915 which puts you into a readline interface. You will have the most fun if
5916 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5919 Once you are on the command line, type 'h' and the rest should be
5922 The function call C<shell> takes two optional arguments, one is the
5923 prompt, the second is the default initial command line (the latter
5924 only works if a real ReadLine interface module is installed).
5926 The most common uses of the interactive modes are
5930 =item Searching for authors, bundles, distribution files and modules
5932 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5933 for each of the four categories and another, C<i> for any of the
5934 mentioned four. Each of the four entities is implemented as a class
5935 with slightly differing methods for displaying an object.
5937 Arguments you pass to these commands are either strings exactly matching
5938 the identification string of an object or regular expressions that are
5939 then matched case-insensitively against various attributes of the
5940 objects. The parser recognizes a regular expression only if you
5941 enclose it between two slashes.
5943 The principle is that the number of found objects influences how an
5944 item is displayed. If the search finds one item, the result is
5945 displayed with the rather verbose method C<as_string>, but if we find
5946 more than one, we display each object with the terse method
5949 =item make, test, install, clean modules or distributions
5951 These commands take any number of arguments and investigate what is
5952 necessary to perform the action. If the argument is a distribution
5953 file name (recognized by embedded slashes), it is processed. If it is
5954 a module, CPAN determines the distribution file in which this module
5955 is included and processes that, following any dependencies named in
5956 the module's Makefile.PL (this behavior is controlled by
5957 I<prerequisites_policy>.)
5959 Any C<make> or C<test> are run unconditionally. An
5961 install <distribution_file>
5963 also is run unconditionally. But for
5967 CPAN checks if an install is actually needed for it and prints
5968 I<module up to date> in the case that the distribution file containing
5969 the module doesn't need to be updated.
5971 CPAN also keeps track of what it has done within the current session
5972 and doesn't try to build a package a second time regardless if it
5973 succeeded or not. The C<force> command takes as a first argument the
5974 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5975 command from scratch.
5979 cpan> install OpenGL
5980 OpenGL is up to date.
5981 cpan> force install OpenGL
5984 OpenGL-0.4/COPYRIGHT
5987 A C<clean> command results in a
5991 being executed within the distribution file's working directory.
5993 =item get, readme, look module or distribution
5995 C<get> downloads a distribution file without further action. C<readme>
5996 displays the README file of the associated distribution. C<Look> gets
5997 and untars (if not yet done) the distribution file, changes to the
5998 appropriate directory and opens a subshell process in that directory.
6002 C<ls> lists all distribution files in and below an author's CPAN
6003 directory. Only those files that contain modules are listed and if
6004 there is more than one for any given module, only the most recent one
6009 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6010 in the cpan-shell it is intended that you can press C<^C> anytime and
6011 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6012 to clean up and leave the shell loop. You can emulate the effect of a
6013 SIGTERM by sending two consecutive SIGINTs, which usually means by
6014 pressing C<^C> twice.
6016 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6017 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6023 The commands that are available in the shell interface are methods in
6024 the package CPAN::Shell. If you enter the shell command, all your
6025 input is split by the Text::ParseWords::shellwords() routine which
6026 acts like most shells do. The first word is being interpreted as the
6027 method to be called and the rest of the words are treated as arguments
6028 to this method. Continuation lines are supported if a line ends with a
6033 C<autobundle> writes a bundle file into the
6034 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6035 a list of all modules that are both available from CPAN and currently
6036 installed within @INC. The name of the bundle file is based on the
6037 current date and a counter.
6041 recompile() is a very special command in that it takes no argument and
6042 runs the make/test/install cycle with brute force over all installed
6043 dynamically loadable extensions (aka XS modules) with 'force' in
6044 effect. The primary purpose of this command is to finish a network
6045 installation. Imagine, you have a common source tree for two different
6046 architectures. You decide to do a completely independent fresh
6047 installation. You start on one architecture with the help of a Bundle
6048 file produced earlier. CPAN installs the whole Bundle for you, but
6049 when you try to repeat the job on the second architecture, CPAN
6050 responds with a C<"Foo up to date"> message for all modules. So you
6051 invoke CPAN's recompile on the second architecture and you're done.
6053 Another popular use for C<recompile> is to act as a rescue in case your
6054 perl breaks binary compatibility. If one of the modules that CPAN uses
6055 is in turn depending on binary compatibility (so you cannot run CPAN
6056 commands), then you should try the CPAN::Nox module for recovery.
6058 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6060 Although it may be considered internal, the class hierarchy does matter
6061 for both users and programmer. CPAN.pm deals with above mentioned four
6062 classes, and all those classes share a set of methods. A classical
6063 single polymorphism is in effect. A metaclass object registers all
6064 objects of all kinds and indexes them with a string. The strings
6065 referencing objects have a separated namespace (well, not completely
6070 words containing a "/" (slash) Distribution
6071 words starting with Bundle:: Bundle
6072 everything else Module or Author
6074 Modules know their associated Distribution objects. They always refer
6075 to the most recent official release. Developers may mark their releases
6076 as unstable development versions (by inserting an underbar into the
6077 module version number which will also be reflected in the distribution
6078 name when you run 'make dist'), so the really hottest and newest
6079 distribution is not always the default. If a module Foo circulates
6080 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6081 way to install version 1.23 by saying
6085 This would install the complete distribution file (say
6086 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6087 like to install version 1.23_90, you need to know where the
6088 distribution file resides on CPAN relative to the authors/id/
6089 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6090 so you would have to say
6092 install BAR/Foo-1.23_90.tar.gz
6094 The first example will be driven by an object of the class
6095 CPAN::Module, the second by an object of class CPAN::Distribution.
6097 =head2 Programmer's interface
6099 If you do not enter the shell, the available shell commands are both
6100 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6101 functions in the calling package (C<install(...)>).
6103 There's currently only one class that has a stable interface -
6104 CPAN::Shell. All commands that are available in the CPAN shell are
6105 methods of the class CPAN::Shell. Each of the commands that produce
6106 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6107 the IDs of all modules within the list.
6111 =item expand($type,@things)
6113 The IDs of all objects available within a program are strings that can
6114 be expanded to the corresponding real objects with the
6115 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6116 list of CPAN::Module objects according to the C<@things> arguments
6117 given. In scalar context it only returns the first element of the
6120 =item expandany(@things)
6122 Like expand, but returns objects of the appropriate type, i.e.
6123 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6124 CPAN::Distribution objects fro distributions.
6126 =item Programming Examples
6128 This enables the programmer to do operations that combine
6129 functionalities that are available in the shell.
6131 # install everything that is outdated on my disk:
6132 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6134 # install my favorite programs if necessary:
6135 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6136 my $obj = CPAN::Shell->expand('Module',$mod);
6140 # list all modules on my disk that have no VERSION number
6141 for $mod (CPAN::Shell->expand("Module","/./")){
6142 next unless $mod->inst_file;
6143 # MakeMaker convention for undefined $VERSION:
6144 next unless $mod->inst_version eq "undef";
6145 print "No VERSION in ", $mod->id, "\n";
6148 # find out which distribution on CPAN contains a module:
6149 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6151 Or if you want to write a cronjob to watch The CPAN, you could list
6152 all modules that need updating. First a quick and dirty way:
6154 perl -e 'use CPAN; CPAN::Shell->r;'
6156 If you don't want to get any output in the case that all modules are
6157 up to date, you can parse the output of above command for the regular
6158 expression //modules are up to date// and decide to mail the output
6159 only if it doesn't match. Ick?
6161 If you prefer to do it more in a programmer style in one single
6162 process, maybe something like this suits you better:
6164 # list all modules on my disk that have newer versions on CPAN
6165 for $mod (CPAN::Shell->expand("Module","/./")){
6166 next unless $mod->inst_file;
6167 next if $mod->uptodate;
6168 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6169 $mod->id, $mod->inst_version, $mod->cpan_version;
6172 If that gives you too much output every day, you maybe only want to
6173 watch for three modules. You can write
6175 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6177 as the first line instead. Or you can combine some of the above
6180 # watch only for a new mod_perl module
6181 $mod = CPAN::Shell->expand("Module","mod_perl");
6182 exit if $mod->uptodate;
6183 # new mod_perl arrived, let me know all update recommendations
6188 =head2 Methods in the other Classes
6190 The programming interface for the classes CPAN::Module,
6191 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6192 beta and partially even alpha. In the following paragraphs only those
6193 methods are documented that have proven useful over a longer time and
6194 thus are unlikely to change.
6198 =item CPAN::Author::as_glimpse()
6200 Returns a one-line description of the author
6202 =item CPAN::Author::as_string()
6204 Returns a multi-line description of the author
6206 =item CPAN::Author::email()
6208 Returns the author's email address
6210 =item CPAN::Author::fullname()
6212 Returns the author's name
6214 =item CPAN::Author::name()
6216 An alias for fullname
6218 =item CPAN::Bundle::as_glimpse()
6220 Returns a one-line description of the bundle
6222 =item CPAN::Bundle::as_string()
6224 Returns a multi-line description of the bundle
6226 =item CPAN::Bundle::clean()
6228 Recursively runs the C<clean> method on all items contained in the bundle.
6230 =item CPAN::Bundle::contains()
6232 Returns a list of objects' IDs contained in a bundle. The associated
6233 objects may be bundles, modules or distributions.
6235 =item CPAN::Bundle::force($method,@args)
6237 Forces CPAN to perform a task that normally would have failed. Force
6238 takes as arguments a method name to be called and any number of
6239 additional arguments that should be passed to the called method. The
6240 internals of the object get the needed changes so that CPAN.pm does
6241 not refuse to take the action. The C<force> is passed recursively to
6242 all contained objects.
6244 =item CPAN::Bundle::get()
6246 Recursively runs the C<get> method on all items contained in the bundle
6248 =item CPAN::Bundle::inst_file()
6250 Returns the highest installed version of the bundle in either @INC or
6251 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6252 CPAN::Module::inst_file.
6254 =item CPAN::Bundle::inst_version()
6256 Like CPAN::Bundle::inst_file, but returns the $VERSION
6258 =item CPAN::Bundle::uptodate()
6260 Returns 1 if the bundle itself and all its members are uptodate.
6262 =item CPAN::Bundle::install()
6264 Recursively runs the C<install> method on all items contained in the bundle
6266 =item CPAN::Bundle::make()
6268 Recursively runs the C<make> method on all items contained in the bundle
6270 =item CPAN::Bundle::readme()
6272 Recursively runs the C<readme> method on all items contained in the bundle
6274 =item CPAN::Bundle::test()
6276 Recursively runs the C<test> method on all items contained in the bundle
6278 =item CPAN::Distribution::as_glimpse()
6280 Returns a one-line description of the distribution
6282 =item CPAN::Distribution::as_string()
6284 Returns a multi-line description of the distribution
6286 =item CPAN::Distribution::clean()
6288 Changes to the directory where the distribution has been unpacked and
6289 runs C<make clean> there.
6291 =item CPAN::Distribution::containsmods()
6293 Returns a list of IDs of modules contained in a distribution file.
6294 Only works for distributions listed in the 02packages.details.txt.gz
6295 file. This typically means that only the most recent version of a
6296 distribution is covered.
6298 =item CPAN::Distribution::cvs_import()
6300 Changes to the directory where the distribution has been unpacked and
6303 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6307 =item CPAN::Distribution::dir()
6309 Returns the directory into which this distribution has been unpacked.
6311 =item CPAN::Distribution::force($method,@args)
6313 Forces CPAN to perform a task that normally would have failed. Force
6314 takes as arguments a method name to be called and any number of
6315 additional arguments that should be passed to the called method. The
6316 internals of the object get the needed changes so that CPAN.pm does
6317 not refuse to take the action.
6319 =item CPAN::Distribution::get()
6321 Downloads the distribution from CPAN and unpacks it. Does nothing if
6322 the distribution has already been downloaded and unpacked within the
6325 =item CPAN::Distribution::install()
6327 Changes to the directory where the distribution has been unpacked and
6328 runs the external command C<make install> there. If C<make> has not
6329 yet been run, it will be run first. A C<make test> will be issued in
6330 any case and if this fails, the install will be canceled. The
6331 cancellation can be avoided by letting C<force> run the C<install> for
6334 =item CPAN::Distribution::isa_perl()
6336 Returns 1 if this distribution file seems to be a perl distribution.
6337 Normally this is derived from the file name only, but the index from
6338 CPAN can contain a hint to achieve a return value of true for other
6341 =item CPAN::Distribution::look()
6343 Changes to the directory where the distribution has been unpacked and
6344 opens a subshell there. Exiting the subshell returns.
6346 =item CPAN::Distribution::make()
6348 First runs the C<get> method to make sure the distribution is
6349 downloaded and unpacked. Changes to the directory where the
6350 distribution has been unpacked and runs the external commands C<perl
6351 Makefile.PL> and C<make> there.
6353 =item CPAN::Distribution::prereq_pm()
6355 Returns the hash reference that has been announced by a distribution
6356 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6357 attempt has been made to C<make> the distribution. Returns undef
6360 =item CPAN::Distribution::readme()
6362 Downloads the README file associated with a distribution and runs it
6363 through the pager specified in C<$CPAN::Config->{pager}>.
6365 =item CPAN::Distribution::test()
6367 Changes to the directory where the distribution has been unpacked and
6368 runs C<make test> there.
6370 =item CPAN::Distribution::uptodate()
6372 Returns 1 if all the modules contained in the distribution are
6373 uptodate. Relies on containsmods.
6375 =item CPAN::Index::force_reload()
6377 Forces a reload of all indices.
6379 =item CPAN::Index::reload()
6381 Reloads all indices if they have been read more than
6382 C<$CPAN::Config->{index_expire}> days.
6384 =item CPAN::InfoObj::dump()
6386 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6387 inherit this method. It prints the data structure associated with an
6388 object. Useful for debugging. Note: the data structure is considered
6389 internal and thus subject to change without notice.
6391 =item CPAN::Module::as_glimpse()
6393 Returns a one-line description of the module
6395 =item CPAN::Module::as_string()
6397 Returns a multi-line description of the module
6399 =item CPAN::Module::clean()
6401 Runs a clean on the distribution associated with this module.
6403 =item CPAN::Module::cpan_file()
6405 Returns the filename on CPAN that is associated with the module.
6407 =item CPAN::Module::cpan_version()
6409 Returns the latest version of this module available on CPAN.
6411 =item CPAN::Module::cvs_import()
6413 Runs a cvs_import on the distribution associated with this module.
6415 =item CPAN::Module::description()
6417 Returns a 44 character description of this module. Only available for
6418 modules listed in The Module List (CPAN/modules/00modlist.long.html
6419 or 00modlist.long.txt.gz)
6421 =item CPAN::Module::force($method,@args)
6423 Forces CPAN to perform a task that normally would have failed. Force
6424 takes as arguments a method name to be called and any number of
6425 additional arguments that should be passed to the called method. The
6426 internals of the object get the needed changes so that CPAN.pm does
6427 not refuse to take the action.
6429 =item CPAN::Module::get()
6431 Runs a get on the distribution associated with this module.
6433 =item CPAN::Module::inst_file()
6435 Returns the filename of the module found in @INC. The first file found
6436 is reported just like perl itself stops searching @INC when it finds a
6439 =item CPAN::Module::inst_version()
6441 Returns the version number of the module in readable format.
6443 =item CPAN::Module::install()
6445 Runs an C<install> on the distribution associated with this module.
6447 =item CPAN::Module::look()
6449 Changes to the directory where the distribution associated with this
6450 module has been unpacked and opens a subshell there. Exiting the
6453 =item CPAN::Module::make()
6455 Runs a C<make> on the distribution associated with this module.
6457 =item CPAN::Module::manpage_headline()
6459 If module is installed, peeks into the module's manpage, reads the
6460 headline and returns it. Moreover, if the module has been downloaded
6461 within this session, does the equivalent on the downloaded module even
6462 if it is not installed.
6464 =item CPAN::Module::readme()
6466 Runs a C<readme> on the distribution associated with this module.
6468 =item CPAN::Module::test()
6470 Runs a C<test> on the distribution associated with this module.
6472 =item CPAN::Module::uptodate()
6474 Returns 1 if the module is installed and up-to-date.
6476 =item CPAN::Module::userid()
6478 Returns the author's ID of the module.
6482 =head2 Cache Manager
6484 Currently the cache manager only keeps track of the build directory
6485 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6486 deletes complete directories below C<build_dir> as soon as the size of
6487 all directories there gets bigger than $CPAN::Config->{build_cache}
6488 (in MB). The contents of this cache may be used for later
6489 re-installations that you intend to do manually, but will never be
6490 trusted by CPAN itself. This is due to the fact that the user might
6491 use these directories for building modules on different architectures.
6493 There is another directory ($CPAN::Config->{keep_source_where}) where
6494 the original distribution files are kept. This directory is not
6495 covered by the cache manager and must be controlled by the user. If
6496 you choose to have the same directory as build_dir and as
6497 keep_source_where directory, then your sources will be deleted with
6498 the same fifo mechanism.
6502 A bundle is just a perl module in the namespace Bundle:: that does not
6503 define any functions or methods. It usually only contains documentation.
6505 It starts like a perl module with a package declaration and a $VERSION
6506 variable. After that the pod section looks like any other pod with the
6507 only difference being that I<one special pod section> exists starting with
6512 In this pod section each line obeys the format
6514 Module_Name [Version_String] [- optional text]
6516 The only required part is the first field, the name of a module
6517 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6518 of the line is optional. The comment part is delimited by a dash just
6519 as in the man page header.
6521 The distribution of a bundle should follow the same convention as
6522 other distributions.
6524 Bundles are treated specially in the CPAN package. If you say 'install
6525 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6526 the modules in the CONTENTS section of the pod. You can install your
6527 own Bundles locally by placing a conformant Bundle file somewhere into
6528 your @INC path. The autobundle() command which is available in the
6529 shell interface does that for you by including all currently installed
6530 modules in a snapshot bundle file.
6532 =head2 Prerequisites
6534 If you have a local mirror of CPAN and can access all files with
6535 "file:" URLs, then you only need a perl better than perl5.003 to run
6536 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6537 required for non-UNIX systems or if your nearest CPAN site is
6538 associated with a URL that is not C<ftp:>.
6540 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6541 implemented for an external ftp command or for an external lynx
6544 =head2 Finding packages and VERSION
6546 This module presumes that all packages on CPAN
6552 declare their $VERSION variable in an easy to parse manner. This
6553 prerequisite can hardly be relaxed because it consumes far too much
6554 memory to load all packages into the running program just to determine
6555 the $VERSION variable. Currently all programs that are dealing with
6556 version use something like this
6558 perl -MExtUtils::MakeMaker -le \
6559 'print MM->parse_version(shift)' filename
6561 If you are author of a package and wonder if your $VERSION can be
6562 parsed, please try the above method.
6566 come as compressed or gzipped tarfiles or as zip files and contain a
6567 Makefile.PL (well, we try to handle a bit more, but without much
6574 The debugging of this module is a bit complex, because we have
6575 interferences of the software producing the indices on CPAN, of the
6576 mirroring process on CPAN, of packaging, of configuration, of
6577 synchronicity, and of bugs within CPAN.pm.
6579 For code debugging in interactive mode you can try "o debug" which
6580 will list options for debugging the various parts of the code. You
6581 should know that "o debug" has built-in completion support.
6583 For data debugging there is the C<dump> command which takes the same
6584 arguments as make/test/install and outputs the object's Data::Dumper
6587 =head2 Floppy, Zip, Offline Mode
6589 CPAN.pm works nicely without network too. If you maintain machines
6590 that are not networked at all, you should consider working with file:
6591 URLs. Of course, you have to collect your modules somewhere first. So
6592 you might use CPAN.pm to put together all you need on a networked
6593 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6594 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6595 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6596 with this floppy. See also below the paragraph about CD-ROM support.
6598 =head1 CONFIGURATION
6600 When the CPAN module is installed, a site wide configuration file is
6601 created as CPAN/Config.pm. The default values defined there can be
6602 overridden in another configuration file: CPAN/MyConfig.pm. You can
6603 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6604 $HOME/.cpan is added to the search path of the CPAN module before the
6605 use() or require() statements.
6607 Currently the following keys in the hash reference $CPAN::Config are
6610 build_cache size of cache for directories to build modules
6611 build_dir locally accessible directory to build modules
6612 index_expire after this many days refetch index files
6613 cache_metadata use serializer to cache metadata
6614 cpan_home local directory reserved for this package
6615 dontload_hash anonymous hash: modules in the keys will not be
6616 loaded by the CPAN::has_inst() routine
6617 gzip location of external program gzip
6618 inactivity_timeout breaks interactive Makefile.PLs after this
6619 many seconds inactivity. Set to 0 to never break.
6620 inhibit_startup_message
6621 if true, does not print the startup message
6622 keep_source_where directory in which to keep the source (if we do)
6623 make location of external make program
6624 make_arg arguments that should always be passed to 'make'
6625 make_install_arg same as make_arg for 'make install'
6626 makepl_arg arguments passed to 'perl Makefile.PL'
6627 pager location of external program more (or any pager)
6628 prerequisites_policy
6629 what to do if you are missing module prerequisites
6630 ('follow' automatically, 'ask' me, or 'ignore')
6631 proxy_user username for accessing an authenticating proxy
6632 proxy_pass password for accessing an authenticating proxy
6633 scan_cache controls scanning of cache ('atstart' or 'never')
6634 tar location of external program tar
6635 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6636 (and nonsense for characters outside latin range)
6637 unzip location of external program unzip
6638 urllist arrayref to nearby CPAN sites (or equivalent locations)
6639 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6640 ftp_proxy, } the three usual variables for configuring
6641 http_proxy, } proxy requests. Both as CPAN::Config variables
6642 no_proxy } and as environment variables configurable.
6644 You can set and query each of these options interactively in the cpan
6645 shell with the command set defined within the C<o conf> command:
6649 =item C<o conf E<lt>scalar optionE<gt>>
6651 prints the current value of the I<scalar option>
6653 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6655 Sets the value of the I<scalar option> to I<value>
6657 =item C<o conf E<lt>list optionE<gt>>
6659 prints the current value of the I<list option> in MakeMaker's
6662 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6664 shifts or pops the array in the I<list option> variable
6666 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6668 works like the corresponding perl commands.
6672 =head2 Note on urllist parameter's format
6674 urllist parameters are URLs according to RFC 1738. We do a little
6675 guessing if your URL is not compliant, but if you have problems with
6676 file URLs, please try the correct format. Either:
6678 file://localhost/whatever/ftp/pub/CPAN/
6682 file:///home/ftp/pub/CPAN/
6684 =head2 urllist parameter has CD-ROM support
6686 The C<urllist> parameter of the configuration table contains a list of
6687 URLs that are to be used for downloading. If the list contains any
6688 C<file> URLs, CPAN always tries to get files from there first. This
6689 feature is disabled for index files. So the recommendation for the
6690 owner of a CD-ROM with CPAN contents is: include your local, possibly
6691 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6693 o conf urllist push file://localhost/CDROM/CPAN
6695 CPAN.pm will then fetch the index files from one of the CPAN sites
6696 that come at the beginning of urllist. It will later check for each
6697 module if there is a local copy of the most recent version.
6699 Another peculiarity of urllist is that the site that we could
6700 successfully fetch the last file from automatically gets a preference
6701 token and is tried as the first site for the next request. So if you
6702 add a new site at runtime it may happen that the previously preferred
6703 site will be tried another time. This means that if you want to disallow
6704 a site for the next transfer, it must be explicitly removed from
6709 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6710 install foreign, unmasked, unsigned code on your machine. We compare
6711 to a checksum that comes from the net just as the distribution file
6712 itself. If somebody has managed to tamper with the distribution file,
6713 they may have as well tampered with the CHECKSUMS file. Future
6714 development will go towards strong authentication.
6718 Most functions in package CPAN are exported per default. The reason
6719 for this is that the primary use is intended for the cpan shell or for
6722 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6724 Populating a freshly installed perl with my favorite modules is pretty
6725 easy if you maintain a private bundle definition file. To get a useful
6726 blueprint of a bundle definition file, the command autobundle can be used
6727 on the CPAN shell command line. This command writes a bundle definition
6728 file for all modules that are installed for the currently running perl
6729 interpreter. It's recommended to run this command only once and from then
6730 on maintain the file manually under a private name, say
6731 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6733 cpan> install Bundle::my_bundle
6735 then answer a few questions and then go out for a coffee.
6737 Maintaining a bundle definition file means keeping track of two
6738 things: dependencies and interactivity. CPAN.pm sometimes fails on
6739 calculating dependencies because not all modules define all MakeMaker
6740 attributes correctly, so a bundle definition file should specify
6741 prerequisites as early as possible. On the other hand, it's a bit
6742 annoying that many distributions need some interactive configuring. So
6743 what I try to accomplish in my private bundle file is to have the
6744 packages that need to be configured early in the file and the gentle
6745 ones later, so I can go out after a few minutes and leave CPAN.pm
6748 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6750 Thanks to Graham Barr for contributing the following paragraphs about
6751 the interaction between perl, and various firewall configurations. For
6752 further informations on firewalls, it is recommended to consult the
6753 documentation that comes with the ncftp program. If you are unable to
6754 go through the firewall with a simple Perl setup, it is very likely
6755 that you can configure ncftp so that it works for your firewall.
6757 =head2 Three basic types of firewalls
6759 Firewalls can be categorized into three basic types.
6765 This is where the firewall machine runs a web server and to access the
6766 outside world you must do it via the web server. If you set environment
6767 variables like http_proxy or ftp_proxy to a values beginning with http://
6768 or in your web browser you have to set proxy information then you know
6769 you are running an http firewall.
6771 To access servers outside these types of firewalls with perl (even for
6772 ftp) you will need to use LWP.
6776 This where the firewall machine runs an ftp server. This kind of
6777 firewall will only let you access ftp servers outside the firewall.
6778 This is usually done by connecting to the firewall with ftp, then
6779 entering a username like "user@outside.host.com"
6781 To access servers outside these type of firewalls with perl you
6782 will need to use Net::FTP.
6784 =item One way visibility
6786 I say one way visibility as these firewalls try to make themselves look
6787 invisible to the users inside the firewall. An FTP data connection is
6788 normally created by sending the remote server your IP address and then
6789 listening for the connection. But the remote server will not be able to
6790 connect to you because of the firewall. So for these types of firewall
6791 FTP connections need to be done in a passive mode.
6793 There are two that I can think off.
6799 If you are using a SOCKS firewall you will need to compile perl and link
6800 it with the SOCKS library, this is what is normally called a 'socksified'
6801 perl. With this executable you will be able to connect to servers outside
6802 the firewall as if it is not there.
6806 This is the firewall implemented in the Linux kernel, it allows you to
6807 hide a complete network behind one IP address. With this firewall no
6808 special compiling is needed as you can access hosts directly.
6814 =head2 Configuring lynx or ncftp for going through a firewall
6816 If you can go through your firewall with e.g. lynx, presumably with a
6819 /usr/local/bin/lynx -pscott:tiger
6821 then you would configure CPAN.pm with the command
6823 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6825 That's all. Similarly for ncftp or ftp, you would configure something
6828 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6830 Your mileage may vary...
6838 I installed a new version of module X but CPAN keeps saying,
6839 I have the old version installed
6841 Most probably you B<do> have the old version installed. This can
6842 happen if a module installs itself into a different directory in the
6843 @INC path than it was previously installed. This is not really a
6844 CPAN.pm problem, you would have the same problem when installing the
6845 module manually. The easiest way to prevent this behaviour is to add
6846 the argument C<UNINST=1> to the C<make install> call, and that is why
6847 many people add this argument permanently by configuring
6849 o conf make_install_arg UNINST=1
6853 So why is UNINST=1 not the default?
6855 Because there are people who have their precise expectations about who
6856 may install where in the @INC path and who uses which @INC array. In
6857 fine tuned environments C<UNINST=1> can cause damage.
6861 I want to clean up my mess, and install a new perl along with
6862 all modules I have. How do I go about it?
6864 Run the autobundle command for your old perl and optionally rename the
6865 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6866 with the Configure option prefix, e.g.
6868 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6870 Install the bundle file you produced in the first step with something like
6872 cpan> install Bundle::mybundle
6878 When I install bundles or multiple modules with one command
6879 there is too much output to keep track of.
6881 You may want to configure something like
6883 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6884 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6886 so that STDOUT is captured in a file for later inspection.
6891 I am not root, how can I install a module in a personal directory?
6893 You will most probably like something like this:
6895 o conf makepl_arg "LIB=~/myperl/lib \
6896 INSTALLMAN1DIR=~/myperl/man/man1 \
6897 INSTALLMAN3DIR=~/myperl/man/man3"
6898 install Sybase::Sybperl
6900 You can make this setting permanent like all C<o conf> settings with
6903 You will have to add ~/myperl/man to the MANPATH environment variable
6904 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6907 use lib "$ENV{HOME}/myperl/lib";
6909 or setting the PERL5LIB environment variable.
6911 Another thing you should bear in mind is that the UNINST parameter
6912 should never be set if you are not root.
6916 How to get a package, unwrap it, and make a change before building it?
6918 look Sybase::Sybperl
6922 I installed a Bundle and had a couple of fails. When I
6923 retried, everything resolved nicely. Can this be fixed to work
6926 The reason for this is that CPAN does not know the dependencies of all
6927 modules when it starts out. To decide about the additional items to
6928 install, it just uses data found in the generated Makefile. An
6929 undetected missing piece breaks the process. But it may well be that
6930 your Bundle installs some prerequisite later than some depending item
6931 and thus your second try is able to resolve everything. Please note,
6932 CPAN.pm does not know the dependency tree in advance and cannot sort
6933 the queue of things to install in a topologically correct order. It
6934 resolves perfectly well IFF all modules declare the prerequisites
6935 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6936 fail and you need to install often, it is recommended sort the Bundle
6937 definition file manually. It is planned to improve the metadata
6938 situation for dependencies on CPAN in general, but this will still
6943 In our intranet we have many modules for internal use. How
6944 can I integrate these modules with CPAN.pm but without uploading
6945 the modules to CPAN?
6947 Have a look at the CPAN::Site module.
6951 When I run CPAN's shell, I get error msg about line 1 to 4,
6952 setting meta input/output via the /etc/inputrc file.
6954 Some versions of readline are picky about capitalization in the
6955 /etc/inputrc file and specifically RedHat 6.2 comes with a
6956 /etc/inputrc that contains the word C<on> in lowercase. Change the
6957 occurrences of C<on> to C<On> and the bug should disappear.
6961 Some authors have strange characters in their names.
6963 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
6964 expecting ISO-8859-1 charset, a converter can be activated by setting
6965 term_is_latin to a true value in your config file. One way of doing so
6968 cpan> ! $CPAN::Config->{term_is_latin}=1
6970 Extended support for converters will be made available as soon as perl
6971 becomes stable with regard to charset issues.
6977 We should give coverage for B<all> of the CPAN and not just the PAUSE
6978 part, right? In this discussion CPAN and PAUSE have become equal --
6979 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6980 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6982 Future development should be directed towards a better integration of
6985 If a Makefile.PL requires special customization of libraries, prompts
6986 the user for special input, etc. then you may find CPAN is not able to
6987 build the distribution. In that case, you should attempt the
6988 traditional method of building a Perl module package from a shell.
6992 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
6996 Kawai,Takanori provides a Japanese translation of this manpage at
6997 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7001 perl(1), CPAN::Nox(3)