1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 # $Id: CPAN.pm,v 1.389 2002/04/19 09:37:07 k Exp $
6 # only used during development:
8 # $Revision = "[".substr(q$Revision: 1.389 $, 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");
790 my($self,$what) = @_;
791 $self->{is_tested}{$what} = 1;
795 my($self,$what) = @_;
796 delete $self->{is_tested}{$what};
801 return unless %{$self->{is_tested}};
802 my $env = $ENV{PERL5LIB};
803 $env = $ENV{PERLLIB} unless defined $env;
805 push @env, $env if defined $env and length $env;
806 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
807 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
808 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
811 package CPAN::CacheMgr;
813 #-> sub CPAN::CacheMgr::as_string ;
815 eval { require Data::Dumper };
817 return shift->SUPER::as_string;
819 return Data::Dumper::Dumper(shift);
823 #-> sub CPAN::CacheMgr::cachesize ;
828 #-> sub CPAN::CacheMgr::tidyup ;
831 return unless -d $self->{ID};
832 while ($self->{DU} > $self->{'MAX'} ) {
833 my($toremove) = shift @{$self->{FIFO}};
834 $CPAN::Frontend->myprint(sprintf(
835 "Deleting from cache".
836 ": $toremove (%.1f>%.1f MB)\n",
837 $self->{DU}, $self->{'MAX'})
839 return if $CPAN::Signal;
840 $self->force_clean_cache($toremove);
841 return if $CPAN::Signal;
845 #-> sub CPAN::CacheMgr::dir ;
850 #-> sub CPAN::CacheMgr::entries ;
853 return unless defined $dir;
854 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
855 $dir ||= $self->{ID};
856 my($cwd) = CPAN::anycwd();
857 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
858 my $dh = DirHandle->new(File::Spec->curdir)
859 or Carp::croak("Couldn't opendir $dir: $!");
862 next if $_ eq "." || $_ eq "..";
864 push @entries, File::Spec->catfile($dir,$_);
866 push @entries, File::Spec->catdir($dir,$_);
868 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
871 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
872 sort { -M $b <=> -M $a} @entries;
875 #-> sub CPAN::CacheMgr::disk_usage ;
878 return if exists $self->{SIZE}{$dir};
879 return if $CPAN::Signal;
883 $File::Find::prune++ if $CPAN::Signal;
885 if ($^O eq 'MacOS') {
887 my $cat = Mac::Files::FSpGetCatInfo($_);
888 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
895 return if $CPAN::Signal;
896 $self->{SIZE}{$dir} = $Du/1024/1024;
897 push @{$self->{FIFO}}, $dir;
898 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
899 $self->{DU} += $Du/1024/1024;
903 #-> sub CPAN::CacheMgr::force_clean_cache ;
904 sub force_clean_cache {
906 return unless -e $dir;
907 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
909 File::Path::rmtree($dir);
910 $self->{DU} -= $self->{SIZE}{$dir};
911 delete $self->{SIZE}{$dir};
914 #-> sub CPAN::CacheMgr::new ;
921 ID => $CPAN::Config->{'build_dir'},
922 MAX => $CPAN::Config->{'build_cache'},
923 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
926 File::Path::mkpath($self->{ID});
927 my $dh = DirHandle->new($self->{ID});
931 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
933 CPAN->debug($debug) if $CPAN::DEBUG;
937 #-> sub CPAN::CacheMgr::scan_cache ;
940 return if $self->{SCAN} eq 'never';
941 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
942 unless $self->{SCAN} eq 'atstart';
943 $CPAN::Frontend->myprint(
944 sprintf("Scanning cache %s for sizes\n",
947 for $e ($self->entries($self->{ID})) {
948 next if $e eq ".." || $e eq ".";
949 $self->disk_usage($e);
950 return if $CPAN::Signal;
957 #-> sub CPAN::Debug::debug ;
960 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
961 # Complete, caller(1)
963 ($caller) = caller(0);
965 $arg = "" unless defined $arg;
966 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
967 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
968 if ($arg and ref $arg) {
969 eval { require Data::Dumper };
971 $CPAN::Frontend->myprint($arg->as_string);
973 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
976 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
981 package CPAN::Config;
983 #-> sub CPAN::Config::edit ;
984 # returns true on successful action
986 my($self,@args) = @_;
988 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
989 my($o,$str,$func,$args,$key_exists);
995 CPAN->debug("o[$o]") if $CPAN::DEBUG;
999 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1001 # Let's avoid eval, it's easier to comprehend without.
1002 if ($func eq "push") {
1003 push @{$CPAN::Config->{$o}}, @args;
1005 } elsif ($func eq "pop") {
1006 pop @{$CPAN::Config->{$o}};
1008 } elsif ($func eq "shift") {
1009 shift @{$CPAN::Config->{$o}};
1011 } elsif ($func eq "unshift") {
1012 unshift @{$CPAN::Config->{$o}}, @args;
1014 } elsif ($func eq "splice") {
1015 splice @{$CPAN::Config->{$o}}, @args;
1018 $CPAN::Config->{$o} = [@args];
1021 $self->prettyprint($o);
1023 if ($o eq "urllist" && $changed) {
1024 # reset the cached values
1025 undef $CPAN::FTP::Thesite;
1026 undef $CPAN::FTP::Themethod;
1030 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1031 $self->prettyprint($o);
1038 my $v = $CPAN::Config->{$k};
1040 my(@report) = ref $v eq "ARRAY" ?
1042 map { sprintf(" %-18s => %s\n",
1044 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1046 $CPAN::Frontend->myprint(
1053 map {"\t$_\n"} @report
1056 } elsif (defined $v) {
1057 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1059 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1063 #-> sub CPAN::Config::commit ;
1065 my($self,$configpm) = @_;
1066 unless (defined $configpm){
1067 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1068 $configpm ||= $INC{"CPAN/Config.pm"};
1069 $configpm || Carp::confess(q{
1070 CPAN::Config::commit called without an argument.
1071 Please specify a filename where to save the configuration or try
1072 "o conf init" to have an interactive course through configing.
1077 $mode = (stat $configpm)[2];
1078 if ($mode && ! -w _) {
1079 Carp::confess("$configpm is not writable");
1084 $msg = <<EOF unless $configpm =~ /MyConfig/;
1086 # This is CPAN.pm's systemwide configuration file. This file provides
1087 # defaults for users, and the values can be changed in a per-user
1088 # configuration file. The user-config file is being looked for as
1089 # ~/.cpan/CPAN/MyConfig.pm.
1093 my($fh) = FileHandle->new;
1094 rename $configpm, "$configpm~" if -f $configpm;
1095 open $fh, ">$configpm" or
1096 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1097 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1098 foreach (sort keys %$CPAN::Config) {
1101 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1106 $fh->print("};\n1;\n__END__\n");
1109 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1110 #chmod $mode, $configpm;
1111 ###why was that so? $self->defaults;
1112 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1116 *default = \&defaults;
1117 #-> sub CPAN::Config::defaults ;
1127 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1136 # This is a piece of repeated code that is abstracted here for
1137 # maintainability. RMB
1140 my($configpmdir, $configpmtest) = @_;
1141 if (-w $configpmtest) {
1142 return $configpmtest;
1143 } elsif (-w $configpmdir) {
1144 #_#_# following code dumped core on me with 5.003_11, a.k.
1145 my $configpm_bak = "$configpmtest.bak";
1146 unlink $configpm_bak if -f $configpm_bak;
1147 if( -f $configpmtest ) {
1148 if( rename $configpmtest, $configpm_bak ) {
1149 $CPAN::Frontend->mywarn(<<END)
1150 Old configuration file $configpmtest
1151 moved to $configpm_bak
1155 my $fh = FileHandle->new;
1156 if ($fh->open(">$configpmtest")) {
1158 return $configpmtest;
1160 # Should never happen
1161 Carp::confess("Cannot open >$configpmtest");
1166 #-> sub CPAN::Config::load ;
1171 eval {require CPAN::Config;}; # We eval because of some
1172 # MakeMaker problems
1173 unless ($dot_cpan++){
1174 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1175 eval {require CPAN::MyConfig;}; # where you can override
1176 # system wide settings
1179 return unless @miss = $self->missing_config_data;
1181 require CPAN::FirstTime;
1182 my($configpm,$fh,$redo,$theycalled);
1184 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1185 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1186 $configpm = $INC{"CPAN/Config.pm"};
1188 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1189 $configpm = $INC{"CPAN/MyConfig.pm"};
1192 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1193 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1194 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1195 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1196 $configpm = _configpmtest($configpmdir,$configpmtest);
1198 unless ($configpm) {
1199 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1200 File::Path::mkpath($configpmdir);
1201 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1202 $configpm = _configpmtest($configpmdir,$configpmtest);
1203 unless ($configpm) {
1204 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1205 qq{create a configuration file.});
1210 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1211 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1215 $CPAN::Frontend->myprint(qq{
1216 $configpm initialized.
1219 CPAN::FirstTime::init($configpm);
1222 #-> sub CPAN::Config::missing_config_data ;
1223 sub missing_config_data {
1226 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1227 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1229 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1230 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1231 "prerequisites_policy",
1234 push @miss, $_ unless defined $CPAN::Config->{$_};
1239 #-> sub CPAN::Config::unload ;
1241 delete $INC{'CPAN/MyConfig.pm'};
1242 delete $INC{'CPAN/Config.pm'};
1245 #-> sub CPAN::Config::help ;
1247 $CPAN::Frontend->myprint(q[
1249 defaults reload default config values from disk
1250 commit commit session changes to disk
1251 init go through a dialog to set all parameters
1253 You may edit key values in the follow fashion (the "o" is a literal
1256 o conf build_cache 15
1258 o conf build_dir "/foo/bar"
1260 o conf urllist shift
1262 o conf urllist unshift ftp://ftp.foo.bar/
1265 undef; #don't reprint CPAN::Config
1268 #-> sub CPAN::Config::cpl ;
1270 my($word,$line,$pos) = @_;
1272 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1273 my(@words) = split " ", substr($line,0,$pos+1);
1278 $words[2] =~ /list$/ && @words == 3
1280 $words[2] =~ /list$/ && @words == 4 && length($word)
1283 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1284 } elsif (@words >= 4) {
1287 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1288 return grep /^\Q$word\E/, @o_conf;
1291 package CPAN::Shell;
1293 #-> sub CPAN::Shell::h ;
1295 my($class,$about) = @_;
1296 if (defined $about) {
1297 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1299 $CPAN::Frontend->myprint(q{
1301 command argument description
1302 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1303 i WORD or /REGEXP/ about anything of above
1304 r NONE reinstall recommendations
1305 ls AUTHOR about files in the author's directory
1307 Download, Test, Make, Install...
1309 make make (implies get)
1310 test MODULES, make test (implies make)
1311 install DISTS, BUNDLES make install (implies test)
1313 look open subshell in these dists' directories
1314 readme display these dists' README files
1317 h,? display this menu ! perl-code eval a perl command
1318 o conf [opt] set and query options q quit the cpan shell
1319 reload cpan load CPAN.pm again reload index load newer indices
1320 autobundle Snapshot force cmd unconditionally do cmd});
1326 #-> sub CPAN::Shell::a ;
1328 my($self,@arg) = @_;
1329 # authors are always UPPERCASE
1331 $_ = uc $_ unless /=/;
1333 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1336 #-> sub CPAN::Shell::ls ;
1338 my($self,@arg) = @_;
1341 unless (/^[A-Z\-]+$/i) {
1342 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
1345 push @accept, uc $_;
1347 for my $a (@accept){
1348 my $author = $self->expand('Author',$a) or die "No author found for $a";
1353 #-> sub CPAN::Shell::local_bundles ;
1355 my($self,@which) = @_;
1356 my($incdir,$bdir,$dh);
1357 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1358 my @bbase = "Bundle";
1359 while (my $bbase = shift @bbase) {
1360 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1361 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1362 if ($dh = DirHandle->new($bdir)) { # may fail
1364 for $entry ($dh->read) {
1365 next if $entry =~ /^\./;
1366 if (-d File::Spec->catdir($bdir,$entry)){
1367 push @bbase, "$bbase\::$entry";
1369 next unless $entry =~ s/\.pm(?!\n)\Z//;
1370 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1378 #-> sub CPAN::Shell::b ;
1380 my($self,@which) = @_;
1381 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1382 $self->local_bundles;
1383 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1386 #-> sub CPAN::Shell::d ;
1387 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1389 #-> sub CPAN::Shell::m ;
1390 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1391 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1394 #-> sub CPAN::Shell::i ;
1399 @type = qw/Author Bundle Distribution Module/;
1400 @args = '/./' unless @args;
1403 push @result, $self->expand($type,@args);
1405 my $result = @result == 1 ?
1406 $result[0]->as_string :
1408 "No objects found of any type for argument @args\n" :
1410 (map {$_->as_glimpse} @result),
1411 scalar @result, " items found\n",
1413 $CPAN::Frontend->myprint($result);
1416 #-> sub CPAN::Shell::o ;
1418 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1419 # should have been called set and 'o debug' maybe 'set debug'
1421 my($self,$o_type,@o_what) = @_;
1423 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1424 if ($o_type eq 'conf') {
1425 shift @o_what if @o_what && $o_what[0] eq 'help';
1426 if (!@o_what) { # print all things, "o conf"
1428 $CPAN::Frontend->myprint("CPAN::Config options");
1429 if (exists $INC{'CPAN/Config.pm'}) {
1430 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1432 if (exists $INC{'CPAN/MyConfig.pm'}) {
1433 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1435 $CPAN::Frontend->myprint(":\n");
1436 for $k (sort keys %CPAN::Config::can) {
1437 $v = $CPAN::Config::can{$k};
1438 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1440 $CPAN::Frontend->myprint("\n");
1441 for $k (sort keys %$CPAN::Config) {
1442 CPAN::Config->prettyprint($k);
1444 $CPAN::Frontend->myprint("\n");
1445 } elsif (!CPAN::Config->edit(@o_what)) {
1446 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1447 qq{edit options\n\n});
1449 } elsif ($o_type eq 'debug') {
1451 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1454 my($what) = shift @o_what;
1455 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1456 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1459 if ( exists $CPAN::DEBUG{$what} ) {
1460 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1461 } elsif ($what =~ /^\d/) {
1462 $CPAN::DEBUG = $what;
1463 } elsif (lc $what eq 'all') {
1465 for (values %CPAN::DEBUG) {
1468 $CPAN::DEBUG = $max;
1471 for (keys %CPAN::DEBUG) {
1472 next unless lc($_) eq lc($what);
1473 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1476 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1481 my $raw = "Valid options for debug are ".
1482 join(", ",sort(keys %CPAN::DEBUG), 'all').
1483 qq{ or a number. Completion works on the options. }.
1484 qq{Case is ignored.};
1486 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1487 $CPAN::Frontend->myprint("\n\n");
1490 $CPAN::Frontend->myprint("Options set for debugging:\n");
1492 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1493 $v = $CPAN::DEBUG{$k};
1494 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1495 if $v & $CPAN::DEBUG;
1498 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1501 $CPAN::Frontend->myprint(qq{
1503 conf set or get configuration variables
1504 debug set or get debugging options
1509 sub paintdots_onreload {
1512 if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1516 # $CPAN::Frontend->myprint(".($subr)");
1517 $CPAN::Frontend->myprint(".");
1524 #-> sub CPAN::Shell::reload ;
1526 my($self,$command,@arg) = @_;
1528 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1529 if ($command =~ /cpan/i) {
1530 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1531 my $fh = FileHandle->new($INC{'CPAN.pm'});
1534 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1537 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1538 } elsif ($command =~ /index/) {
1539 CPAN::Index->force_reload;
1541 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1542 index re-reads the index files\n});
1546 #-> sub CPAN::Shell::_binary_extensions ;
1547 sub _binary_extensions {
1548 my($self) = shift @_;
1549 my(@result,$module,%seen,%need,$headerdone);
1550 for $module ($self->expand('Module','/./')) {
1551 my $file = $module->cpan_file;
1552 next if $file eq "N/A";
1553 next if $file =~ /^Contact Author/;
1554 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1555 next if $dist->isa_perl;
1556 next unless $module->xs_file;
1558 $CPAN::Frontend->myprint(".");
1559 push @result, $module;
1561 # print join " | ", @result;
1562 $CPAN::Frontend->myprint("\n");
1566 #-> sub CPAN::Shell::recompile ;
1568 my($self) = shift @_;
1569 my($module,@module,$cpan_file,%dist);
1570 @module = $self->_binary_extensions();
1571 for $module (@module){ # we force now and compile later, so we
1573 $cpan_file = $module->cpan_file;
1574 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1576 $dist{$cpan_file}++;
1578 for $cpan_file (sort keys %dist) {
1579 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1580 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1582 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1583 # stop a package from recompiling,
1584 # e.g. IO-1.12 when we have perl5.003_10
1588 #-> sub CPAN::Shell::_u_r_common ;
1590 my($self) = shift @_;
1591 my($what) = shift @_;
1592 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1593 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1594 $what && $what =~ /^[aru]$/;
1596 @args = '/./' unless @args;
1597 my(@result,$module,%seen,%need,$headerdone,
1598 $version_undefs,$version_zeroes);
1599 $version_undefs = $version_zeroes = 0;
1600 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1601 my @expand = $self->expand('Module',@args);
1602 my $expand = scalar @expand;
1603 if (0) { # Looks like noise to me, was very useful for debugging
1604 # for metadata cache
1605 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1607 for $module (@expand) {
1608 my $file = $module->cpan_file;
1609 next unless defined $file; # ??
1610 my($latest) = $module->cpan_version;
1611 my($inst_file) = $module->inst_file;
1613 return if $CPAN::Signal;
1616 $have = $module->inst_version;
1617 } elsif ($what eq "r") {
1618 $have = $module->inst_version;
1620 if ($have eq "undef"){
1622 } elsif ($have == 0){
1625 next unless CPAN::Version->vgt($latest, $have);
1626 # to be pedantic we should probably say:
1627 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1628 # to catch the case where CPAN has a version 0 and we have a version undef
1629 } elsif ($what eq "u") {
1635 } elsif ($what eq "r") {
1637 } elsif ($what eq "u") {
1641 return if $CPAN::Signal; # this is sometimes lengthy
1644 push @result, sprintf "%s %s\n", $module->id, $have;
1645 } elsif ($what eq "r") {
1646 push @result, $module->id;
1647 next if $seen{$file}++;
1648 } elsif ($what eq "u") {
1649 push @result, $module->id;
1650 next if $seen{$file}++;
1651 next if $file =~ /^Contact/;
1653 unless ($headerdone++){
1654 $CPAN::Frontend->myprint("\n");
1655 $CPAN::Frontend->myprint(sprintf(
1658 "Package namespace",
1670 $CPAN::META->has_inst("Term::ANSIColor")
1672 $module->{RO}{description}
1674 $color_on = Term::ANSIColor::color("green");
1675 $color_off = Term::ANSIColor::color("reset");
1677 $CPAN::Frontend->myprint(sprintf $sprintf,
1684 $need{$module->id}++;
1688 $CPAN::Frontend->myprint("No modules found for @args\n");
1689 } elsif ($what eq "r") {
1690 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1694 if ($version_zeroes) {
1695 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1696 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1697 qq{a version number of 0\n});
1699 if ($version_undefs) {
1700 my $s_has = $version_undefs > 1 ? "s have" : " has";
1701 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1702 qq{parseable version number\n});
1708 #-> sub CPAN::Shell::r ;
1710 shift->_u_r_common("r",@_);
1713 #-> sub CPAN::Shell::u ;
1715 shift->_u_r_common("u",@_);
1718 #-> sub CPAN::Shell::autobundle ;
1721 CPAN::Config->load unless $CPAN::Config_loaded++;
1722 my(@bundle) = $self->_u_r_common("a",@_);
1723 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1724 File::Path::mkpath($todir);
1725 unless (-d $todir) {
1726 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1729 my($y,$m,$d) = (localtime)[5,4,3];
1733 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1734 my($to) = File::Spec->catfile($todir,"$me.pm");
1736 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1737 $to = File::Spec->catfile($todir,"$me.pm");
1739 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1741 "package Bundle::$me;\n\n",
1742 "\$VERSION = '0.01';\n\n",
1746 "Bundle::$me - Snapshot of installation on ",
1747 $Config::Config{'myhostname'},
1750 "\n\n=head1 SYNOPSIS\n\n",
1751 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1752 "=head1 CONTENTS\n\n",
1753 join("\n", @bundle),
1754 "\n\n=head1 CONFIGURATION\n\n",
1756 "\n\n=head1 AUTHOR\n\n",
1757 "This Bundle has been generated automatically ",
1758 "by the autobundle routine in CPAN.pm.\n",
1761 $CPAN::Frontend->myprint("\nWrote bundle file
1765 #-> sub CPAN::Shell::expandany ;
1768 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1769 if ($s =~ m|/|) { # looks like a file
1770 $s = CPAN::Distribution->normalize($s);
1771 return $CPAN::META->instance('CPAN::Distribution',$s);
1772 # Distributions spring into existence, not expand
1773 } elsif ($s =~ m|^Bundle::|) {
1774 $self->local_bundles; # scanning so late for bundles seems
1775 # both attractive and crumpy: always
1776 # current state but easy to forget
1778 return $self->expand('Bundle',$s);
1780 return $self->expand('Module',$s)
1781 if $CPAN::META->exists('CPAN::Module',$s);
1786 #-> sub CPAN::Shell::expand ;
1789 my($type,@args) = @_;
1791 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1793 my($regex,$command);
1794 if ($arg =~ m|^/(.*)/$|) {
1796 } elsif ($arg =~ m/=/) {
1799 my $class = "CPAN::$type";
1801 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1803 defined $regex ? $regex : "UNDEFINED",
1804 $command || "UNDEFINED",
1806 if (defined $regex) {
1810 $CPAN::META->all_objects($class)
1813 # BUG, we got an empty object somewhere
1814 require Data::Dumper;
1815 CPAN->debug(sprintf(
1816 "Bug in CPAN: Empty id on obj[%s][%s]",
1818 Data::Dumper::Dumper($obj)
1823 if $obj->id =~ /$regex/i
1827 $] < 5.00303 ### provide sort of
1828 ### compatibility with 5.003
1833 $obj->name =~ /$regex/i
1836 } elsif ($command) {
1837 die "equal sign in command disabled (immature interface), ".
1839 ! \$CPAN::Shell::ADVANCED_QUERY=1
1840 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1841 that may go away anytime.\n"
1842 unless $ADVANCED_QUERY;
1843 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1844 my($matchcrit) = $criterion =~ m/^~(.+)/;
1848 $CPAN::META->all_objects($class)
1850 my $lhs = $self->$method() or next; # () for 5.00503
1852 push @m, $self if $lhs =~ m/$matchcrit/;
1854 push @m, $self if $lhs eq $criterion;
1859 if ( $type eq 'Bundle' ) {
1860 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1861 } elsif ($type eq "Distribution") {
1862 $xarg = CPAN::Distribution->normalize($arg);
1864 if ($CPAN::META->exists($class,$xarg)) {
1865 $obj = $CPAN::META->instance($class,$xarg);
1866 } elsif ($CPAN::META->exists($class,$arg)) {
1867 $obj = $CPAN::META->instance($class,$arg);
1874 return wantarray ? @m : $m[0];
1877 #-> sub CPAN::Shell::format_result ;
1880 my($type,@args) = @_;
1881 @args = '/./' unless @args;
1882 my(@result) = $self->expand($type,@args);
1883 my $result = @result == 1 ?
1884 $result[0]->as_string :
1886 "No objects of type $type found for argument @args\n" :
1888 (map {$_->as_glimpse} @result),
1889 scalar @result, " items found\n",
1894 # The only reason for this method is currently to have a reliable
1895 # debugging utility that reveals which output is going through which
1896 # channel. No, I don't like the colors ;-)
1898 #-> sub CPAN::Shell::print_ornameted ;
1899 sub print_ornamented {
1900 my($self,$what,$ornament) = @_;
1902 return unless defined $what;
1904 if ($CPAN::Config->{term_is_latin}){
1907 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1909 if ($PRINT_ORNAMENTING) {
1910 unless (defined &color) {
1911 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1912 import Term::ANSIColor "color";
1914 *color = sub { return "" };
1918 for $line (split /\n/, $what) {
1919 $longest = length($line) if length($line) > $longest;
1921 my $sprintf = "%-" . $longest . "s";
1923 $what =~ s/(.*\n?)//m;
1926 my($nl) = chomp $line ? "\n" : "";
1927 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1928 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1936 my($self,$what) = @_;
1938 $self->print_ornamented($what, 'bold blue on_yellow');
1942 my($self,$what) = @_;
1943 $self->myprint($what);
1948 my($self,$what) = @_;
1949 $self->print_ornamented($what, 'bold red on_yellow');
1953 my($self,$what) = @_;
1954 $self->print_ornamented($what, 'bold red on_white');
1955 Carp::confess "died";
1959 my($self,$what) = @_;
1960 $self->print_ornamented($what, 'bold red on_white');
1965 return if -t STDOUT;
1966 my $odef = select STDERR;
1973 #-> sub CPAN::Shell::rematein ;
1974 # RE-adme||MA-ke||TE-st||IN-stall
1977 my($meth,@some) = @_;
1979 if ($meth eq 'force') {
1981 $meth = shift @some;
1984 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1986 # Here is the place to set "test_count" on all involved parties to
1987 # 0. We then can pass this counter on to the involved
1988 # distributions and those can refuse to test if test_count > X. In
1989 # the first stab at it we could use a 1 for "X".
1991 # But when do I reset the distributions to start with 0 again?
1992 # Jost suggested to have a random or cycling interaction ID that
1993 # we pass through. But the ID is something that is just left lying
1994 # around in addition to the counter, so I'd prefer to set the
1995 # counter to 0 now, and repeat at the end of the loop. But what
1996 # about dependencies? They appear later and are not reset, they
1997 # enter the queue but not its copy. How do they get a sensible
2000 # construct the queue
2002 foreach $s (@some) {
2005 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2007 } elsif ($s =~ m|^/|) { # looks like a regexp
2008 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2013 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2014 $obj = CPAN::Shell->expandany($s);
2017 $obj->color_cmd_tmps(0,1);
2018 CPAN::Queue->new($obj->id);
2020 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2021 $obj = $CPAN::META->instance('CPAN::Author',$s);
2022 if ($meth eq "dump") {
2025 $CPAN::Frontend->myprint(
2027 "Don't be silly, you can't $meth ",
2035 ->myprint(qq{Warning: Cannot $meth $s, }.
2036 qq{don\'t know what it is.
2041 to find objects with matching identifiers.
2047 # queuerunner (please be warned: when I started to change the
2048 # queue to hold objects instead of names, I made one or two
2049 # mistakes and never found which. I reverted back instead)
2050 while ($s = CPAN::Queue->first) {
2053 $obj = $s; # I do not believe, we would survive if this happened
2055 $obj = CPAN::Shell->expandany($s);
2059 ($] < 5.00303 || $obj->can($pragma))){
2060 ### compatibility with 5.003
2061 $obj->$pragma($meth); # the pragma "force" in
2062 # "CPAN::Distribution" must know
2063 # what we are intending
2065 if ($]>=5.00303 && $obj->can('called_for')) {
2066 $obj->called_for($s);
2069 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2075 CPAN::Queue->delete($s);
2077 CPAN->debug("failed");
2081 CPAN::Queue->delete_first($s);
2083 for my $obj (@qcopy) {
2084 $obj->color_cmd_tmps(0,0);
2088 #-> sub CPAN::Shell::dump ;
2089 sub dump { shift->rematein('dump',@_); }
2090 #-> sub CPAN::Shell::force ;
2091 sub force { shift->rematein('force',@_); }
2092 #-> sub CPAN::Shell::get ;
2093 sub get { shift->rematein('get',@_); }
2094 #-> sub CPAN::Shell::readme ;
2095 sub readme { shift->rematein('readme',@_); }
2096 #-> sub CPAN::Shell::make ;
2097 sub make { shift->rematein('make',@_); }
2098 #-> sub CPAN::Shell::test ;
2099 sub test { shift->rematein('test',@_); }
2100 #-> sub CPAN::Shell::install ;
2101 sub install { shift->rematein('install',@_); }
2102 #-> sub CPAN::Shell::clean ;
2103 sub clean { shift->rematein('clean',@_); }
2104 #-> sub CPAN::Shell::look ;
2105 sub look { shift->rematein('look',@_); }
2106 #-> sub CPAN::Shell::cvs_import ;
2107 sub cvs_import { shift->rematein('cvs_import',@_); }
2109 package CPAN::LWP::UserAgent;
2112 return if $SETUPDONE;
2113 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2114 require LWP::UserAgent;
2115 @ISA = qw(Exporter LWP::UserAgent);
2118 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2122 sub get_basic_credentials {
2123 my($self, $realm, $uri, $proxy) = @_;
2124 return unless $proxy;
2125 if ($USER && $PASSWD) {
2126 } elsif (defined $CPAN::Config->{proxy_user} &&
2127 defined $CPAN::Config->{proxy_pass}) {
2128 $USER = $CPAN::Config->{proxy_user};
2129 $PASSWD = $CPAN::Config->{proxy_pass};
2131 require ExtUtils::MakeMaker;
2132 ExtUtils::MakeMaker->import(qw(prompt));
2133 $USER = prompt("Proxy authentication needed!
2134 (Note: to permanently configure username and password run
2135 o conf proxy_user your_username
2136 o conf proxy_pass your_password
2138 if ($CPAN::META->has_inst("Term::ReadKey")) {
2139 Term::ReadKey::ReadMode("noecho");
2141 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2143 $PASSWD = prompt("Password:");
2144 if ($CPAN::META->has_inst("Term::ReadKey")) {
2145 Term::ReadKey::ReadMode("restore");
2147 $CPAN::Frontend->myprint("\n\n");
2149 return($USER,$PASSWD);
2153 my($self,$url,$aslocal) = @_;
2154 my $result = $self->SUPER::mirror($url,$aslocal);
2155 if ($result->code == 407) {
2158 $result = $self->SUPER::mirror($url,$aslocal);
2165 #-> sub CPAN::FTP::ftp_get ;
2167 my($class,$host,$dir,$file,$target) = @_;
2169 qq[Going to fetch file [$file] from dir [$dir]
2170 on host [$host] as local [$target]\n]
2172 my $ftp = Net::FTP->new($host);
2173 return 0 unless defined $ftp;
2174 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2175 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2176 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2177 warn "Couldn't login on $host";
2180 unless ( $ftp->cwd($dir) ){
2181 warn "Couldn't cwd $dir";
2185 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2186 unless ( $ftp->get($file,$target) ){
2187 warn "Couldn't fetch $file from $host\n";
2190 $ftp->quit; # it's ok if this fails
2194 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2196 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2197 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2199 # > *** 1562,1567 ****
2200 # > --- 1562,1580 ----
2201 # > return 1 if substr($url,0,4) eq "file";
2202 # > return 1 unless $url =~ m|://([^/]+)|;
2204 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2206 # > + $proxy =~ m|://([^/:]+)|;
2208 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2209 # > + if ($noproxy) {
2210 # > + if ($host !~ /$noproxy$/) {
2211 # > + $host = $proxy;
2214 # > + $host = $proxy;
2217 # > require Net::Ping;
2218 # > return 1 unless $Net::Ping::VERSION >= 2;
2222 #-> sub CPAN::FTP::localize ;
2224 my($self,$file,$aslocal,$force) = @_;
2226 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2227 unless defined $aslocal;
2228 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2231 if ($^O eq 'MacOS') {
2232 # Comment by AK on 2000-09-03: Uniq short filenames would be
2233 # available in CHECKSUMS file
2234 my($name, $path) = File::Basename::fileparse($aslocal, '');
2235 if (length($name) > 31) {
2246 my $size = 31 - length($suf);
2247 while (length($name) > $size) {
2251 $aslocal = File::Spec->catfile($path, $name);
2255 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2258 rename $aslocal, "$aslocal.bak";
2262 my($aslocal_dir) = File::Basename::dirname($aslocal);
2263 File::Path::mkpath($aslocal_dir);
2264 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2265 qq{directory "$aslocal_dir".
2266 I\'ll continue, but if you encounter problems, they may be due
2267 to insufficient permissions.\n}) unless -w $aslocal_dir;
2269 # Inheritance is not easier to manage than a few if/else branches
2270 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2272 CPAN::LWP::UserAgent->config;
2273 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2275 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@")
2279 $Ua->proxy('ftp', $var)
2280 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2281 $Ua->proxy('http', $var)
2282 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2285 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2287 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2288 # > use ones that require basic autorization.
2290 # > Example of when I use it manually in my own stuff:
2292 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2293 # > $req->proxy_authorization_basic("username","password");
2294 # > $res = $ua->request($req);
2298 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2302 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2303 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2304 if $CPAN::Config->{http_proxy};
2305 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2307 # Try the list of urls for each single object. We keep a record
2308 # where we did get a file from
2309 my(@reordered,$last);
2310 $CPAN::Config->{urllist} ||= [];
2311 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2312 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2314 $last = $#{$CPAN::Config->{urllist}};
2315 if ($force & 2) { # local cpans probably out of date, don't reorder
2316 @reordered = (0..$last);
2320 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2322 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2333 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2335 @levels = qw/easy hard hardest/;
2337 @levels = qw/easy/ if $^O eq 'MacOS';
2339 for $levelno (0..$#levels) {
2340 my $level = $levels[$levelno];
2341 my $method = "host$level";
2342 my @host_seq = $level eq "easy" ?
2343 @reordered : 0..$last; # reordered has CDROM up front
2344 @host_seq = (0) unless @host_seq;
2345 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2347 $Themethod = $level;
2349 # utime $now, $now, $aslocal; # too bad, if we do that, we
2350 # might alter a local mirror
2351 $self->debug("level[$level]") if $CPAN::DEBUG;
2355 last if $CPAN::Signal; # need to cleanup
2358 unless ($CPAN::Signal) {
2361 qq{Please check, if the URLs I found in your configuration file \(}.
2362 join(", ", @{$CPAN::Config->{urllist}}).
2363 qq{\) are valid. The urllist can be edited.},
2364 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2365 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2367 $CPAN::Frontend->myprint("Could not fetch $file\n");
2370 rename "$aslocal.bak", $aslocal;
2371 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2372 $self->ls($aslocal));
2379 my($self,$host_seq,$file,$aslocal) = @_;
2381 HOSTEASY: for $i (@$host_seq) {
2382 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2383 $url .= "/" unless substr($url,-1) eq "/";
2385 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2386 if ($url =~ /^file:/) {
2388 if ($CPAN::META->has_inst('URI::URL')) {
2389 my $u = URI::URL->new($url);
2391 } else { # works only on Unix, is poorly constructed, but
2392 # hopefully better than nothing.
2393 # RFC 1738 says fileurl BNF is
2394 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2395 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2397 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2398 $l =~ s|^file:||; # assume they
2401 $l =~ s|^/||s unless -f $l; # e.g. /P:
2402 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2404 if ( -f $l && -r _) {
2408 # Maybe mirror has compressed it?
2410 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2411 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2418 if ($CPAN::META->has_usable('LWP')) {
2419 $CPAN::Frontend->myprint("Fetching with LWP:
2423 CPAN::LWP::UserAgent->config;
2424 eval { $Ua = CPAN::LWP::UserAgent->new; };
2426 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@");
2429 my $res = $Ua->mirror($url, $aslocal);
2430 if ($res->is_success) {
2433 utime $now, $now, $aslocal; # download time is more
2434 # important than upload time
2436 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2437 my $gzurl = "$url.gz";
2438 $CPAN::Frontend->myprint("Fetching with LWP:
2441 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2442 if ($res->is_success &&
2443 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2449 $CPAN::Frontend->myprint(sprintf(
2450 "LWP failed with code[%s] message[%s]\n",
2454 # Alan Burlison informed me that in firewall environments
2455 # Net::FTP can still succeed where LWP fails. So we do not
2456 # skip Net::FTP anymore when LWP is available.
2459 $CPAN::Frontend->myprint("LWP not available\n");
2461 return if $CPAN::Signal;
2462 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2463 # that's the nice and easy way thanks to Graham
2464 my($host,$dir,$getfile) = ($1,$2,$3);
2465 if ($CPAN::META->has_usable('Net::FTP')) {
2467 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2470 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2471 "aslocal[$aslocal]") if $CPAN::DEBUG;
2472 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2476 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2477 my $gz = "$aslocal.gz";
2478 $CPAN::Frontend->myprint("Fetching with Net::FTP
2481 if (CPAN::FTP->ftp_get($host,
2485 CPAN::Tarzip->gunzip($gz,$aslocal)
2494 return if $CPAN::Signal;
2499 my($self,$host_seq,$file,$aslocal) = @_;
2501 # Came back if Net::FTP couldn't establish connection (or
2502 # failed otherwise) Maybe they are behind a firewall, but they
2503 # gave us a socksified (or other) ftp program...
2506 my($devnull) = $CPAN::Config->{devnull} || "";
2508 my($aslocal_dir) = File::Basename::dirname($aslocal);
2509 File::Path::mkpath($aslocal_dir);
2510 HOSTHARD: for $i (@$host_seq) {
2511 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2512 $url .= "/" unless substr($url,-1) eq "/";
2514 my($proto,$host,$dir,$getfile);
2516 # Courtesy Mark Conty mark_conty@cargill.com change from
2517 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2519 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2520 # proto not yet used
2521 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2523 next HOSTHARD; # who said, we could ftp anything except ftp?
2525 next HOSTHARD if $proto eq "file"; # file URLs would have had
2526 # success above. Likely a bogus URL
2528 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2530 for $f ('lynx','ncftpget','ncftp','wget') {
2531 next unless exists $CPAN::Config->{$f};
2532 $funkyftp = $CPAN::Config->{$f};
2533 next unless defined $funkyftp;
2534 next if $funkyftp =~ /^\s*$/;
2535 my($asl_ungz, $asl_gz);
2536 ($asl_ungz = $aslocal) =~ s/\.gz//;
2537 $asl_gz = "$asl_ungz.gz";
2538 my($src_switch) = "";
2540 $src_switch = " -source";
2541 } elsif ($f eq "ncftp"){
2542 $src_switch = " -c";
2543 } elsif ($f eq "wget"){
2544 $src_switch = " -O -";
2547 my($stdout_redir) = " > $asl_ungz";
2548 if ($f eq "ncftpget"){
2549 $chdir = "cd $aslocal_dir && ";
2552 $CPAN::Frontend->myprint(
2554 Trying with "$funkyftp$src_switch" to get
2558 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2559 $self->debug("system[$system]") if $CPAN::DEBUG;
2561 if (($wstatus = system($system)) == 0
2564 -s $asl_ungz # lynx returns 0 when it fails somewhere
2570 } elsif ($asl_ungz ne $aslocal) {
2571 # test gzip integrity
2572 if (CPAN::Tarzip->gtest($asl_ungz)) {
2573 # e.g. foo.tar is gzipped --> foo.tar.gz
2574 rename $asl_ungz, $aslocal;
2576 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2581 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2583 -f $asl_ungz && -s _ == 0;
2584 my $gz = "$aslocal.gz";
2585 my $gzurl = "$url.gz";
2586 $CPAN::Frontend->myprint(
2588 Trying with "$funkyftp$src_switch" to get
2591 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2592 $self->debug("system[$system]") if $CPAN::DEBUG;
2594 if (($wstatus = system($system)) == 0
2598 # test gzip integrity
2599 if (CPAN::Tarzip->gtest($asl_gz)) {
2600 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2602 # somebody uncompressed file for us?
2603 rename $asl_ungz, $aslocal;
2608 unlink $asl_gz if -f $asl_gz;
2611 my $estatus = $wstatus >> 8;
2612 my $size = -f $aslocal ?
2613 ", left\n$aslocal with size ".-s _ :
2614 "\nWarning: expected file [$aslocal] doesn't exist";
2615 $CPAN::Frontend->myprint(qq{
2616 System call "$system"
2617 returned status $estatus (wstat $wstatus)$size
2620 return if $CPAN::Signal;
2621 } # lynx,ncftpget,ncftp
2626 my($self,$host_seq,$file,$aslocal) = @_;
2629 my($aslocal_dir) = File::Basename::dirname($aslocal);
2630 File::Path::mkpath($aslocal_dir);
2631 HOSTHARDEST: for $i (@$host_seq) {
2632 unless (length $CPAN::Config->{'ftp'}) {
2633 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2636 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2637 $url .= "/" unless substr($url,-1) eq "/";
2639 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2640 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2643 my($host,$dir,$getfile) = ($1,$2,$3);
2645 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2646 $ctime,$blksize,$blocks) = stat($aslocal);
2647 $timestamp = $mtime ||= 0;
2648 my($netrc) = CPAN::FTP::netrc->new;
2649 my($netrcfile) = $netrc->netrc;
2650 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2651 my $targetfile = File::Basename::basename($aslocal);
2657 map("cd $_", split "/", $dir), # RFC 1738
2659 "get $getfile $targetfile",
2663 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2664 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2665 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2667 $netrc->contains($host))) if $CPAN::DEBUG;
2668 if ($netrc->protected) {
2669 $CPAN::Frontend->myprint(qq{
2670 Trying with external ftp to get
2672 As this requires some features that are not thoroughly tested, we\'re
2673 not sure, that we get it right....
2677 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2679 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2680 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2682 if ($mtime > $timestamp) {
2683 $CPAN::Frontend->myprint("GOT $aslocal\n");
2687 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2689 return if $CPAN::Signal;
2691 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2692 qq{correctly protected.\n});
2695 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2696 nor does it have a default entry\n");
2699 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2700 # then and login manually to host, using e-mail as
2702 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2706 "user anonymous $Config::Config{'cf_email'}"
2708 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2709 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2710 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2712 if ($mtime > $timestamp) {
2713 $CPAN::Frontend->myprint("GOT $aslocal\n");
2717 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2719 return if $CPAN::Signal;
2720 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2726 my($self,$command,@dialog) = @_;
2727 my $fh = FileHandle->new;
2728 $fh->open("|$command") or die "Couldn't open ftp: $!";
2729 foreach (@dialog) { $fh->print("$_\n") }
2730 $fh->close; # Wait for process to complete
2732 my $estatus = $wstatus >> 8;
2733 $CPAN::Frontend->myprint(qq{
2734 Subprocess "|$command"
2735 returned status $estatus (wstat $wstatus)
2739 # find2perl needs modularization, too, all the following is stolen
2743 my($self,$name) = @_;
2744 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2745 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2747 my($perms,%user,%group);
2751 $blocks = int(($blocks + 1) / 2);
2754 $blocks = int(($sizemm + 1023) / 1024);
2757 if (-f _) { $perms = '-'; }
2758 elsif (-d _) { $perms = 'd'; }
2759 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2760 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2761 elsif (-p _) { $perms = 'p'; }
2762 elsif (-S _) { $perms = 's'; }
2763 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2765 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2766 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2767 my $tmpmode = $mode;
2768 my $tmp = $rwx[$tmpmode & 7];
2770 $tmp = $rwx[$tmpmode & 7] . $tmp;
2772 $tmp = $rwx[$tmpmode & 7] . $tmp;
2773 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2774 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2775 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2778 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2779 my $group = $group{$gid} || $gid;
2781 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2783 my($moname) = $moname[$mon];
2784 if (-M _ > 365.25 / 2) {
2785 $timeyear = $year + 1900;
2788 $timeyear = sprintf("%02d:%02d", $hour, $min);
2791 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2805 package CPAN::FTP::netrc;
2809 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2811 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2812 $atime,$mtime,$ctime,$blksize,$blocks)
2817 my($fh,@machines,$hasdefault);
2819 $fh = FileHandle->new or die "Could not create a filehandle";
2821 if($fh->open($file)){
2822 $protected = ($mode & 077) == 0;
2824 NETRC: while (<$fh>) {
2825 my(@tokens) = split " ", $_;
2826 TOKEN: while (@tokens) {
2827 my($t) = shift @tokens;
2828 if ($t eq "default"){
2832 last TOKEN if $t eq "macdef";
2833 if ($t eq "machine") {
2834 push @machines, shift @tokens;
2839 $file = $hasdefault = $protected = "";
2843 'mach' => [@machines],
2845 'hasdefault' => $hasdefault,
2846 'protected' => $protected,
2850 # CPAN::FTP::hasdefault;
2851 sub hasdefault { shift->{'hasdefault'} }
2852 sub netrc { shift->{'netrc'} }
2853 sub protected { shift->{'protected'} }
2855 my($self,$mach) = @_;
2856 for ( @{$self->{'mach'}} ) {
2857 return 1 if $_ eq $mach;
2862 package CPAN::Complete;
2865 my($text, $line, $start, $end) = @_;
2866 my(@perlret) = cpl($text, $line, $start);
2867 # find longest common match. Can anybody show me how to peruse
2868 # T::R::Gnu to have this done automatically? Seems expensive.
2869 return () unless @perlret;
2870 my($newtext) = $text;
2871 for (my $i = length($text)+1;;$i++) {
2872 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2873 my $try = substr($perlret[0],0,$i);
2874 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2875 # warn "try[$try]tries[@tries]";
2876 if (@tries == @perlret) {
2882 ($newtext,@perlret);
2885 #-> sub CPAN::Complete::cpl ;
2887 my($word,$line,$pos) = @_;
2891 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2893 if ($line =~ s/^(force\s*)//) {
2898 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2899 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2901 } elsif ($line =~ /^(a|ls)\s/) {
2902 @return = cplx('CPAN::Author',uc($word));
2903 } elsif ($line =~ /^b\s/) {
2904 CPAN::Shell->local_bundles;
2905 @return = cplx('CPAN::Bundle',$word);
2906 } elsif ($line =~ /^d\s/) {
2907 @return = cplx('CPAN::Distribution',$word);
2908 } elsif ($line =~ m/^(
2909 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2911 if ($word =~ /^Bundle::/) {
2912 CPAN::Shell->local_bundles;
2914 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2915 } elsif ($line =~ /^i\s/) {
2916 @return = cpl_any($word);
2917 } elsif ($line =~ /^reload\s/) {
2918 @return = cpl_reload($word,$line,$pos);
2919 } elsif ($line =~ /^o\s/) {
2920 @return = cpl_option($word,$line,$pos);
2921 } elsif ($line =~ m/^\S+\s/ ) {
2922 # fallback for future commands and what we have forgotten above
2923 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2930 #-> sub CPAN::Complete::cplx ;
2932 my($class, $word) = @_;
2933 # I believed for many years that this was sorted, today I
2934 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2935 # make it sorted again. Maybe sort was dropped when GNU-readline
2936 # support came in? The RCS file is difficult to read on that:-(
2937 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2940 #-> sub CPAN::Complete::cpl_any ;
2944 cplx('CPAN::Author',$word),
2945 cplx('CPAN::Bundle',$word),
2946 cplx('CPAN::Distribution',$word),
2947 cplx('CPAN::Module',$word),
2951 #-> sub CPAN::Complete::cpl_reload ;
2953 my($word,$line,$pos) = @_;
2955 my(@words) = split " ", $line;
2956 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2957 my(@ok) = qw(cpan index);
2958 return @ok if @words == 1;
2959 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2962 #-> sub CPAN::Complete::cpl_option ;
2964 my($word,$line,$pos) = @_;
2966 my(@words) = split " ", $line;
2967 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2968 my(@ok) = qw(conf debug);
2969 return @ok if @words == 1;
2970 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2972 } elsif ($words[1] eq 'index') {
2974 } elsif ($words[1] eq 'conf') {
2975 return CPAN::Config::cpl(@_);
2976 } elsif ($words[1] eq 'debug') {
2977 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2981 package CPAN::Index;
2983 #-> sub CPAN::Index::force_reload ;
2986 $CPAN::Index::LAST_TIME = 0;
2990 #-> sub CPAN::Index::reload ;
2992 my($cl,$force) = @_;
2995 # XXX check if a newer one is available. (We currently read it
2996 # from time to time)
2997 for ($CPAN::Config->{index_expire}) {
2998 $_ = 0.001 unless $_ && $_ > 0.001;
3000 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3001 # debug here when CPAN doesn't seem to read the Metadata
3003 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3005 unless ($CPAN::META->{PROTOCOL}) {
3006 $cl->read_metadata_cache;
3007 $CPAN::META->{PROTOCOL} ||= "1.0";
3009 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3010 # warn "Setting last_time to 0";
3011 $LAST_TIME = 0; # No warning necessary
3013 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3016 # IFF we are developing, it helps to wipe out the memory
3017 # between reloads, otherwise it is not what a user expects.
3018 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3019 $CPAN::META = CPAN->new;
3023 local $LAST_TIME = $time;
3024 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3026 my $needshort = $^O eq "dos";
3028 $cl->rd_authindex($cl
3030 "authors/01mailrc.txt.gz",
3032 File::Spec->catfile('authors', '01mailrc.gz') :
3033 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3036 $debug = "timing reading 01[".($t2 - $time)."]";
3038 return if $CPAN::Signal; # this is sometimes lengthy
3039 $cl->rd_modpacks($cl
3041 "modules/02packages.details.txt.gz",
3043 File::Spec->catfile('modules', '02packag.gz') :
3044 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3047 $debug .= "02[".($t2 - $time)."]";
3049 return if $CPAN::Signal; # this is sometimes lengthy
3052 "modules/03modlist.data.gz",
3054 File::Spec->catfile('modules', '03mlist.gz') :
3055 File::Spec->catfile('modules', '03modlist.data.gz'),
3057 $cl->write_metadata_cache;
3059 $debug .= "03[".($t2 - $time)."]";
3061 CPAN->debug($debug) if $CPAN::DEBUG;
3064 $CPAN::META->{PROTOCOL} = PROTOCOL;
3067 #-> sub CPAN::Index::reload_x ;
3069 my($cl,$wanted,$localname,$force) = @_;
3070 $force |= 2; # means we're dealing with an index here
3071 CPAN::Config->load; # we should guarantee loading wherever we rely
3073 $localname ||= $wanted;
3074 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3078 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3081 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3082 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3083 qq{day$s. I\'ll use that.});
3086 $force |= 1; # means we're quite serious about it.
3088 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3091 #-> sub CPAN::Index::rd_authindex ;
3093 my($cl, $index_target) = @_;
3095 return unless defined $index_target;
3096 $CPAN::Frontend->myprint("Going to read $index_target\n");
3098 tie *FH, CPAN::Tarzip, $index_target;
3100 push @lines, split /\012/ while <FH>;
3102 my($userid,$fullname,$email) =
3103 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3104 next unless $userid && $fullname && $email;
3106 # instantiate an author object
3107 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3108 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3109 return if $CPAN::Signal;
3114 my($self,$dist) = @_;
3115 $dist = $self->{'id'} unless defined $dist;
3116 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3120 #-> sub CPAN::Index::rd_modpacks ;
3122 my($self, $index_target) = @_;
3124 return unless defined $index_target;
3125 $CPAN::Frontend->myprint("Going to read $index_target\n");
3126 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3128 while ($_ = $fh->READLINE) {
3130 my @ls = map {"$_\n"} split /\n/, $_;
3131 unshift @ls, "\n" x length($1) if /^(\n+)/;
3135 my($line_count,$last_updated);
3137 my $shift = shift(@lines);
3138 last if $shift =~ /^\s*$/;
3139 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3140 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3142 if (not defined $line_count) {
3144 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3145 Please check the validity of the index file by comparing it to more
3146 than one CPAN mirror. I'll continue but problems seem likely to
3151 } elsif ($line_count != scalar @lines) {
3153 warn sprintf qq{Warning: Your %s
3154 contains a Line-Count header of %d but I see %d lines there. Please
3155 check the validity of the index file by comparing it to more than one
3156 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3157 $index_target, $line_count, scalar(@lines);
3160 if (not defined $last_updated) {
3162 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3163 Please check the validity of the index file by comparing it to more
3164 than one CPAN mirror. I'll continue but problems seem likely to
3172 ->myprint(sprintf qq{ Database was generated on %s\n},
3174 $DATE_OF_02 = $last_updated;
3176 if ($CPAN::META->has_inst(HTTP::Date)) {
3178 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3183 qq{Warning: This index file is %d days old.
3184 Please check the host you chose as your CPAN mirror for staleness.
3185 I'll continue but problems seem likely to happen.\a\n},
3190 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3195 # A necessity since we have metadata_cache: delete what isn't
3197 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3198 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3202 # before 1.56 we split into 3 and discarded the rest. From
3203 # 1.57 we assign remaining text to $comment thus allowing to
3204 # influence isa_perl
3205 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3206 my($bundle,$id,$userid);
3208 if ($mod eq 'CPAN' &&
3210 CPAN::Queue->exists('Bundle::CPAN') ||
3211 CPAN::Queue->exists('CPAN')
3215 if ($version > $CPAN::VERSION){
3216 $CPAN::Frontend->myprint(qq{
3217 There's a new CPAN.pm version (v$version) available!
3218 [Current version is v$CPAN::VERSION]
3219 You might want to try
3220 install Bundle::CPAN
3222 without quitting the current session. It should be a seamless upgrade
3223 while we are running...
3226 $CPAN::Frontend->myprint(qq{\n});
3228 last if $CPAN::Signal;
3229 } elsif ($mod =~ /^Bundle::(.*)/) {
3234 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3235 # Let's make it a module too, because bundles have so much
3236 # in common with modules.
3238 # Changed in 1.57_63: seems like memory bloat now without
3239 # any value, so commented out
3241 # $CPAN::META->instance('CPAN::Module',$mod);
3245 # instantiate a module object
3246 $id = $CPAN::META->instance('CPAN::Module',$mod);
3250 if ($id->cpan_file ne $dist){ # update only if file is
3251 # different. CPAN prohibits same
3252 # name with different version
3253 $userid = $self->userid($dist);
3255 'CPAN_USERID' => $userid,
3256 'CPAN_VERSION' => $version,
3257 'CPAN_FILE' => $dist,
3261 # instantiate a distribution object
3262 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3263 # we do not need CONTAINSMODS unless we do something with
3264 # this dist, so we better produce it on demand.
3266 ## my $obj = $CPAN::META->instance(
3267 ## 'CPAN::Distribution' => $dist
3269 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3271 $CPAN::META->instance(
3272 'CPAN::Distribution' => $dist
3274 'CPAN_USERID' => $userid,
3275 'CPAN_COMMENT' => $comment,
3279 for my $name ($mod,$dist) {
3280 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3281 $exists{$name} = undef;
3284 return if $CPAN::Signal;
3288 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3289 for my $o ($CPAN::META->all_objects($class)) {
3290 next if exists $exists{$o->{ID}};
3291 $CPAN::META->delete($class,$o->{ID});
3292 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3299 #-> sub CPAN::Index::rd_modlist ;
3301 my($cl,$index_target) = @_;
3302 return unless defined $index_target;
3303 $CPAN::Frontend->myprint("Going to read $index_target\n");
3304 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3307 while ($_ = $fh->READLINE) {
3309 my @ls = map {"$_\n"} split /\n/, $_;
3310 unshift @ls, "\n" x length($1) if /^(\n+)/;
3314 my $shift = shift(@eval);
3315 if ($shift =~ /^Date:\s+(.*)/){
3316 return if $DATE_OF_03 eq $1;
3319 last if $shift =~ /^\s*$/;
3322 push @eval, q{CPAN::Modulelist->data;};
3324 my($comp) = Safe->new("CPAN::Safe1");
3325 my($eval) = join("", @eval);
3326 my $ret = $comp->reval($eval);
3327 Carp::confess($@) if $@;
3328 return if $CPAN::Signal;
3330 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3331 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3332 $obj->set(%{$ret->{$_}});
3333 return if $CPAN::Signal;
3337 #-> sub CPAN::Index::write_metadata_cache ;
3338 sub write_metadata_cache {
3340 return unless $CPAN::Config->{'cache_metadata'};
3341 return unless $CPAN::META->has_usable("Storable");
3343 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3344 CPAN::Distribution)) {
3345 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3347 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3348 $cache->{last_time} = $LAST_TIME;
3349 $cache->{DATE_OF_02} = $DATE_OF_02;
3350 $cache->{PROTOCOL} = PROTOCOL;
3351 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3352 eval { Storable::nstore($cache, $metadata_file) };
3353 $CPAN::Frontend->mywarn($@) if $@;
3356 #-> sub CPAN::Index::read_metadata_cache ;
3357 sub read_metadata_cache {
3359 return unless $CPAN::Config->{'cache_metadata'};
3360 return unless $CPAN::META->has_usable("Storable");
3361 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3362 return unless -r $metadata_file and -f $metadata_file;
3363 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3365 eval { $cache = Storable::retrieve($metadata_file) };
3366 $CPAN::Frontend->mywarn($@) if $@;
3367 if (!$cache || ref $cache ne 'HASH'){
3371 if (exists $cache->{PROTOCOL}) {
3372 if (PROTOCOL > $cache->{PROTOCOL}) {
3373 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3374 "with protocol v%s, requiring v%s",
3381 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3382 "with protocol v1.0");
3387 while(my($class,$v) = each %$cache) {
3388 next unless $class =~ /^CPAN::/;
3389 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3390 while (my($id,$ro) = each %$v) {
3391 $CPAN::META->{readwrite}{$class}{$id} ||=
3392 $class->new(ID=>$id, RO=>$ro);
3397 unless ($clcnt) { # sanity check
3398 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3401 if ($idcnt < 1000) {
3402 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3403 "in $metadata_file\n");
3406 $CPAN::META->{PROTOCOL} ||=
3407 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3408 # does initialize to some protocol
3409 $LAST_TIME = $cache->{last_time};
3410 $DATE_OF_02 = $cache->{DATE_OF_02};
3411 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3412 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3416 package CPAN::InfoObj;
3419 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3420 sub id { shift->{ID}; }
3422 #-> sub CPAN::InfoObj::new ;
3424 my $this = bless {}, shift;
3429 # The set method may only be used by code that reads index data or
3430 # otherwise "objective" data from the outside world. All session
3431 # related material may do anything else with instance variables but
3432 # must not touch the hash under the RO attribute. The reason is that
3433 # the RO hash gets written to Metadata file and is thus persistent.
3435 #-> sub CPAN::InfoObj::set ;
3437 my($self,%att) = @_;
3438 my $class = ref $self;
3440 # This must be ||=, not ||, because only if we write an empty
3441 # reference, only then the set method will write into the readonly
3442 # area. But for Distributions that spring into existence, maybe
3443 # because of a typo, we do not like it that they are written into
3444 # the readonly area and made permanent (at least for a while) and
3445 # that is why we do not "allow" other places to call ->set.
3446 unless ($self->id) {
3447 CPAN->debug("Bug? Empty ID, rejecting");
3450 my $ro = $self->{RO} =
3451 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3453 while (my($k,$v) = each %att) {
3458 #-> sub CPAN::InfoObj::as_glimpse ;
3462 my $class = ref($self);
3463 $class =~ s/^CPAN:://;
3464 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3468 #-> sub CPAN::InfoObj::as_string ;
3472 my $class = ref($self);
3473 $class =~ s/^CPAN:://;
3474 push @m, $class, " id = $self->{ID}\n";
3475 for (sort keys %{$self->{RO}}) {
3476 # next if m/^(ID|RO)$/;
3478 if ($_ eq "CPAN_USERID") {
3479 $extra .= " (".$self->author;
3480 my $email; # old perls!
3481 if ($email = $CPAN::META->instance("CPAN::Author",
3484 $extra .= " <$email>";
3486 $extra .= " <no email>";
3489 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3490 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3493 next unless defined $self->{RO}{$_};
3494 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3496 for (sort keys %$self) {
3497 next if m/^(ID|RO)$/;
3498 if (ref($self->{$_}) eq "ARRAY") {
3499 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3500 } elsif (ref($self->{$_}) eq "HASH") {
3504 join(" ",keys %{$self->{$_}}),
3507 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3513 #-> sub CPAN::InfoObj::author ;
3516 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3519 #-> sub CPAN::InfoObj::dump ;
3522 require Data::Dumper;
3523 print Data::Dumper::Dumper($self);
3526 package CPAN::Author;
3528 #-> sub CPAN::Author::id
3531 my $id = $self->{ID};
3532 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3536 #-> sub CPAN::Author::as_glimpse ;
3540 my $class = ref($self);
3541 $class =~ s/^CPAN:://;
3542 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3550 #-> sub CPAN::Author::fullname ;
3552 shift->{RO}{FULLNAME};
3556 #-> sub CPAN::Author::email ;
3557 sub email { shift->{RO}{EMAIL}; }
3559 #-> sub CPAN::Author::ls ;
3564 # adapted from CPAN::Distribution::verifyMD5 ;
3565 my(@csf); # chksumfile
3566 @csf = $self->id =~ /(.)(.)(.*)/;
3567 $csf[1] = join "", @csf[0,1];
3568 $csf[2] = join "", @csf[1,2];
3570 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3571 unless (grep {$_->[2] eq $csf[1]} @dl) {
3572 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3575 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3576 unless (grep {$_->[2] eq $csf[2]} @dl) {
3577 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3580 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3581 $CPAN::Frontend->myprint(join "", map {
3582 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3583 } sort { $a->[2] cmp $b->[2] } @dl);
3586 # returns an array of arrays, the latter contain (size,mtime,filename)
3587 #-> sub CPAN::Author::dir_listing ;
3590 my $chksumfile = shift;
3591 my $recursive = shift;
3593 File::Spec->catfile($CPAN::Config->{keep_source_where},
3594 "authors", "id", @$chksumfile);
3596 # connect "force" argument with "index_expire".
3598 if (my @stat = stat $lc_want) {
3599 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3601 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3604 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3605 $chksumfile->[-1] .= ".gz";
3606 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3609 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3610 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3616 # adapted from CPAN::Distribution::MD5_check_file ;
3617 my $fh = FileHandle->new;
3619 if (open $fh, $lc_file){
3622 $eval =~ s/\015?\012/\n/g;
3624 my($comp) = Safe->new();
3625 $cksum = $comp->reval($eval);
3627 rename $lc_file, "$lc_file.bad";
3628 Carp::confess($@) if $@;
3631 Carp::carp "Could not open $lc_file for reading";
3634 for $f (sort keys %$cksum) {
3635 if (exists $cksum->{$f}{isdir}) {
3637 my(@dir) = @$chksumfile;
3639 push @dir, $f, "CHECKSUMS";
3641 [$_->[0], $_->[1], "$f/$_->[2]"]
3642 } $self->dir_listing(\@dir,1);
3644 push @result, [ 0, "-", $f ];
3648 ($cksum->{$f}{"size"}||0),
3649 $cksum->{$f}{"mtime"}||"---",
3657 package CPAN::Distribution;
3660 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3664 delete $self->{later};
3667 # CPAN::Distribution::normalize
3670 $s = $self->id unless defined $s;
3674 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3676 return $s if $s =~ m:^N/A|^Contact Author: ;
3677 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3678 $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3679 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3684 #-> sub CPAN::Distribution::color_cmd_tmps ;
3685 sub color_cmd_tmps {
3687 my($depth) = shift || 0;
3688 my($color) = shift || 0;
3689 # a distribution needs to recurse into its prereq_pms
3691 return if exists $self->{incommandcolor}
3692 && $self->{incommandcolor}==$color;
3693 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3694 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3699 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3700 my $prereq_pm = $self->prereq_pm;
3701 if (defined $prereq_pm) {
3702 for my $pre (keys %$prereq_pm) {
3703 my $premo = CPAN::Shell->expand("Module",$pre);
3704 $premo->color_cmd_tmps($depth+1,$color);
3708 delete $self->{sponsored_mods};
3709 delete $self->{badtestcnt};
3711 $self->{incommandcolor} = $color;
3714 #-> sub CPAN::Distribution::as_string ;
3717 $self->containsmods;
3718 $self->SUPER::as_string(@_);
3721 #-> sub CPAN::Distribution::containsmods ;
3724 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3725 my $dist_id = $self->{ID};
3726 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3727 my $mod_file = $mod->cpan_file or next;
3728 my $mod_id = $mod->{ID} or next;
3729 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3731 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3733 keys %{$self->{CONTAINSMODS}};
3736 #-> sub CPAN::Distribution::uptodate ;
3740 foreach $c ($self->containsmods) {
3741 my $obj = CPAN::Shell->expandany($c);
3742 return 0 unless $obj->uptodate;
3747 #-> sub CPAN::Distribution::called_for ;
3750 $self->{CALLED_FOR} = $id if defined $id;
3751 return $self->{CALLED_FOR};
3754 #-> sub CPAN::Distribution::safe_chdir ;
3756 my($self,$todir) = @_;
3757 # we die if we cannot chdir and we are debuggable
3758 Carp::confess("safe_chdir called without todir argument")
3759 unless defined $todir and length $todir;
3761 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3764 my $cwd = CPAN::anycwd();
3765 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3766 qq{to todir[$todir]: $!});
3770 #-> sub CPAN::Distribution::get ;
3775 exists $self->{'build_dir'} and push @e,
3776 "Is already unwrapped into directory $self->{'build_dir'}";
3777 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3779 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3782 # Get the file on local disk
3787 File::Spec->catfile(
3788 $CPAN::Config->{keep_source_where},
3791 split("/",$self->id)
3794 $self->debug("Doing localize") if $CPAN::DEBUG;
3795 unless ($local_file =
3796 CPAN::FTP->localize("authors/id/$self->{ID}",
3799 if ($CPAN::Index::DATE_OF_02) {
3800 $note = "Note: Current database in memory was generated ".
3801 "on $CPAN::Index::DATE_OF_02\n";
3803 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3805 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3806 $self->{localfile} = $local_file;
3807 return if $CPAN::Signal;
3812 if ($CPAN::META->has_inst("Digest::MD5")) {
3813 $self->debug("Digest::MD5 is installed, verifying");
3816 $self->debug("Digest::MD5 is NOT installed");
3818 return if $CPAN::Signal;
3821 # Create a clean room and go there
3823 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3824 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3825 $self->safe_chdir($builddir);
3826 $self->debug("Removing tmp") if $CPAN::DEBUG;
3827 File::Path::rmtree("tmp");
3828 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3830 $self->safe_chdir($sub_wd);
3833 $self->safe_chdir("tmp");
3838 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3839 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3840 $self->untar_me($local_file);
3841 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3842 $self->unzip_me($local_file);
3843 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3844 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3845 $self->pm2dir_me($local_file);
3847 $self->{archived} = "NO";
3848 $self->safe_chdir($sub_wd);
3852 # we are still in the tmp directory!
3853 # Let's check if the package has its own directory.
3854 my $dh = DirHandle->new(File::Spec->curdir)
3855 or Carp::croak("Couldn't opendir .: $!");
3856 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3858 my ($distdir,$packagedir);
3859 if (@readdir == 1 && -d $readdir[0]) {
3860 $distdir = $readdir[0];
3861 $packagedir = File::Spec->catdir($builddir,$distdir);
3862 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3864 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3866 File::Path::rmtree($packagedir);
3867 rename($distdir,$packagedir) or
3868 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3869 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3876 my $userid = $self->cpan_userid;
3878 CPAN->debug("no userid? self[$self]");
3881 my $pragmatic_dir = $userid . '000';
3882 $pragmatic_dir =~ s/\W_//g;
3883 $pragmatic_dir++ while -d "../$pragmatic_dir";
3884 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3885 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3886 File::Path::mkpath($packagedir);
3888 for $f (@readdir) { # is already without "." and ".."
3889 my $to = File::Spec->catdir($packagedir,$f);
3890 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3894 $self->safe_chdir($sub_wd);
3898 $self->{'build_dir'} = $packagedir;
3899 $self->safe_chdir(File::Spec->updir);
3900 File::Path::rmtree("tmp");
3902 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3903 my($mpl_exists) = -f $mpl;
3904 unless ($mpl_exists) {
3905 # NFS has been reported to have racing problems after the
3906 # renaming of a directory in some environments.
3909 my $mpldh = DirHandle->new($packagedir)
3910 or Carp::croak("Couldn't opendir $packagedir: $!");
3911 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3914 unless ($mpl_exists) {
3915 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3919 my($configure) = File::Spec->catfile($packagedir,"Configure");
3920 if (-f $configure) {
3921 # do we have anything to do?
3922 $self->{'configure'} = $configure;
3923 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
3924 $CPAN::Frontend->myprint(qq{
3925 Package comes with a Makefile and without a Makefile.PL.
3926 We\'ll try to build it with that Makefile then.
3928 $self->{writemakefile} = "YES";
3931 my $cf = $self->called_for || "unknown";
3936 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3937 $cf = "unknown" unless length($cf);
3938 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3939 (The test -f "$mpl" returned false.)
3940 Writing one on our own (setting NAME to $cf)\a\n});
3941 $self->{had_no_makefile_pl}++;
3944 # Writing our own Makefile.PL
3946 my $fh = FileHandle->new;
3948 or Carp::croak("Could not open >$mpl: $!");
3950 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3951 # because there was no Makefile.PL supplied.
3952 # Autogenerated on: }.scalar localtime().qq{
3954 use ExtUtils::MakeMaker;
3955 WriteMakefile(NAME => q[$cf]);
3965 # CPAN::Distribution::untar_me ;
3967 my($self,$local_file) = @_;
3968 $self->{archived} = "tar";
3969 if (CPAN::Tarzip->untar($local_file)) {
3970 $self->{unwrapped} = "YES";
3972 $self->{unwrapped} = "NO";
3976 # CPAN::Distribution::unzip_me ;
3978 my($self,$local_file) = @_;
3979 $self->{archived} = "zip";
3980 if (CPAN::Tarzip->unzip($local_file)) {
3981 $self->{unwrapped} = "YES";
3983 $self->{unwrapped} = "NO";
3989 my($self,$local_file) = @_;
3990 $self->{archived} = "pm";
3991 my $to = File::Basename::basename($local_file);
3992 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3993 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3994 $self->{unwrapped} = "YES";
3996 $self->{unwrapped} = "NO";
4000 #-> sub CPAN::Distribution::new ;
4002 my($class,%att) = @_;
4004 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4006 my $this = { %att };
4007 return bless $this, $class;
4010 #-> sub CPAN::Distribution::look ;
4014 if ($^O eq 'MacOS') {
4015 $self->Mac::BuildTools::look;
4019 if ( $CPAN::Config->{'shell'} ) {
4020 $CPAN::Frontend->myprint(qq{
4021 Trying to open a subshell in the build directory...
4024 $CPAN::Frontend->myprint(qq{
4025 Your configuration does not define a value for subshells.
4026 Please define it with "o conf shell <your shell>"
4030 my $dist = $self->id;
4032 unless ($dir = $self->dir) {
4035 unless ($dir ||= $self->dir) {
4036 $CPAN::Frontend->mywarn(qq{
4037 Could not determine which directory to use for looking at $dist.
4041 my $pwd = CPAN::anycwd();
4042 $self->safe_chdir($dir);
4043 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4044 system($CPAN::Config->{'shell'}) == 0
4045 or $CPAN::Frontend->mydie("Subprocess shell error");
4046 $self->safe_chdir($pwd);
4049 # CPAN::Distribution::cvs_import ;
4053 my $dir = $self->dir;
4055 my $package = $self->called_for;
4056 my $module = $CPAN::META->instance('CPAN::Module', $package);
4057 my $version = $module->cpan_version;
4059 my $userid = $self->cpan_userid;
4061 my $cvs_dir = (split '/', $dir)[-1];
4062 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4064 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4066 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4067 if ($cvs_site_perl) {
4068 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4070 my $cvs_log = qq{"imported $package $version sources"};
4071 $version =~ s/\./_/g;
4072 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4073 "$cvs_dir", $userid, "v$version");
4075 my $pwd = CPAN::anycwd();
4076 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4078 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4080 $CPAN::Frontend->myprint(qq{@cmd\n});
4081 system(@cmd) == 0 or
4082 $CPAN::Frontend->mydie("cvs import failed");
4083 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4086 #-> sub CPAN::Distribution::readme ;
4089 my($dist) = $self->id;
4090 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4091 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4094 File::Spec->catfile(
4095 $CPAN::Config->{keep_source_where},
4098 split("/","$sans.readme"),
4100 $self->debug("Doing localize") if $CPAN::DEBUG;
4101 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4103 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4105 if ($^O eq 'MacOS') {
4106 Mac::BuildTools::launch_file($local_file);
4110 my $fh_pager = FileHandle->new;
4111 local($SIG{PIPE}) = "IGNORE";
4112 $fh_pager->open("|$CPAN::Config->{'pager'}")
4113 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4114 my $fh_readme = FileHandle->new;
4115 $fh_readme->open($local_file)
4116 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4117 $CPAN::Frontend->myprint(qq{
4120 with pager "$CPAN::Config->{'pager'}"
4123 $fh_pager->print(<$fh_readme>);
4126 #-> sub CPAN::Distribution::verifyMD5 ;
4131 $self->{MD5_STATUS} ||= "";
4132 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4133 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4135 my($lc_want,$lc_file,@local,$basename);
4136 @local = split("/",$self->id);
4138 push @local, "CHECKSUMS";
4140 File::Spec->catfile($CPAN::Config->{keep_source_where},
4141 "authors", "id", @local);
4146 $self->MD5_check_file($lc_want)
4148 return $self->{MD5_STATUS} = "OK";
4150 $lc_file = CPAN::FTP->localize("authors/id/@local",
4153 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4154 $local[-1] .= ".gz";
4155 $lc_file = CPAN::FTP->localize("authors/id/@local",
4158 $lc_file =~ s/\.gz(?!\n)\Z//;
4159 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4164 $self->MD5_check_file($lc_file);
4167 #-> sub CPAN::Distribution::MD5_check_file ;
4168 sub MD5_check_file {
4169 my($self,$chk_file) = @_;
4170 my($cksum,$file,$basename);
4171 $file = $self->{localfile};
4172 $basename = File::Basename::basename($file);
4173 my $fh = FileHandle->new;
4174 if (open $fh, $chk_file){
4177 $eval =~ s/\015?\012/\n/g;
4179 my($comp) = Safe->new();
4180 $cksum = $comp->reval($eval);
4182 rename $chk_file, "$chk_file.bad";
4183 Carp::confess($@) if $@;
4186 Carp::carp "Could not open $chk_file for reading";
4189 if (exists $cksum->{$basename}{md5}) {
4190 $self->debug("Found checksum for $basename:" .
4191 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4195 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4197 $fh = CPAN::Tarzip->TIEHANDLE($file);
4200 # had to inline it, when I tied it, the tiedness got lost on
4201 # the call to eq_MD5. (Jan 1998)
4202 my $md5 = Digest::MD5->new;
4205 while ($fh->READ($ref, 4096) > 0){
4208 my $hexdigest = $md5->hexdigest;
4209 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4213 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4214 return $self->{MD5_STATUS} = "OK";
4216 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4217 qq{distribution file. }.
4218 qq{Please investigate.\n\n}.
4220 $CPAN::META->instance(
4225 my $wrap = qq{I\'d recommend removing $file. Its MD5
4226 checksum is incorrect. Maybe you have configured your 'urllist' with
4227 a bad URL. Please check this array with 'o conf urllist', and
4230 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4232 # former versions just returned here but this seems a
4233 # serious threat that deserves a die
4235 # $CPAN::Frontend->myprint("\n\n");
4239 # close $fh if fileno($fh);
4241 $self->{MD5_STATUS} ||= "";
4242 if ($self->{MD5_STATUS} eq "NIL") {
4243 $CPAN::Frontend->mywarn(qq{
4244 Warning: No md5 checksum for $basename in $chk_file.
4246 The cause for this may be that the file is very new and the checksum
4247 has not yet been calculated, but it may also be that something is
4248 going awry right now.
4250 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4251 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4253 $self->{MD5_STATUS} = "NIL";
4258 #-> sub CPAN::Distribution::eq_MD5 ;
4260 my($self,$fh,$expectMD5) = @_;
4261 my $md5 = Digest::MD5->new;
4263 while (read($fh, $data, 4096)){
4266 # $md5->addfile($fh);
4267 my $hexdigest = $md5->hexdigest;
4268 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4269 $hexdigest eq $expectMD5;
4272 #-> sub CPAN::Distribution::force ;
4274 # Both modules and distributions know if "force" is in effect by
4275 # autoinspection, not by inspecting a global variable. One of the
4276 # reason why this was chosen to work that way was the treatment of
4277 # dependencies. They should not autpomatically inherit the force
4278 # status. But this has the downside that ^C and die() will return to
4279 # the prompt but will not be able to reset the force_update
4280 # attributes. We try to correct for it currently in the read_metadata
4281 # routine, and immediately before we check for a Signal. I hope this
4282 # works out in one of v1.57_53ff
4285 my($self, $method) = @_;
4287 MD5_STATUS archived build_dir localfile make install unwrapped
4290 delete $self->{$att};
4292 if ($method && $method eq "install") {
4293 $self->{"force_update"}++; # name should probably have been force_install
4297 #-> sub CPAN::Distribution::unforce ;
4300 delete $self->{'force_update'};
4303 #-> sub CPAN::Distribution::isa_perl ;
4306 my $file = File::Basename::basename($self->id);
4307 if ($file =~ m{ ^ perl
4320 } elsif ($self->cpan_comment
4322 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4327 #-> sub CPAN::Distribution::perl ;
4330 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4331 my $pwd = CPAN::anycwd();
4332 my $candidate = File::Spec->catfile($pwd,$^X);
4333 $perl ||= $candidate if MM->maybe_command($candidate);
4335 my ($component,$perl_name);
4336 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4337 PATH_COMPONENT: foreach $component (File::Spec->path(),
4338 $Config::Config{'binexp'}) {
4339 next unless defined($component) && $component;
4340 my($abs) = File::Spec->catfile($component,$perl_name);
4341 if (MM->maybe_command($abs)) {
4351 #-> sub CPAN::Distribution::make ;
4354 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4355 # Emergency brake if they said install Pippi and get newest perl
4356 if ($self->isa_perl) {
4358 $self->called_for ne $self->id &&
4359 ! $self->{force_update}
4361 # if we die here, we break bundles
4362 $CPAN::Frontend->mywarn(sprintf qq{
4363 The most recent version "%s" of the module "%s"
4364 comes with the current version of perl (%s).
4365 I\'ll build that only if you ask for something like
4370 $CPAN::META->instance(
4384 $self->{archived} eq "NO" and push @e,
4385 "Is neither a tar nor a zip archive.";
4387 $self->{unwrapped} eq "NO" and push @e,
4388 "had problems unarchiving. Please build manually";
4390 exists $self->{writemakefile} &&
4391 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4392 $1 || "Had some problem writing Makefile";
4394 defined $self->{'make'} and push @e,
4395 "Has already been processed within this session";
4397 exists $self->{later} and length($self->{later}) and
4398 push @e, $self->{later};
4400 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4402 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4403 my $builddir = $self->dir;
4404 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4405 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4407 if ($^O eq 'MacOS') {
4408 Mac::BuildTools::make($self);
4413 if ($self->{'configure'}) {
4414 $system = $self->{'configure'};
4416 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4418 # This needs a handler that can be turned on or off:
4419 # $switch = "-MExtUtils::MakeMaker ".
4420 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4422 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4424 unless (exists $self->{writemakefile}) {
4425 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4428 if ($CPAN::Config->{inactivity_timeout}) {
4430 alarm $CPAN::Config->{inactivity_timeout};
4431 local $SIG{CHLD}; # = sub { wait };
4432 if (defined($pid = fork)) {
4437 # note, this exec isn't necessary if
4438 # inactivity_timeout is 0. On the Mac I'd
4439 # suggest, we set it always to 0.
4443 $CPAN::Frontend->myprint("Cannot fork: $!");
4451 $CPAN::Frontend->myprint($@);
4452 $self->{writemakefile} = "NO $@";
4457 $ret = system($system);
4459 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4463 if (-f "Makefile") {
4464 $self->{writemakefile} = "YES";
4465 delete $self->{make_clean}; # if cleaned before, enable next
4467 $self->{writemakefile} =
4468 qq{NO Makefile.PL refused to write a Makefile.};
4469 # It's probably worth it to record the reason, so let's retry
4471 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4472 # $self->{writemakefile} .= <$fh>;
4476 delete $self->{force_update};
4479 if (my @prereq = $self->unsat_prereq){
4480 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4482 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4483 if (system($system) == 0) {
4484 $CPAN::Frontend->myprint(" $system -- OK\n");
4485 $self->{'make'} = "YES";
4487 $self->{writemakefile} ||= "YES";
4488 $self->{'make'} = "NO";
4489 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4493 sub follow_prereqs {
4497 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4498 "during [$id] -----\n");
4500 for my $p (@prereq) {
4501 $CPAN::Frontend->myprint(" $p\n");
4504 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4506 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4507 require ExtUtils::MakeMaker;
4508 my $answer = ExtUtils::MakeMaker::prompt(
4509 "Shall I follow them and prepend them to the queue
4510 of modules we are processing right now?", "yes");
4511 $follow = $answer =~ /^\s*y/i;
4515 myprint(" Ignoring dependencies on modules @prereq\n");
4518 # color them as dirty
4519 for my $p (@prereq) {
4520 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4522 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4523 $self->{later} = "Delayed until after prerequisites";
4524 return 1; # signal success to the queuerunner
4528 #-> sub CPAN::Distribution::unsat_prereq ;
4531 my $prereq_pm = $self->prereq_pm or return;
4533 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4534 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4535 # we were too demanding:
4536 next if $nmo->uptodate;
4538 # if they have not specified a version, we accept any installed one
4539 if (not defined $need_version or
4540 $need_version == 0 or
4541 $need_version eq "undef") {
4542 next if defined $nmo->inst_file;
4545 # We only want to install prereqs if either they're not installed
4546 # or if the installed version is too old. We cannot omit this
4547 # check, because if 'force' is in effect, nobody else will check.
4551 defined $nmo->inst_file &&
4552 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4554 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4558 CPAN::Version->readable($need_version)
4564 if ($self->{sponsored_mods}{$need_module}++){
4565 # We have already sponsored it and for some reason it's still
4566 # not available. So we do nothing. Or what should we do?
4567 # if we push it again, we have a potential infinite loop
4570 push @need, $need_module;
4575 #-> sub CPAN::Distribution::prereq_pm ;
4578 return $self->{prereq_pm} if
4579 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4580 return unless $self->{writemakefile}; # no need to have succeeded
4581 # but we must have run it
4582 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4583 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4588 $fh = FileHandle->new("<$makefile\0")) {
4592 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4594 last if /MakeMaker post_initialize section/;
4596 \s+PREREQ_PM\s+=>\s+(.+)
4599 # warn "Found prereq expr[$p]";
4601 # Regexp modified by A.Speer to remember actual version of file
4602 # PREREQ_PM hash key wants, then add to
4603 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4604 # In case a prereq is mentioned twice, complain.
4605 if ( defined $p{$1} ) {
4606 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4613 $self->{prereq_pm_detected}++;
4614 return $self->{prereq_pm} = \%p;
4617 #-> sub CPAN::Distribution::test ;
4622 delete $self->{force_update};
4625 $CPAN::Frontend->myprint("Running make test\n");
4626 if (my @prereq = $self->unsat_prereq){
4627 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4631 exists $self->{make} or exists $self->{later} or push @e,
4632 "Make had some problems, maybe interrupted? Won't test";
4634 exists $self->{'make'} and
4635 $self->{'make'} eq 'NO' and
4636 push @e, "Can't test without successful make";
4638 exists $self->{build_dir} or push @e, "Has no own directory";
4639 $self->{badtestcnt} ||= 0;
4640 $self->{badtestcnt} > 0 and
4641 push @e, "Won't repeat unsuccessful test during this command";
4643 exists $self->{later} and length($self->{later}) and
4644 push @e, $self->{later};
4646 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4648 chdir $self->{'build_dir'} or
4649 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4650 $self->debug("Changed directory to $self->{'build_dir'}")
4653 if ($^O eq 'MacOS') {
4654 Mac::BuildTools::make_test($self);
4658 local $ENV{PERL5LIB} = $ENV{PERL5LIB};
4659 $CPAN::META->set_perl5lib;
4660 my $system = join " ", $CPAN::Config->{'make'}, "test";
4661 if (system($system) == 0) {
4662 $CPAN::Frontend->myprint(" $system -- OK\n");
4663 $CPAN::META->is_tested($self->{'build_dir'});
4664 $self->{make_test} = "YES";
4666 $self->{make_test} = "NO";
4667 $self->{badtestcnt}++;
4668 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4672 #-> sub CPAN::Distribution::clean ;
4675 $CPAN::Frontend->myprint("Running make clean\n");
4678 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4679 push @e, "make clean already called once";
4680 exists $self->{build_dir} or push @e, "Has no own directory";
4681 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4683 chdir $self->{'build_dir'} or
4684 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4685 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4687 if ($^O eq 'MacOS') {
4688 Mac::BuildTools::make_clean($self);
4692 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4693 if (system($system) == 0) {
4694 $CPAN::Frontend->myprint(" $system -- OK\n");
4698 # Jost Krieger pointed out that this "force" was wrong because
4699 # it has the effect that the next "install" on this distribution
4700 # will untar everything again. Instead we should bring the
4701 # object's state back to where it is after untarring.
4703 delete $self->{force_update};
4704 delete $self->{install};
4705 delete $self->{writemakefile};
4706 delete $self->{make};
4707 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4708 $self->{make_clean} = "YES";
4711 # Hmmm, what to do if make clean failed?
4713 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4715 make clean did not succeed, marking directory as unusable for further work.
4717 $self->force("make"); # so that this directory won't be used again
4722 #-> sub CPAN::Distribution::install ;
4727 delete $self->{force_update};
4730 $CPAN::Frontend->myprint("Running make install\n");
4733 exists $self->{build_dir} or push @e, "Has no own directory";
4735 exists $self->{make} or exists $self->{later} or push @e,
4736 "Make had some problems, maybe interrupted? Won't install";
4738 exists $self->{'make'} and
4739 $self->{'make'} eq 'NO' and
4740 push @e, "make had returned bad status, install seems impossible";
4742 push @e, "make test had returned bad status, ".
4743 "won't install without force"
4744 if exists $self->{'make_test'} and
4745 $self->{'make_test'} eq 'NO' and
4746 ! $self->{'force_update'};
4748 exists $self->{'install'} and push @e,
4749 $self->{'install'} eq "YES" ?
4750 "Already done" : "Already tried without success";
4752 exists $self->{later} and length($self->{later}) and
4753 push @e, $self->{later};
4755 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4757 chdir $self->{'build_dir'} or
4758 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4759 $self->debug("Changed directory to $self->{'build_dir'}")
4762 if ($^O eq 'MacOS') {
4763 Mac::BuildTools::make_install($self);
4767 my $system = join(" ", $CPAN::Config->{'make'},
4768 "install", $CPAN::Config->{make_install_arg});
4769 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4770 my($pipe) = FileHandle->new("$system $stderr |");
4773 $CPAN::Frontend->myprint($_);
4778 $CPAN::Frontend->myprint(" $system -- OK\n");
4779 $CPAN::META->is_installed($self->{'build_dir'});
4780 return $self->{'install'} = "YES";
4782 $self->{'install'} = "NO";
4783 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4784 if ($makeout =~ /permission/s && $> > 0) {
4785 $CPAN::Frontend->myprint(qq{ You may have to su }.
4786 qq{to root to install the package\n});
4789 delete $self->{force_update};
4792 #-> sub CPAN::Distribution::dir ;
4794 shift->{'build_dir'};
4797 package CPAN::Bundle;
4801 $CPAN::Frontend->myprint(
4802 qq{ look() commmand on bundles not}.
4803 qq{ implemented (What should it do?)}
4809 delete $self->{later};
4810 for my $c ( $self->contains ) {
4811 my $obj = CPAN::Shell->expandany($c) or next;
4816 #-> sub CPAN::Bundle::color_cmd_tmps ;
4817 sub color_cmd_tmps {
4819 my($depth) = shift || 0;
4820 my($color) = shift || 0;
4821 # a module needs to recurse to its cpan_file, a distribution needs
4822 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4824 return if exists $self->{incommandcolor}
4825 && $self->{incommandcolor}==$color;
4826 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4827 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4832 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4834 for my $c ( $self->contains ) {
4835 my $obj = CPAN::Shell->expandany($c) or next;
4836 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4837 $obj->color_cmd_tmps($depth+1,$color);
4840 delete $self->{badtestcnt};
4842 $self->{incommandcolor} = $color;
4845 #-> sub CPAN::Bundle::as_string ;
4849 # following line must be "=", not "||=" because we have a moving target
4850 $self->{INST_VERSION} = $self->inst_version;
4851 return $self->SUPER::as_string;
4854 #-> sub CPAN::Bundle::contains ;
4857 my($inst_file) = $self->inst_file || "";
4858 my($id) = $self->id;
4859 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4860 unless ($inst_file) {
4861 # Try to get at it in the cpan directory
4862 $self->debug("no inst_file") if $CPAN::DEBUG;
4864 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4865 $cpan_file = $self->cpan_file;
4866 if ($cpan_file eq "N/A") {
4867 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4868 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4870 my $dist = $CPAN::META->instance('CPAN::Distribution',
4873 $self->debug($dist->as_string) if $CPAN::DEBUG;
4874 my($todir) = $CPAN::Config->{'cpan_home'};
4875 my(@me,$from,$to,$me);
4876 @me = split /::/, $self->id;
4878 $me = File::Spec->catfile(@me);
4879 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4880 $to = File::Spec->catfile($todir,$me);
4881 File::Path::mkpath(File::Basename::dirname($to));
4882 File::Copy::copy($from, $to)
4883 or Carp::confess("Couldn't copy $from to $to: $!");
4887 my $fh = FileHandle->new;
4889 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4891 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4893 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4894 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4895 next unless $in_cont;
4900 push @result, (split " ", $_, 2)[0];
4903 delete $self->{STATUS};
4904 $self->{CONTAINS} = \@result;
4905 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4907 $CPAN::Frontend->mywarn(qq{
4908 The bundle file "$inst_file" may be a broken
4909 bundlefile. It seems not to contain any bundle definition.
4910 Please check the file and if it is bogus, please delete it.
4911 Sorry for the inconvenience.
4917 #-> sub CPAN::Bundle::find_bundle_file
4918 sub find_bundle_file {
4919 my($self,$where,$what) = @_;
4920 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4921 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4922 ### my $bu = File::Spec->catfile($where,$what);
4923 ### return $bu if -f $bu;
4924 my $manifest = File::Spec->catfile($where,"MANIFEST");
4925 unless (-f $manifest) {
4926 require ExtUtils::Manifest;
4927 my $cwd = CPAN::anycwd();
4928 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4929 ExtUtils::Manifest::mkmanifest();
4930 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4932 my $fh = FileHandle->new($manifest)
4933 or Carp::croak("Couldn't open $manifest: $!");
4936 if ($^O eq 'MacOS') {
4939 $what2 =~ s/:Bundle://;
4942 $what2 =~ s|Bundle[/\\]||;
4947 my($file) = /(\S+)/;
4948 if ($file =~ m|\Q$what\E$|) {
4950 # return File::Spec->catfile($where,$bu); # bad
4953 # retry if she managed to
4954 # have no Bundle directory
4955 $bu = $file if $file =~ m|\Q$what2\E$|;
4957 $bu =~ tr|/|:| if $^O eq 'MacOS';
4958 return File::Spec->catfile($where, $bu) if $bu;
4959 Carp::croak("Couldn't find a Bundle file in $where");
4962 # needs to work quite differently from Module::inst_file because of
4963 # cpan_home/Bundle/ directory and the possibility that we have
4964 # shadowing effect. As it makes no sense to take the first in @INC for
4965 # Bundles, we parse them all for $VERSION and take the newest.
4967 #-> sub CPAN::Bundle::inst_file ;
4972 @me = split /::/, $self->id;
4975 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4976 my $bfile = File::Spec->catfile($incdir, @me);
4977 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4978 next unless -f $bfile;
4979 my $foundv = MM->parse_version($bfile);
4980 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4981 $self->{INST_FILE} = $bfile;
4982 $self->{INST_VERSION} = $bestv = $foundv;
4988 #-> sub CPAN::Bundle::inst_version ;
4991 $self->inst_file; # finds INST_VERSION as side effect
4992 $self->{INST_VERSION};
4995 #-> sub CPAN::Bundle::rematein ;
4997 my($self,$meth) = @_;
4998 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4999 my($id) = $self->id;
5000 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5001 unless $self->inst_file || $self->cpan_file;
5003 for $s ($self->contains) {
5004 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5005 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5006 if ($type eq 'CPAN::Distribution') {
5007 $CPAN::Frontend->mywarn(qq{
5008 The Bundle }.$self->id.qq{ contains
5009 explicitly a file $s.
5013 # possibly noisy action:
5014 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5015 my $obj = $CPAN::META->instance($type,$s);
5017 if ($obj->isa(CPAN::Bundle)
5019 exists $obj->{install_failed}
5021 ref($obj->{install_failed}) eq "HASH"
5023 for (keys %{$obj->{install_failed}}) {
5024 $self->{install_failed}{$_} = undef; # propagate faiure up
5027 $fail{$s} = 1; # the bundle itself may have succeeded but
5032 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5033 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5035 delete $self->{install_failed}{$s};
5042 # recap with less noise
5043 if ( $meth eq "install" ) {
5046 my $raw = sprintf(qq{Bundle summary:
5047 The following items in bundle %s had installation problems:},
5050 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5051 $CPAN::Frontend->myprint("\n");
5054 for $s ($self->contains) {
5056 $paragraph .= "$s ";
5057 $self->{install_failed}{$s} = undef;
5058 $reported{$s} = undef;
5061 my $report_propagated;
5062 for $s (sort keys %{$self->{install_failed}}) {
5063 next if exists $reported{$s};
5064 $paragraph .= "and the following items had problems
5065 during recursive bundle calls: " unless $report_propagated++;
5066 $paragraph .= "$s ";
5068 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5069 $CPAN::Frontend->myprint("\n");
5071 $self->{'install'} = 'YES';
5076 #sub CPAN::Bundle::xs_file
5078 # If a bundle contains another that contains an xs_file we have
5079 # here, we just don't bother I suppose
5083 #-> sub CPAN::Bundle::force ;
5084 sub force { shift->rematein('force',@_); }
5085 #-> sub CPAN::Bundle::get ;
5086 sub get { shift->rematein('get',@_); }
5087 #-> sub CPAN::Bundle::make ;
5088 sub make { shift->rematein('make',@_); }
5089 #-> sub CPAN::Bundle::test ;
5092 $self->{badtestcnt} ||= 0;
5093 $self->rematein('test',@_);
5095 #-> sub CPAN::Bundle::install ;
5098 $self->rematein('install',@_);
5100 #-> sub CPAN::Bundle::clean ;
5101 sub clean { shift->rematein('clean',@_); }
5103 #-> sub CPAN::Bundle::uptodate ;
5106 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5108 foreach $c ($self->contains) {
5109 my $obj = CPAN::Shell->expandany($c);
5110 return 0 unless $obj->uptodate;
5115 #-> sub CPAN::Bundle::readme ;
5118 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5119 No File found for bundle } . $self->id . qq{\n}), return;
5120 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5121 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5124 package CPAN::Module;
5127 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5130 return unless exists $self->{RO}; # should never happen
5131 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5133 sub description { shift->{RO}{description} }
5137 delete $self->{later};
5138 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5143 #-> sub CPAN::Module::color_cmd_tmps ;
5144 sub color_cmd_tmps {
5146 my($depth) = shift || 0;
5147 my($color) = shift || 0;
5148 # a module needs to recurse to its cpan_file
5150 return if exists $self->{incommandcolor}
5151 && $self->{incommandcolor}==$color;
5152 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5153 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5158 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5160 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5161 $dist->color_cmd_tmps($depth+1,$color);
5164 delete $self->{badtestcnt};
5166 $self->{incommandcolor} = $color;
5169 #-> sub CPAN::Module::as_glimpse ;
5173 my $class = ref($self);
5174 $class =~ s/^CPAN:://;
5178 $CPAN::Shell::COLOR_REGISTERED
5180 $CPAN::META->has_inst("Term::ANSIColor")
5182 $self->{RO}{description}
5184 $color_on = Term::ANSIColor::color("green");
5185 $color_off = Term::ANSIColor::color("reset");
5187 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5196 #-> sub CPAN::Module::as_string ;
5200 CPAN->debug($self) if $CPAN::DEBUG;
5201 my $class = ref($self);
5202 $class =~ s/^CPAN:://;
5204 push @m, $class, " id = $self->{ID}\n";
5205 my $sprintf = " %-12s %s\n";
5206 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5207 if $self->description;
5208 my $sprintf2 = " %-12s %s (%s)\n";
5210 if ($userid = $self->cpan_userid || $self->userid){
5212 if ($author = CPAN::Shell->expand('Author',$userid)) {
5215 if ($m = $author->email) {
5222 $author->fullname . $email
5226 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5227 if $self->cpan_version;
5228 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5229 if $self->cpan_file;
5230 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5231 my(%statd,%stats,%statl,%stati);
5232 @statd{qw,? i c a b R M S,} = qw,unknown idea
5233 pre-alpha alpha beta released mature standard,;
5234 @stats{qw,? m d u n,} = qw,unknown mailing-list
5235 developer comp.lang.perl.* none,;
5236 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5237 @stati{qw,? f r O h,} = qw,unknown functions
5238 references+ties object-oriented hybrid,;
5239 $statd{' '} = 'unknown';
5240 $stats{' '} = 'unknown';
5241 $statl{' '} = 'unknown';
5242 $stati{' '} = 'unknown';
5250 $statd{$self->{RO}{statd}},
5251 $stats{$self->{RO}{stats}},
5252 $statl{$self->{RO}{statl}},
5253 $stati{$self->{RO}{stati}}
5254 ) if $self->{RO}{statd};
5255 my $local_file = $self->inst_file;
5256 unless ($self->{MANPAGE}) {
5258 $self->{MANPAGE} = $self->manpage_headline($local_file);
5260 # If we have already untarred it, we should look there
5261 my $dist = $CPAN::META->instance('CPAN::Distribution',
5263 # warn "dist[$dist]";
5264 # mff=manifest file; mfh=manifest handle
5269 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5271 $mfh = FileHandle->new($mff)
5273 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5274 my $lfre = $self->id; # local file RE
5277 my($lfl); # local file file
5279 my(@mflines) = <$mfh>;
5284 while (length($lfre)>5 and !$lfl) {
5285 ($lfl) = grep /$lfre/, @mflines;
5286 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5289 $lfl =~ s/\s.*//; # remove comments
5290 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5291 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5292 # warn "lfl_abs[$lfl_abs]";
5294 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5300 for $item (qw/MANPAGE/) {
5301 push @m, sprintf($sprintf, $item, $self->{$item})
5302 if exists $self->{$item};
5304 for $item (qw/CONTAINS/) {
5305 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5306 if exists $self->{$item} && @{$self->{$item}};
5308 push @m, sprintf($sprintf, 'INST_FILE',
5309 $local_file || "(not installed)");
5310 push @m, sprintf($sprintf, 'INST_VERSION',
5311 $self->inst_version) if $local_file;
5315 sub manpage_headline {
5316 my($self,$local_file) = @_;
5317 my(@local_file) = $local_file;
5318 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5319 push @local_file, $local_file;
5321 for $locf (@local_file) {
5322 next unless -f $locf;
5323 my $fh = FileHandle->new($locf)
5324 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5328 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5329 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5342 #-> sub CPAN::Module::cpan_file ;
5343 # Note: also inherited by CPAN::Bundle
5346 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5347 unless (defined $self->{RO}{CPAN_FILE}) {
5348 CPAN::Index->reload;
5350 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5351 return $self->{RO}{CPAN_FILE};
5353 my $userid = $self->userid;
5355 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5356 my $author = $CPAN::META->instance("CPAN::Author",
5358 my $fullname = $author->fullname;
5359 my $email = $author->email;
5360 unless (defined $fullname && defined $email) {
5361 return sprintf("Contact Author %s",
5365 return "Contact Author $fullname <$email>";
5367 return "UserID $userid";
5375 #-> sub CPAN::Module::cpan_version ;
5379 $self->{RO}{CPAN_VERSION} = 'undef'
5380 unless defined $self->{RO}{CPAN_VERSION};
5381 # I believe this is always a bug in the index and should be reported
5382 # as such, but usually I find out such an error and do not want to
5383 # provoke too many bugreports
5385 $self->{RO}{CPAN_VERSION};
5388 #-> sub CPAN::Module::force ;
5391 $self->{'force_update'}++;
5394 #-> sub CPAN::Module::rematein ;
5396 my($self,$meth) = @_;
5397 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5400 my $cpan_file = $self->cpan_file;
5401 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5402 $CPAN::Frontend->mywarn(sprintf qq{
5403 The module %s isn\'t available on CPAN.
5405 Either the module has not yet been uploaded to CPAN, or it is
5406 temporary unavailable. Please contact the author to find out
5407 more about the status. Try 'i %s'.
5414 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5415 $pack->called_for($self->id);
5416 $pack->force($meth) if exists $self->{'force_update'};
5418 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5419 delete $self->{'force_update'};
5422 #-> sub CPAN::Module::readme ;
5423 sub readme { shift->rematein('readme') }
5424 #-> sub CPAN::Module::look ;
5425 sub look { shift->rematein('look') }
5426 #-> sub CPAN::Module::cvs_import ;
5427 sub cvs_import { shift->rematein('cvs_import') }
5428 #-> sub CPAN::Module::get ;
5429 sub get { shift->rematein('get',@_); }
5430 #-> sub CPAN::Module::make ;
5433 $self->rematein('make');
5435 #-> sub CPAN::Module::test ;
5438 $self->{badtestcnt} ||= 0;
5439 $self->rematein('test',@_);
5441 #-> sub CPAN::Module::uptodate ;
5444 my($latest) = $self->cpan_version;
5446 my($inst_file) = $self->inst_file;
5448 if (defined $inst_file) {
5449 $have = $self->inst_version;
5454 ! CPAN::Version->vgt($latest, $have)
5456 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5457 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5462 #-> sub CPAN::Module::install ;
5468 not exists $self->{'force_update'}
5470 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5474 $self->rematein('install') if $doit;
5476 #-> sub CPAN::Module::clean ;
5477 sub clean { shift->rematein('clean') }
5479 #-> sub CPAN::Module::inst_file ;
5483 @packpath = split /::/, $self->{ID};
5484 $packpath[-1] .= ".pm";
5485 foreach $dir (@INC) {
5486 my $pmfile = File::Spec->catfile($dir,@packpath);
5494 #-> sub CPAN::Module::xs_file ;
5498 @packpath = split /::/, $self->{ID};
5499 push @packpath, $packpath[-1];
5500 $packpath[-1] .= "." . $Config::Config{'dlext'};
5501 foreach $dir (@INC) {
5502 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5510 #-> sub CPAN::Module::inst_version ;
5513 my $parsefile = $self->inst_file or return;
5514 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5517 # there was a bug in 5.6.0 that let lots of unini warnings out of
5518 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5519 # the following workaround after 5.6.1 is out.
5520 local($SIG{__WARN__}) = sub { my $w = shift;
5521 return if $w =~ /uninitialized/i;
5525 $have = MM->parse_version($parsefile) || "undef";
5526 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5527 $have =~ s/ $//; # trailing whitespace happens all the time
5529 # My thoughts about why %vd processing should happen here
5531 # Alt1 maintain it as string with leading v:
5532 # read index files do nothing
5533 # compare it use utility for compare
5534 # print it do nothing
5536 # Alt2 maintain it as what it is
5537 # read index files convert
5538 # compare it use utility because there's still a ">" vs "gt" issue
5539 # print it use CPAN::Version for print
5541 # Seems cleaner to hold it in memory as a string starting with a "v"
5543 # If the author of this module made a mistake and wrote a quoted
5544 # "v1.13" instead of v1.13, we simply leave it at that with the
5545 # effect that *we* will treat it like a v-tring while the rest of
5546 # perl won't. Seems sensible when we consider that any action we
5547 # could take now would just add complexity.
5549 $have = CPAN::Version->readable($have);
5551 $have =~ s/\s*//g; # stringify to float around floating point issues
5552 $have; # no stringify needed, \s* above matches always
5555 package CPAN::Tarzip;
5557 # CPAN::Tarzip::gzip
5559 my($class,$read,$write) = @_;
5560 if ($CPAN::META->has_inst("Compress::Zlib")) {
5562 $fhw = FileHandle->new($read)
5563 or $CPAN::Frontend->mydie("Could not open $read: $!");
5564 my $gz = Compress::Zlib::gzopen($write, "wb")
5565 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5566 $gz->gzwrite($buffer)
5567 while read($fhw,$buffer,4096) > 0 ;
5572 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5577 # CPAN::Tarzip::gunzip
5579 my($class,$read,$write) = @_;
5580 if ($CPAN::META->has_inst("Compress::Zlib")) {
5582 $fhw = FileHandle->new(">$write")
5583 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5584 my $gz = Compress::Zlib::gzopen($read, "rb")
5585 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5586 $fhw->print($buffer)
5587 while $gz->gzread($buffer) > 0 ;
5588 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5589 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5594 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5599 # CPAN::Tarzip::gtest
5601 my($class,$read) = @_;
5602 # After I had reread the documentation in zlib.h, I discovered that
5603 # uncompressed files do not lead to an gzerror (anymore?).
5604 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5607 my $gz = Compress::Zlib::gzopen($read, "rb")
5608 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5610 $Compress::Zlib::gzerrno));
5611 while ($gz->gzread($buffer) > 0 ){
5612 $len += length($buffer);
5615 my $err = $gz->gzerror;
5616 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5617 if ($len == -s $read){
5619 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5622 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5625 return system("$CPAN::Config->{gzip} -dt $read")==0;
5630 # CPAN::Tarzip::TIEHANDLE
5632 my($class,$file) = @_;
5634 $class->debug("file[$file]");
5635 if ($CPAN::META->has_inst("Compress::Zlib")) {
5636 my $gz = Compress::Zlib::gzopen($file,"rb") or
5637 die "Could not gzopen $file";
5638 $ret = bless {GZ => $gz}, $class;
5640 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5641 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5643 $ret = bless {FH => $fh}, $class;
5649 # CPAN::Tarzip::READLINE
5652 if (exists $self->{GZ}) {
5653 my $gz = $self->{GZ};
5654 my($line,$bytesread);
5655 $bytesread = $gz->gzreadline($line);
5656 return undef if $bytesread <= 0;
5659 my $fh = $self->{FH};
5660 return scalar <$fh>;
5665 # CPAN::Tarzip::READ
5667 my($self,$ref,$length,$offset) = @_;
5668 die "read with offset not implemented" if defined $offset;
5669 if (exists $self->{GZ}) {
5670 my $gz = $self->{GZ};
5671 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5674 my $fh = $self->{FH};
5675 return read($fh,$$ref,$length);
5680 # CPAN::Tarzip::DESTROY
5683 if (exists $self->{GZ}) {
5684 my $gz = $self->{GZ};
5685 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5686 # to be undef ever. AK, 2000-09
5688 my $fh = $self->{FH};
5689 $fh->close if defined $fh;
5695 # CPAN::Tarzip::untar
5697 my($class,$file) = @_;
5700 if (0) { # makes changing order easier
5701 } elsif ($BUGHUNTING){
5703 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5705 MM->maybe_command($CPAN::Config->{'tar'})) {
5706 # should be default until Archive::Tar is fixed
5709 $CPAN::META->has_inst("Archive::Tar")
5711 $CPAN::META->has_inst("Compress::Zlib") ) {
5714 $CPAN::Frontend->mydie(qq{
5715 CPAN.pm needs either both external programs tar and gzip installed or
5716 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5717 is available. Can\'t continue.
5720 if ($prefer==1) { # 1 => external gzip+tar
5722 my $is_compressed = $class->gtest($file);
5723 if ($is_compressed) {
5724 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5725 "< $file | $CPAN::Config->{tar} xvf -";
5727 $system = "$CPAN::Config->{tar} xvf $file";
5729 if (system($system) != 0) {
5730 # people find the most curious tar binaries that cannot handle
5732 if ($is_compressed) {
5733 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5734 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5735 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5737 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5741 $system = "$CPAN::Config->{tar} xvf $file";
5742 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5743 if (system($system)==0) {
5744 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5746 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5752 } elsif ($prefer==2) { # 2 => modules
5753 my $tar = Archive::Tar->new($file,1);
5754 my $af; # archive file
5757 # RCS 1.337 had this code, it turned out unacceptable slow but
5758 # it revealed a bug in Archive::Tar. Code is only here to hunt
5759 # the bug again. It should never be enabled in published code.
5760 # GDGraph3d-0.53 was an interesting case according to Larry
5762 warn(">>>Bughunting code enabled<<< " x 20);
5763 for $af ($tar->list_files) {
5764 if ($af =~ m!^(/|\.\./)!) {
5765 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5766 "illegal member [$af]");
5768 $CPAN::Frontend->myprint("$af\n");
5769 $tar->extract($af); # slow but effective for finding the bug
5770 return if $CPAN::Signal;
5773 for $af ($tar->list_files) {
5774 if ($af =~ m!^(/|\.\./)!) {
5775 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5776 "illegal member [$af]");
5778 $CPAN::Frontend->myprint("$af\n");
5780 return if $CPAN::Signal;
5785 Mac::BuildTools::convert_files([$tar->list_files], 1)
5786 if ($^O eq 'MacOS');
5793 my($class,$file) = @_;
5794 if ($CPAN::META->has_inst("Archive::Zip")) {
5795 # blueprint of the code from Archive::Zip::Tree::extractTree();
5796 my $zip = Archive::Zip->new();
5798 $status = $zip->read($file);
5799 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5800 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5801 my @members = $zip->members();
5802 for my $member ( @members ) {
5803 my $af = $member->fileName();
5804 if ($af =~ m!^(/|\.\./)!) {
5805 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5806 "illegal member [$af]");
5808 my $status = $member->extractToFileNamed( $af );
5809 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5810 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5811 $status != Archive::Zip::AZ_OK();
5812 return if $CPAN::Signal;
5816 my $unzip = $CPAN::Config->{unzip} or
5817 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5818 my @system = ($unzip, $file);
5819 return system(@system) == 0;
5824 package CPAN::Version;
5825 # CPAN::Version::vcmp courtesy Jost Krieger
5827 my($self,$l,$r) = @_;
5829 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5831 return 0 if $l eq $r; # short circuit for quicker success
5833 if ($l=~/^v/ <=> $r=~/^v/) {
5836 $_ = $self->float2vv($_);
5841 ($l ne "undef") <=> ($r ne "undef") ||
5845 $self->vstring($l) cmp $self->vstring($r)) ||
5851 my($self,$l,$r) = @_;
5852 $self->vcmp($l,$r) > 0;
5857 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5858 pack "U*", split /\./, $n;
5861 # vv => visible vstring
5866 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5867 # architecture influence
5869 $mantissa .= "0" while length($mantissa)%3;
5870 my $ret = "v" . $rev;
5872 $mantissa =~ s/(\d{1,3})// or
5873 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5874 $ret .= ".".int($1);
5876 # warn "n[$n]ret[$ret]";
5882 $n =~ /^([\w\-\+\.]+)/;
5884 return $1 if defined $1 && length($1)>0;
5885 # if the first user reaches version v43, he will be treated as "+".
5886 # We'll have to decide about a new rule here then, depending on what
5887 # will be the prevailing versioning behavior then.
5889 if ($] < 5.006) { # or whenever v-strings were introduced
5890 # we get them wrong anyway, whatever we do, because 5.005 will
5891 # have already interpreted 0.2.4 to be "0.24". So even if he
5892 # indexer sends us something like "v0.2.4" we compare wrongly.
5894 # And if they say v1.2, then the old perl takes it as "v12"
5896 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5899 my $better = sprintf "v%vd", $n;
5900 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5912 CPAN - query, download and build perl modules from CPAN sites
5918 perl -MCPAN -e shell;
5924 autobundle, clean, install, make, recompile, test
5928 The CPAN module is designed to automate the make and install of perl
5929 modules and extensions. It includes some searching capabilities and
5930 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5931 to fetch the raw data from the net.
5933 Modules are fetched from one or more of the mirrored CPAN
5934 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5937 The CPAN module also supports the concept of named and versioned
5938 I<bundles> of modules. Bundles simplify the handling of sets of
5939 related modules. See Bundles below.
5941 The package contains a session manager and a cache manager. There is
5942 no status retained between sessions. The session manager keeps track
5943 of what has been fetched, built and installed in the current
5944 session. The cache manager keeps track of the disk space occupied by
5945 the make processes and deletes excess space according to a simple FIFO
5948 For extended searching capabilities there's a plugin for CPAN available,
5949 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5950 that indexes all documents available in CPAN authors directories. If
5951 C<CPAN::WAIT> is installed on your system, the interactive shell of
5952 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5953 which send queries to the WAIT server that has been configured for your
5956 All other methods provided are accessible in a programmer style and in an
5957 interactive shell style.
5959 =head2 Interactive Mode
5961 The interactive mode is entered by running
5963 perl -MCPAN -e shell
5965 which puts you into a readline interface. You will have the most fun if
5966 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5969 Once you are on the command line, type 'h' and the rest should be
5972 The function call C<shell> takes two optional arguments, one is the
5973 prompt, the second is the default initial command line (the latter
5974 only works if a real ReadLine interface module is installed).
5976 The most common uses of the interactive modes are
5980 =item Searching for authors, bundles, distribution files and modules
5982 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5983 for each of the four categories and another, C<i> for any of the
5984 mentioned four. Each of the four entities is implemented as a class
5985 with slightly differing methods for displaying an object.
5987 Arguments you pass to these commands are either strings exactly matching
5988 the identification string of an object or regular expressions that are
5989 then matched case-insensitively against various attributes of the
5990 objects. The parser recognizes a regular expression only if you
5991 enclose it between two slashes.
5993 The principle is that the number of found objects influences how an
5994 item is displayed. If the search finds one item, the result is
5995 displayed with the rather verbose method C<as_string>, but if we find
5996 more than one, we display each object with the terse method
5999 =item make, test, install, clean modules or distributions
6001 These commands take any number of arguments and investigate what is
6002 necessary to perform the action. If the argument is a distribution
6003 file name (recognized by embedded slashes), it is processed. If it is
6004 a module, CPAN determines the distribution file in which this module
6005 is included and processes that, following any dependencies named in
6006 the module's Makefile.PL (this behavior is controlled by
6007 I<prerequisites_policy>.)
6009 Any C<make> or C<test> are run unconditionally. An
6011 install <distribution_file>
6013 also is run unconditionally. But for
6017 CPAN checks if an install is actually needed for it and prints
6018 I<module up to date> in the case that the distribution file containing
6019 the module doesn't need to be updated.
6021 CPAN also keeps track of what it has done within the current session
6022 and doesn't try to build a package a second time regardless if it
6023 succeeded or not. The C<force> command takes as a first argument the
6024 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6025 command from scratch.
6029 cpan> install OpenGL
6030 OpenGL is up to date.
6031 cpan> force install OpenGL
6034 OpenGL-0.4/COPYRIGHT
6037 A C<clean> command results in a
6041 being executed within the distribution file's working directory.
6043 =item get, readme, look module or distribution
6045 C<get> downloads a distribution file without further action. C<readme>
6046 displays the README file of the associated distribution. C<Look> gets
6047 and untars (if not yet done) the distribution file, changes to the
6048 appropriate directory and opens a subshell process in that directory.
6052 C<ls> lists all distribution files in and below an author's CPAN
6053 directory. Only those files that contain modules are listed and if
6054 there is more than one for any given module, only the most recent one
6059 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6060 in the cpan-shell it is intended that you can press C<^C> anytime and
6061 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6062 to clean up and leave the shell loop. You can emulate the effect of a
6063 SIGTERM by sending two consecutive SIGINTs, which usually means by
6064 pressing C<^C> twice.
6066 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6067 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6073 The commands that are available in the shell interface are methods in
6074 the package CPAN::Shell. If you enter the shell command, all your
6075 input is split by the Text::ParseWords::shellwords() routine which
6076 acts like most shells do. The first word is being interpreted as the
6077 method to be called and the rest of the words are treated as arguments
6078 to this method. Continuation lines are supported if a line ends with a
6083 C<autobundle> writes a bundle file into the
6084 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6085 a list of all modules that are both available from CPAN and currently
6086 installed within @INC. The name of the bundle file is based on the
6087 current date and a counter.
6091 recompile() is a very special command in that it takes no argument and
6092 runs the make/test/install cycle with brute force over all installed
6093 dynamically loadable extensions (aka XS modules) with 'force' in
6094 effect. The primary purpose of this command is to finish a network
6095 installation. Imagine, you have a common source tree for two different
6096 architectures. You decide to do a completely independent fresh
6097 installation. You start on one architecture with the help of a Bundle
6098 file produced earlier. CPAN installs the whole Bundle for you, but
6099 when you try to repeat the job on the second architecture, CPAN
6100 responds with a C<"Foo up to date"> message for all modules. So you
6101 invoke CPAN's recompile on the second architecture and you're done.
6103 Another popular use for C<recompile> is to act as a rescue in case your
6104 perl breaks binary compatibility. If one of the modules that CPAN uses
6105 is in turn depending on binary compatibility (so you cannot run CPAN
6106 commands), then you should try the CPAN::Nox module for recovery.
6108 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6110 Although it may be considered internal, the class hierarchy does matter
6111 for both users and programmer. CPAN.pm deals with above mentioned four
6112 classes, and all those classes share a set of methods. A classical
6113 single polymorphism is in effect. A metaclass object registers all
6114 objects of all kinds and indexes them with a string. The strings
6115 referencing objects have a separated namespace (well, not completely
6120 words containing a "/" (slash) Distribution
6121 words starting with Bundle:: Bundle
6122 everything else Module or Author
6124 Modules know their associated Distribution objects. They always refer
6125 to the most recent official release. Developers may mark their releases
6126 as unstable development versions (by inserting an underbar into the
6127 module version number which will also be reflected in the distribution
6128 name when you run 'make dist'), so the really hottest and newest
6129 distribution is not always the default. If a module Foo circulates
6130 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6131 way to install version 1.23 by saying
6135 This would install the complete distribution file (say
6136 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6137 like to install version 1.23_90, you need to know where the
6138 distribution file resides on CPAN relative to the authors/id/
6139 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6140 so you would have to say
6142 install BAR/Foo-1.23_90.tar.gz
6144 The first example will be driven by an object of the class
6145 CPAN::Module, the second by an object of class CPAN::Distribution.
6147 =head2 Programmer's interface
6149 If you do not enter the shell, the available shell commands are both
6150 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6151 functions in the calling package (C<install(...)>).
6153 There's currently only one class that has a stable interface -
6154 CPAN::Shell. All commands that are available in the CPAN shell are
6155 methods of the class CPAN::Shell. Each of the commands that produce
6156 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6157 the IDs of all modules within the list.
6161 =item expand($type,@things)
6163 The IDs of all objects available within a program are strings that can
6164 be expanded to the corresponding real objects with the
6165 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6166 list of CPAN::Module objects according to the C<@things> arguments
6167 given. In scalar context it only returns the first element of the
6170 =item expandany(@things)
6172 Like expand, but returns objects of the appropriate type, i.e.
6173 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6174 CPAN::Distribution objects fro distributions.
6176 =item Programming Examples
6178 This enables the programmer to do operations that combine
6179 functionalities that are available in the shell.
6181 # install everything that is outdated on my disk:
6182 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6184 # install my favorite programs if necessary:
6185 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6186 my $obj = CPAN::Shell->expand('Module',$mod);
6190 # list all modules on my disk that have no VERSION number
6191 for $mod (CPAN::Shell->expand("Module","/./")){
6192 next unless $mod->inst_file;
6193 # MakeMaker convention for undefined $VERSION:
6194 next unless $mod->inst_version eq "undef";
6195 print "No VERSION in ", $mod->id, "\n";
6198 # find out which distribution on CPAN contains a module:
6199 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6201 Or if you want to write a cronjob to watch The CPAN, you could list
6202 all modules that need updating. First a quick and dirty way:
6204 perl -e 'use CPAN; CPAN::Shell->r;'
6206 If you don't want to get any output in the case that all modules are
6207 up to date, you can parse the output of above command for the regular
6208 expression //modules are up to date// and decide to mail the output
6209 only if it doesn't match. Ick?
6211 If you prefer to do it more in a programmer style in one single
6212 process, maybe something like this suits you better:
6214 # list all modules on my disk that have newer versions on CPAN
6215 for $mod (CPAN::Shell->expand("Module","/./")){
6216 next unless $mod->inst_file;
6217 next if $mod->uptodate;
6218 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6219 $mod->id, $mod->inst_version, $mod->cpan_version;
6222 If that gives you too much output every day, you maybe only want to
6223 watch for three modules. You can write
6225 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6227 as the first line instead. Or you can combine some of the above
6230 # watch only for a new mod_perl module
6231 $mod = CPAN::Shell->expand("Module","mod_perl");
6232 exit if $mod->uptodate;
6233 # new mod_perl arrived, let me know all update recommendations
6238 =head2 Methods in the other Classes
6240 The programming interface for the classes CPAN::Module,
6241 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6242 beta and partially even alpha. In the following paragraphs only those
6243 methods are documented that have proven useful over a longer time and
6244 thus are unlikely to change.
6248 =item CPAN::Author::as_glimpse()
6250 Returns a one-line description of the author
6252 =item CPAN::Author::as_string()
6254 Returns a multi-line description of the author
6256 =item CPAN::Author::email()
6258 Returns the author's email address
6260 =item CPAN::Author::fullname()
6262 Returns the author's name
6264 =item CPAN::Author::name()
6266 An alias for fullname
6268 =item CPAN::Bundle::as_glimpse()
6270 Returns a one-line description of the bundle
6272 =item CPAN::Bundle::as_string()
6274 Returns a multi-line description of the bundle
6276 =item CPAN::Bundle::clean()
6278 Recursively runs the C<clean> method on all items contained in the bundle.
6280 =item CPAN::Bundle::contains()
6282 Returns a list of objects' IDs contained in a bundle. The associated
6283 objects may be bundles, modules or distributions.
6285 =item CPAN::Bundle::force($method,@args)
6287 Forces CPAN to perform a task that normally would have failed. Force
6288 takes as arguments a method name to be called and any number of
6289 additional arguments that should be passed to the called method. The
6290 internals of the object get the needed changes so that CPAN.pm does
6291 not refuse to take the action. The C<force> is passed recursively to
6292 all contained objects.
6294 =item CPAN::Bundle::get()
6296 Recursively runs the C<get> method on all items contained in the bundle
6298 =item CPAN::Bundle::inst_file()
6300 Returns the highest installed version of the bundle in either @INC or
6301 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6302 CPAN::Module::inst_file.
6304 =item CPAN::Bundle::inst_version()
6306 Like CPAN::Bundle::inst_file, but returns the $VERSION
6308 =item CPAN::Bundle::uptodate()
6310 Returns 1 if the bundle itself and all its members are uptodate.
6312 =item CPAN::Bundle::install()
6314 Recursively runs the C<install> method on all items contained in the bundle
6316 =item CPAN::Bundle::make()
6318 Recursively runs the C<make> method on all items contained in the bundle
6320 =item CPAN::Bundle::readme()
6322 Recursively runs the C<readme> method on all items contained in the bundle
6324 =item CPAN::Bundle::test()
6326 Recursively runs the C<test> method on all items contained in the bundle
6328 =item CPAN::Distribution::as_glimpse()
6330 Returns a one-line description of the distribution
6332 =item CPAN::Distribution::as_string()
6334 Returns a multi-line description of the distribution
6336 =item CPAN::Distribution::clean()
6338 Changes to the directory where the distribution has been unpacked and
6339 runs C<make clean> there.
6341 =item CPAN::Distribution::containsmods()
6343 Returns a list of IDs of modules contained in a distribution file.
6344 Only works for distributions listed in the 02packages.details.txt.gz
6345 file. This typically means that only the most recent version of a
6346 distribution is covered.
6348 =item CPAN::Distribution::cvs_import()
6350 Changes to the directory where the distribution has been unpacked and
6353 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6357 =item CPAN::Distribution::dir()
6359 Returns the directory into which this distribution has been unpacked.
6361 =item CPAN::Distribution::force($method,@args)
6363 Forces CPAN to perform a task that normally would have failed. Force
6364 takes as arguments a method name to be called and any number of
6365 additional arguments that should be passed to the called method. The
6366 internals of the object get the needed changes so that CPAN.pm does
6367 not refuse to take the action.
6369 =item CPAN::Distribution::get()
6371 Downloads the distribution from CPAN and unpacks it. Does nothing if
6372 the distribution has already been downloaded and unpacked within the
6375 =item CPAN::Distribution::install()
6377 Changes to the directory where the distribution has been unpacked and
6378 runs the external command C<make install> there. If C<make> has not
6379 yet been run, it will be run first. A C<make test> will be issued in
6380 any case and if this fails, the install will be canceled. The
6381 cancellation can be avoided by letting C<force> run the C<install> for
6384 =item CPAN::Distribution::isa_perl()
6386 Returns 1 if this distribution file seems to be a perl distribution.
6387 Normally this is derived from the file name only, but the index from
6388 CPAN can contain a hint to achieve a return value of true for other
6391 =item CPAN::Distribution::look()
6393 Changes to the directory where the distribution has been unpacked and
6394 opens a subshell there. Exiting the subshell returns.
6396 =item CPAN::Distribution::make()
6398 First runs the C<get> method to make sure the distribution is
6399 downloaded and unpacked. Changes to the directory where the
6400 distribution has been unpacked and runs the external commands C<perl
6401 Makefile.PL> and C<make> there.
6403 =item CPAN::Distribution::prereq_pm()
6405 Returns the hash reference that has been announced by a distribution
6406 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6407 attempt has been made to C<make> the distribution. Returns undef
6410 =item CPAN::Distribution::readme()
6412 Downloads the README file associated with a distribution and runs it
6413 through the pager specified in C<$CPAN::Config->{pager}>.
6415 =item CPAN::Distribution::test()
6417 Changes to the directory where the distribution has been unpacked and
6418 runs C<make test> there.
6420 =item CPAN::Distribution::uptodate()
6422 Returns 1 if all the modules contained in the distribution are
6423 uptodate. Relies on containsmods.
6425 =item CPAN::Index::force_reload()
6427 Forces a reload of all indices.
6429 =item CPAN::Index::reload()
6431 Reloads all indices if they have been read more than
6432 C<$CPAN::Config->{index_expire}> days.
6434 =item CPAN::InfoObj::dump()
6436 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6437 inherit this method. It prints the data structure associated with an
6438 object. Useful for debugging. Note: the data structure is considered
6439 internal and thus subject to change without notice.
6441 =item CPAN::Module::as_glimpse()
6443 Returns a one-line description of the module
6445 =item CPAN::Module::as_string()
6447 Returns a multi-line description of the module
6449 =item CPAN::Module::clean()
6451 Runs a clean on the distribution associated with this module.
6453 =item CPAN::Module::cpan_file()
6455 Returns the filename on CPAN that is associated with the module.
6457 =item CPAN::Module::cpan_version()
6459 Returns the latest version of this module available on CPAN.
6461 =item CPAN::Module::cvs_import()
6463 Runs a cvs_import on the distribution associated with this module.
6465 =item CPAN::Module::description()
6467 Returns a 44 character description of this module. Only available for
6468 modules listed in The Module List (CPAN/modules/00modlist.long.html
6469 or 00modlist.long.txt.gz)
6471 =item CPAN::Module::force($method,@args)
6473 Forces CPAN to perform a task that normally would have failed. Force
6474 takes as arguments a method name to be called and any number of
6475 additional arguments that should be passed to the called method. The
6476 internals of the object get the needed changes so that CPAN.pm does
6477 not refuse to take the action.
6479 =item CPAN::Module::get()
6481 Runs a get on the distribution associated with this module.
6483 =item CPAN::Module::inst_file()
6485 Returns the filename of the module found in @INC. The first file found
6486 is reported just like perl itself stops searching @INC when it finds a
6489 =item CPAN::Module::inst_version()
6491 Returns the version number of the module in readable format.
6493 =item CPAN::Module::install()
6495 Runs an C<install> on the distribution associated with this module.
6497 =item CPAN::Module::look()
6499 Changes to the directory where the distribution associated with this
6500 module has been unpacked and opens a subshell there. Exiting the
6503 =item CPAN::Module::make()
6505 Runs a C<make> on the distribution associated with this module.
6507 =item CPAN::Module::manpage_headline()
6509 If module is installed, peeks into the module's manpage, reads the
6510 headline and returns it. Moreover, if the module has been downloaded
6511 within this session, does the equivalent on the downloaded module even
6512 if it is not installed.
6514 =item CPAN::Module::readme()
6516 Runs a C<readme> on the distribution associated with this module.
6518 =item CPAN::Module::test()
6520 Runs a C<test> on the distribution associated with this module.
6522 =item CPAN::Module::uptodate()
6524 Returns 1 if the module is installed and up-to-date.
6526 =item CPAN::Module::userid()
6528 Returns the author's ID of the module.
6532 =head2 Cache Manager
6534 Currently the cache manager only keeps track of the build directory
6535 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6536 deletes complete directories below C<build_dir> as soon as the size of
6537 all directories there gets bigger than $CPAN::Config->{build_cache}
6538 (in MB). The contents of this cache may be used for later
6539 re-installations that you intend to do manually, but will never be
6540 trusted by CPAN itself. This is due to the fact that the user might
6541 use these directories for building modules on different architectures.
6543 There is another directory ($CPAN::Config->{keep_source_where}) where
6544 the original distribution files are kept. This directory is not
6545 covered by the cache manager and must be controlled by the user. If
6546 you choose to have the same directory as build_dir and as
6547 keep_source_where directory, then your sources will be deleted with
6548 the same fifo mechanism.
6552 A bundle is just a perl module in the namespace Bundle:: that does not
6553 define any functions or methods. It usually only contains documentation.
6555 It starts like a perl module with a package declaration and a $VERSION
6556 variable. After that the pod section looks like any other pod with the
6557 only difference being that I<one special pod section> exists starting with
6562 In this pod section each line obeys the format
6564 Module_Name [Version_String] [- optional text]
6566 The only required part is the first field, the name of a module
6567 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6568 of the line is optional. The comment part is delimited by a dash just
6569 as in the man page header.
6571 The distribution of a bundle should follow the same convention as
6572 other distributions.
6574 Bundles are treated specially in the CPAN package. If you say 'install
6575 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6576 the modules in the CONTENTS section of the pod. You can install your
6577 own Bundles locally by placing a conformant Bundle file somewhere into
6578 your @INC path. The autobundle() command which is available in the
6579 shell interface does that for you by including all currently installed
6580 modules in a snapshot bundle file.
6582 =head2 Prerequisites
6584 If you have a local mirror of CPAN and can access all files with
6585 "file:" URLs, then you only need a perl better than perl5.003 to run
6586 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6587 required for non-UNIX systems or if your nearest CPAN site is
6588 associated with a URL that is not C<ftp:>.
6590 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6591 implemented for an external ftp command or for an external lynx
6594 =head2 Finding packages and VERSION
6596 This module presumes that all packages on CPAN
6602 declare their $VERSION variable in an easy to parse manner. This
6603 prerequisite can hardly be relaxed because it consumes far too much
6604 memory to load all packages into the running program just to determine
6605 the $VERSION variable. Currently all programs that are dealing with
6606 version use something like this
6608 perl -MExtUtils::MakeMaker -le \
6609 'print MM->parse_version(shift)' filename
6611 If you are author of a package and wonder if your $VERSION can be
6612 parsed, please try the above method.
6616 come as compressed or gzipped tarfiles or as zip files and contain a
6617 Makefile.PL (well, we try to handle a bit more, but without much
6624 The debugging of this module is a bit complex, because we have
6625 interferences of the software producing the indices on CPAN, of the
6626 mirroring process on CPAN, of packaging, of configuration, of
6627 synchronicity, and of bugs within CPAN.pm.
6629 For code debugging in interactive mode you can try "o debug" which
6630 will list options for debugging the various parts of the code. You
6631 should know that "o debug" has built-in completion support.
6633 For data debugging there is the C<dump> command which takes the same
6634 arguments as make/test/install and outputs the object's Data::Dumper
6637 =head2 Floppy, Zip, Offline Mode
6639 CPAN.pm works nicely without network too. If you maintain machines
6640 that are not networked at all, you should consider working with file:
6641 URLs. Of course, you have to collect your modules somewhere first. So
6642 you might use CPAN.pm to put together all you need on a networked
6643 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6644 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6645 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6646 with this floppy. See also below the paragraph about CD-ROM support.
6648 =head1 CONFIGURATION
6650 When the CPAN module is installed, a site wide configuration file is
6651 created as CPAN/Config.pm. The default values defined there can be
6652 overridden in another configuration file: CPAN/MyConfig.pm. You can
6653 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6654 $HOME/.cpan is added to the search path of the CPAN module before the
6655 use() or require() statements.
6657 Currently the following keys in the hash reference $CPAN::Config are
6660 build_cache size of cache for directories to build modules
6661 build_dir locally accessible directory to build modules
6662 index_expire after this many days refetch index files
6663 cache_metadata use serializer to cache metadata
6664 cpan_home local directory reserved for this package
6665 dontload_hash anonymous hash: modules in the keys will not be
6666 loaded by the CPAN::has_inst() routine
6667 gzip location of external program gzip
6668 inactivity_timeout breaks interactive Makefile.PLs after this
6669 many seconds inactivity. Set to 0 to never break.
6670 inhibit_startup_message
6671 if true, does not print the startup message
6672 keep_source_where directory in which to keep the source (if we do)
6673 make location of external make program
6674 make_arg arguments that should always be passed to 'make'
6675 make_install_arg same as make_arg for 'make install'
6676 makepl_arg arguments passed to 'perl Makefile.PL'
6677 pager location of external program more (or any pager)
6678 prerequisites_policy
6679 what to do if you are missing module prerequisites
6680 ('follow' automatically, 'ask' me, or 'ignore')
6681 proxy_user username for accessing an authenticating proxy
6682 proxy_pass password for accessing an authenticating proxy
6683 scan_cache controls scanning of cache ('atstart' or 'never')
6684 tar location of external program tar
6685 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6686 (and nonsense for characters outside latin range)
6687 unzip location of external program unzip
6688 urllist arrayref to nearby CPAN sites (or equivalent locations)
6689 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6690 ftp_proxy, } the three usual variables for configuring
6691 http_proxy, } proxy requests. Both as CPAN::Config variables
6692 no_proxy } and as environment variables configurable.
6694 You can set and query each of these options interactively in the cpan
6695 shell with the command set defined within the C<o conf> command:
6699 =item C<o conf E<lt>scalar optionE<gt>>
6701 prints the current value of the I<scalar option>
6703 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6705 Sets the value of the I<scalar option> to I<value>
6707 =item C<o conf E<lt>list optionE<gt>>
6709 prints the current value of the I<list option> in MakeMaker's
6712 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6714 shifts or pops the array in the I<list option> variable
6716 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6718 works like the corresponding perl commands.
6722 =head2 Note on urllist parameter's format
6724 urllist parameters are URLs according to RFC 1738. We do a little
6725 guessing if your URL is not compliant, but if you have problems with
6726 file URLs, please try the correct format. Either:
6728 file://localhost/whatever/ftp/pub/CPAN/
6732 file:///home/ftp/pub/CPAN/
6734 =head2 urllist parameter has CD-ROM support
6736 The C<urllist> parameter of the configuration table contains a list of
6737 URLs that are to be used for downloading. If the list contains any
6738 C<file> URLs, CPAN always tries to get files from there first. This
6739 feature is disabled for index files. So the recommendation for the
6740 owner of a CD-ROM with CPAN contents is: include your local, possibly
6741 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6743 o conf urllist push file://localhost/CDROM/CPAN
6745 CPAN.pm will then fetch the index files from one of the CPAN sites
6746 that come at the beginning of urllist. It will later check for each
6747 module if there is a local copy of the most recent version.
6749 Another peculiarity of urllist is that the site that we could
6750 successfully fetch the last file from automatically gets a preference
6751 token and is tried as the first site for the next request. So if you
6752 add a new site at runtime it may happen that the previously preferred
6753 site will be tried another time. This means that if you want to disallow
6754 a site for the next transfer, it must be explicitly removed from
6759 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6760 install foreign, unmasked, unsigned code on your machine. We compare
6761 to a checksum that comes from the net just as the distribution file
6762 itself. If somebody has managed to tamper with the distribution file,
6763 they may have as well tampered with the CHECKSUMS file. Future
6764 development will go towards strong authentication.
6768 Most functions in package CPAN are exported per default. The reason
6769 for this is that the primary use is intended for the cpan shell or for
6772 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6774 Populating a freshly installed perl with my favorite modules is pretty
6775 easy if you maintain a private bundle definition file. To get a useful
6776 blueprint of a bundle definition file, the command autobundle can be used
6777 on the CPAN shell command line. This command writes a bundle definition
6778 file for all modules that are installed for the currently running perl
6779 interpreter. It's recommended to run this command only once and from then
6780 on maintain the file manually under a private name, say
6781 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6783 cpan> install Bundle::my_bundle
6785 then answer a few questions and then go out for a coffee.
6787 Maintaining a bundle definition file means keeping track of two
6788 things: dependencies and interactivity. CPAN.pm sometimes fails on
6789 calculating dependencies because not all modules define all MakeMaker
6790 attributes correctly, so a bundle definition file should specify
6791 prerequisites as early as possible. On the other hand, it's a bit
6792 annoying that many distributions need some interactive configuring. So
6793 what I try to accomplish in my private bundle file is to have the
6794 packages that need to be configured early in the file and the gentle
6795 ones later, so I can go out after a few minutes and leave CPAN.pm
6798 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6800 Thanks to Graham Barr for contributing the following paragraphs about
6801 the interaction between perl, and various firewall configurations. For
6802 further informations on firewalls, it is recommended to consult the
6803 documentation that comes with the ncftp program. If you are unable to
6804 go through the firewall with a simple Perl setup, it is very likely
6805 that you can configure ncftp so that it works for your firewall.
6807 =head2 Three basic types of firewalls
6809 Firewalls can be categorized into three basic types.
6815 This is where the firewall machine runs a web server and to access the
6816 outside world you must do it via the web server. If you set environment
6817 variables like http_proxy or ftp_proxy to a values beginning with http://
6818 or in your web browser you have to set proxy information then you know
6819 you are running an http firewall.
6821 To access servers outside these types of firewalls with perl (even for
6822 ftp) you will need to use LWP.
6826 This where the firewall machine runs an ftp server. This kind of
6827 firewall will only let you access ftp servers outside the firewall.
6828 This is usually done by connecting to the firewall with ftp, then
6829 entering a username like "user@outside.host.com"
6831 To access servers outside these type of firewalls with perl you
6832 will need to use Net::FTP.
6834 =item One way visibility
6836 I say one way visibility as these firewalls try to make themselves look
6837 invisible to the users inside the firewall. An FTP data connection is
6838 normally created by sending the remote server your IP address and then
6839 listening for the connection. But the remote server will not be able to
6840 connect to you because of the firewall. So for these types of firewall
6841 FTP connections need to be done in a passive mode.
6843 There are two that I can think off.
6849 If you are using a SOCKS firewall you will need to compile perl and link
6850 it with the SOCKS library, this is what is normally called a 'socksified'
6851 perl. With this executable you will be able to connect to servers outside
6852 the firewall as if it is not there.
6856 This is the firewall implemented in the Linux kernel, it allows you to
6857 hide a complete network behind one IP address. With this firewall no
6858 special compiling is needed as you can access hosts directly.
6864 =head2 Configuring lynx or ncftp for going through a firewall
6866 If you can go through your firewall with e.g. lynx, presumably with a
6869 /usr/local/bin/lynx -pscott:tiger
6871 then you would configure CPAN.pm with the command
6873 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6875 That's all. Similarly for ncftp or ftp, you would configure something
6878 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6880 Your mileage may vary...
6888 I installed a new version of module X but CPAN keeps saying,
6889 I have the old version installed
6891 Most probably you B<do> have the old version installed. This can
6892 happen if a module installs itself into a different directory in the
6893 @INC path than it was previously installed. This is not really a
6894 CPAN.pm problem, you would have the same problem when installing the
6895 module manually. The easiest way to prevent this behaviour is to add
6896 the argument C<UNINST=1> to the C<make install> call, and that is why
6897 many people add this argument permanently by configuring
6899 o conf make_install_arg UNINST=1
6903 So why is UNINST=1 not the default?
6905 Because there are people who have their precise expectations about who
6906 may install where in the @INC path and who uses which @INC array. In
6907 fine tuned environments C<UNINST=1> can cause damage.
6911 I want to clean up my mess, and install a new perl along with
6912 all modules I have. How do I go about it?
6914 Run the autobundle command for your old perl and optionally rename the
6915 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6916 with the Configure option prefix, e.g.
6918 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6920 Install the bundle file you produced in the first step with something like
6922 cpan> install Bundle::mybundle
6928 When I install bundles or multiple modules with one command
6929 there is too much output to keep track of.
6931 You may want to configure something like
6933 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6934 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6936 so that STDOUT is captured in a file for later inspection.
6941 I am not root, how can I install a module in a personal directory?
6943 You will most probably like something like this:
6945 o conf makepl_arg "LIB=~/myperl/lib \
6946 INSTALLMAN1DIR=~/myperl/man/man1 \
6947 INSTALLMAN3DIR=~/myperl/man/man3"
6948 install Sybase::Sybperl
6950 You can make this setting permanent like all C<o conf> settings with
6953 You will have to add ~/myperl/man to the MANPATH environment variable
6954 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6957 use lib "$ENV{HOME}/myperl/lib";
6959 or setting the PERL5LIB environment variable.
6961 Another thing you should bear in mind is that the UNINST parameter
6962 should never be set if you are not root.
6966 How to get a package, unwrap it, and make a change before building it?
6968 look Sybase::Sybperl
6972 I installed a Bundle and had a couple of fails. When I
6973 retried, everything resolved nicely. Can this be fixed to work
6976 The reason for this is that CPAN does not know the dependencies of all
6977 modules when it starts out. To decide about the additional items to
6978 install, it just uses data found in the generated Makefile. An
6979 undetected missing piece breaks the process. But it may well be that
6980 your Bundle installs some prerequisite later than some depending item
6981 and thus your second try is able to resolve everything. Please note,
6982 CPAN.pm does not know the dependency tree in advance and cannot sort
6983 the queue of things to install in a topologically correct order. It
6984 resolves perfectly well IFF all modules declare the prerequisites
6985 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6986 fail and you need to install often, it is recommended sort the Bundle
6987 definition file manually. It is planned to improve the metadata
6988 situation for dependencies on CPAN in general, but this will still
6993 In our intranet we have many modules for internal use. How
6994 can I integrate these modules with CPAN.pm but without uploading
6995 the modules to CPAN?
6997 Have a look at the CPAN::Site module.
7001 When I run CPAN's shell, I get error msg about line 1 to 4,
7002 setting meta input/output via the /etc/inputrc file.
7004 Some versions of readline are picky about capitalization in the
7005 /etc/inputrc file and specifically RedHat 6.2 comes with a
7006 /etc/inputrc that contains the word C<on> in lowercase. Change the
7007 occurrences of C<on> to C<On> and the bug should disappear.
7011 Some authors have strange characters in their names.
7013 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7014 expecting ISO-8859-1 charset, a converter can be activated by setting
7015 term_is_latin to a true value in your config file. One way of doing so
7018 cpan> ! $CPAN::Config->{term_is_latin}=1
7020 Extended support for converters will be made available as soon as perl
7021 becomes stable with regard to charset issues.
7027 We should give coverage for B<all> of the CPAN and not just the PAUSE
7028 part, right? In this discussion CPAN and PAUSE have become equal --
7029 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7030 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7032 Future development should be directed towards a better integration of
7035 If a Makefile.PL requires special customization of libraries, prompts
7036 the user for special input, etc. then you may find CPAN is not able to
7037 build the distribution. In that case, you should attempt the
7038 traditional method of building a Perl module package from a shell.
7042 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7046 Kawai,Takanori provides a Japanese translation of this manpage at
7047 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7051 perl(1), CPAN::Nox(3)