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 ();
26 no lib "."; # we need to run chdir all over and we would get at wrong
29 require Mac::BuildTools if $^O eq 'MacOS';
31 END { $End++; &cleanup; }
54 $CPAN::Frontend ||= "CPAN::Shell";
55 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
60 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
61 $Revision $Signal $End $Suppress_readline $Frontend
62 $Defaultsite $Have_warned);
64 @CPAN::ISA = qw(CPAN::Debug Exporter);
67 autobundle bundle expand force get cvs_import
68 install make readme recompile shell test clean
71 #-> sub CPAN::AUTOLOAD ;
76 @EXPORT{@EXPORT} = '';
77 CPAN::Config->load unless $CPAN::Config_loaded++;
78 if (exists $EXPORT{$l}){
81 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
90 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
91 CPAN::Config->load unless $CPAN::Config_loaded++;
93 my $oprompt = shift || "cpan> ";
94 my $prompt = $oprompt;
95 my $commandline = shift || "";
98 unless ($Suppress_readline) {
99 require Term::ReadLine;
102 $term->ReadLine eq "Term::ReadLine::Stub"
104 $term = Term::ReadLine->new('CPAN Monitor');
106 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
107 my $attribs = $term->Attribs;
108 $attribs->{attempted_completion_function} = sub {
109 &CPAN::Complete::gnu_cpl;
112 $readline::rl_completion_function =
113 $readline::rl_completion_function = 'CPAN::Complete::cpl';
115 # $term->OUT is autoflushed anyway
116 my $odef = select STDERR;
123 # no strict; # I do not recall why no strict was here (2000-09-03)
125 my $cwd = CPAN::anycwd();
126 my $try_detect_readline;
127 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
128 my $rl_avail = $Suppress_readline ? "suppressed" :
129 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
130 "available (try 'install Bundle::CPAN')";
132 $CPAN::Frontend->myprint(
134 cpan shell -- CPAN exploration and modules installation (v%s%s)
142 unless $CPAN::Config->{'inhibit_startup_message'} ;
143 my($continuation) = "";
144 SHELLCOMMAND: while () {
145 if ($Suppress_readline) {
147 last SHELLCOMMAND unless defined ($_ = <> );
150 last SHELLCOMMAND unless
151 defined ($_ = $term->readline($prompt, $commandline));
153 $_ = "$continuation$_" if $continuation;
155 next SHELLCOMMAND if /^$/;
156 $_ = 'h' if /^\s*\?/;
157 if (/^(?:q(?:uit)?|bye|exit)$/i) {
167 use vars qw($import_done);
168 CPAN->import(':DEFAULT') unless $import_done++;
169 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
176 if ($] < 5.00322) { # parsewords had a bug until recently
179 eval { @line = Text::ParseWords::shellwords($_) };
180 warn($@), next SHELLCOMMAND if $@;
181 warn("Text::Parsewords could not parse the line [$_]"),
182 next SHELLCOMMAND unless @line;
184 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
185 my $command = shift @line;
186 eval { CPAN::Shell->$command(@line) };
188 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
189 $CPAN::Frontend->myprint("\n");
194 $commandline = ""; # I do want to be able to pass a default to
195 # shell, but on the second command I see no
198 CPAN::Queue->nullify_queue;
199 if ($try_detect_readline) {
200 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
202 $CPAN::META->has_inst("Term::ReadLine::Perl")
204 delete $INC{"Term/ReadLine.pm"};
206 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
207 require Term::ReadLine;
208 $CPAN::Frontend->myprint("\n$redef subroutines in ".
209 "Term::ReadLine redefined\n");
215 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
218 package CPAN::CacheMgr;
219 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
222 package CPAN::Config;
223 use vars qw(%can $dot_cpan);
226 'commit' => "Commit changes to disk",
227 'defaults' => "Reload defaults from disk",
228 'init' => "Interactive setting of all options",
232 use vars qw($Ua $Thesite $Themethod);
233 @CPAN::FTP::ISA = qw(CPAN::Debug);
235 package CPAN::LWP::UserAgent;
236 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
237 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
239 package CPAN::Complete;
240 @CPAN::Complete::ISA = qw(CPAN::Debug);
241 @CPAN::Complete::COMMANDS = sort qw(
242 ! a b d h i m o q r u autobundle clean dump
243 make test install force readme reload look
245 ) unless @CPAN::Complete::COMMANDS;
248 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
249 @CPAN::Index::ISA = qw(CPAN::Debug);
252 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
255 package CPAN::InfoObj;
256 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
258 package CPAN::Author;
259 @CPAN::Author::ISA = qw(CPAN::InfoObj);
261 package CPAN::Distribution;
262 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
264 package CPAN::Bundle;
265 @CPAN::Bundle::ISA = qw(CPAN::Module);
267 package CPAN::Module;
268 @CPAN::Module::ISA = qw(CPAN::InfoObj);
271 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
272 @CPAN::Shell::ISA = qw(CPAN::Debug);
273 $COLOR_REGISTERED ||= 0;
274 $PRINT_ORNAMENTING ||= 0;
276 #-> sub CPAN::Shell::AUTOLOAD ;
278 my($autoload) = $AUTOLOAD;
279 my $class = shift(@_);
280 # warn "autoload[$autoload] class[$class]";
281 $autoload =~ s/.*:://;
282 if ($autoload =~ /^w/) {
283 if ($CPAN::META->has_inst('CPAN::WAIT')) {
284 CPAN::WAIT->$autoload(@_);
286 $CPAN::Frontend->mywarn(qq{
287 Commands starting with "w" require CPAN::WAIT to be installed.
288 Please consider installing CPAN::WAIT to use the fulltext index.
289 For this you just need to type
294 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
300 package CPAN::Tarzip;
301 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
302 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
303 $BUGHUNTING = 0; # released code must have turned off
307 # One use of the queue is to determine if we should or shouldn't
308 # announce the availability of a new CPAN module
310 # Now we try to use it for dependency tracking. For that to happen
311 # we need to draw a dependency tree and do the leaves first. This can
312 # easily be reached by running CPAN.pm recursively, but we don't want
313 # to waste memory and run into deep recursion. So what we can do is
316 # CPAN::Queue is the package where the queue is maintained. Dependencies
317 # often have high priority and must be brought to the head of the queue,
318 # possibly by jumping the queue if they are already there. My first code
319 # attempt tried to be extremely correct. Whenever a module needed
320 # immediate treatment, I either unshifted it to the front of the queue,
321 # or, if it was already in the queue, I spliced and let it bypass the
322 # others. This became a too correct model that made it impossible to put
323 # an item more than once into the queue. Why would you need that? Well,
324 # you need temporary duplicates as the manager of the queue is a loop
327 # (1) looks at the first item in the queue without shifting it off
329 # (2) cares for the item
331 # (3) removes the item from the queue, *even if its agenda failed and
332 # even if the item isn't the first in the queue anymore* (that way
333 # protecting against never ending queues)
335 # So if an item has prerequisites, the installation fails now, but we
336 # want to retry later. That's easy if we have it twice in the queue.
338 # I also expect insane dependency situations where an item gets more
339 # than two lives in the queue. Simplest example is triggered by 'install
340 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
341 # get in the way. I wanted the queue manager to be a dumb servant, not
342 # one that knows everything.
344 # Who would I tell in this model that the user wants to be asked before
345 # processing? I can't attach that information to the module object,
346 # because not modules are installed but distributions. So I'd have to
347 # tell the distribution object that it should ask the user before
348 # processing. Where would the question be triggered then? Most probably
349 # in CPAN::Distribution::rematein.
350 # Hope that makes sense, my head is a bit off:-) -- AK
357 my $self = bless { qmod => $s }, $class;
362 # CPAN::Queue::first ;
368 # CPAN::Queue::delete_first ;
370 my($class,$what) = @_;
372 for my $i (0..$#All) {
373 if ( $All[$i]->{qmod} eq $what ) {
380 # CPAN::Queue::jumpqueue ;
384 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
385 join(",",map {$_->{qmod}} @All),
388 WHAT: for my $what (reverse @what) {
390 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
391 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
392 if ($All[$i]->{qmod} eq $what){
394 if ($jumped > 100) { # one's OK if e.g. just
395 # processing now; more are OK if
396 # user typed it several times
397 $CPAN::Frontend->mywarn(
398 qq{Object [$what] queued more than 100 times, ignoring}
404 my $obj = bless { qmod => $what }, $class;
407 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
408 join(",",map {$_->{qmod}} @All),
413 # CPAN::Queue::exists ;
415 my($self,$what) = @_;
416 my @all = map { $_->{qmod} } @All;
417 my $exists = grep { $_->{qmod} eq $what } @All;
418 # warn "in exists what[$what] all[@all] exists[$exists]";
422 # CPAN::Queue::delete ;
425 @All = grep { $_->{qmod} ne $mod } @All;
428 # CPAN::Queue::nullify_queue ;
437 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
439 # from here on only subs.
440 ################################################################################
442 #-> sub CPAN::all_objects ;
444 my($mgr,$class) = @_;
445 CPAN::Config->load unless $CPAN::Config_loaded++;
446 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
448 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
450 *all = \&all_objects;
452 # Called by shell, not in batch mode. In batch mode I see no risk in
453 # having many processes updating something as installations are
454 # continually checked at runtime. In shell mode I suspect it is
455 # unintentional to open more than one shell at a time
457 #-> sub CPAN::checklock ;
460 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
461 if (-f $lockfile && -M _ > 0) {
462 my $fh = FileHandle->new($lockfile) or
463 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
464 my $otherpid = <$fh>;
465 my $otherhost = <$fh>;
467 if (defined $otherpid && $otherpid) {
470 if (defined $otherhost && $otherhost) {
473 my $thishost = hostname();
474 if (defined $otherhost && defined $thishost &&
475 $otherhost ne '' && $thishost ne '' &&
476 $otherhost ne $thishost) {
477 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
478 "reports other host $otherhost and other process $otherpid.\n".
479 "Cannot proceed.\n"));
481 elsif (defined $otherpid && $otherpid) {
482 return if $$ == $otherpid; # should never happen
483 $CPAN::Frontend->mywarn(
485 There seems to be running another CPAN process (pid $otherpid). Contacting...
487 if (kill 0, $otherpid) {
488 $CPAN::Frontend->mydie(qq{Other job is running.
489 You may want to kill it and delete the lockfile, maybe. On UNIX try:
493 } elsif (-w $lockfile) {
495 ExtUtils::MakeMaker::prompt
496 (qq{Other job not responding. Shall I overwrite }.
497 qq{the lockfile? (Y/N)},"y");
498 $CPAN::Frontend->myexit("Ok, bye\n")
499 unless $ans =~ /^y/i;
502 qq{Lockfile $lockfile not writeable by you. }.
503 qq{Cannot proceed.\n}.
506 qq{ and then rerun us.\n}
510 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
511 "reports other process with ID ".
512 "$otherpid. Cannot proceed.\n"));
515 my $dotcpan = $CPAN::Config->{cpan_home};
516 eval { File::Path::mkpath($dotcpan);};
518 # A special case at least for Jarkko.
523 $symlinkcpan = readlink $dotcpan;
524 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
525 eval { File::Path::mkpath($symlinkcpan); };
529 $CPAN::Frontend->mywarn(qq{
530 Working directory $symlinkcpan created.
534 unless (-d $dotcpan) {
536 Your configuration suggests "$dotcpan" as your
537 CPAN.pm working directory. I could not create this directory due
538 to this error: $firsterror\n};
540 As "$dotcpan" is a symlink to "$symlinkcpan",
541 I tried to create that, but I failed with this error: $seconderror
544 Please make sure the directory exists and is writable.
546 $CPAN::Frontend->mydie($diemess);
550 unless ($fh = FileHandle->new(">$lockfile")) {
551 if ($! =~ /Permission/) {
552 my $incc = $INC{'CPAN/Config.pm'};
553 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
554 $CPAN::Frontend->myprint(qq{
556 Your configuration suggests that CPAN.pm should use a working
558 $CPAN::Config->{cpan_home}
559 Unfortunately we could not create the lock file
561 due to permission problems.
563 Please make sure that the configuration variable
564 \$CPAN::Config->{cpan_home}
565 points to a directory where you can write a .lock file. You can set
566 this variable in either
573 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
575 $fh->print($$, "\n");
576 $fh->print(hostname(), "\n");
577 $self->{LOCK} = $lockfile;
581 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
586 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
587 print "Caught SIGINT\n";
591 # From: Larry Wall <larry@wall.org>
592 # Subject: Re: deprecating SIGDIE
593 # To: perl5-porters@perl.org
594 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
596 # The original intent of __DIE__ was only to allow you to substitute one
597 # kind of death for another on an application-wide basis without respect
598 # to whether you were in an eval or not. As a global backstop, it should
599 # not be used any more lightly (or any more heavily :-) than class
600 # UNIVERSAL. Any attempt to build a general exception model on it should
601 # be politely squashed. Any bug that causes every eval {} to have to be
602 # modified should be not so politely squashed.
604 # Those are my current opinions. It is also my optinion that polite
605 # arguments degenerate to personal arguments far too frequently, and that
606 # when they do, it's because both people wanted it to, or at least didn't
607 # sufficiently want it not to.
611 # global backstop to cleanup if we should really die
612 $SIG{__DIE__} = \&cleanup;
613 $self->debug("Signal handler set.") if $CPAN::DEBUG;
616 #-> sub CPAN::DESTROY ;
618 &cleanup; # need an eval?
621 #-> sub CPAN::anycwd ;
624 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
629 sub cwd {Cwd::cwd();}
631 #-> sub CPAN::getcwd ;
632 sub getcwd {Cwd::getcwd();}
634 #-> sub CPAN::exists ;
636 my($mgr,$class,$id) = @_;
637 CPAN::Config->load unless $CPAN::Config_loaded++;
639 ### Carp::croak "exists called without class argument" unless $class;
641 exists $META->{readonly}{$class}{$id} or
642 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
645 #-> sub CPAN::delete ;
647 my($mgr,$class,$id) = @_;
648 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
649 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
652 #-> sub CPAN::has_usable
653 # has_inst is sometimes too optimistic, we should replace it with this
654 # has_usable whenever a case is given
656 my($self,$mod,$message) = @_;
657 return 1 if $HAS_USABLE->{$mod};
658 my $has_inst = $self->has_inst($mod,$message);
659 return unless $has_inst;
662 LWP => [ # we frequently had "Can't locate object
663 # method "new" via package "LWP::UserAgent" at
664 # (eval 69) line 2006
666 sub {require LWP::UserAgent},
667 sub {require HTTP::Request},
668 sub {require URI::URL},
671 sub {require Net::FTP},
672 sub {require Net::Config},
675 if ($usable->{$mod}) {
676 for my $c (0..$#{$usable->{$mod}}) {
677 my $code = $usable->{$mod}[$c];
678 my $ret = eval { &$code() };
680 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
685 return $HAS_USABLE->{$mod} = 1;
688 #-> sub CPAN::has_inst
690 my($self,$mod,$message) = @_;
691 Carp::croak("CPAN->has_inst() called without an argument")
693 if (defined $message && $message eq "no"
695 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
697 exists $CPAN::Config->{dontload_hash}{$mod}
699 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
705 $file =~ s|/|\\|g if $^O eq 'MSWin32';
708 # checking %INC is wrong, because $INC{LWP} may be true
709 # although $INC{"URI/URL.pm"} may have failed. But as
710 # I really want to say "bla loaded OK", I have to somehow
712 ### warn "$file in %INC"; #debug
714 } elsif (eval { require $file }) {
715 # eval is good: if we haven't yet read the database it's
716 # perfect and if we have installed the module in the meantime,
717 # it tries again. The second require is only a NOOP returning
718 # 1 if we had success, otherwise it's retrying
720 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
721 if ($mod eq "CPAN::WAIT") {
722 push @CPAN::Shell::ISA, CPAN::WAIT;
725 } elsif ($mod eq "Net::FTP") {
726 $CPAN::Frontend->mywarn(qq{
727 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
729 install Bundle::libnet
731 }) unless $Have_warned->{"Net::FTP"}++;
733 } elsif ($mod eq "Digest::MD5"){
734 $CPAN::Frontend->myprint(qq{
735 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
736 Please consider installing the Digest::MD5 module.
741 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
746 #-> sub CPAN::instance ;
748 my($mgr,$class,$id) = @_;
751 # unsafe meta access, ok?
752 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
753 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
761 #-> sub CPAN::cleanup ;
763 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
764 local $SIG{__DIE__} = '';
769 0 && # disabled, try reload cpan with it
770 $] > 5.004_60 # thereabouts
775 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
777 $subroutine eq '(eval)';
780 return if $ineval && !$End;
781 return unless defined $META->{LOCK}; # unsafe meta access, ok
782 return unless -f $META->{LOCK}; # unsafe meta access, ok
783 unlink $META->{LOCK}; # unsafe meta access, ok
785 # Carp::cluck("DEBUGGING");
786 $CPAN::Frontend->mywarn("Lockfile removed.\n");
789 package CPAN::CacheMgr;
791 #-> sub CPAN::CacheMgr::as_string ;
793 eval { require Data::Dumper };
795 return shift->SUPER::as_string;
797 return Data::Dumper::Dumper(shift);
801 #-> sub CPAN::CacheMgr::cachesize ;
806 #-> sub CPAN::CacheMgr::tidyup ;
809 return unless -d $self->{ID};
810 while ($self->{DU} > $self->{'MAX'} ) {
811 my($toremove) = shift @{$self->{FIFO}};
812 $CPAN::Frontend->myprint(sprintf(
813 "Deleting from cache".
814 ": $toremove (%.1f>%.1f MB)\n",
815 $self->{DU}, $self->{'MAX'})
817 return if $CPAN::Signal;
818 $self->force_clean_cache($toremove);
819 return if $CPAN::Signal;
823 #-> sub CPAN::CacheMgr::dir ;
828 #-> sub CPAN::CacheMgr::entries ;
831 return unless defined $dir;
832 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
833 $dir ||= $self->{ID};
834 my($cwd) = CPAN::anycwd();
835 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
836 my $dh = DirHandle->new(File::Spec->curdir)
837 or Carp::croak("Couldn't opendir $dir: $!");
840 next if $_ eq "." || $_ eq "..";
842 push @entries, File::Spec->catfile($dir,$_);
844 push @entries, File::Spec->catdir($dir,$_);
846 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
849 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
850 sort { -M $b <=> -M $a} @entries;
853 #-> sub CPAN::CacheMgr::disk_usage ;
856 return if exists $self->{SIZE}{$dir};
857 return if $CPAN::Signal;
861 $File::Find::prune++ if $CPAN::Signal;
863 if ($^O eq 'MacOS') {
865 my $cat = Mac::Files::FSpGetCatInfo($_);
866 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
873 return if $CPAN::Signal;
874 $self->{SIZE}{$dir} = $Du/1024/1024;
875 push @{$self->{FIFO}}, $dir;
876 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
877 $self->{DU} += $Du/1024/1024;
881 #-> sub CPAN::CacheMgr::force_clean_cache ;
882 sub force_clean_cache {
884 return unless -e $dir;
885 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
887 File::Path::rmtree($dir);
888 $self->{DU} -= $self->{SIZE}{$dir};
889 delete $self->{SIZE}{$dir};
892 #-> sub CPAN::CacheMgr::new ;
899 ID => $CPAN::Config->{'build_dir'},
900 MAX => $CPAN::Config->{'build_cache'},
901 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
904 File::Path::mkpath($self->{ID});
905 my $dh = DirHandle->new($self->{ID});
909 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
911 CPAN->debug($debug) if $CPAN::DEBUG;
915 #-> sub CPAN::CacheMgr::scan_cache ;
918 return if $self->{SCAN} eq 'never';
919 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
920 unless $self->{SCAN} eq 'atstart';
921 $CPAN::Frontend->myprint(
922 sprintf("Scanning cache %s for sizes\n",
925 for $e ($self->entries($self->{ID})) {
926 next if $e eq ".." || $e eq ".";
927 $self->disk_usage($e);
928 return if $CPAN::Signal;
935 #-> sub CPAN::Debug::debug ;
938 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
939 # Complete, caller(1)
941 ($caller) = caller(0);
943 $arg = "" unless defined $arg;
944 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
945 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
946 if ($arg and ref $arg) {
947 eval { require Data::Dumper };
949 $CPAN::Frontend->myprint($arg->as_string);
951 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
954 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
959 package CPAN::Config;
961 #-> sub CPAN::Config::edit ;
962 # returns true on successful action
964 my($self,@args) = @_;
966 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
967 my($o,$str,$func,$args,$key_exists);
973 CPAN->debug("o[$o]") if $CPAN::DEBUG;
977 CPAN->debug("func[$func]") if $CPAN::DEBUG;
979 # Let's avoid eval, it's easier to comprehend without.
980 if ($func eq "push") {
981 push @{$CPAN::Config->{$o}}, @args;
983 } elsif ($func eq "pop") {
984 pop @{$CPAN::Config->{$o}};
986 } elsif ($func eq "shift") {
987 shift @{$CPAN::Config->{$o}};
989 } elsif ($func eq "unshift") {
990 unshift @{$CPAN::Config->{$o}}, @args;
992 } elsif ($func eq "splice") {
993 splice @{$CPAN::Config->{$o}}, @args;
996 $CPAN::Config->{$o} = [@args];
999 $self->prettyprint($o);
1001 if ($o eq "urllist" && $changed) {
1002 # reset the cached values
1003 undef $CPAN::FTP::Thesite;
1004 undef $CPAN::FTP::Themethod;
1008 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1009 $self->prettyprint($o);
1016 my $v = $CPAN::Config->{$k};
1018 my(@report) = ref $v eq "ARRAY" ?
1020 map { sprintf(" %-18s => %s\n",
1022 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1024 $CPAN::Frontend->myprint(
1031 map {"\t$_\n"} @report
1034 } elsif (defined $v) {
1035 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1037 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1041 #-> sub CPAN::Config::commit ;
1043 my($self,$configpm) = @_;
1044 unless (defined $configpm){
1045 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1046 $configpm ||= $INC{"CPAN/Config.pm"};
1047 $configpm || Carp::confess(q{
1048 CPAN::Config::commit called without an argument.
1049 Please specify a filename where to save the configuration or try
1050 "o conf init" to have an interactive course through configing.
1055 $mode = (stat $configpm)[2];
1056 if ($mode && ! -w _) {
1057 Carp::confess("$configpm is not writable");
1062 $msg = <<EOF unless $configpm =~ /MyConfig/;
1064 # This is CPAN.pm's systemwide configuration file. This file provides
1065 # defaults for users, and the values can be changed in a per-user
1066 # configuration file. The user-config file is being looked for as
1067 # ~/.cpan/CPAN/MyConfig.pm.
1071 my($fh) = FileHandle->new;
1072 rename $configpm, "$configpm~" if -f $configpm;
1073 open $fh, ">$configpm" or
1074 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1075 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1076 foreach (sort keys %$CPAN::Config) {
1079 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1084 $fh->print("};\n1;\n__END__\n");
1087 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1088 #chmod $mode, $configpm;
1089 ###why was that so? $self->defaults;
1090 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1094 *default = \&defaults;
1095 #-> sub CPAN::Config::defaults ;
1105 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1114 # This is a piece of repeated code that is abstracted here for
1115 # maintainability. RMB
1118 my($configpmdir, $configpmtest) = @_;
1119 if (-w $configpmtest) {
1120 return $configpmtest;
1121 } elsif (-w $configpmdir) {
1122 #_#_# following code dumped core on me with 5.003_11, a.k.
1123 my $configpm_bak = "$configpmtest.bak";
1124 unlink $configpm_bak if -f $configpm_bak;
1125 if( -f $configpmtest ) {
1126 if( rename $configpmtest, $configpm_bak ) {
1127 $CPAN::Frontend->mywarn(<<END)
1128 Old configuration file $configpmtest
1129 moved to $configpm_bak
1133 my $fh = FileHandle->new;
1134 if ($fh->open(">$configpmtest")) {
1136 return $configpmtest;
1138 # Should never happen
1139 Carp::confess("Cannot open >$configpmtest");
1144 #-> sub CPAN::Config::load ;
1149 eval {require CPAN::Config;}; # We eval because of some
1150 # MakeMaker problems
1151 unless ($dot_cpan++){
1152 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1153 eval {require CPAN::MyConfig;}; # where you can override
1154 # system wide settings
1157 return unless @miss = $self->missing_config_data;
1159 require CPAN::FirstTime;
1160 my($configpm,$fh,$redo,$theycalled);
1162 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1163 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1164 $configpm = $INC{"CPAN/Config.pm"};
1166 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1167 $configpm = $INC{"CPAN/MyConfig.pm"};
1170 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1171 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1172 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1173 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1174 $configpm = _configpmtest($configpmdir,$configpmtest);
1176 unless ($configpm) {
1177 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1178 File::Path::mkpath($configpmdir);
1179 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1180 $configpm = _configpmtest($configpmdir,$configpmtest);
1181 unless ($configpm) {
1182 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1183 qq{create a configuration file.});
1188 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1189 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1193 $CPAN::Frontend->myprint(qq{
1194 $configpm initialized.
1197 CPAN::FirstTime::init($configpm);
1200 #-> sub CPAN::Config::missing_config_data ;
1201 sub missing_config_data {
1204 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1205 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1207 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1208 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1209 "prerequisites_policy",
1212 push @miss, $_ unless defined $CPAN::Config->{$_};
1217 #-> sub CPAN::Config::unload ;
1219 delete $INC{'CPAN/MyConfig.pm'};
1220 delete $INC{'CPAN/Config.pm'};
1223 #-> sub CPAN::Config::help ;
1225 $CPAN::Frontend->myprint(q[
1227 defaults reload default config values from disk
1228 commit commit session changes to disk
1229 init go through a dialog to set all parameters
1231 You may edit key values in the follow fashion (the "o" is a literal
1234 o conf build_cache 15
1236 o conf build_dir "/foo/bar"
1238 o conf urllist shift
1240 o conf urllist unshift ftp://ftp.foo.bar/
1243 undef; #don't reprint CPAN::Config
1246 #-> sub CPAN::Config::cpl ;
1248 my($word,$line,$pos) = @_;
1250 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1251 my(@words) = split " ", substr($line,0,$pos+1);
1256 $words[2] =~ /list$/ && @words == 3
1258 $words[2] =~ /list$/ && @words == 4 && length($word)
1261 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1262 } elsif (@words >= 4) {
1265 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1266 return grep /^\Q$word\E/, @o_conf;
1269 package CPAN::Shell;
1271 #-> sub CPAN::Shell::h ;
1273 my($class,$about) = @_;
1274 if (defined $about) {
1275 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1277 $CPAN::Frontend->myprint(q{
1279 command argument description
1280 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1281 i WORD or /REGEXP/ about anything of above
1282 r NONE reinstall recommendations
1283 ls AUTHOR about files in the author's directory
1285 Download, Test, Make, Install...
1287 make make (implies get)
1288 test MODULES, make test (implies make)
1289 install DISTS, BUNDLES make install (implies test)
1291 look open subshell in these dists' directories
1292 readme display these dists' README files
1295 h,? display this menu ! perl-code eval a perl command
1296 o conf [opt] set and query options q quit the cpan shell
1297 reload cpan load CPAN.pm again reload index load newer indices
1298 autobundle Snapshot force cmd unconditionally do cmd});
1304 #-> sub CPAN::Shell::a ;
1306 my($self,@arg) = @_;
1307 # authors are always UPPERCASE
1309 $_ = uc $_ unless /=/;
1311 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1314 #-> sub CPAN::Shell::ls ;
1316 my($self,@arg) = @_;
1319 unless (/^[A-Z\-]+$/i) {
1320 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
1323 push @accept, uc $_;
1325 for my $a (@accept){
1326 my $author = $self->expand('Author',$a) or die "No author found for $a";
1331 #-> sub CPAN::Shell::local_bundles ;
1333 my($self,@which) = @_;
1334 my($incdir,$bdir,$dh);
1335 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1336 my @bbase = "Bundle";
1337 while (my $bbase = shift @bbase) {
1338 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1339 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1340 if ($dh = DirHandle->new($bdir)) { # may fail
1342 for $entry ($dh->read) {
1343 next if $entry =~ /^\./;
1344 if (-d File::Spec->catdir($bdir,$entry)){
1345 push @bbase, "$bbase\::$entry";
1347 next unless $entry =~ s/\.pm(?!\n)\Z//;
1348 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1356 #-> sub CPAN::Shell::b ;
1358 my($self,@which) = @_;
1359 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1360 $self->local_bundles;
1361 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1364 #-> sub CPAN::Shell::d ;
1365 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1367 #-> sub CPAN::Shell::m ;
1368 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1369 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1372 #-> sub CPAN::Shell::i ;
1377 @type = qw/Author Bundle Distribution Module/;
1378 @args = '/./' unless @args;
1381 push @result, $self->expand($type,@args);
1383 my $result = @result == 1 ?
1384 $result[0]->as_string :
1386 "No objects found of any type for argument @args\n" :
1388 (map {$_->as_glimpse} @result),
1389 scalar @result, " items found\n",
1391 $CPAN::Frontend->myprint($result);
1394 #-> sub CPAN::Shell::o ;
1396 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1397 # should have been called set and 'o debug' maybe 'set debug'
1399 my($self,$o_type,@o_what) = @_;
1401 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1402 if ($o_type eq 'conf') {
1403 shift @o_what if @o_what && $o_what[0] eq 'help';
1404 if (!@o_what) { # print all things, "o conf"
1406 $CPAN::Frontend->myprint("CPAN::Config options");
1407 if (exists $INC{'CPAN/Config.pm'}) {
1408 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1410 if (exists $INC{'CPAN/MyConfig.pm'}) {
1411 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1413 $CPAN::Frontend->myprint(":\n");
1414 for $k (sort keys %CPAN::Config::can) {
1415 $v = $CPAN::Config::can{$k};
1416 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1418 $CPAN::Frontend->myprint("\n");
1419 for $k (sort keys %$CPAN::Config) {
1420 CPAN::Config->prettyprint($k);
1422 $CPAN::Frontend->myprint("\n");
1423 } elsif (!CPAN::Config->edit(@o_what)) {
1424 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1425 qq{edit options\n\n});
1427 } elsif ($o_type eq 'debug') {
1429 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1432 my($what) = shift @o_what;
1433 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1434 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1437 if ( exists $CPAN::DEBUG{$what} ) {
1438 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1439 } elsif ($what =~ /^\d/) {
1440 $CPAN::DEBUG = $what;
1441 } elsif (lc $what eq 'all') {
1443 for (values %CPAN::DEBUG) {
1446 $CPAN::DEBUG = $max;
1449 for (keys %CPAN::DEBUG) {
1450 next unless lc($_) eq lc($what);
1451 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1454 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1459 my $raw = "Valid options for debug are ".
1460 join(", ",sort(keys %CPAN::DEBUG), 'all').
1461 qq{ or a number. Completion works on the options. }.
1462 qq{Case is ignored.};
1464 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1465 $CPAN::Frontend->myprint("\n\n");
1468 $CPAN::Frontend->myprint("Options set for debugging:\n");
1470 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1471 $v = $CPAN::DEBUG{$k};
1472 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1473 if $v & $CPAN::DEBUG;
1476 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1479 $CPAN::Frontend->myprint(qq{
1481 conf set or get configuration variables
1482 debug set or get debugging options
1487 sub paintdots_onreload {
1490 if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1494 # $CPAN::Frontend->myprint(".($subr)");
1495 $CPAN::Frontend->myprint(".");
1502 #-> sub CPAN::Shell::reload ;
1504 my($self,$command,@arg) = @_;
1506 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1507 if ($command =~ /cpan/i) {
1508 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1509 my $fh = FileHandle->new($INC{'CPAN.pm'});
1512 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1515 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1516 } elsif ($command =~ /index/) {
1517 CPAN::Index->force_reload;
1519 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1520 index re-reads the index files\n});
1524 #-> sub CPAN::Shell::_binary_extensions ;
1525 sub _binary_extensions {
1526 my($self) = shift @_;
1527 my(@result,$module,%seen,%need,$headerdone);
1528 for $module ($self->expand('Module','/./')) {
1529 my $file = $module->cpan_file;
1530 next if $file eq "N/A";
1531 next if $file =~ /^Contact Author/;
1532 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1533 next if $dist->isa_perl;
1534 next unless $module->xs_file;
1536 $CPAN::Frontend->myprint(".");
1537 push @result, $module;
1539 # print join " | ", @result;
1540 $CPAN::Frontend->myprint("\n");
1544 #-> sub CPAN::Shell::recompile ;
1546 my($self) = shift @_;
1547 my($module,@module,$cpan_file,%dist);
1548 @module = $self->_binary_extensions();
1549 for $module (@module){ # we force now and compile later, so we
1551 $cpan_file = $module->cpan_file;
1552 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1554 $dist{$cpan_file}++;
1556 for $cpan_file (sort keys %dist) {
1557 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1558 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1560 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1561 # stop a package from recompiling,
1562 # e.g. IO-1.12 when we have perl5.003_10
1566 #-> sub CPAN::Shell::_u_r_common ;
1568 my($self) = shift @_;
1569 my($what) = shift @_;
1570 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1571 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1572 $what && $what =~ /^[aru]$/;
1574 @args = '/./' unless @args;
1575 my(@result,$module,%seen,%need,$headerdone,
1576 $version_undefs,$version_zeroes);
1577 $version_undefs = $version_zeroes = 0;
1578 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1579 my @expand = $self->expand('Module',@args);
1580 my $expand = scalar @expand;
1581 if (0) { # Looks like noise to me, was very useful for debugging
1582 # for metadata cache
1583 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1585 for $module (@expand) {
1586 my $file = $module->cpan_file;
1587 next unless defined $file; # ??
1588 my($latest) = $module->cpan_version;
1589 my($inst_file) = $module->inst_file;
1591 return if $CPAN::Signal;
1594 $have = $module->inst_version;
1595 } elsif ($what eq "r") {
1596 $have = $module->inst_version;
1598 if ($have eq "undef"){
1600 } elsif ($have == 0){
1603 next unless CPAN::Version->vgt($latest, $have);
1604 # to be pedantic we should probably say:
1605 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1606 # to catch the case where CPAN has a version 0 and we have a version undef
1607 } elsif ($what eq "u") {
1613 } elsif ($what eq "r") {
1615 } elsif ($what eq "u") {
1619 return if $CPAN::Signal; # this is sometimes lengthy
1622 push @result, sprintf "%s %s\n", $module->id, $have;
1623 } elsif ($what eq "r") {
1624 push @result, $module->id;
1625 next if $seen{$file}++;
1626 } elsif ($what eq "u") {
1627 push @result, $module->id;
1628 next if $seen{$file}++;
1629 next if $file =~ /^Contact/;
1631 unless ($headerdone++){
1632 $CPAN::Frontend->myprint("\n");
1633 $CPAN::Frontend->myprint(sprintf(
1636 "Package namespace",
1648 $CPAN::META->has_inst("Term::ANSIColor")
1650 $module->{RO}{description}
1652 $color_on = Term::ANSIColor::color("green");
1653 $color_off = Term::ANSIColor::color("reset");
1655 $CPAN::Frontend->myprint(sprintf $sprintf,
1662 $need{$module->id}++;
1666 $CPAN::Frontend->myprint("No modules found for @args\n");
1667 } elsif ($what eq "r") {
1668 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1672 if ($version_zeroes) {
1673 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1674 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1675 qq{a version number of 0\n});
1677 if ($version_undefs) {
1678 my $s_has = $version_undefs > 1 ? "s have" : " has";
1679 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1680 qq{parseable version number\n});
1686 #-> sub CPAN::Shell::r ;
1688 shift->_u_r_common("r",@_);
1691 #-> sub CPAN::Shell::u ;
1693 shift->_u_r_common("u",@_);
1696 #-> sub CPAN::Shell::autobundle ;
1699 CPAN::Config->load unless $CPAN::Config_loaded++;
1700 my(@bundle) = $self->_u_r_common("a",@_);
1701 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1702 File::Path::mkpath($todir);
1703 unless (-d $todir) {
1704 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1707 my($y,$m,$d) = (localtime)[5,4,3];
1711 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1712 my($to) = File::Spec->catfile($todir,"$me.pm");
1714 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1715 $to = File::Spec->catfile($todir,"$me.pm");
1717 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1719 "package Bundle::$me;\n\n",
1720 "\$VERSION = '0.01';\n\n",
1724 "Bundle::$me - Snapshot of installation on ",
1725 $Config::Config{'myhostname'},
1728 "\n\n=head1 SYNOPSIS\n\n",
1729 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1730 "=head1 CONTENTS\n\n",
1731 join("\n", @bundle),
1732 "\n\n=head1 CONFIGURATION\n\n",
1734 "\n\n=head1 AUTHOR\n\n",
1735 "This Bundle has been generated automatically ",
1736 "by the autobundle routine in CPAN.pm.\n",
1739 $CPAN::Frontend->myprint("\nWrote bundle file
1743 #-> sub CPAN::Shell::expandany ;
1746 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1747 if ($s =~ m|/|) { # looks like a file
1748 $s = CPAN::Distribution->normalize($s);
1749 return $CPAN::META->instance('CPAN::Distribution',$s);
1750 # Distributions spring into existence, not expand
1751 } elsif ($s =~ m|^Bundle::|) {
1752 $self->local_bundles; # scanning so late for bundles seems
1753 # both attractive and crumpy: always
1754 # current state but easy to forget
1756 return $self->expand('Bundle',$s);
1758 return $self->expand('Module',$s)
1759 if $CPAN::META->exists('CPAN::Module',$s);
1764 #-> sub CPAN::Shell::expand ;
1767 my($type,@args) = @_;
1769 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1771 my($regex,$command);
1772 if ($arg =~ m|^/(.*)/$|) {
1774 } elsif ($arg =~ m/=/) {
1777 my $class = "CPAN::$type";
1779 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1781 defined $regex ? $regex : "UNDEFINED",
1782 $command || "UNDEFINED",
1784 if (defined $regex) {
1788 $CPAN::META->all_objects($class)
1791 # BUG, we got an empty object somewhere
1792 require Data::Dumper;
1793 CPAN->debug(sprintf(
1794 "Bug in CPAN: Empty id on obj[%s][%s]",
1796 Data::Dumper::Dumper($obj)
1801 if $obj->id =~ /$regex/i
1805 $] < 5.00303 ### provide sort of
1806 ### compatibility with 5.003
1811 $obj->name =~ /$regex/i
1814 } elsif ($command) {
1815 die "equal sign in command disabled (immature interface), ".
1817 ! \$CPAN::Shell::ADVANCED_QUERY=1
1818 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1819 that may go away anytime.\n"
1820 unless $ADVANCED_QUERY;
1821 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1822 my($matchcrit) = $criterion =~ m/^~(.+)/;
1826 $CPAN::META->all_objects($class)
1828 my $lhs = $self->$method() or next; # () for 5.00503
1830 push @m, $self if $lhs =~ m/$matchcrit/;
1832 push @m, $self if $lhs eq $criterion;
1837 if ( $type eq 'Bundle' ) {
1838 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1839 } elsif ($type eq "Distribution") {
1840 $xarg = CPAN::Distribution->normalize($arg);
1842 if ($CPAN::META->exists($class,$xarg)) {
1843 $obj = $CPAN::META->instance($class,$xarg);
1844 } elsif ($CPAN::META->exists($class,$arg)) {
1845 $obj = $CPAN::META->instance($class,$arg);
1852 return wantarray ? @m : $m[0];
1855 #-> sub CPAN::Shell::format_result ;
1858 my($type,@args) = @_;
1859 @args = '/./' unless @args;
1860 my(@result) = $self->expand($type,@args);
1861 my $result = @result == 1 ?
1862 $result[0]->as_string :
1864 "No objects of type $type found for argument @args\n" :
1866 (map {$_->as_glimpse} @result),
1867 scalar @result, " items found\n",
1872 # The only reason for this method is currently to have a reliable
1873 # debugging utility that reveals which output is going through which
1874 # channel. No, I don't like the colors ;-)
1876 #-> sub CPAN::Shell::print_ornameted ;
1877 sub print_ornamented {
1878 my($self,$what,$ornament) = @_;
1880 return unless defined $what;
1882 if ($CPAN::Config->{term_is_latin}){
1885 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1887 if ($PRINT_ORNAMENTING) {
1888 unless (defined &color) {
1889 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1890 import Term::ANSIColor "color";
1892 *color = sub { return "" };
1896 for $line (split /\n/, $what) {
1897 $longest = length($line) if length($line) > $longest;
1899 my $sprintf = "%-" . $longest . "s";
1901 $what =~ s/(.*\n?)//m;
1904 my($nl) = chomp $line ? "\n" : "";
1905 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1906 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1914 my($self,$what) = @_;
1916 $self->print_ornamented($what, 'bold blue on_yellow');
1920 my($self,$what) = @_;
1921 $self->myprint($what);
1926 my($self,$what) = @_;
1927 $self->print_ornamented($what, 'bold red on_yellow');
1931 my($self,$what) = @_;
1932 $self->print_ornamented($what, 'bold red on_white');
1933 Carp::confess "died";
1937 my($self,$what) = @_;
1938 $self->print_ornamented($what, 'bold red on_white');
1943 return if -t STDOUT;
1944 my $odef = select STDERR;
1951 #-> sub CPAN::Shell::rematein ;
1952 # RE-adme||MA-ke||TE-st||IN-stall
1955 my($meth,@some) = @_;
1957 if ($meth eq 'force') {
1959 $meth = shift @some;
1962 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1964 # Here is the place to set "test_count" on all involved parties to
1965 # 0. We then can pass this counter on to the involved
1966 # distributions and those can refuse to test if test_count > X. In
1967 # the first stab at it we could use a 1 for "X".
1969 # But when do I reset the distributions to start with 0 again?
1970 # Jost suggested to have a random or cycling interaction ID that
1971 # we pass through. But the ID is something that is just left lying
1972 # around in addition to the counter, so I'd prefer to set the
1973 # counter to 0 now, and repeat at the end of the loop. But what
1974 # about dependencies? They appear later and are not reset, they
1975 # enter the queue but not its copy. How do they get a sensible
1978 # construct the queue
1980 foreach $s (@some) {
1983 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1985 } elsif ($s =~ m|^/|) { # looks like a regexp
1986 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1991 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1992 $obj = CPAN::Shell->expandany($s);
1995 $obj->color_cmd_tmps(0,1);
1996 CPAN::Queue->new($obj->id);
1998 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1999 $obj = $CPAN::META->instance('CPAN::Author',$s);
2000 if ($meth eq "dump") {
2003 $CPAN::Frontend->myprint(
2005 "Don't be silly, you can't $meth ",
2013 ->myprint(qq{Warning: Cannot $meth $s, }.
2014 qq{don\'t know what it is.
2019 to find objects with matching identifiers.
2025 # queuerunner (please be warned: when I started to change the
2026 # queue to hold objects instead of names, I made one or two
2027 # mistakes and never found which. I reverted back instead)
2028 while ($s = CPAN::Queue->first) {
2031 $obj = $s; # I do not believe, we would survive if this happened
2033 $obj = CPAN::Shell->expandany($s);
2037 ($] < 5.00303 || $obj->can($pragma))){
2038 ### compatibility with 5.003
2039 $obj->$pragma($meth); # the pragma "force" in
2040 # "CPAN::Distribution" must know
2041 # what we are intending
2043 if ($]>=5.00303 && $obj->can('called_for')) {
2044 $obj->called_for($s);
2047 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2053 CPAN::Queue->delete($s);
2055 CPAN->debug("failed");
2059 CPAN::Queue->delete_first($s);
2061 for my $obj (@qcopy) {
2062 $obj->color_cmd_tmps(0,0);
2066 #-> sub CPAN::Shell::dump ;
2067 sub dump { shift->rematein('dump',@_); }
2068 #-> sub CPAN::Shell::force ;
2069 sub force { shift->rematein('force',@_); }
2070 #-> sub CPAN::Shell::get ;
2071 sub get { shift->rematein('get',@_); }
2072 #-> sub CPAN::Shell::readme ;
2073 sub readme { shift->rematein('readme',@_); }
2074 #-> sub CPAN::Shell::make ;
2075 sub make { shift->rematein('make',@_); }
2076 #-> sub CPAN::Shell::test ;
2077 sub test { shift->rematein('test',@_); }
2078 #-> sub CPAN::Shell::install ;
2079 sub install { shift->rematein('install',@_); }
2080 #-> sub CPAN::Shell::clean ;
2081 sub clean { shift->rematein('clean',@_); }
2082 #-> sub CPAN::Shell::look ;
2083 sub look { shift->rematein('look',@_); }
2084 #-> sub CPAN::Shell::cvs_import ;
2085 sub cvs_import { shift->rematein('cvs_import',@_); }
2087 package CPAN::LWP::UserAgent;
2090 return if $SETUPDONE;
2091 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2092 require LWP::UserAgent;
2093 @ISA = qw(Exporter LWP::UserAgent);
2096 $CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
2100 sub get_basic_credentials {
2101 my($self, $realm, $uri, $proxy) = @_;
2102 return unless $proxy;
2103 if ($USER && $PASSWD) {
2104 } elsif (defined $CPAN::Config->{proxy_user} &&
2105 defined $CPAN::Config->{proxy_pass}) {
2106 $USER = $CPAN::Config->{proxy_user};
2107 $PASSWD = $CPAN::Config->{proxy_pass};
2109 require ExtUtils::MakeMaker;
2110 ExtUtils::MakeMaker->import(qw(prompt));
2111 $USER = prompt("Proxy authentication needed!
2112 (Note: to permanently configure username and password run
2113 o conf proxy_user your_username
2114 o conf proxy_pass your_password
2116 if ($CPAN::META->has_inst("Term::ReadKey")) {
2117 Term::ReadKey::ReadMode("noecho");
2119 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2121 $PASSWD = prompt("Password:");
2122 if ($CPAN::META->has_inst("Term::ReadKey")) {
2123 Term::ReadKey::ReadMode("restore");
2125 $CPAN::Frontend->myprint("\n\n");
2127 return($USER,$PASSWD);
2131 my($self,$url,$aslocal) = @_;
2132 my $result = $self->SUPER::mirror($url,$aslocal);
2133 if ($result->code == 407) {
2136 $result = $self->SUPER::mirror($url,$aslocal);
2143 #-> sub CPAN::FTP::ftp_get ;
2145 my($class,$host,$dir,$file,$target) = @_;
2147 qq[Going to fetch file [$file] from dir [$dir]
2148 on host [$host] as local [$target]\n]
2150 my $ftp = Net::FTP->new($host);
2151 return 0 unless defined $ftp;
2152 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2153 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2154 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2155 warn "Couldn't login on $host";
2158 unless ( $ftp->cwd($dir) ){
2159 warn "Couldn't cwd $dir";
2163 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2164 unless ( $ftp->get($file,$target) ){
2165 warn "Couldn't fetch $file from $host\n";
2168 $ftp->quit; # it's ok if this fails
2172 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2174 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2175 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2177 # > *** 1562,1567 ****
2178 # > --- 1562,1580 ----
2179 # > return 1 if substr($url,0,4) eq "file";
2180 # > return 1 unless $url =~ m|://([^/]+)|;
2182 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2184 # > + $proxy =~ m|://([^/:]+)|;
2186 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2187 # > + if ($noproxy) {
2188 # > + if ($host !~ /$noproxy$/) {
2189 # > + $host = $proxy;
2192 # > + $host = $proxy;
2195 # > require Net::Ping;
2196 # > return 1 unless $Net::Ping::VERSION >= 2;
2200 #-> sub CPAN::FTP::localize ;
2202 my($self,$file,$aslocal,$force) = @_;
2204 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2205 unless defined $aslocal;
2206 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2209 if ($^O eq 'MacOS') {
2210 # Comment by AK on 2000-09-03: Uniq short filenames would be
2211 # available in CHECKSUMS file
2212 my($name, $path) = File::Basename::fileparse($aslocal, '');
2213 if (length($name) > 31) {
2224 my $size = 31 - length($suf);
2225 while (length($name) > $size) {
2229 $aslocal = File::Spec->catfile($path, $name);
2233 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2236 rename $aslocal, "$aslocal.bak";
2240 my($aslocal_dir) = File::Basename::dirname($aslocal);
2241 File::Path::mkpath($aslocal_dir);
2242 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2243 qq{directory "$aslocal_dir".
2244 I\'ll continue, but if you encounter problems, they may be due
2245 to insufficient permissions.\n}) unless -w $aslocal_dir;
2247 # Inheritance is not easier to manage than a few if/else branches
2248 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2250 CPAN::LWP::UserAgent->config;
2251 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2253 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
2257 $Ua->proxy('ftp', $var)
2258 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2259 $Ua->proxy('http', $var)
2260 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2263 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2265 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2266 # > use ones that require basic autorization.
2268 # > Example of when I use it manually in my own stuff:
2270 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2271 # > $req->proxy_authorization_basic("username","password");
2272 # > $res = $ua->request($req);
2276 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2280 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2281 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2282 if $CPAN::Config->{http_proxy};
2283 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2285 # Try the list of urls for each single object. We keep a record
2286 # where we did get a file from
2287 my(@reordered,$last);
2288 $CPAN::Config->{urllist} ||= [];
2289 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2290 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2292 $last = $#{$CPAN::Config->{urllist}};
2293 if ($force & 2) { # local cpans probably out of date, don't reorder
2294 @reordered = (0..$last);
2298 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2300 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2311 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2313 @levels = qw/easy hard hardest/;
2315 @levels = qw/easy/ if $^O eq 'MacOS';
2317 for $levelno (0..$#levels) {
2318 my $level = $levels[$levelno];
2319 my $method = "host$level";
2320 my @host_seq = $level eq "easy" ?
2321 @reordered : 0..$last; # reordered has CDROM up front
2322 @host_seq = (0) unless @host_seq;
2323 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2325 $Themethod = $level;
2327 # utime $now, $now, $aslocal; # too bad, if we do that, we
2328 # might alter a local mirror
2329 $self->debug("level[$level]") if $CPAN::DEBUG;
2333 last if $CPAN::Signal; # need to cleanup
2336 unless ($CPAN::Signal) {
2339 qq{Please check, if the URLs I found in your configuration file \(}.
2340 join(", ", @{$CPAN::Config->{urllist}}).
2341 qq{\) are valid. The urllist can be edited.},
2342 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2343 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2345 $CPAN::Frontend->myprint("Could not fetch $file\n");
2348 rename "$aslocal.bak", $aslocal;
2349 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2350 $self->ls($aslocal));
2357 my($self,$host_seq,$file,$aslocal) = @_;
2359 HOSTEASY: for $i (@$host_seq) {
2360 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2361 $url .= "/" unless substr($url,-1) eq "/";
2363 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2364 if ($url =~ /^file:/) {
2366 if ($CPAN::META->has_inst('URI::URL')) {
2367 my $u = URI::URL->new($url);
2369 } else { # works only on Unix, is poorly constructed, but
2370 # hopefully better than nothing.
2371 # RFC 1738 says fileurl BNF is
2372 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2373 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2375 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2376 $l =~ s|^file:||; # assume they
2379 $l =~ s|^/||s unless -f $l; # e.g. /P:
2380 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2382 if ( -f $l && -r _) {
2386 # Maybe mirror has compressed it?
2388 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2389 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2396 if ($CPAN::META->has_usable('LWP')) {
2397 $CPAN::Frontend->myprint("Fetching with LWP:
2401 CPAN::LWP::UserAgent->config;
2402 eval { $Ua = CPAN::LWP::UserAgent->new; };
2404 $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
2407 my $res = $Ua->mirror($url, $aslocal);
2408 if ($res->is_success) {
2411 utime $now, $now, $aslocal; # download time is more
2412 # important than upload time
2414 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2415 my $gzurl = "$url.gz";
2416 $CPAN::Frontend->myprint("Fetching with LWP:
2419 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2420 if ($res->is_success &&
2421 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2427 $CPAN::Frontend->myprint(sprintf(
2428 "LWP failed with code[%s] message[%s]\n",
2432 # Alan Burlison informed me that in firewall environments
2433 # Net::FTP can still succeed where LWP fails. So we do not
2434 # skip Net::FTP anymore when LWP is available.
2437 $CPAN::Frontend->myprint("LWP not available\n");
2439 return if $CPAN::Signal;
2440 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2441 # that's the nice and easy way thanks to Graham
2442 my($host,$dir,$getfile) = ($1,$2,$3);
2443 if ($CPAN::META->has_usable('Net::FTP')) {
2445 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2448 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2449 "aslocal[$aslocal]") if $CPAN::DEBUG;
2450 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2454 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2455 my $gz = "$aslocal.gz";
2456 $CPAN::Frontend->myprint("Fetching with Net::FTP
2459 if (CPAN::FTP->ftp_get($host,
2463 CPAN::Tarzip->gunzip($gz,$aslocal)
2472 return if $CPAN::Signal;
2477 my($self,$host_seq,$file,$aslocal) = @_;
2479 # Came back if Net::FTP couldn't establish connection (or
2480 # failed otherwise) Maybe they are behind a firewall, but they
2481 # gave us a socksified (or other) ftp program...
2484 my($devnull) = $CPAN::Config->{devnull} || "";
2486 my($aslocal_dir) = File::Basename::dirname($aslocal);
2487 File::Path::mkpath($aslocal_dir);
2488 HOSTHARD: for $i (@$host_seq) {
2489 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2490 $url .= "/" unless substr($url,-1) eq "/";
2492 my($proto,$host,$dir,$getfile);
2494 # Courtesy Mark Conty mark_conty@cargill.com change from
2495 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2497 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2498 # proto not yet used
2499 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2501 next HOSTHARD; # who said, we could ftp anything except ftp?
2503 next HOSTHARD if $proto eq "file"; # file URLs would have had
2504 # success above. Likely a bogus URL
2506 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2508 for $f ('lynx','ncftpget','ncftp','wget') {
2509 next unless exists $CPAN::Config->{$f};
2510 $funkyftp = $CPAN::Config->{$f};
2511 next unless defined $funkyftp;
2512 next if $funkyftp =~ /^\s*$/;
2513 my($asl_ungz, $asl_gz);
2514 ($asl_ungz = $aslocal) =~ s/\.gz//;
2515 $asl_gz = "$asl_ungz.gz";
2516 my($src_switch) = "";
2518 $src_switch = " -source";
2519 } elsif ($f eq "ncftp"){
2520 $src_switch = " -c";
2521 } elsif ($f eq "wget"){
2522 $src_switch = " -O -";
2525 my($stdout_redir) = " > $asl_ungz";
2526 if ($f eq "ncftpget"){
2527 $chdir = "cd $aslocal_dir && ";
2530 $CPAN::Frontend->myprint(
2532 Trying with "$funkyftp$src_switch" to get
2536 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2537 $self->debug("system[$system]") if $CPAN::DEBUG;
2539 if (($wstatus = system($system)) == 0
2542 -s $asl_ungz # lynx returns 0 when it fails somewhere
2548 } elsif ($asl_ungz ne $aslocal) {
2549 # test gzip integrity
2550 if (CPAN::Tarzip->gtest($asl_ungz)) {
2551 # e.g. foo.tar is gzipped --> foo.tar.gz
2552 rename $asl_ungz, $aslocal;
2554 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2559 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2561 -f $asl_ungz && -s _ == 0;
2562 my $gz = "$aslocal.gz";
2563 my $gzurl = "$url.gz";
2564 $CPAN::Frontend->myprint(
2566 Trying with "$funkyftp$src_switch" to get
2569 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2570 $self->debug("system[$system]") if $CPAN::DEBUG;
2572 if (($wstatus = system($system)) == 0
2576 # test gzip integrity
2577 if (CPAN::Tarzip->gtest($asl_gz)) {
2578 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2580 # somebody uncompressed file for us?
2581 rename $asl_ungz, $aslocal;
2586 unlink $asl_gz if -f $asl_gz;
2589 my $estatus = $wstatus >> 8;
2590 my $size = -f $aslocal ?
2591 ", left\n$aslocal with size ".-s _ :
2592 "\nWarning: expected file [$aslocal] doesn't exist";
2593 $CPAN::Frontend->myprint(qq{
2594 System call "$system"
2595 returned status $estatus (wstat $wstatus)$size
2598 return if $CPAN::Signal;
2599 } # lynx,ncftpget,ncftp
2604 my($self,$host_seq,$file,$aslocal) = @_;
2607 my($aslocal_dir) = File::Basename::dirname($aslocal);
2608 File::Path::mkpath($aslocal_dir);
2609 HOSTHARDEST: for $i (@$host_seq) {
2610 unless (length $CPAN::Config->{'ftp'}) {
2611 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2614 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2615 $url .= "/" unless substr($url,-1) eq "/";
2617 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2618 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2621 my($host,$dir,$getfile) = ($1,$2,$3);
2623 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2624 $ctime,$blksize,$blocks) = stat($aslocal);
2625 $timestamp = $mtime ||= 0;
2626 my($netrc) = CPAN::FTP::netrc->new;
2627 my($netrcfile) = $netrc->netrc;
2628 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2629 my $targetfile = File::Basename::basename($aslocal);
2635 map("cd $_", split "/", $dir), # RFC 1738
2637 "get $getfile $targetfile",
2641 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2642 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2643 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2645 $netrc->contains($host))) if $CPAN::DEBUG;
2646 if ($netrc->protected) {
2647 $CPAN::Frontend->myprint(qq{
2648 Trying with external ftp to get
2650 As this requires some features that are not thoroughly tested, we\'re
2651 not sure, that we get it right....
2655 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2657 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2658 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2660 if ($mtime > $timestamp) {
2661 $CPAN::Frontend->myprint("GOT $aslocal\n");
2665 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2667 return if $CPAN::Signal;
2669 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2670 qq{correctly protected.\n});
2673 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2674 nor does it have a default entry\n");
2677 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2678 # then and login manually to host, using e-mail as
2680 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2684 "user anonymous $Config::Config{'cf_email'}"
2686 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2687 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2688 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2690 if ($mtime > $timestamp) {
2691 $CPAN::Frontend->myprint("GOT $aslocal\n");
2695 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2697 return if $CPAN::Signal;
2698 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2704 my($self,$command,@dialog) = @_;
2705 my $fh = FileHandle->new;
2706 $fh->open("|$command") or die "Couldn't open ftp: $!";
2707 foreach (@dialog) { $fh->print("$_\n") }
2708 $fh->close; # Wait for process to complete
2710 my $estatus = $wstatus >> 8;
2711 $CPAN::Frontend->myprint(qq{
2712 Subprocess "|$command"
2713 returned status $estatus (wstat $wstatus)
2717 # find2perl needs modularization, too, all the following is stolen
2721 my($self,$name) = @_;
2722 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2723 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2725 my($perms,%user,%group);
2729 $blocks = int(($blocks + 1) / 2);
2732 $blocks = int(($sizemm + 1023) / 1024);
2735 if (-f _) { $perms = '-'; }
2736 elsif (-d _) { $perms = 'd'; }
2737 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2738 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2739 elsif (-p _) { $perms = 'p'; }
2740 elsif (-S _) { $perms = 's'; }
2741 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2743 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2744 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2745 my $tmpmode = $mode;
2746 my $tmp = $rwx[$tmpmode & 7];
2748 $tmp = $rwx[$tmpmode & 7] . $tmp;
2750 $tmp = $rwx[$tmpmode & 7] . $tmp;
2751 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2752 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2753 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2756 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2757 my $group = $group{$gid} || $gid;
2759 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2761 my($moname) = $moname[$mon];
2762 if (-M _ > 365.25 / 2) {
2763 $timeyear = $year + 1900;
2766 $timeyear = sprintf("%02d:%02d", $hour, $min);
2769 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2783 package CPAN::FTP::netrc;
2787 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2789 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2790 $atime,$mtime,$ctime,$blksize,$blocks)
2795 my($fh,@machines,$hasdefault);
2797 $fh = FileHandle->new or die "Could not create a filehandle";
2799 if($fh->open($file)){
2800 $protected = ($mode & 077) == 0;
2802 NETRC: while (<$fh>) {
2803 my(@tokens) = split " ", $_;
2804 TOKEN: while (@tokens) {
2805 my($t) = shift @tokens;
2806 if ($t eq "default"){
2810 last TOKEN if $t eq "macdef";
2811 if ($t eq "machine") {
2812 push @machines, shift @tokens;
2817 $file = $hasdefault = $protected = "";
2821 'mach' => [@machines],
2823 'hasdefault' => $hasdefault,
2824 'protected' => $protected,
2828 # CPAN::FTP::hasdefault;
2829 sub hasdefault { shift->{'hasdefault'} }
2830 sub netrc { shift->{'netrc'} }
2831 sub protected { shift->{'protected'} }
2833 my($self,$mach) = @_;
2834 for ( @{$self->{'mach'}} ) {
2835 return 1 if $_ eq $mach;
2840 package CPAN::Complete;
2843 my($text, $line, $start, $end) = @_;
2844 my(@perlret) = cpl($text, $line, $start);
2845 # find longest common match. Can anybody show me how to peruse
2846 # T::R::Gnu to have this done automatically? Seems expensive.
2847 return () unless @perlret;
2848 my($newtext) = $text;
2849 for (my $i = length($text)+1;;$i++) {
2850 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2851 my $try = substr($perlret[0],0,$i);
2852 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2853 # warn "try[$try]tries[@tries]";
2854 if (@tries == @perlret) {
2860 ($newtext,@perlret);
2863 #-> sub CPAN::Complete::cpl ;
2865 my($word,$line,$pos) = @_;
2869 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2871 if ($line =~ s/^(force\s*)//) {
2876 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2877 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2879 } elsif ($line =~ /^(a|ls)\s/) {
2880 @return = cplx('CPAN::Author',uc($word));
2881 } elsif ($line =~ /^b\s/) {
2882 CPAN::Shell->local_bundles;
2883 @return = cplx('CPAN::Bundle',$word);
2884 } elsif ($line =~ /^d\s/) {
2885 @return = cplx('CPAN::Distribution',$word);
2886 } elsif ($line =~ m/^(
2887 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2889 if ($word =~ /^Bundle::/) {
2890 CPAN::Shell->local_bundles;
2892 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2893 } elsif ($line =~ /^i\s/) {
2894 @return = cpl_any($word);
2895 } elsif ($line =~ /^reload\s/) {
2896 @return = cpl_reload($word,$line,$pos);
2897 } elsif ($line =~ /^o\s/) {
2898 @return = cpl_option($word,$line,$pos);
2899 } elsif ($line =~ m/^\S+\s/ ) {
2900 # fallback for future commands and what we have forgotten above
2901 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2908 #-> sub CPAN::Complete::cplx ;
2910 my($class, $word) = @_;
2911 # I believed for many years that this was sorted, today I
2912 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2913 # make it sorted again. Maybe sort was dropped when GNU-readline
2914 # support came in? The RCS file is difficult to read on that:-(
2915 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2918 #-> sub CPAN::Complete::cpl_any ;
2922 cplx('CPAN::Author',$word),
2923 cplx('CPAN::Bundle',$word),
2924 cplx('CPAN::Distribution',$word),
2925 cplx('CPAN::Module',$word),
2929 #-> sub CPAN::Complete::cpl_reload ;
2931 my($word,$line,$pos) = @_;
2933 my(@words) = split " ", $line;
2934 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2935 my(@ok) = qw(cpan index);
2936 return @ok if @words == 1;
2937 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2940 #-> sub CPAN::Complete::cpl_option ;
2942 my($word,$line,$pos) = @_;
2944 my(@words) = split " ", $line;
2945 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2946 my(@ok) = qw(conf debug);
2947 return @ok if @words == 1;
2948 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2950 } elsif ($words[1] eq 'index') {
2952 } elsif ($words[1] eq 'conf') {
2953 return CPAN::Config::cpl(@_);
2954 } elsif ($words[1] eq 'debug') {
2955 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2959 package CPAN::Index;
2961 #-> sub CPAN::Index::force_reload ;
2964 $CPAN::Index::LAST_TIME = 0;
2968 #-> sub CPAN::Index::reload ;
2970 my($cl,$force) = @_;
2973 # XXX check if a newer one is available. (We currently read it
2974 # from time to time)
2975 for ($CPAN::Config->{index_expire}) {
2976 $_ = 0.001 unless $_ && $_ > 0.001;
2978 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2979 # debug here when CPAN doesn't seem to read the Metadata
2981 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2983 unless ($CPAN::META->{PROTOCOL}) {
2984 $cl->read_metadata_cache;
2985 $CPAN::META->{PROTOCOL} ||= "1.0";
2987 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
2988 # warn "Setting last_time to 0";
2989 $LAST_TIME = 0; # No warning necessary
2991 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
2994 # IFF we are developing, it helps to wipe out the memory
2995 # between reloads, otherwise it is not what a user expects.
2996 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2997 $CPAN::META = CPAN->new;
3001 local $LAST_TIME = $time;
3002 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3004 my $needshort = $^O eq "dos";
3006 $cl->rd_authindex($cl
3008 "authors/01mailrc.txt.gz",
3010 File::Spec->catfile('authors', '01mailrc.gz') :
3011 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3014 $debug = "timing reading 01[".($t2 - $time)."]";
3016 return if $CPAN::Signal; # this is sometimes lengthy
3017 $cl->rd_modpacks($cl
3019 "modules/02packages.details.txt.gz",
3021 File::Spec->catfile('modules', '02packag.gz') :
3022 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3025 $debug .= "02[".($t2 - $time)."]";
3027 return if $CPAN::Signal; # this is sometimes lengthy
3030 "modules/03modlist.data.gz",
3032 File::Spec->catfile('modules', '03mlist.gz') :
3033 File::Spec->catfile('modules', '03modlist.data.gz'),
3035 $cl->write_metadata_cache;
3037 $debug .= "03[".($t2 - $time)."]";
3039 CPAN->debug($debug) if $CPAN::DEBUG;
3042 $CPAN::META->{PROTOCOL} = PROTOCOL;
3045 #-> sub CPAN::Index::reload_x ;
3047 my($cl,$wanted,$localname,$force) = @_;
3048 $force |= 2; # means we're dealing with an index here
3049 CPAN::Config->load; # we should guarantee loading wherever we rely
3051 $localname ||= $wanted;
3052 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3056 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3059 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3060 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3061 qq{day$s. I\'ll use that.});
3064 $force |= 1; # means we're quite serious about it.
3066 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3069 #-> sub CPAN::Index::rd_authindex ;
3071 my($cl, $index_target) = @_;
3073 return unless defined $index_target;
3074 $CPAN::Frontend->myprint("Going to read $index_target\n");
3076 tie *FH, CPAN::Tarzip, $index_target;
3078 push @lines, split /\012/ while <FH>;
3080 my($userid,$fullname,$email) =
3081 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3082 next unless $userid && $fullname && $email;
3084 # instantiate an author object
3085 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3086 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3087 return if $CPAN::Signal;
3092 my($self,$dist) = @_;
3093 $dist = $self->{'id'} unless defined $dist;
3094 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3098 #-> sub CPAN::Index::rd_modpacks ;
3100 my($self, $index_target) = @_;
3102 return unless defined $index_target;
3103 $CPAN::Frontend->myprint("Going to read $index_target\n");
3104 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3106 while ($_ = $fh->READLINE) {
3108 my @ls = map {"$_\n"} split /\n/, $_;
3109 unshift @ls, "\n" x length($1) if /^(\n+)/;
3113 my($line_count,$last_updated);
3115 my $shift = shift(@lines);
3116 last if $shift =~ /^\s*$/;
3117 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3118 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3120 if (not defined $line_count) {
3122 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3123 Please check the validity of the index file by comparing it to more
3124 than one CPAN mirror. I'll continue but problems seem likely to
3129 } elsif ($line_count != scalar @lines) {
3131 warn sprintf qq{Warning: Your %s
3132 contains a Line-Count header of %d but I see %d lines there. Please
3133 check the validity of the index file by comparing it to more than one
3134 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3135 $index_target, $line_count, scalar(@lines);
3138 if (not defined $last_updated) {
3140 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3141 Please check the validity of the index file by comparing it to more
3142 than one CPAN mirror. I'll continue but problems seem likely to
3150 ->myprint(sprintf qq{ Database was generated on %s\n},
3152 $DATE_OF_02 = $last_updated;
3154 if ($CPAN::META->has_inst(HTTP::Date)) {
3156 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3161 qq{Warning: This index file is %d days old.
3162 Please check the host you chose as your CPAN mirror for staleness.
3163 I'll continue but problems seem likely to happen.\a\n},
3168 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3173 # A necessity since we have metadata_cache: delete what isn't
3175 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3176 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3180 # before 1.56 we split into 3 and discarded the rest. From
3181 # 1.57 we assign remaining text to $comment thus allowing to
3182 # influence isa_perl
3183 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3184 my($bundle,$id,$userid);
3186 if ($mod eq 'CPAN' &&
3188 CPAN::Queue->exists('Bundle::CPAN') ||
3189 CPAN::Queue->exists('CPAN')
3193 if ($version > $CPAN::VERSION){
3194 $CPAN::Frontend->myprint(qq{
3195 There's a new CPAN.pm version (v$version) available!
3196 [Current version is v$CPAN::VERSION]
3197 You might want to try
3198 install Bundle::CPAN
3200 without quitting the current session. It should be a seamless upgrade
3201 while we are running...
3204 $CPAN::Frontend->myprint(qq{\n});
3206 last if $CPAN::Signal;
3207 } elsif ($mod =~ /^Bundle::(.*)/) {
3212 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3213 # Let's make it a module too, because bundles have so much
3214 # in common with modules.
3216 # Changed in 1.57_63: seems like memory bloat now without
3217 # any value, so commented out
3219 # $CPAN::META->instance('CPAN::Module',$mod);
3223 # instantiate a module object
3224 $id = $CPAN::META->instance('CPAN::Module',$mod);
3228 if ($id->cpan_file ne $dist){ # update only if file is
3229 # different. CPAN prohibits same
3230 # name with different version
3231 $userid = $self->userid($dist);
3233 'CPAN_USERID' => $userid,
3234 'CPAN_VERSION' => $version,
3235 'CPAN_FILE' => $dist,
3239 # instantiate a distribution object
3240 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3241 # we do not need CONTAINSMODS unless we do something with
3242 # this dist, so we better produce it on demand.
3244 ## my $obj = $CPAN::META->instance(
3245 ## 'CPAN::Distribution' => $dist
3247 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3249 $CPAN::META->instance(
3250 'CPAN::Distribution' => $dist
3252 'CPAN_USERID' => $userid,
3253 'CPAN_COMMENT' => $comment,
3257 for my $name ($mod,$dist) {
3258 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3259 $exists{$name} = undef;
3262 return if $CPAN::Signal;
3266 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3267 for my $o ($CPAN::META->all_objects($class)) {
3268 next if exists $exists{$o->{ID}};
3269 $CPAN::META->delete($class,$o->{ID});
3270 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3277 #-> sub CPAN::Index::rd_modlist ;
3279 my($cl,$index_target) = @_;
3280 return unless defined $index_target;
3281 $CPAN::Frontend->myprint("Going to read $index_target\n");
3282 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3285 while ($_ = $fh->READLINE) {
3287 my @ls = map {"$_\n"} split /\n/, $_;
3288 unshift @ls, "\n" x length($1) if /^(\n+)/;
3292 my $shift = shift(@eval);
3293 if ($shift =~ /^Date:\s+(.*)/){
3294 return if $DATE_OF_03 eq $1;
3297 last if $shift =~ /^\s*$/;
3300 push @eval, q{CPAN::Modulelist->data;};
3302 my($comp) = Safe->new("CPAN::Safe1");
3303 my($eval) = join("", @eval);
3304 my $ret = $comp->reval($eval);
3305 Carp::confess($@) if $@;
3306 return if $CPAN::Signal;
3308 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3309 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3310 $obj->set(%{$ret->{$_}});
3311 return if $CPAN::Signal;
3315 #-> sub CPAN::Index::write_metadata_cache ;
3316 sub write_metadata_cache {
3318 return unless $CPAN::Config->{'cache_metadata'};
3319 return unless $CPAN::META->has_usable("Storable");
3321 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3322 CPAN::Distribution)) {
3323 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3325 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3326 $cache->{last_time} = $LAST_TIME;
3327 $cache->{DATE_OF_02} = $DATE_OF_02;
3328 $cache->{PROTOCOL} = PROTOCOL;
3329 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3330 eval { Storable::nstore($cache, $metadata_file) };
3331 $CPAN::Frontend->mywarn($@) if $@;
3334 #-> sub CPAN::Index::read_metadata_cache ;
3335 sub read_metadata_cache {
3337 return unless $CPAN::Config->{'cache_metadata'};
3338 return unless $CPAN::META->has_usable("Storable");
3339 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3340 return unless -r $metadata_file and -f $metadata_file;
3341 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3343 eval { $cache = Storable::retrieve($metadata_file) };
3344 $CPAN::Frontend->mywarn($@) if $@;
3345 if (!$cache || ref $cache ne 'HASH'){
3349 if (exists $cache->{PROTOCOL}) {
3350 if (PROTOCOL > $cache->{PROTOCOL}) {
3351 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3352 "with protocol v%s, requiring v%s",
3359 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3360 "with protocol v1.0");
3365 while(my($class,$v) = each %$cache) {
3366 next unless $class =~ /^CPAN::/;
3367 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3368 while (my($id,$ro) = each %$v) {
3369 $CPAN::META->{readwrite}{$class}{$id} ||=
3370 $class->new(ID=>$id, RO=>$ro);
3375 unless ($clcnt) { # sanity check
3376 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3379 if ($idcnt < 1000) {
3380 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3381 "in $metadata_file\n");
3384 $CPAN::META->{PROTOCOL} ||=
3385 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3386 # does initialize to some protocol
3387 $LAST_TIME = $cache->{last_time};
3388 $DATE_OF_02 = $cache->{DATE_OF_02};
3389 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3390 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3394 package CPAN::InfoObj;
3397 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3398 sub id { shift->{ID}; }
3400 #-> sub CPAN::InfoObj::new ;
3402 my $this = bless {}, shift;
3407 # The set method may only be used by code that reads index data or
3408 # otherwise "objective" data from the outside world. All session
3409 # related material may do anything else with instance variables but
3410 # must not touch the hash under the RO attribute. The reason is that
3411 # the RO hash gets written to Metadata file and is thus persistent.
3413 #-> sub CPAN::InfoObj::set ;
3415 my($self,%att) = @_;
3416 my $class = ref $self;
3418 # This must be ||=, not ||, because only if we write an empty
3419 # reference, only then the set method will write into the readonly
3420 # area. But for Distributions that spring into existence, maybe
3421 # because of a typo, we do not like it that they are written into
3422 # the readonly area and made permanent (at least for a while) and
3423 # that is why we do not "allow" other places to call ->set.
3424 unless ($self->id) {
3425 CPAN->debug("Bug? Empty ID, rejecting");
3428 my $ro = $self->{RO} =
3429 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3431 while (my($k,$v) = each %att) {
3436 #-> sub CPAN::InfoObj::as_glimpse ;
3440 my $class = ref($self);
3441 $class =~ s/^CPAN:://;
3442 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3446 #-> sub CPAN::InfoObj::as_string ;
3450 my $class = ref($self);
3451 $class =~ s/^CPAN:://;
3452 push @m, $class, " id = $self->{ID}\n";
3453 for (sort keys %{$self->{RO}}) {
3454 # next if m/^(ID|RO)$/;
3456 if ($_ eq "CPAN_USERID") {
3457 $extra .= " (".$self->author;
3458 my $email; # old perls!
3459 if ($email = $CPAN::META->instance("CPAN::Author",
3462 $extra .= " <$email>";
3464 $extra .= " <no email>";
3467 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3468 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3471 next unless defined $self->{RO}{$_};
3472 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3474 for (sort keys %$self) {
3475 next if m/^(ID|RO)$/;
3476 if (ref($self->{$_}) eq "ARRAY") {
3477 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3478 } elsif (ref($self->{$_}) eq "HASH") {
3482 join(" ",keys %{$self->{$_}}),
3485 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3491 #-> sub CPAN::InfoObj::author ;
3494 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3497 #-> sub CPAN::InfoObj::dump ;
3500 require Data::Dumper;
3501 print Data::Dumper::Dumper($self);
3504 package CPAN::Author;
3506 #-> sub CPAN::Author::id
3509 my $id = $self->{ID};
3510 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3514 #-> sub CPAN::Author::as_glimpse ;
3518 my $class = ref($self);
3519 $class =~ s/^CPAN:://;
3520 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3528 #-> sub CPAN::Author::fullname ;
3530 shift->{RO}{FULLNAME};
3534 #-> sub CPAN::Author::email ;
3535 sub email { shift->{RO}{EMAIL}; }
3537 #-> sub CPAN::Author::ls ;
3542 # adapted from CPAN::Distribution::verifyMD5 ;
3543 my(@csf); # chksumfile
3544 @csf = $self->id =~ /(.)(.)(.*)/;
3545 $csf[1] = join "", @csf[0,1];
3546 $csf[2] = join "", @csf[1,2];
3548 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3549 unless (grep {$_->[2] eq $csf[1]} @dl) {
3550 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3553 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3554 unless (grep {$_->[2] eq $csf[2]} @dl) {
3555 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3558 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3559 $CPAN::Frontend->myprint(join "", map {
3560 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3561 } sort { $a->[2] cmp $b->[2] } @dl);
3564 # returns an array of arrays, the latter contain (size,mtime,filename)
3565 #-> sub CPAN::Author::dir_listing ;
3568 my $chksumfile = shift;
3569 my $recursive = shift;
3571 File::Spec->catfile($CPAN::Config->{keep_source_where},
3572 "authors", "id", @$chksumfile);
3574 # connect "force" argument with "index_expire".
3576 if (my @stat = stat $lc_want) {
3577 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3579 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3582 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3583 $chksumfile->[-1] .= ".gz";
3584 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3587 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3588 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3594 # adapted from CPAN::Distribution::MD5_check_file ;
3595 my $fh = FileHandle->new;
3597 if (open $fh, $lc_file){
3600 $eval =~ s/\015?\012/\n/g;
3602 my($comp) = Safe->new();
3603 $cksum = $comp->reval($eval);
3605 rename $lc_file, "$lc_file.bad";
3606 Carp::confess($@) if $@;
3609 Carp::carp "Could not open $lc_file for reading";
3612 for $f (sort keys %$cksum) {
3613 if (exists $cksum->{$f}{isdir}) {
3615 my(@dir) = @$chksumfile;
3617 push @dir, $f, "CHECKSUMS";
3619 [$_->[0], $_->[1], "$f/$_->[2]"]
3620 } $self->dir_listing(\@dir,1);
3622 push @result, [ 0, "-", $f ];
3626 ($cksum->{$f}{"size"}||0),
3627 $cksum->{$f}{"mtime"}||"---",
3635 package CPAN::Distribution;
3638 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3642 delete $self->{later};
3645 # CPAN::Distribution::normalize
3648 $s = $self->id unless defined $s;
3652 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3654 return $s if $s =~ m:^N/A|^Contact Author: ;
3655 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3656 $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3657 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3662 #-> sub CPAN::Distribution::color_cmd_tmps ;
3663 sub color_cmd_tmps {
3665 my($depth) = shift || 0;
3666 my($color) = shift || 0;
3667 # a distribution needs to recurse into its prereq_pms
3669 return if exists $self->{incommandcolor}
3670 && $self->{incommandcolor}==$color;
3671 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3672 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3677 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3678 my $prereq_pm = $self->prereq_pm;
3679 if (defined $prereq_pm) {
3680 for my $pre (keys %$prereq_pm) {
3681 my $premo = CPAN::Shell->expand("Module",$pre);
3682 $premo->color_cmd_tmps($depth+1,$color);
3686 delete $self->{sponsored_mods};
3687 delete $self->{badtestcnt};
3689 $self->{incommandcolor} = $color;
3692 #-> sub CPAN::Distribution::as_string ;
3695 $self->containsmods;
3696 $self->SUPER::as_string(@_);
3699 #-> sub CPAN::Distribution::containsmods ;
3702 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3703 my $dist_id = $self->{ID};
3704 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3705 my $mod_file = $mod->cpan_file or next;
3706 my $mod_id = $mod->{ID} or next;
3707 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3709 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3711 keys %{$self->{CONTAINSMODS}};
3714 #-> sub CPAN::Distribution::uptodate ;
3718 foreach $c ($self->containsmods) {
3719 my $obj = CPAN::Shell->expandany($c);
3720 return 0 unless $obj->uptodate;
3725 #-> sub CPAN::Distribution::called_for ;
3728 $self->{CALLED_FOR} = $id if defined $id;
3729 return $self->{CALLED_FOR};
3732 #-> sub CPAN::Distribution::safe_chdir ;
3734 my($self,$todir) = @_;
3735 # we die if we cannot chdir and we are debuggable
3736 Carp::confess("safe_chdir called without todir argument")
3737 unless defined $todir and length $todir;
3739 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3742 my $cwd = CPAN::anycwd();
3743 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3744 qq{to todir[$todir]: $!});
3748 #-> sub CPAN::Distribution::get ;
3753 exists $self->{'build_dir'} and push @e,
3754 "Is already unwrapped into directory $self->{'build_dir'}";
3755 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3757 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3760 # Get the file on local disk
3765 File::Spec->catfile(
3766 $CPAN::Config->{keep_source_where},
3769 split("/",$self->id)
3772 $self->debug("Doing localize") if $CPAN::DEBUG;
3773 unless ($local_file =
3774 CPAN::FTP->localize("authors/id/$self->{ID}",
3777 if ($CPAN::Index::DATE_OF_02) {
3778 $note = "Note: Current database in memory was generated ".
3779 "on $CPAN::Index::DATE_OF_02\n";
3781 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3783 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3784 $self->{localfile} = $local_file;
3785 return if $CPAN::Signal;
3790 if ($CPAN::META->has_inst("Digest::MD5")) {
3791 $self->debug("Digest::MD5 is installed, verifying");
3794 $self->debug("Digest::MD5 is NOT installed");
3796 return if $CPAN::Signal;
3799 # Create a clean room and go there
3801 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3802 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3803 $self->safe_chdir($builddir);
3804 $self->debug("Removing tmp") if $CPAN::DEBUG;
3805 File::Path::rmtree("tmp");
3806 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3808 $self->safe_chdir($sub_wd);
3811 $self->safe_chdir("tmp");
3816 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3817 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3818 $self->untar_me($local_file);
3819 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3820 $self->unzip_me($local_file);
3821 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3822 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3823 $self->pm2dir_me($local_file);
3825 $self->{archived} = "NO";
3826 $self->safe_chdir($sub_wd);
3830 # we are still in the tmp directory!
3831 # Let's check if the package has its own directory.
3832 my $dh = DirHandle->new(File::Spec->curdir)
3833 or Carp::croak("Couldn't opendir .: $!");
3834 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3836 my ($distdir,$packagedir);
3837 if (@readdir == 1 && -d $readdir[0]) {
3838 $distdir = $readdir[0];
3839 $packagedir = File::Spec->catdir($builddir,$distdir);
3840 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3842 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3844 File::Path::rmtree($packagedir);
3845 rename($distdir,$packagedir) or
3846 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3847 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3854 my $userid = $self->cpan_userid;
3856 CPAN->debug("no userid? self[$self]");
3859 my $pragmatic_dir = $userid . '000';
3860 $pragmatic_dir =~ s/\W_//g;
3861 $pragmatic_dir++ while -d "../$pragmatic_dir";
3862 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3863 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3864 File::Path::mkpath($packagedir);
3866 for $f (@readdir) { # is already without "." and ".."
3867 my $to = File::Spec->catdir($packagedir,$f);
3868 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3872 $self->safe_chdir($sub_wd);
3876 $self->{'build_dir'} = $packagedir;
3877 $self->safe_chdir(File::Spec->updir);
3878 File::Path::rmtree("tmp");
3880 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3881 my($mpl_exists) = -f $mpl;
3882 unless ($mpl_exists) {
3883 # NFS has been reported to have racing problems after the
3884 # renaming of a directory in some environments.
3887 my $mpldh = DirHandle->new($packagedir)
3888 or Carp::croak("Couldn't opendir $packagedir: $!");
3889 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3892 unless ($mpl_exists) {
3893 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3897 my($configure) = File::Spec->catfile($packagedir,"Configure");
3898 if (-f $configure) {
3899 # do we have anything to do?
3900 $self->{'configure'} = $configure;
3901 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
3902 $CPAN::Frontend->myprint(qq{
3903 Package comes with a Makefile and without a Makefile.PL.
3904 We\'ll try to build it with that Makefile then.
3906 $self->{writemakefile} = "YES";
3909 my $cf = $self->called_for || "unknown";
3914 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3915 $cf = "unknown" unless length($cf);
3916 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3917 (The test -f "$mpl" returned false.)
3918 Writing one on our own (setting NAME to $cf)\a\n});
3919 $self->{had_no_makefile_pl}++;
3922 # Writing our own Makefile.PL
3924 my $fh = FileHandle->new;
3926 or Carp::croak("Could not open >$mpl: $!");
3928 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3929 # because there was no Makefile.PL supplied.
3930 # Autogenerated on: }.scalar localtime().qq{
3932 use ExtUtils::MakeMaker;
3933 WriteMakefile(NAME => q[$cf]);
3943 # CPAN::Distribution::untar_me ;
3945 my($self,$local_file) = @_;
3946 $self->{archived} = "tar";
3947 if (CPAN::Tarzip->untar($local_file)) {
3948 $self->{unwrapped} = "YES";
3950 $self->{unwrapped} = "NO";
3954 # CPAN::Distribution::unzip_me ;
3956 my($self,$local_file) = @_;
3957 $self->{archived} = "zip";
3958 if (CPAN::Tarzip->unzip($local_file)) {
3959 $self->{unwrapped} = "YES";
3961 $self->{unwrapped} = "NO";
3967 my($self,$local_file) = @_;
3968 $self->{archived} = "pm";
3969 my $to = File::Basename::basename($local_file);
3970 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3971 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3972 $self->{unwrapped} = "YES";
3974 $self->{unwrapped} = "NO";
3978 #-> sub CPAN::Distribution::new ;
3980 my($class,%att) = @_;
3982 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3984 my $this = { %att };
3985 return bless $this, $class;
3988 #-> sub CPAN::Distribution::look ;
3992 if ($^O eq 'MacOS') {
3993 $self->Mac::BuildTools::look;
3997 if ( $CPAN::Config->{'shell'} ) {
3998 $CPAN::Frontend->myprint(qq{
3999 Trying to open a subshell in the build directory...
4002 $CPAN::Frontend->myprint(qq{
4003 Your configuration does not define a value for subshells.
4004 Please define it with "o conf shell <your shell>"
4008 my $dist = $self->id;
4010 unless ($dir = $self->dir) {
4013 unless ($dir ||= $self->dir) {
4014 $CPAN::Frontend->mywarn(qq{
4015 Could not determine which directory to use for looking at $dist.
4019 my $pwd = CPAN::anycwd();
4020 $self->safe_chdir($dir);
4021 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4022 system($CPAN::Config->{'shell'}) == 0
4023 or $CPAN::Frontend->mydie("Subprocess shell error");
4024 $self->safe_chdir($pwd);
4027 # CPAN::Distribution::cvs_import ;
4031 my $dir = $self->dir;
4033 my $package = $self->called_for;
4034 my $module = $CPAN::META->instance('CPAN::Module', $package);
4035 my $version = $module->cpan_version;
4037 my $userid = $self->cpan_userid;
4039 my $cvs_dir = (split '/', $dir)[-1];
4040 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4042 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4044 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4045 if ($cvs_site_perl) {
4046 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4048 my $cvs_log = qq{"imported $package $version sources"};
4049 $version =~ s/\./_/g;
4050 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4051 "$cvs_dir", $userid, "v$version");
4053 my $pwd = CPAN::anycwd();
4054 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4056 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4058 $CPAN::Frontend->myprint(qq{@cmd\n});
4059 system(@cmd) == 0 or
4060 $CPAN::Frontend->mydie("cvs import failed");
4061 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4064 #-> sub CPAN::Distribution::readme ;
4067 my($dist) = $self->id;
4068 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4069 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4072 File::Spec->catfile(
4073 $CPAN::Config->{keep_source_where},
4076 split("/","$sans.readme"),
4078 $self->debug("Doing localize") if $CPAN::DEBUG;
4079 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4081 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4083 if ($^O eq 'MacOS') {
4084 Mac::BuildTools::launch_file($local_file);
4088 my $fh_pager = FileHandle->new;
4089 local($SIG{PIPE}) = "IGNORE";
4090 $fh_pager->open("|$CPAN::Config->{'pager'}")
4091 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4092 my $fh_readme = FileHandle->new;
4093 $fh_readme->open($local_file)
4094 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4095 $CPAN::Frontend->myprint(qq{
4098 with pager "$CPAN::Config->{'pager'}"
4101 $fh_pager->print(<$fh_readme>);
4104 #-> sub CPAN::Distribution::verifyMD5 ;
4109 $self->{MD5_STATUS} ||= "";
4110 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4111 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4113 my($lc_want,$lc_file,@local,$basename);
4114 @local = split("/",$self->id);
4116 push @local, "CHECKSUMS";
4118 File::Spec->catfile($CPAN::Config->{keep_source_where},
4119 "authors", "id", @local);
4124 $self->MD5_check_file($lc_want)
4126 return $self->{MD5_STATUS} = "OK";
4128 $lc_file = CPAN::FTP->localize("authors/id/@local",
4131 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4132 $local[-1] .= ".gz";
4133 $lc_file = CPAN::FTP->localize("authors/id/@local",
4136 $lc_file =~ s/\.gz(?!\n)\Z//;
4137 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4142 $self->MD5_check_file($lc_file);
4145 #-> sub CPAN::Distribution::MD5_check_file ;
4146 sub MD5_check_file {
4147 my($self,$chk_file) = @_;
4148 my($cksum,$file,$basename);
4149 $file = $self->{localfile};
4150 $basename = File::Basename::basename($file);
4151 my $fh = FileHandle->new;
4152 if (open $fh, $chk_file){
4155 $eval =~ s/\015?\012/\n/g;
4157 my($comp) = Safe->new();
4158 $cksum = $comp->reval($eval);
4160 rename $chk_file, "$chk_file.bad";
4161 Carp::confess($@) if $@;
4164 Carp::carp "Could not open $chk_file for reading";
4167 if (exists $cksum->{$basename}{md5}) {
4168 $self->debug("Found checksum for $basename:" .
4169 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4173 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4175 $fh = CPAN::Tarzip->TIEHANDLE($file);
4178 # had to inline it, when I tied it, the tiedness got lost on
4179 # the call to eq_MD5. (Jan 1998)
4180 my $md5 = Digest::MD5->new;
4183 while ($fh->READ($ref, 4096) > 0){
4186 my $hexdigest = $md5->hexdigest;
4187 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4191 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4192 return $self->{MD5_STATUS} = "OK";
4194 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4195 qq{distribution file. }.
4196 qq{Please investigate.\n\n}.
4198 $CPAN::META->instance(
4203 my $wrap = qq{I\'d recommend removing $file. Its MD5
4204 checksum is incorrect. Maybe you have configured your 'urllist' with
4205 a bad URL. Please check this array with 'o conf urllist', and
4208 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4210 # former versions just returned here but this seems a
4211 # serious threat that deserves a die
4213 # $CPAN::Frontend->myprint("\n\n");
4217 # close $fh if fileno($fh);
4219 $self->{MD5_STATUS} ||= "";
4220 if ($self->{MD5_STATUS} eq "NIL") {
4221 $CPAN::Frontend->mywarn(qq{
4222 Warning: No md5 checksum for $basename in $chk_file.
4224 The cause for this may be that the file is very new and the checksum
4225 has not yet been calculated, but it may also be that something is
4226 going awry right now.
4228 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4229 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4231 $self->{MD5_STATUS} = "NIL";
4236 #-> sub CPAN::Distribution::eq_MD5 ;
4238 my($self,$fh,$expectMD5) = @_;
4239 my $md5 = Digest::MD5->new;
4241 while (read($fh, $data, 4096)){
4244 # $md5->addfile($fh);
4245 my $hexdigest = $md5->hexdigest;
4246 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4247 $hexdigest eq $expectMD5;
4250 #-> sub CPAN::Distribution::force ;
4252 # Both modules and distributions know if "force" is in effect by
4253 # autoinspection, not by inspecting a global variable. One of the
4254 # reason why this was chosen to work that way was the treatment of
4255 # dependencies. They should not autpomatically inherit the force
4256 # status. But this has the downside that ^C and die() will return to
4257 # the prompt but will not be able to reset the force_update
4258 # attributes. We try to correct for it currently in the read_metadata
4259 # routine, and immediately before we check for a Signal. I hope this
4260 # works out in one of v1.57_53ff
4263 my($self, $method) = @_;
4265 MD5_STATUS archived build_dir localfile make install unwrapped
4268 delete $self->{$att};
4270 if ($method && $method eq "install") {
4271 $self->{"force_update"}++; # name should probably have been force_install
4275 #-> sub CPAN::Distribution::unforce ;
4278 delete $self->{'force_update'};
4281 #-> sub CPAN::Distribution::isa_perl ;
4284 my $file = File::Basename::basename($self->id);
4285 if ($file =~ m{ ^ perl
4298 } elsif ($self->cpan_comment
4300 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4305 #-> sub CPAN::Distribution::perl ;
4308 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4309 my $pwd = CPAN::anycwd();
4310 my $candidate = File::Spec->catfile($pwd,$^X);
4311 $perl ||= $candidate if MM->maybe_command($candidate);
4313 my ($component,$perl_name);
4314 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4315 PATH_COMPONENT: foreach $component (File::Spec->path(),
4316 $Config::Config{'binexp'}) {
4317 next unless defined($component) && $component;
4318 my($abs) = File::Spec->catfile($component,$perl_name);
4319 if (MM->maybe_command($abs)) {
4329 #-> sub CPAN::Distribution::make ;
4332 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4333 # Emergency brake if they said install Pippi and get newest perl
4334 if ($self->isa_perl) {
4336 $self->called_for ne $self->id &&
4337 ! $self->{force_update}
4339 # if we die here, we break bundles
4340 $CPAN::Frontend->mywarn(sprintf qq{
4341 The most recent version "%s" of the module "%s"
4342 comes with the current version of perl (%s).
4343 I\'ll build that only if you ask for something like
4348 $CPAN::META->instance(
4362 $self->{archived} eq "NO" and push @e,
4363 "Is neither a tar nor a zip archive.";
4365 $self->{unwrapped} eq "NO" and push @e,
4366 "had problems unarchiving. Please build manually";
4368 exists $self->{writemakefile} &&
4369 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4370 $1 || "Had some problem writing Makefile";
4372 defined $self->{'make'} and push @e,
4373 "Has already been processed within this session";
4375 exists $self->{later} and length($self->{later}) and
4376 push @e, $self->{later};
4378 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4380 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4381 my $builddir = $self->dir;
4382 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4383 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4385 if ($^O eq 'MacOS') {
4386 Mac::BuildTools::make($self);
4391 if ($self->{'configure'}) {
4392 $system = $self->{'configure'};
4394 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4396 # This needs a handler that can be turned on or off:
4397 # $switch = "-MExtUtils::MakeMaker ".
4398 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4400 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4402 unless (exists $self->{writemakefile}) {
4403 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4406 if ($CPAN::Config->{inactivity_timeout}) {
4408 alarm $CPAN::Config->{inactivity_timeout};
4409 local $SIG{CHLD}; # = sub { wait };
4410 if (defined($pid = fork)) {
4415 # note, this exec isn't necessary if
4416 # inactivity_timeout is 0. On the Mac I'd
4417 # suggest, we set it always to 0.
4421 $CPAN::Frontend->myprint("Cannot fork: $!");
4429 $CPAN::Frontend->myprint($@);
4430 $self->{writemakefile} = "NO $@";
4435 $ret = system($system);
4437 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4441 if (-f "Makefile") {
4442 $self->{writemakefile} = "YES";
4443 delete $self->{make_clean}; # if cleaned before, enable next
4445 $self->{writemakefile} =
4446 qq{NO Makefile.PL refused to write a Makefile.};
4447 # It's probably worth it to record the reason, so let's retry
4449 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4450 # $self->{writemakefile} .= <$fh>;
4454 delete $self->{force_update};
4457 if (my @prereq = $self->unsat_prereq){
4458 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4460 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4461 if (system($system) == 0) {
4462 $CPAN::Frontend->myprint(" $system -- OK\n");
4463 $self->{'make'} = "YES";
4465 $self->{writemakefile} ||= "YES";
4466 $self->{'make'} = "NO";
4467 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4471 sub follow_prereqs {
4475 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4476 "during [$id] -----\n");
4478 for my $p (@prereq) {
4479 $CPAN::Frontend->myprint(" $p\n");
4482 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4484 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4485 require ExtUtils::MakeMaker;
4486 my $answer = ExtUtils::MakeMaker::prompt(
4487 "Shall I follow them and prepend them to the queue
4488 of modules we are processing right now?", "yes");
4489 $follow = $answer =~ /^\s*y/i;
4493 myprint(" Ignoring dependencies on modules @prereq\n");
4496 # color them as dirty
4497 for my $p (@prereq) {
4498 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4500 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4501 $self->{later} = "Delayed until after prerequisites";
4502 return 1; # signal success to the queuerunner
4506 #-> sub CPAN::Distribution::unsat_prereq ;
4509 my $prereq_pm = $self->prereq_pm or return;
4511 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4512 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4513 # we were too demanding:
4514 next if $nmo->uptodate;
4516 # if they have not specified a version, we accept any installed one
4517 if (not defined $need_version or
4518 $need_version == 0 or
4519 $need_version eq "undef") {
4520 next if defined $nmo->inst_file;
4523 # We only want to install prereqs if either they're not installed
4524 # or if the installed version is too old. We cannot omit this
4525 # check, because if 'force' is in effect, nobody else will check.
4529 defined $nmo->inst_file &&
4530 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4532 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4536 CPAN::Version->readable($need_version)
4542 if ($self->{sponsored_mods}{$need_module}++){
4543 # We have already sponsored it and for some reason it's still
4544 # not available. So we do nothing. Or what should we do?
4545 # if we push it again, we have a potential infinite loop
4548 push @need, $need_module;
4553 #-> sub CPAN::Distribution::prereq_pm ;
4556 return $self->{prereq_pm} if
4557 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4558 return unless $self->{writemakefile}; # no need to have succeeded
4559 # but we must have run it
4560 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4561 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4566 $fh = FileHandle->new("<$makefile\0")) {
4570 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4572 last if /MakeMaker post_initialize section/;
4574 \s+PREREQ_PM\s+=>\s+(.+)
4577 # warn "Found prereq expr[$p]";
4579 # Regexp modified by A.Speer to remember actual version of file
4580 # PREREQ_PM hash key wants, then add to
4581 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4582 # In case a prereq is mentioned twice, complain.
4583 if ( defined $p{$1} ) {
4584 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4591 $self->{prereq_pm_detected}++;
4592 return $self->{prereq_pm} = \%p;
4595 #-> sub CPAN::Distribution::test ;
4600 delete $self->{force_update};
4603 $CPAN::Frontend->myprint("Running make test\n");
4604 if (my @prereq = $self->unsat_prereq){
4605 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4609 exists $self->{make} or exists $self->{later} or push @e,
4610 "Make had some problems, maybe interrupted? Won't test";
4612 exists $self->{'make'} and
4613 $self->{'make'} eq 'NO' and
4614 push @e, "Can't test without successful make";
4616 exists $self->{build_dir} or push @e, "Has no own directory";
4617 $self->{badtestcnt} ||= 0;
4618 $self->{badtestcnt} > 0 and
4619 push @e, "Won't repeat unsuccessful test during this command";
4621 exists $self->{later} and length($self->{later}) and
4622 push @e, $self->{later};
4624 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4626 chdir $self->{'build_dir'} or
4627 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4628 $self->debug("Changed directory to $self->{'build_dir'}")
4631 if ($^O eq 'MacOS') {
4632 Mac::BuildTools::make_test($self);
4636 my $system = join " ", $CPAN::Config->{'make'}, "test";
4637 if (system($system) == 0) {
4638 $CPAN::Frontend->myprint(" $system -- OK\n");
4639 $self->{make_test} = "YES";
4641 $self->{make_test} = "NO";
4642 $self->{badtestcnt}++;
4643 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4647 #-> sub CPAN::Distribution::clean ;
4650 $CPAN::Frontend->myprint("Running make clean\n");
4653 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4654 push @e, "make clean already called once";
4655 exists $self->{build_dir} or push @e, "Has no own directory";
4656 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4658 chdir $self->{'build_dir'} or
4659 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4660 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4662 if ($^O eq 'MacOS') {
4663 Mac::BuildTools::make_clean($self);
4667 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4668 if (system($system) == 0) {
4669 $CPAN::Frontend->myprint(" $system -- OK\n");
4673 # Jost Krieger pointed out that this "force" was wrong because
4674 # it has the effect that the next "install" on this distribution
4675 # will untar everything again. Instead we should bring the
4676 # object's state back to where it is after untarring.
4678 delete $self->{force_update};
4679 delete $self->{install};
4680 delete $self->{writemakefile};
4681 delete $self->{make};
4682 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4683 $self->{make_clean} = "YES";
4686 # Hmmm, what to do if make clean failed?
4688 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4690 make clean did not succeed, marking directory as unusable for further work.
4692 $self->force("make"); # so that this directory won't be used again
4697 #-> sub CPAN::Distribution::install ;
4702 delete $self->{force_update};
4705 $CPAN::Frontend->myprint("Running make install\n");
4708 exists $self->{build_dir} or push @e, "Has no own directory";
4710 exists $self->{make} or exists $self->{later} or push @e,
4711 "Make had some problems, maybe interrupted? Won't install";
4713 exists $self->{'make'} and
4714 $self->{'make'} eq 'NO' and
4715 push @e, "make had returned bad status, install seems impossible";
4717 push @e, "make test had returned bad status, ".
4718 "won't install without force"
4719 if exists $self->{'make_test'} and
4720 $self->{'make_test'} eq 'NO' and
4721 ! $self->{'force_update'};
4723 exists $self->{'install'} and push @e,
4724 $self->{'install'} eq "YES" ?
4725 "Already done" : "Already tried without success";
4727 exists $self->{later} and length($self->{later}) and
4728 push @e, $self->{later};
4730 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4732 chdir $self->{'build_dir'} or
4733 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4734 $self->debug("Changed directory to $self->{'build_dir'}")
4737 if ($^O eq 'MacOS') {
4738 Mac::BuildTools::make_install($self);
4742 my $system = join(" ", $CPAN::Config->{'make'},
4743 "install", $CPAN::Config->{make_install_arg});
4744 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4745 my($pipe) = FileHandle->new("$system $stderr |");
4748 $CPAN::Frontend->myprint($_);
4753 $CPAN::Frontend->myprint(" $system -- OK\n");
4754 return $self->{'install'} = "YES";
4756 $self->{'install'} = "NO";
4757 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4758 if ($makeout =~ /permission/s && $> > 0) {
4759 $CPAN::Frontend->myprint(qq{ You may have to su }.
4760 qq{to root to install the package\n});
4763 delete $self->{force_update};
4766 #-> sub CPAN::Distribution::dir ;
4768 shift->{'build_dir'};
4771 package CPAN::Bundle;
4775 delete $self->{later};
4776 for my $c ( $self->contains ) {
4777 my $obj = CPAN::Shell->expandany($c) or next;
4782 #-> sub CPAN::Bundle::color_cmd_tmps ;
4783 sub color_cmd_tmps {
4785 my($depth) = shift || 0;
4786 my($color) = shift || 0;
4787 # a module needs to recurse to its cpan_file, a distribution needs
4788 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4790 return if exists $self->{incommandcolor}
4791 && $self->{incommandcolor}==$color;
4792 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4793 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4798 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4800 for my $c ( $self->contains ) {
4801 my $obj = CPAN::Shell->expandany($c) or next;
4802 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4803 $obj->color_cmd_tmps($depth+1,$color);
4806 delete $self->{badtestcnt};
4808 $self->{incommandcolor} = $color;
4811 #-> sub CPAN::Bundle::as_string ;
4815 # following line must be "=", not "||=" because we have a moving target
4816 $self->{INST_VERSION} = $self->inst_version;
4817 return $self->SUPER::as_string;
4820 #-> sub CPAN::Bundle::contains ;
4823 my($inst_file) = $self->inst_file || "";
4824 my($id) = $self->id;
4825 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4826 unless ($inst_file) {
4827 # Try to get at it in the cpan directory
4828 $self->debug("no inst_file") if $CPAN::DEBUG;
4830 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4831 $cpan_file = $self->cpan_file;
4832 if ($cpan_file eq "N/A") {
4833 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4834 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4836 my $dist = $CPAN::META->instance('CPAN::Distribution',
4839 $self->debug($dist->as_string) if $CPAN::DEBUG;
4840 my($todir) = $CPAN::Config->{'cpan_home'};
4841 my(@me,$from,$to,$me);
4842 @me = split /::/, $self->id;
4844 $me = File::Spec->catfile(@me);
4845 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4846 $to = File::Spec->catfile($todir,$me);
4847 File::Path::mkpath(File::Basename::dirname($to));
4848 File::Copy::copy($from, $to)
4849 or Carp::confess("Couldn't copy $from to $to: $!");
4853 my $fh = FileHandle->new;
4855 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4857 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4859 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4860 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4861 next unless $in_cont;
4866 push @result, (split " ", $_, 2)[0];
4869 delete $self->{STATUS};
4870 $self->{CONTAINS} = \@result;
4871 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4873 $CPAN::Frontend->mywarn(qq{
4874 The bundle file "$inst_file" may be a broken
4875 bundlefile. It seems not to contain any bundle definition.
4876 Please check the file and if it is bogus, please delete it.
4877 Sorry for the inconvenience.
4883 #-> sub CPAN::Bundle::find_bundle_file
4884 sub find_bundle_file {
4885 my($self,$where,$what) = @_;
4886 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4887 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4888 ### my $bu = File::Spec->catfile($where,$what);
4889 ### return $bu if -f $bu;
4890 my $manifest = File::Spec->catfile($where,"MANIFEST");
4891 unless (-f $manifest) {
4892 require ExtUtils::Manifest;
4893 my $cwd = CPAN::anycwd();
4894 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4895 ExtUtils::Manifest::mkmanifest();
4896 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4898 my $fh = FileHandle->new($manifest)
4899 or Carp::croak("Couldn't open $manifest: $!");
4902 if ($^O eq 'MacOS') {
4905 $what2 =~ s/:Bundle://;
4908 $what2 =~ s|Bundle[/\\]||;
4913 my($file) = /(\S+)/;
4914 if ($file =~ m|\Q$what\E$|) {
4916 # return File::Spec->catfile($where,$bu); # bad
4919 # retry if she managed to
4920 # have no Bundle directory
4921 $bu = $file if $file =~ m|\Q$what2\E$|;
4923 $bu =~ tr|/|:| if $^O eq 'MacOS';
4924 return File::Spec->catfile($where, $bu) if $bu;
4925 Carp::croak("Couldn't find a Bundle file in $where");
4928 # needs to work quite differently from Module::inst_file because of
4929 # cpan_home/Bundle/ directory and the possibility that we have
4930 # shadowing effect. As it makes no sense to take the first in @INC for
4931 # Bundles, we parse them all for $VERSION and take the newest.
4933 #-> sub CPAN::Bundle::inst_file ;
4938 @me = split /::/, $self->id;
4941 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4942 my $bfile = File::Spec->catfile($incdir, @me);
4943 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4944 next unless -f $bfile;
4945 my $foundv = MM->parse_version($bfile);
4946 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4947 $self->{INST_FILE} = $bfile;
4948 $self->{INST_VERSION} = $bestv = $foundv;
4954 #-> sub CPAN::Bundle::inst_version ;
4957 $self->inst_file; # finds INST_VERSION as side effect
4958 $self->{INST_VERSION};
4961 #-> sub CPAN::Bundle::rematein ;
4963 my($self,$meth) = @_;
4964 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4965 my($id) = $self->id;
4966 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4967 unless $self->inst_file || $self->cpan_file;
4969 for $s ($self->contains) {
4970 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4971 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4972 if ($type eq 'CPAN::Distribution') {
4973 $CPAN::Frontend->mywarn(qq{
4974 The Bundle }.$self->id.qq{ contains
4975 explicitly a file $s.
4979 # possibly noisy action:
4980 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4981 my $obj = $CPAN::META->instance($type,$s);
4983 if ($obj->isa(CPAN::Bundle)
4985 exists $obj->{install_failed}
4987 ref($obj->{install_failed}) eq "HASH"
4989 for (keys %{$obj->{install_failed}}) {
4990 $self->{install_failed}{$_} = undef; # propagate faiure up
4993 $fail{$s} = 1; # the bundle itself may have succeeded but
4998 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4999 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5001 delete $self->{install_failed}{$s};
5008 # recap with less noise
5009 if ( $meth eq "install" ) {
5012 my $raw = sprintf(qq{Bundle summary:
5013 The following items in bundle %s had installation problems:},
5016 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5017 $CPAN::Frontend->myprint("\n");
5020 for $s ($self->contains) {
5022 $paragraph .= "$s ";
5023 $self->{install_failed}{$s} = undef;
5024 $reported{$s} = undef;
5027 my $report_propagated;
5028 for $s (sort keys %{$self->{install_failed}}) {
5029 next if exists $reported{$s};
5030 $paragraph .= "and the following items had problems
5031 during recursive bundle calls: " unless $report_propagated++;
5032 $paragraph .= "$s ";
5034 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5035 $CPAN::Frontend->myprint("\n");
5037 $self->{'install'} = 'YES';
5042 #sub CPAN::Bundle::xs_file
5044 # If a bundle contains another that contains an xs_file we have
5045 # here, we just don't bother I suppose
5049 #-> sub CPAN::Bundle::force ;
5050 sub force { shift->rematein('force',@_); }
5051 #-> sub CPAN::Bundle::get ;
5052 sub get { shift->rematein('get',@_); }
5053 #-> sub CPAN::Bundle::make ;
5054 sub make { shift->rematein('make',@_); }
5055 #-> sub CPAN::Bundle::test ;
5058 $self->{badtestcnt} ||= 0;
5059 $self->rematein('test',@_);
5061 #-> sub CPAN::Bundle::install ;
5064 $self->rematein('install',@_);
5066 #-> sub CPAN::Bundle::clean ;
5067 sub clean { shift->rematein('clean',@_); }
5069 #-> sub CPAN::Bundle::uptodate ;
5072 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5074 foreach $c ($self->contains) {
5075 my $obj = CPAN::Shell->expandany($c);
5076 return 0 unless $obj->uptodate;
5081 #-> sub CPAN::Bundle::readme ;
5084 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5085 No File found for bundle } . $self->id . qq{\n}), return;
5086 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5087 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5090 package CPAN::Module;
5093 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5096 return unless exists $self->{RO}; # should never happen
5097 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5099 sub description { shift->{RO}{description} }
5103 delete $self->{later};
5104 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5109 #-> sub CPAN::Module::color_cmd_tmps ;
5110 sub color_cmd_tmps {
5112 my($depth) = shift || 0;
5113 my($color) = shift || 0;
5114 # a module needs to recurse to its cpan_file
5116 return if exists $self->{incommandcolor}
5117 && $self->{incommandcolor}==$color;
5118 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5119 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5124 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5126 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5127 $dist->color_cmd_tmps($depth+1,$color);
5130 delete $self->{badtestcnt};
5132 $self->{incommandcolor} = $color;
5135 #-> sub CPAN::Module::as_glimpse ;
5139 my $class = ref($self);
5140 $class =~ s/^CPAN:://;
5144 $CPAN::Shell::COLOR_REGISTERED
5146 $CPAN::META->has_inst("Term::ANSIColor")
5148 $self->{RO}{description}
5150 $color_on = Term::ANSIColor::color("green");
5151 $color_off = Term::ANSIColor::color("reset");
5153 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5162 #-> sub CPAN::Module::as_string ;
5166 CPAN->debug($self) if $CPAN::DEBUG;
5167 my $class = ref($self);
5168 $class =~ s/^CPAN:://;
5170 push @m, $class, " id = $self->{ID}\n";
5171 my $sprintf = " %-12s %s\n";
5172 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5173 if $self->description;
5174 my $sprintf2 = " %-12s %s (%s)\n";
5176 if ($userid = $self->cpan_userid || $self->userid){
5178 if ($author = CPAN::Shell->expand('Author',$userid)) {
5181 if ($m = $author->email) {
5188 $author->fullname . $email
5192 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5193 if $self->cpan_version;
5194 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5195 if $self->cpan_file;
5196 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5197 my(%statd,%stats,%statl,%stati);
5198 @statd{qw,? i c a b R M S,} = qw,unknown idea
5199 pre-alpha alpha beta released mature standard,;
5200 @stats{qw,? m d u n,} = qw,unknown mailing-list
5201 developer comp.lang.perl.* none,;
5202 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5203 @stati{qw,? f r O h,} = qw,unknown functions
5204 references+ties object-oriented hybrid,;
5205 $statd{' '} = 'unknown';
5206 $stats{' '} = 'unknown';
5207 $statl{' '} = 'unknown';
5208 $stati{' '} = 'unknown';
5216 $statd{$self->{RO}{statd}},
5217 $stats{$self->{RO}{stats}},
5218 $statl{$self->{RO}{statl}},
5219 $stati{$self->{RO}{stati}}
5220 ) if $self->{RO}{statd};
5221 my $local_file = $self->inst_file;
5222 unless ($self->{MANPAGE}) {
5224 $self->{MANPAGE} = $self->manpage_headline($local_file);
5226 # If we have already untarred it, we should look there
5227 my $dist = $CPAN::META->instance('CPAN::Distribution',
5229 # warn "dist[$dist]";
5230 # mff=manifest file; mfh=manifest handle
5235 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5237 $mfh = FileHandle->new($mff)
5239 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5240 my $lfre = $self->id; # local file RE
5243 my($lfl); # local file file
5245 my(@mflines) = <$mfh>;
5250 while (length($lfre)>5 and !$lfl) {
5251 ($lfl) = grep /$lfre/, @mflines;
5252 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5255 $lfl =~ s/\s.*//; # remove comments
5256 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5257 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5258 # warn "lfl_abs[$lfl_abs]";
5260 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5266 for $item (qw/MANPAGE/) {
5267 push @m, sprintf($sprintf, $item, $self->{$item})
5268 if exists $self->{$item};
5270 for $item (qw/CONTAINS/) {
5271 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5272 if exists $self->{$item} && @{$self->{$item}};
5274 push @m, sprintf($sprintf, 'INST_FILE',
5275 $local_file || "(not installed)");
5276 push @m, sprintf($sprintf, 'INST_VERSION',
5277 $self->inst_version) if $local_file;
5281 sub manpage_headline {
5282 my($self,$local_file) = @_;
5283 my(@local_file) = $local_file;
5284 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5285 push @local_file, $local_file;
5287 for $locf (@local_file) {
5288 next unless -f $locf;
5289 my $fh = FileHandle->new($locf)
5290 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5294 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
5295 m/^=head1\s+NAME/ ? 1 : $inpod;
5308 #-> sub CPAN::Module::cpan_file ;
5309 # Note: also inherited by CPAN::Bundle
5312 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5313 unless (defined $self->{RO}{CPAN_FILE}) {
5314 CPAN::Index->reload;
5316 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5317 return $self->{RO}{CPAN_FILE};
5319 my $userid = $self->userid;
5321 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5322 my $author = $CPAN::META->instance("CPAN::Author",
5324 my $fullname = $author->fullname;
5325 my $email = $author->email;
5326 unless (defined $fullname && defined $email) {
5327 return sprintf("Contact Author %s",
5331 return "Contact Author $fullname <$email>";
5333 return "UserID $userid";
5341 #-> sub CPAN::Module::cpan_version ;
5345 $self->{RO}{CPAN_VERSION} = 'undef'
5346 unless defined $self->{RO}{CPAN_VERSION};
5347 # I believe this is always a bug in the index and should be reported
5348 # as such, but usually I find out such an error and do not want to
5349 # provoke too many bugreports
5351 $self->{RO}{CPAN_VERSION};
5354 #-> sub CPAN::Module::force ;
5357 $self->{'force_update'}++;
5360 #-> sub CPAN::Module::rematein ;
5362 my($self,$meth) = @_;
5363 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5366 my $cpan_file = $self->cpan_file;
5367 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5368 $CPAN::Frontend->mywarn(sprintf qq{
5369 The module %s isn\'t available on CPAN.
5371 Either the module has not yet been uploaded to CPAN, or it is
5372 temporary unavailable. Please contact the author to find out
5373 more about the status. Try 'i %s'.
5380 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5381 $pack->called_for($self->id);
5382 $pack->force($meth) if exists $self->{'force_update'};
5384 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5385 delete $self->{'force_update'};
5388 #-> sub CPAN::Module::readme ;
5389 sub readme { shift->rematein('readme') }
5390 #-> sub CPAN::Module::look ;
5391 sub look { shift->rematein('look') }
5392 #-> sub CPAN::Module::cvs_import ;
5393 sub cvs_import { shift->rematein('cvs_import') }
5394 #-> sub CPAN::Module::get ;
5395 sub get { shift->rematein('get',@_); }
5396 #-> sub CPAN::Module::make ;
5399 $self->rematein('make');
5401 #-> sub CPAN::Module::test ;
5404 $self->{badtestcnt} ||= 0;
5405 $self->rematein('test',@_);
5407 #-> sub CPAN::Module::uptodate ;
5410 my($latest) = $self->cpan_version;
5412 my($inst_file) = $self->inst_file;
5414 if (defined $inst_file) {
5415 $have = $self->inst_version;
5420 ! CPAN::Version->vgt($latest, $have)
5422 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5423 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5428 #-> sub CPAN::Module::install ;
5434 not exists $self->{'force_update'}
5436 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5440 $self->rematein('install') if $doit;
5442 #-> sub CPAN::Module::clean ;
5443 sub clean { shift->rematein('clean') }
5445 #-> sub CPAN::Module::inst_file ;
5449 @packpath = split /::/, $self->{ID};
5450 $packpath[-1] .= ".pm";
5451 foreach $dir (@INC) {
5452 my $pmfile = File::Spec->catfile($dir,@packpath);
5460 #-> sub CPAN::Module::xs_file ;
5464 @packpath = split /::/, $self->{ID};
5465 push @packpath, $packpath[-1];
5466 $packpath[-1] .= "." . $Config::Config{'dlext'};
5467 foreach $dir (@INC) {
5468 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5476 #-> sub CPAN::Module::inst_version ;
5479 my $parsefile = $self->inst_file or return;
5480 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5483 # there was a bug in 5.6.0 that let lots of unini warnings out of
5484 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5485 # the following workaround after 5.6.1 is out.
5486 local($SIG{__WARN__}) = sub { my $w = shift;
5487 return if $w =~ /uninitialized/i;
5491 $have = MM->parse_version($parsefile) || "undef";
5492 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5493 $have =~ s/ $//; # trailing whitespace happens all the time
5495 # My thoughts about why %vd processing should happen here
5497 # Alt1 maintain it as string with leading v:
5498 # read index files do nothing
5499 # compare it use utility for compare
5500 # print it do nothing
5502 # Alt2 maintain it as what it is
5503 # read index files convert
5504 # compare it use utility because there's still a ">" vs "gt" issue
5505 # print it use CPAN::Version for print
5507 # Seems cleaner to hold it in memory as a string starting with a "v"
5509 # If the author of this module made a mistake and wrote a quoted
5510 # "v1.13" instead of v1.13, we simply leave it at that with the
5511 # effect that *we* will treat it like a v-tring while the rest of
5512 # perl won't. Seems sensible when we consider that any action we
5513 # could take now would just add complexity.
5515 $have = CPAN::Version->readable($have);
5517 $have =~ s/\s*//g; # stringify to float around floating point issues
5518 $have; # no stringify needed, \s* above matches always
5521 package CPAN::Tarzip;
5523 # CPAN::Tarzip::gzip
5525 my($class,$read,$write) = @_;
5526 if ($CPAN::META->has_inst("Compress::Zlib")) {
5528 $fhw = FileHandle->new($read)
5529 or $CPAN::Frontend->mydie("Could not open $read: $!");
5530 my $gz = Compress::Zlib::gzopen($write, "wb")
5531 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5532 $gz->gzwrite($buffer)
5533 while read($fhw,$buffer,4096) > 0 ;
5538 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5543 # CPAN::Tarzip::gunzip
5545 my($class,$read,$write) = @_;
5546 if ($CPAN::META->has_inst("Compress::Zlib")) {
5548 $fhw = FileHandle->new(">$write")
5549 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5550 my $gz = Compress::Zlib::gzopen($read, "rb")
5551 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5552 $fhw->print($buffer)
5553 while $gz->gzread($buffer) > 0 ;
5554 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5555 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5560 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5565 # CPAN::Tarzip::gtest
5567 my($class,$read) = @_;
5568 # After I had reread the documentation in zlib.h, I discovered that
5569 # uncompressed files do not lead to an gzerror (anymore?).
5570 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5573 my $gz = Compress::Zlib::gzopen($read, "rb")
5574 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5576 $Compress::Zlib::gzerrno));
5577 while ($gz->gzread($buffer) > 0 ){
5578 $len += length($buffer);
5581 my $err = $gz->gzerror;
5582 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5583 if ($len == -s $read){
5585 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5588 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5591 return system("$CPAN::Config->{gzip} -dt $read")==0;
5596 # CPAN::Tarzip::TIEHANDLE
5598 my($class,$file) = @_;
5600 $class->debug("file[$file]");
5601 if ($CPAN::META->has_inst("Compress::Zlib")) {
5602 my $gz = Compress::Zlib::gzopen($file,"rb") or
5603 die "Could not gzopen $file";
5604 $ret = bless {GZ => $gz}, $class;
5606 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5607 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5609 $ret = bless {FH => $fh}, $class;
5615 # CPAN::Tarzip::READLINE
5618 if (exists $self->{GZ}) {
5619 my $gz = $self->{GZ};
5620 my($line,$bytesread);
5621 $bytesread = $gz->gzreadline($line);
5622 return undef if $bytesread <= 0;
5625 my $fh = $self->{FH};
5626 return scalar <$fh>;
5631 # CPAN::Tarzip::READ
5633 my($self,$ref,$length,$offset) = @_;
5634 die "read with offset not implemented" if defined $offset;
5635 if (exists $self->{GZ}) {
5636 my $gz = $self->{GZ};
5637 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5640 my $fh = $self->{FH};
5641 return read($fh,$$ref,$length);
5646 # CPAN::Tarzip::DESTROY
5649 if (exists $self->{GZ}) {
5650 my $gz = $self->{GZ};
5651 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5652 # to be undef ever. AK, 2000-09
5654 my $fh = $self->{FH};
5655 $fh->close if defined $fh;
5661 # CPAN::Tarzip::untar
5663 my($class,$file) = @_;
5666 if (0) { # makes changing order easier
5667 } elsif ($BUGHUNTING){
5669 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5671 MM->maybe_command($CPAN::Config->{'tar'})) {
5672 # should be default until Archive::Tar is fixed
5675 $CPAN::META->has_inst("Archive::Tar")
5677 $CPAN::META->has_inst("Compress::Zlib") ) {
5680 $CPAN::Frontend->mydie(qq{
5681 CPAN.pm needs either both external programs tar and gzip installed or
5682 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5683 is available. Can\'t continue.
5686 if ($prefer==1) { # 1 => external gzip+tar
5688 my $is_compressed = $class->gtest($file);
5689 if ($is_compressed) {
5690 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5691 "< $file | $CPAN::Config->{tar} xvf -";
5693 $system = "$CPAN::Config->{tar} xvf $file";
5695 if (system($system) != 0) {
5696 # people find the most curious tar binaries that cannot handle
5698 if ($is_compressed) {
5699 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5700 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5701 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5703 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5707 $system = "$CPAN::Config->{tar} xvf $file";
5708 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5709 if (system($system)==0) {
5710 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5712 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5718 } elsif ($prefer==2) { # 2 => modules
5719 my $tar = Archive::Tar->new($file,1);
5720 my $af; # archive file
5723 # RCS 1.337 had this code, it turned out unacceptable slow but
5724 # it revealed a bug in Archive::Tar. Code is only here to hunt
5725 # the bug again. It should never be enabled in published code.
5726 # GDGraph3d-0.53 was an interesting case according to Larry
5728 warn(">>>Bughunting code enabled<<< " x 20);
5729 for $af ($tar->list_files) {
5730 if ($af =~ m!^(/|\.\./)!) {
5731 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5732 "illegal member [$af]");
5734 $CPAN::Frontend->myprint("$af\n");
5735 $tar->extract($af); # slow but effective for finding the bug
5736 return if $CPAN::Signal;
5739 for $af ($tar->list_files) {
5740 if ($af =~ m!^(/|\.\./)!) {
5741 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5742 "illegal member [$af]");
5744 $CPAN::Frontend->myprint("$af\n");
5746 return if $CPAN::Signal;
5751 Mac::BuildTools::convert_files([$tar->list_files], 1)
5752 if ($^O eq 'MacOS');
5759 my($class,$file) = @_;
5760 if ($CPAN::META->has_inst("Archive::Zip")) {
5761 # blueprint of the code from Archive::Zip::Tree::extractTree();
5762 my $zip = Archive::Zip->new();
5764 $status = $zip->read($file);
5765 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5766 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5767 my @members = $zip->members();
5768 for my $member ( @members ) {
5769 my $af = $member->fileName();
5770 if ($af =~ m!^(/|\.\./)!) {
5771 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5772 "illegal member [$af]");
5774 my $status = $member->extractToFileNamed( $af );
5775 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5776 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5777 $status != Archive::Zip::AZ_OK();
5778 return if $CPAN::Signal;
5782 my $unzip = $CPAN::Config->{unzip} or
5783 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5784 my @system = ($unzip, $file);
5785 return system(@system) == 0;
5790 package CPAN::Version;
5791 # CPAN::Version::vcmp courtesy Jost Krieger
5793 my($self,$l,$r) = @_;
5795 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5797 return 0 if $l eq $r; # short circuit for quicker success
5799 if ($l=~/^v/ <=> $r=~/^v/) {
5802 $_ = $self->float2vv($_);
5807 ($l ne "undef") <=> ($r ne "undef") ||
5811 $self->vstring($l) cmp $self->vstring($r)) ||
5817 my($self,$l,$r) = @_;
5818 $self->vcmp($l,$r) > 0;
5823 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5824 pack "U*", split /\./, $n;
5827 # vv => visible vstring
5832 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5833 # architecture influence
5835 $mantissa .= "0" while length($mantissa)%3;
5836 my $ret = "v" . $rev;
5838 $mantissa =~ s/(\d{1,3})// or
5839 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5840 $ret .= ".".int($1);
5842 # warn "n[$n]ret[$ret]";
5848 $n =~ /^([\w\-\+\.]+)/;
5850 return $1 if defined $1 && length($1)>0;
5851 # if the first user reaches version v43, he will be treated as "+".
5852 # We'll have to decide about a new rule here then, depending on what
5853 # will be the prevailing versioning behavior then.
5855 if ($] < 5.006) { # or whenever v-strings were introduced
5856 # we get them wrong anyway, whatever we do, because 5.005 will
5857 # have already interpreted 0.2.4 to be "0.24". So even if he
5858 # indexer sends us something like "v0.2.4" we compare wrongly.
5860 # And if they say v1.2, then the old perl takes it as "v12"
5862 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5865 my $better = sprintf "v%vd", $n;
5866 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5878 CPAN - query, download and build perl modules from CPAN sites
5884 perl -MCPAN -e shell;
5890 autobundle, clean, install, make, recompile, test
5894 The CPAN module is designed to automate the make and install of perl
5895 modules and extensions. It includes some searching capabilities and
5896 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5897 to fetch the raw data from the net.
5899 Modules are fetched from one or more of the mirrored CPAN
5900 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5903 The CPAN module also supports the concept of named and versioned
5904 I<bundles> of modules. Bundles simplify the handling of sets of
5905 related modules. See Bundles below.
5907 The package contains a session manager and a cache manager. There is
5908 no status retained between sessions. The session manager keeps track
5909 of what has been fetched, built and installed in the current
5910 session. The cache manager keeps track of the disk space occupied by
5911 the make processes and deletes excess space according to a simple FIFO
5914 For extended searching capabilities there's a plugin for CPAN available,
5915 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5916 that indexes all documents available in CPAN authors directories. If
5917 C<CPAN::WAIT> is installed on your system, the interactive shell of
5918 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5919 which send queries to the WAIT server that has been configured for your
5922 All other methods provided are accessible in a programmer style and in an
5923 interactive shell style.
5925 =head2 Interactive Mode
5927 The interactive mode is entered by running
5929 perl -MCPAN -e shell
5931 which puts you into a readline interface. You will have the most fun if
5932 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5935 Once you are on the command line, type 'h' and the rest should be
5938 The function call C<shell> takes two optional arguments, one is the
5939 prompt, the second is the default initial command line (the latter
5940 only works if a real ReadLine interface module is installed).
5942 The most common uses of the interactive modes are
5946 =item Searching for authors, bundles, distribution files and modules
5948 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5949 for each of the four categories and another, C<i> for any of the
5950 mentioned four. Each of the four entities is implemented as a class
5951 with slightly differing methods for displaying an object.
5953 Arguments you pass to these commands are either strings exactly matching
5954 the identification string of an object or regular expressions that are
5955 then matched case-insensitively against various attributes of the
5956 objects. The parser recognizes a regular expression only if you
5957 enclose it between two slashes.
5959 The principle is that the number of found objects influences how an
5960 item is displayed. If the search finds one item, the result is
5961 displayed with the rather verbose method C<as_string>, but if we find
5962 more than one, we display each object with the terse method
5965 =item make, test, install, clean modules or distributions
5967 These commands take any number of arguments and investigate what is
5968 necessary to perform the action. If the argument is a distribution
5969 file name (recognized by embedded slashes), it is processed. If it is
5970 a module, CPAN determines the distribution file in which this module
5971 is included and processes that, following any dependencies named in
5972 the module's Makefile.PL (this behavior is controlled by
5973 I<prerequisites_policy>.)
5975 Any C<make> or C<test> are run unconditionally. An
5977 install <distribution_file>
5979 also is run unconditionally. But for
5983 CPAN checks if an install is actually needed for it and prints
5984 I<module up to date> in the case that the distribution file containing
5985 the module doesn't need to be updated.
5987 CPAN also keeps track of what it has done within the current session
5988 and doesn't try to build a package a second time regardless if it
5989 succeeded or not. The C<force> command takes as a first argument the
5990 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5991 command from scratch.
5995 cpan> install OpenGL
5996 OpenGL is up to date.
5997 cpan> force install OpenGL
6000 OpenGL-0.4/COPYRIGHT
6003 A C<clean> command results in a
6007 being executed within the distribution file's working directory.
6009 =item get, readme, look module or distribution
6011 C<get> downloads a distribution file without further action. C<readme>
6012 displays the README file of the associated distribution. C<Look> gets
6013 and untars (if not yet done) the distribution file, changes to the
6014 appropriate directory and opens a subshell process in that directory.
6018 C<ls> lists all distribution files in and below an author's CPAN
6019 directory. Only those files that contain modules are listed and if
6020 there is more than one for any given module, only the most recent one
6025 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6026 in the cpan-shell it is intended that you can press C<^C> anytime and
6027 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6028 to clean up and leave the shell loop. You can emulate the effect of a
6029 SIGTERM by sending two consecutive SIGINTs, which usually means by
6030 pressing C<^C> twice.
6032 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6033 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6039 The commands that are available in the shell interface are methods in
6040 the package CPAN::Shell. If you enter the shell command, all your
6041 input is split by the Text::ParseWords::shellwords() routine which
6042 acts like most shells do. The first word is being interpreted as the
6043 method to be called and the rest of the words are treated as arguments
6044 to this method. Continuation lines are supported if a line ends with a
6049 C<autobundle> writes a bundle file into the
6050 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6051 a list of all modules that are both available from CPAN and currently
6052 installed within @INC. The name of the bundle file is based on the
6053 current date and a counter.
6057 recompile() is a very special command in that it takes no argument and
6058 runs the make/test/install cycle with brute force over all installed
6059 dynamically loadable extensions (aka XS modules) with 'force' in
6060 effect. The primary purpose of this command is to finish a network
6061 installation. Imagine, you have a common source tree for two different
6062 architectures. You decide to do a completely independent fresh
6063 installation. You start on one architecture with the help of a Bundle
6064 file produced earlier. CPAN installs the whole Bundle for you, but
6065 when you try to repeat the job on the second architecture, CPAN
6066 responds with a C<"Foo up to date"> message for all modules. So you
6067 invoke CPAN's recompile on the second architecture and you're done.
6069 Another popular use for C<recompile> is to act as a rescue in case your
6070 perl breaks binary compatibility. If one of the modules that CPAN uses
6071 is in turn depending on binary compatibility (so you cannot run CPAN
6072 commands), then you should try the CPAN::Nox module for recovery.
6074 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6076 Although it may be considered internal, the class hierarchy does matter
6077 for both users and programmer. CPAN.pm deals with above mentioned four
6078 classes, and all those classes share a set of methods. A classical
6079 single polymorphism is in effect. A metaclass object registers all
6080 objects of all kinds and indexes them with a string. The strings
6081 referencing objects have a separated namespace (well, not completely
6086 words containing a "/" (slash) Distribution
6087 words starting with Bundle:: Bundle
6088 everything else Module or Author
6090 Modules know their associated Distribution objects. They always refer
6091 to the most recent official release. Developers may mark their releases
6092 as unstable development versions (by inserting an underbar into the
6093 module version number which will also be reflected in the distribution
6094 name when you run 'make dist'), so the really hottest and newest
6095 distribution is not always the default. If a module Foo circulates
6096 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6097 way to install version 1.23 by saying
6101 This would install the complete distribution file (say
6102 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6103 like to install version 1.23_90, you need to know where the
6104 distribution file resides on CPAN relative to the authors/id/
6105 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6106 so you would have to say
6108 install BAR/Foo-1.23_90.tar.gz
6110 The first example will be driven by an object of the class
6111 CPAN::Module, the second by an object of class CPAN::Distribution.
6113 =head2 Programmer's interface
6115 If you do not enter the shell, the available shell commands are both
6116 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6117 functions in the calling package (C<install(...)>).
6119 There's currently only one class that has a stable interface -
6120 CPAN::Shell. All commands that are available in the CPAN shell are
6121 methods of the class CPAN::Shell. Each of the commands that produce
6122 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6123 the IDs of all modules within the list.
6127 =item expand($type,@things)
6129 The IDs of all objects available within a program are strings that can
6130 be expanded to the corresponding real objects with the
6131 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6132 list of CPAN::Module objects according to the C<@things> arguments
6133 given. In scalar context it only returns the first element of the
6136 =item expandany(@things)
6138 Like expand, but returns objects of the appropriate type, i.e.
6139 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6140 CPAN::Distribution objects fro distributions.
6142 =item Programming Examples
6144 This enables the programmer to do operations that combine
6145 functionalities that are available in the shell.
6147 # install everything that is outdated on my disk:
6148 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6150 # install my favorite programs if necessary:
6151 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6152 my $obj = CPAN::Shell->expand('Module',$mod);
6156 # list all modules on my disk that have no VERSION number
6157 for $mod (CPAN::Shell->expand("Module","/./")){
6158 next unless $mod->inst_file;
6159 # MakeMaker convention for undefined $VERSION:
6160 next unless $mod->inst_version eq "undef";
6161 print "No VERSION in ", $mod->id, "\n";
6164 # find out which distribution on CPAN contains a module:
6165 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6167 Or if you want to write a cronjob to watch The CPAN, you could list
6168 all modules that need updating. First a quick and dirty way:
6170 perl -e 'use CPAN; CPAN::Shell->r;'
6172 If you don't want to get any output in the case that all modules are
6173 up to date, you can parse the output of above command for the regular
6174 expression //modules are up to date// and decide to mail the output
6175 only if it doesn't match. Ick?
6177 If you prefer to do it more in a programmer style in one single
6178 process, maybe something like this suits you better:
6180 # list all modules on my disk that have newer versions on CPAN
6181 for $mod (CPAN::Shell->expand("Module","/./")){
6182 next unless $mod->inst_file;
6183 next if $mod->uptodate;
6184 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6185 $mod->id, $mod->inst_version, $mod->cpan_version;
6188 If that gives you too much output every day, you maybe only want to
6189 watch for three modules. You can write
6191 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6193 as the first line instead. Or you can combine some of the above
6196 # watch only for a new mod_perl module
6197 $mod = CPAN::Shell->expand("Module","mod_perl");
6198 exit if $mod->uptodate;
6199 # new mod_perl arrived, let me know all update recommendations
6204 =head2 Methods in the other Classes
6206 The programming interface for the classes CPAN::Module,
6207 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6208 beta and partially even alpha. In the following paragraphs only those
6209 methods are documented that have proven useful over a longer time and
6210 thus are unlikely to change.
6214 =item CPAN::Author::as_glimpse()
6216 Returns a one-line description of the author
6218 =item CPAN::Author::as_string()
6220 Returns a multi-line description of the author
6222 =item CPAN::Author::email()
6224 Returns the author's email address
6226 =item CPAN::Author::fullname()
6228 Returns the author's name
6230 =item CPAN::Author::name()
6232 An alias for fullname
6234 =item CPAN::Bundle::as_glimpse()
6236 Returns a one-line description of the bundle
6238 =item CPAN::Bundle::as_string()
6240 Returns a multi-line description of the bundle
6242 =item CPAN::Bundle::clean()
6244 Recursively runs the C<clean> method on all items contained in the bundle.
6246 =item CPAN::Bundle::contains()
6248 Returns a list of objects' IDs contained in a bundle. The associated
6249 objects may be bundles, modules or distributions.
6251 =item CPAN::Bundle::force($method,@args)
6253 Forces CPAN to perform a task that normally would have failed. Force
6254 takes as arguments a method name to be called and any number of
6255 additional arguments that should be passed to the called method. The
6256 internals of the object get the needed changes so that CPAN.pm does
6257 not refuse to take the action. The C<force> is passed recursively to
6258 all contained objects.
6260 =item CPAN::Bundle::get()
6262 Recursively runs the C<get> method on all items contained in the bundle
6264 =item CPAN::Bundle::inst_file()
6266 Returns the highest installed version of the bundle in either @INC or
6267 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6268 CPAN::Module::inst_file.
6270 =item CPAN::Bundle::inst_version()
6272 Like CPAN::Bundle::inst_file, but returns the $VERSION
6274 =item CPAN::Bundle::uptodate()
6276 Returns 1 if the bundle itself and all its members are uptodate.
6278 =item CPAN::Bundle::install()
6280 Recursively runs the C<install> method on all items contained in the bundle
6282 =item CPAN::Bundle::make()
6284 Recursively runs the C<make> method on all items contained in the bundle
6286 =item CPAN::Bundle::readme()
6288 Recursively runs the C<readme> method on all items contained in the bundle
6290 =item CPAN::Bundle::test()
6292 Recursively runs the C<test> method on all items contained in the bundle
6294 =item CPAN::Distribution::as_glimpse()
6296 Returns a one-line description of the distribution
6298 =item CPAN::Distribution::as_string()
6300 Returns a multi-line description of the distribution
6302 =item CPAN::Distribution::clean()
6304 Changes to the directory where the distribution has been unpacked and
6305 runs C<make clean> there.
6307 =item CPAN::Distribution::containsmods()
6309 Returns a list of IDs of modules contained in a distribution file.
6310 Only works for distributions listed in the 02packages.details.txt.gz
6311 file. This typically means that only the most recent version of a
6312 distribution is covered.
6314 =item CPAN::Distribution::cvs_import()
6316 Changes to the directory where the distribution has been unpacked and
6319 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6323 =item CPAN::Distribution::dir()
6325 Returns the directory into which this distribution has been unpacked.
6327 =item CPAN::Distribution::force($method,@args)
6329 Forces CPAN to perform a task that normally would have failed. Force
6330 takes as arguments a method name to be called and any number of
6331 additional arguments that should be passed to the called method. The
6332 internals of the object get the needed changes so that CPAN.pm does
6333 not refuse to take the action.
6335 =item CPAN::Distribution::get()
6337 Downloads the distribution from CPAN and unpacks it. Does nothing if
6338 the distribution has already been downloaded and unpacked within the
6341 =item CPAN::Distribution::install()
6343 Changes to the directory where the distribution has been unpacked and
6344 runs the external command C<make install> there. If C<make> has not
6345 yet been run, it will be run first. A C<make test> will be issued in
6346 any case and if this fails, the install will be canceled. The
6347 cancellation can be avoided by letting C<force> run the C<install> for
6350 =item CPAN::Distribution::isa_perl()
6352 Returns 1 if this distribution file seems to be a perl distribution.
6353 Normally this is derived from the file name only, but the index from
6354 CPAN can contain a hint to achieve a return value of true for other
6357 =item CPAN::Distribution::look()
6359 Changes to the directory where the distribution has been unpacked and
6360 opens a subshell there. Exiting the subshell returns.
6362 =item CPAN::Distribution::make()
6364 First runs the C<get> method to make sure the distribution is
6365 downloaded and unpacked. Changes to the directory where the
6366 distribution has been unpacked and runs the external commands C<perl
6367 Makefile.PL> and C<make> there.
6369 =item CPAN::Distribution::prereq_pm()
6371 Returns the hash reference that has been announced by a distribution
6372 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6373 attempt has been made to C<make> the distribution. Returns undef
6376 =item CPAN::Distribution::readme()
6378 Downloads the README file associated with a distribution and runs it
6379 through the pager specified in C<$CPAN::Config->{pager}>.
6381 =item CPAN::Distribution::test()
6383 Changes to the directory where the distribution has been unpacked and
6384 runs C<make test> there.
6386 =item CPAN::Distribution::uptodate()
6388 Returns 1 if all the modules contained in the distribution are
6389 uptodate. Relies on containsmods.
6391 =item CPAN::Index::force_reload()
6393 Forces a reload of all indices.
6395 =item CPAN::Index::reload()
6397 Reloads all indices if they have been read more than
6398 C<$CPAN::Config->{index_expire}> days.
6400 =item CPAN::InfoObj::dump()
6402 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6403 inherit this method. It prints the data structure associated with an
6404 object. Useful for debugging. Note: the data structure is considered
6405 internal and thus subject to change without notice.
6407 =item CPAN::Module::as_glimpse()
6409 Returns a one-line description of the module
6411 =item CPAN::Module::as_string()
6413 Returns a multi-line description of the module
6415 =item CPAN::Module::clean()
6417 Runs a clean on the distribution associated with this module.
6419 =item CPAN::Module::cpan_file()
6421 Returns the filename on CPAN that is associated with the module.
6423 =item CPAN::Module::cpan_version()
6425 Returns the latest version of this module available on CPAN.
6427 =item CPAN::Module::cvs_import()
6429 Runs a cvs_import on the distribution associated with this module.
6431 =item CPAN::Module::description()
6433 Returns a 44 character description of this module. Only available for
6434 modules listed in The Module List (CPAN/modules/00modlist.long.html
6435 or 00modlist.long.txt.gz)
6437 =item CPAN::Module::force($method,@args)
6439 Forces CPAN to perform a task that normally would have failed. Force
6440 takes as arguments a method name to be called and any number of
6441 additional arguments that should be passed to the called method. The
6442 internals of the object get the needed changes so that CPAN.pm does
6443 not refuse to take the action.
6445 =item CPAN::Module::get()
6447 Runs a get on the distribution associated with this module.
6449 =item CPAN::Module::inst_file()
6451 Returns the filename of the module found in @INC. The first file found
6452 is reported just like perl itself stops searching @INC when it finds a
6455 =item CPAN::Module::inst_version()
6457 Returns the version number of the module in readable format.
6459 =item CPAN::Module::install()
6461 Runs an C<install> on the distribution associated with this module.
6463 =item CPAN::Module::look()
6465 Changes to the directory where the distribution associated with this
6466 module has been unpacked and opens a subshell there. Exiting the
6469 =item CPAN::Module::make()
6471 Runs a C<make> on the distribution associated with this module.
6473 =item CPAN::Module::manpage_headline()
6475 If module is installed, peeks into the module's manpage, reads the
6476 headline and returns it. Moreover, if the module has been downloaded
6477 within this session, does the equivalent on the downloaded module even
6478 if it is not installed.
6480 =item CPAN::Module::readme()
6482 Runs a C<readme> on the distribution associated with this module.
6484 =item CPAN::Module::test()
6486 Runs a C<test> on the distribution associated with this module.
6488 =item CPAN::Module::uptodate()
6490 Returns 1 if the module is installed and up-to-date.
6492 =item CPAN::Module::userid()
6494 Returns the author's ID of the module.
6498 =head2 Cache Manager
6500 Currently the cache manager only keeps track of the build directory
6501 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6502 deletes complete directories below C<build_dir> as soon as the size of
6503 all directories there gets bigger than $CPAN::Config->{build_cache}
6504 (in MB). The contents of this cache may be used for later
6505 re-installations that you intend to do manually, but will never be
6506 trusted by CPAN itself. This is due to the fact that the user might
6507 use these directories for building modules on different architectures.
6509 There is another directory ($CPAN::Config->{keep_source_where}) where
6510 the original distribution files are kept. This directory is not
6511 covered by the cache manager and must be controlled by the user. If
6512 you choose to have the same directory as build_dir and as
6513 keep_source_where directory, then your sources will be deleted with
6514 the same fifo mechanism.
6518 A bundle is just a perl module in the namespace Bundle:: that does not
6519 define any functions or methods. It usually only contains documentation.
6521 It starts like a perl module with a package declaration and a $VERSION
6522 variable. After that the pod section looks like any other pod with the
6523 only difference being that I<one special pod section> exists starting with
6528 In this pod section each line obeys the format
6530 Module_Name [Version_String] [- optional text]
6532 The only required part is the first field, the name of a module
6533 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6534 of the line is optional. The comment part is delimited by a dash just
6535 as in the man page header.
6537 The distribution of a bundle should follow the same convention as
6538 other distributions.
6540 Bundles are treated specially in the CPAN package. If you say 'install
6541 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6542 the modules in the CONTENTS section of the pod. You can install your
6543 own Bundles locally by placing a conformant Bundle file somewhere into
6544 your @INC path. The autobundle() command which is available in the
6545 shell interface does that for you by including all currently installed
6546 modules in a snapshot bundle file.
6548 =head2 Prerequisites
6550 If you have a local mirror of CPAN and can access all files with
6551 "file:" URLs, then you only need a perl better than perl5.003 to run
6552 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6553 required for non-UNIX systems or if your nearest CPAN site is
6554 associated with a URL that is not C<ftp:>.
6556 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6557 implemented for an external ftp command or for an external lynx
6560 =head2 Finding packages and VERSION
6562 This module presumes that all packages on CPAN
6568 declare their $VERSION variable in an easy to parse manner. This
6569 prerequisite can hardly be relaxed because it consumes far too much
6570 memory to load all packages into the running program just to determine
6571 the $VERSION variable. Currently all programs that are dealing with
6572 version use something like this
6574 perl -MExtUtils::MakeMaker -le \
6575 'print MM->parse_version(shift)' filename
6577 If you are author of a package and wonder if your $VERSION can be
6578 parsed, please try the above method.
6582 come as compressed or gzipped tarfiles or as zip files and contain a
6583 Makefile.PL (well, we try to handle a bit more, but without much
6590 The debugging of this module is a bit complex, because we have
6591 interferences of the software producing the indices on CPAN, of the
6592 mirroring process on CPAN, of packaging, of configuration, of
6593 synchronicity, and of bugs within CPAN.pm.
6595 For code debugging in interactive mode you can try "o debug" which
6596 will list options for debugging the various parts of the code. You
6597 should know that "o debug" has built-in completion support.
6599 For data debugging there is the C<dump> command which takes the same
6600 arguments as make/test/install and outputs the object's Data::Dumper
6603 =head2 Floppy, Zip, Offline Mode
6605 CPAN.pm works nicely without network too. If you maintain machines
6606 that are not networked at all, you should consider working with file:
6607 URLs. Of course, you have to collect your modules somewhere first. So
6608 you might use CPAN.pm to put together all you need on a networked
6609 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6610 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6611 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6612 with this floppy. See also below the paragraph about CD-ROM support.
6614 =head1 CONFIGURATION
6616 When the CPAN module is installed, a site wide configuration file is
6617 created as CPAN/Config.pm. The default values defined there can be
6618 overridden in another configuration file: CPAN/MyConfig.pm. You can
6619 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6620 $HOME/.cpan is added to the search path of the CPAN module before the
6621 use() or require() statements.
6623 Currently the following keys in the hash reference $CPAN::Config are
6626 build_cache size of cache for directories to build modules
6627 build_dir locally accessible directory to build modules
6628 index_expire after this many days refetch index files
6629 cache_metadata use serializer to cache metadata
6630 cpan_home local directory reserved for this package
6631 dontload_hash anonymous hash: modules in the keys will not be
6632 loaded by the CPAN::has_inst() routine
6633 gzip location of external program gzip
6634 inactivity_timeout breaks interactive Makefile.PLs after this
6635 many seconds inactivity. Set to 0 to never break.
6636 inhibit_startup_message
6637 if true, does not print the startup message
6638 keep_source_where directory in which to keep the source (if we do)
6639 make location of external make program
6640 make_arg arguments that should always be passed to 'make'
6641 make_install_arg same as make_arg for 'make install'
6642 makepl_arg arguments passed to 'perl Makefile.PL'
6643 pager location of external program more (or any pager)
6644 prerequisites_policy
6645 what to do if you are missing module prerequisites
6646 ('follow' automatically, 'ask' me, or 'ignore')
6647 proxy_user username for accessing an authenticating proxy
6648 proxy_pass password for accessing an authenticating proxy
6649 scan_cache controls scanning of cache ('atstart' or 'never')
6650 tar location of external program tar
6651 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6652 (and nonsense for characters outside latin range)
6653 unzip location of external program unzip
6654 urllist arrayref to nearby CPAN sites (or equivalent locations)
6655 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6656 ftp_proxy, } the three usual variables for configuring
6657 http_proxy, } proxy requests. Both as CPAN::Config variables
6658 no_proxy } and as environment variables configurable.
6660 You can set and query each of these options interactively in the cpan
6661 shell with the command set defined within the C<o conf> command:
6665 =item C<o conf E<lt>scalar optionE<gt>>
6667 prints the current value of the I<scalar option>
6669 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6671 Sets the value of the I<scalar option> to I<value>
6673 =item C<o conf E<lt>list optionE<gt>>
6675 prints the current value of the I<list option> in MakeMaker's
6678 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6680 shifts or pops the array in the I<list option> variable
6682 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6684 works like the corresponding perl commands.
6688 =head2 Note on urllist parameter's format
6690 urllist parameters are URLs according to RFC 1738. We do a little
6691 guessing if your URL is not compliant, but if you have problems with
6692 file URLs, please try the correct format. Either:
6694 file://localhost/whatever/ftp/pub/CPAN/
6698 file:///home/ftp/pub/CPAN/
6700 =head2 urllist parameter has CD-ROM support
6702 The C<urllist> parameter of the configuration table contains a list of
6703 URLs that are to be used for downloading. If the list contains any
6704 C<file> URLs, CPAN always tries to get files from there first. This
6705 feature is disabled for index files. So the recommendation for the
6706 owner of a CD-ROM with CPAN contents is: include your local, possibly
6707 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6709 o conf urllist push file://localhost/CDROM/CPAN
6711 CPAN.pm will then fetch the index files from one of the CPAN sites
6712 that come at the beginning of urllist. It will later check for each
6713 module if there is a local copy of the most recent version.
6715 Another peculiarity of urllist is that the site that we could
6716 successfully fetch the last file from automatically gets a preference
6717 token and is tried as the first site for the next request. So if you
6718 add a new site at runtime it may happen that the previously preferred
6719 site will be tried another time. This means that if you want to disallow
6720 a site for the next transfer, it must be explicitly removed from
6725 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6726 install foreign, unmasked, unsigned code on your machine. We compare
6727 to a checksum that comes from the net just as the distribution file
6728 itself. If somebody has managed to tamper with the distribution file,
6729 they may have as well tampered with the CHECKSUMS file. Future
6730 development will go towards strong authentication.
6734 Most functions in package CPAN are exported per default. The reason
6735 for this is that the primary use is intended for the cpan shell or for
6738 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6740 Populating a freshly installed perl with my favorite modules is pretty
6741 easy if you maintain a private bundle definition file. To get a useful
6742 blueprint of a bundle definition file, the command autobundle can be used
6743 on the CPAN shell command line. This command writes a bundle definition
6744 file for all modules that are installed for the currently running perl
6745 interpreter. It's recommended to run this command only once and from then
6746 on maintain the file manually under a private name, say
6747 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6749 cpan> install Bundle::my_bundle
6751 then answer a few questions and then go out for a coffee.
6753 Maintaining a bundle definition file means keeping track of two
6754 things: dependencies and interactivity. CPAN.pm sometimes fails on
6755 calculating dependencies because not all modules define all MakeMaker
6756 attributes correctly, so a bundle definition file should specify
6757 prerequisites as early as possible. On the other hand, it's a bit
6758 annoying that many distributions need some interactive configuring. So
6759 what I try to accomplish in my private bundle file is to have the
6760 packages that need to be configured early in the file and the gentle
6761 ones later, so I can go out after a few minutes and leave CPAN.pm
6764 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6766 Thanks to Graham Barr for contributing the following paragraphs about
6767 the interaction between perl, and various firewall configurations. For
6768 further informations on firewalls, it is recommended to consult the
6769 documentation that comes with the ncftp program. If you are unable to
6770 go through the firewall with a simple Perl setup, it is very likely
6771 that you can configure ncftp so that it works for your firewall.
6773 =head2 Three basic types of firewalls
6775 Firewalls can be categorized into three basic types.
6781 This is where the firewall machine runs a web server and to access the
6782 outside world you must do it via the web server. If you set environment
6783 variables like http_proxy or ftp_proxy to a values beginning with http://
6784 or in your web browser you have to set proxy information then you know
6785 you are running an http firewall.
6787 To access servers outside these types of firewalls with perl (even for
6788 ftp) you will need to use LWP.
6792 This where the firewall machine runs an ftp server. This kind of
6793 firewall will only let you access ftp servers outside the firewall.
6794 This is usually done by connecting to the firewall with ftp, then
6795 entering a username like "user@outside.host.com"
6797 To access servers outside these type of firewalls with perl you
6798 will need to use Net::FTP.
6800 =item One way visibility
6802 I say one way visibility as these firewalls try to make themselves look
6803 invisible to the users inside the firewall. An FTP data connection is
6804 normally created by sending the remote server your IP address and then
6805 listening for the connection. But the remote server will not be able to
6806 connect to you because of the firewall. So for these types of firewall
6807 FTP connections need to be done in a passive mode.
6809 There are two that I can think off.
6815 If you are using a SOCKS firewall you will need to compile perl and link
6816 it with the SOCKS library, this is what is normally called a 'socksified'
6817 perl. With this executable you will be able to connect to servers outside
6818 the firewall as if it is not there.
6822 This is the firewall implemented in the Linux kernel, it allows you to
6823 hide a complete network behind one IP address. With this firewall no
6824 special compiling is needed as you can access hosts directly.
6830 =head2 Configuring lynx or ncftp for going through a firewall
6832 If you can go through your firewall with e.g. lynx, presumably with a
6835 /usr/local/bin/lynx -pscott:tiger
6837 then you would configure CPAN.pm with the command
6839 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6841 That's all. Similarly for ncftp or ftp, you would configure something
6844 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6846 Your mileage may vary...
6854 I installed a new version of module X but CPAN keeps saying,
6855 I have the old version installed
6857 Most probably you B<do> have the old version installed. This can
6858 happen if a module installs itself into a different directory in the
6859 @INC path than it was previously installed. This is not really a
6860 CPAN.pm problem, you would have the same problem when installing the
6861 module manually. The easiest way to prevent this behaviour is to add
6862 the argument C<UNINST=1> to the C<make install> call, and that is why
6863 many people add this argument permanently by configuring
6865 o conf make_install_arg UNINST=1
6869 So why is UNINST=1 not the default?
6871 Because there are people who have their precise expectations about who
6872 may install where in the @INC path and who uses which @INC array. In
6873 fine tuned environments C<UNINST=1> can cause damage.
6877 I want to clean up my mess, and install a new perl along with
6878 all modules I have. How do I go about it?
6880 Run the autobundle command for your old perl and optionally rename the
6881 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6882 with the Configure option prefix, e.g.
6884 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6886 Install the bundle file you produced in the first step with something like
6888 cpan> install Bundle::mybundle
6894 When I install bundles or multiple modules with one command
6895 there is too much output to keep track of.
6897 You may want to configure something like
6899 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6900 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6902 so that STDOUT is captured in a file for later inspection.
6907 I am not root, how can I install a module in a personal directory?
6909 You will most probably like something like this:
6911 o conf makepl_arg "LIB=~/myperl/lib \
6912 INSTALLMAN1DIR=~/myperl/man/man1 \
6913 INSTALLMAN3DIR=~/myperl/man/man3"
6914 install Sybase::Sybperl
6916 You can make this setting permanent like all C<o conf> settings with
6919 You will have to add ~/myperl/man to the MANPATH environment variable
6920 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6923 use lib "$ENV{HOME}/myperl/lib";
6925 or setting the PERL5LIB environment variable.
6927 Another thing you should bear in mind is that the UNINST parameter
6928 should never be set if you are not root.
6932 How to get a package, unwrap it, and make a change before building it?
6934 look Sybase::Sybperl
6938 I installed a Bundle and had a couple of fails. When I
6939 retried, everything resolved nicely. Can this be fixed to work
6942 The reason for this is that CPAN does not know the dependencies of all
6943 modules when it starts out. To decide about the additional items to
6944 install, it just uses data found in the generated Makefile. An
6945 undetected missing piece breaks the process. But it may well be that
6946 your Bundle installs some prerequisite later than some depending item
6947 and thus your second try is able to resolve everything. Please note,
6948 CPAN.pm does not know the dependency tree in advance and cannot sort
6949 the queue of things to install in a topologically correct order. It
6950 resolves perfectly well IFF all modules declare the prerequisites
6951 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6952 fail and you need to install often, it is recommended sort the Bundle
6953 definition file manually. It is planned to improve the metadata
6954 situation for dependencies on CPAN in general, but this will still
6959 In our intranet we have many modules for internal use. How
6960 can I integrate these modules with CPAN.pm but without uploading
6961 the modules to CPAN?
6963 Have a look at the CPAN::Site module.
6967 When I run CPAN's shell, I get error msg about line 1 to 4,
6968 setting meta input/output via the /etc/inputrc file.
6970 Some versions of readline are picky about capitalization in the
6971 /etc/inputrc file and specifically RedHat 6.2 comes with a
6972 /etc/inputrc that contains the word C<on> in lowercase. Change the
6973 occurrences of C<on> to C<On> and the bug should disappear.
6977 Some authors have strange characters in their names.
6979 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
6980 expecting ISO-8859-1 charset, a converter can be activated by setting
6981 term_is_latin to a true value in your config file. One way of doing so
6984 cpan> ! $CPAN::Config->{term_is_latin}=1
6986 Extended support for converters will be made available as soon as perl
6987 becomes stable with regard to charset issues.
6993 We should give coverage for B<all> of the CPAN and not just the PAUSE
6994 part, right? In this discussion CPAN and PAUSE have become equal --
6995 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6996 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6998 Future development should be directed towards a better integration of
7001 If a Makefile.PL requires special customization of libraries, prompts
7002 the user for special input, etc. then you may find CPAN is not able to
7003 build the distribution. In that case, you should attempt the
7004 traditional method of building a Perl module package from a shell.
7008 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7012 Kawai,Takanori provides a Japanese translation of this manpage at
7013 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7017 perl(1), CPAN::Nox(3)