1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 # $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $
6 # only used during development:
8 # $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";
15 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
16 use File::Basename ();
22 use Text::ParseWords ();
26 no lib "."; # we need to run chdir all over and we would get at wrong
29 require Mac::BuildTools if $^O eq 'MacOS';
31 END { $End++; &cleanup; }
54 $CPAN::Frontend ||= "CPAN::Shell";
55 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
60 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
61 $Revision $Signal $End $Suppress_readline $Frontend
62 $Defaultsite $Have_warned);
64 @CPAN::ISA = qw(CPAN::Debug Exporter);
67 autobundle bundle expand force get cvs_import
68 install make readme recompile shell test clean
71 #-> sub CPAN::AUTOLOAD ;
76 @EXPORT{@EXPORT} = '';
77 CPAN::Config->load unless $CPAN::Config_loaded++;
78 if (exists $EXPORT{$l}){
81 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
90 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
91 CPAN::Config->load unless $CPAN::Config_loaded++;
93 my $oprompt = shift || "cpan> ";
94 my $prompt = $oprompt;
95 my $commandline = shift || "";
98 unless ($Suppress_readline) {
99 require Term::ReadLine;
102 $term->ReadLine eq "Term::ReadLine::Stub"
104 $term = Term::ReadLine->new('CPAN Monitor');
106 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
107 my $attribs = $term->Attribs;
108 $attribs->{attempted_completion_function} = sub {
109 &CPAN::Complete::gnu_cpl;
112 $readline::rl_completion_function =
113 $readline::rl_completion_function = 'CPAN::Complete::cpl';
115 # $term->OUT is autoflushed anyway
116 my $odef = select STDERR;
123 # no strict; # I do not recall why no strict was here (2000-09-03)
125 my $cwd = CPAN::anycwd();
126 my $try_detect_readline;
127 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
128 my $rl_avail = $Suppress_readline ? "suppressed" :
129 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
130 "available (try 'install Bundle::CPAN')";
132 $CPAN::Frontend->myprint(
134 cpan shell -- CPAN exploration and modules installation (v%s%s)
142 unless $CPAN::Config->{'inhibit_startup_message'} ;
143 my($continuation) = "";
144 SHELLCOMMAND: while () {
145 if ($Suppress_readline) {
147 last SHELLCOMMAND unless defined ($_ = <> );
150 last SHELLCOMMAND unless
151 defined ($_ = $term->readline($prompt, $commandline));
153 $_ = "$continuation$_" if $continuation;
155 next SHELLCOMMAND if /^$/;
156 $_ = 'h' if /^\s*\?/;
157 if (/^(?:q(?:uit)?|bye|exit)$/i) {
167 use vars qw($import_done);
168 CPAN->import(':DEFAULT') unless $import_done++;
169 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
176 if ($] < 5.00322) { # parsewords had a bug until recently
179 eval { @line = Text::ParseWords::shellwords($_) };
180 warn($@), next SHELLCOMMAND if $@;
181 warn("Text::Parsewords could not parse the line [$_]"),
182 next SHELLCOMMAND unless @line;
184 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
185 my $command = shift @line;
186 eval { CPAN::Shell->$command(@line) };
188 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
189 $CPAN::Frontend->myprint("\n");
194 $commandline = ""; # I do want to be able to pass a default to
195 # shell, but on the second command I see no
198 CPAN::Queue->nullify_queue;
199 if ($try_detect_readline) {
200 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
202 $CPAN::META->has_inst("Term::ReadLine::Perl")
204 delete $INC{"Term/ReadLine.pm"};
206 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
207 require Term::ReadLine;
208 $CPAN::Frontend->myprint("\n$redef subroutines in ".
209 "Term::ReadLine redefined\n");
215 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
218 package CPAN::CacheMgr;
219 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
222 package CPAN::Config;
223 use vars qw(%can $dot_cpan);
226 'commit' => "Commit changes to disk",
227 'defaults' => "Reload defaults from disk",
228 'init' => "Interactive setting of all options",
232 use vars qw($Ua $Thesite $Themethod);
233 @CPAN::FTP::ISA = qw(CPAN::Debug);
235 package CPAN::LWP::UserAgent;
236 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
237 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
239 package CPAN::Complete;
240 @CPAN::Complete::ISA = qw(CPAN::Debug);
241 @CPAN::Complete::COMMANDS = sort qw(
242 ! a b d h i m o q r u autobundle clean dump
243 make test install force readme reload look
245 ) unless @CPAN::Complete::COMMANDS;
248 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
249 @CPAN::Index::ISA = qw(CPAN::Debug);
252 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
255 package CPAN::InfoObj;
256 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
258 package CPAN::Author;
259 @CPAN::Author::ISA = qw(CPAN::InfoObj);
261 package CPAN::Distribution;
262 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
264 package CPAN::Bundle;
265 @CPAN::Bundle::ISA = qw(CPAN::Module);
267 package CPAN::Module;
268 @CPAN::Module::ISA = qw(CPAN::InfoObj);
271 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
272 @CPAN::Shell::ISA = qw(CPAN::Debug);
273 $COLOR_REGISTERED ||= 0;
274 $PRINT_ORNAMENTING ||= 0;
276 #-> sub CPAN::Shell::AUTOLOAD ;
278 my($autoload) = $AUTOLOAD;
279 my $class = shift(@_);
280 # warn "autoload[$autoload] class[$class]";
281 $autoload =~ s/.*:://;
282 if ($autoload =~ /^w/) {
283 if ($CPAN::META->has_inst('CPAN::WAIT')) {
284 CPAN::WAIT->$autoload(@_);
286 $CPAN::Frontend->mywarn(qq{
287 Commands starting with "w" require CPAN::WAIT to be installed.
288 Please consider installing CPAN::WAIT to use the fulltext index.
289 For this you just need to type
294 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
300 package CPAN::Tarzip;
301 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
302 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
303 $BUGHUNTING = 0; # released code must have turned off
307 # One use of the queue is to determine if we should or shouldn't
308 # announce the availability of a new CPAN module
310 # Now we try to use it for dependency tracking. For that to happen
311 # we need to draw a dependency tree and do the leaves first. This can
312 # easily be reached by running CPAN.pm recursively, but we don't want
313 # to waste memory and run into deep recursion. So what we can do is
316 # CPAN::Queue is the package where the queue is maintained. Dependencies
317 # often have high priority and must be brought to the head of the queue,
318 # possibly by jumping the queue if they are already there. My first code
319 # attempt tried to be extremely correct. Whenever a module needed
320 # immediate treatment, I either unshifted it to the front of the queue,
321 # or, if it was already in the queue, I spliced and let it bypass the
322 # others. This became a too correct model that made it impossible to put
323 # an item more than once into the queue. Why would you need that? Well,
324 # you need temporary duplicates as the manager of the queue is a loop
327 # (1) looks at the first item in the queue without shifting it off
329 # (2) cares for the item
331 # (3) removes the item from the queue, *even if its agenda failed and
332 # even if the item isn't the first in the queue anymore* (that way
333 # protecting against never ending queues)
335 # So if an item has prerequisites, the installation fails now, but we
336 # want to retry later. That's easy if we have it twice in the queue.
338 # I also expect insane dependency situations where an item gets more
339 # than two lives in the queue. Simplest example is triggered by 'install
340 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
341 # get in the way. I wanted the queue manager to be a dumb servant, not
342 # one that knows everything.
344 # Who would I tell in this model that the user wants to be asked before
345 # processing? I can't attach that information to the module object,
346 # because not modules are installed but distributions. So I'd have to
347 # tell the distribution object that it should ask the user before
348 # processing. Where would the question be triggered then? Most probably
349 # in CPAN::Distribution::rematein.
350 # Hope that makes sense, my head is a bit off:-) -- AK
357 my $self = bless { qmod => $s }, $class;
362 # CPAN::Queue::first ;
368 # CPAN::Queue::delete_first ;
370 my($class,$what) = @_;
372 for my $i (0..$#All) {
373 if ( $All[$i]->{qmod} eq $what ) {
380 # CPAN::Queue::jumpqueue ;
384 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
385 join(",",map {$_->{qmod}} @All),
388 WHAT: for my $what (reverse @what) {
390 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
391 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
392 if ($All[$i]->{qmod} eq $what){
394 if ($jumped > 100) { # one's OK if e.g. just
395 # processing now; more are OK if
396 # user typed it several times
397 $CPAN::Frontend->mywarn(
398 qq{Object [$what] queued more than 100 times, ignoring}
404 my $obj = bless { qmod => $what }, $class;
407 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
408 join(",",map {$_->{qmod}} @All),
413 # CPAN::Queue::exists ;
415 my($self,$what) = @_;
416 my @all = map { $_->{qmod} } @All;
417 my $exists = grep { $_->{qmod} eq $what } @All;
418 # warn "in exists what[$what] all[@all] exists[$exists]";
422 # CPAN::Queue::delete ;
425 @All = grep { $_->{qmod} ne $mod } @All;
428 # CPAN::Queue::nullify_queue ;
437 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
439 # from here on only subs.
440 ################################################################################
442 #-> sub CPAN::all_objects ;
444 my($mgr,$class) = @_;
445 CPAN::Config->load unless $CPAN::Config_loaded++;
446 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
448 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
450 *all = \&all_objects;
452 # Called by shell, not in batch mode. In batch mode I see no risk in
453 # having many processes updating something as installations are
454 # continually checked at runtime. In shell mode I suspect it is
455 # unintentional to open more than one shell at a time
457 #-> sub CPAN::checklock ;
460 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
461 if (-f $lockfile && -M _ > 0) {
462 my $fh = FileHandle->new($lockfile) or
463 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
464 my $otherpid = <$fh>;
465 my $otherhost = <$fh>;
467 if (defined $otherpid && $otherpid) {
470 if (defined $otherhost && $otherhost) {
473 my $thishost = hostname();
474 if (defined $otherhost && defined $thishost &&
475 $otherhost ne '' && $thishost ne '' &&
476 $otherhost ne $thishost) {
477 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
478 "reports other host $otherhost and other process $otherpid.\n".
479 "Cannot proceed.\n"));
481 elsif (defined $otherpid && $otherpid) {
482 return if $$ == $otherpid; # should never happen
483 $CPAN::Frontend->mywarn(
485 There seems to be running another CPAN process (pid $otherpid). Contacting...
487 if (kill 0, $otherpid) {
488 $CPAN::Frontend->mydie(qq{Other job is running.
489 You may want to kill it and delete the lockfile, maybe. On UNIX try:
493 } elsif (-w $lockfile) {
495 ExtUtils::MakeMaker::prompt
496 (qq{Other job not responding. Shall I overwrite }.
497 qq{the lockfile? (Y/N)},"y");
498 $CPAN::Frontend->myexit("Ok, bye\n")
499 unless $ans =~ /^y/i;
502 qq{Lockfile $lockfile not writeable by you. }.
503 qq{Cannot proceed.\n}.
506 qq{ and then rerun us.\n}
510 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
511 "reports other process with ID ".
512 "$otherpid. Cannot proceed.\n"));
515 my $dotcpan = $CPAN::Config->{cpan_home};
516 eval { File::Path::mkpath($dotcpan);};
518 # A special case at least for Jarkko.
523 $symlinkcpan = readlink $dotcpan;
524 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
525 eval { File::Path::mkpath($symlinkcpan); };
529 $CPAN::Frontend->mywarn(qq{
530 Working directory $symlinkcpan created.
534 unless (-d $dotcpan) {
536 Your configuration suggests "$dotcpan" as your
537 CPAN.pm working directory. I could not create this directory due
538 to this error: $firsterror\n};
540 As "$dotcpan" is a symlink to "$symlinkcpan",
541 I tried to create that, but I failed with this error: $seconderror
544 Please make sure the directory exists and is writable.
546 $CPAN::Frontend->mydie($diemess);
550 unless ($fh = FileHandle->new(">$lockfile")) {
551 if ($! =~ /Permission/) {
552 my $incc = $INC{'CPAN/Config.pm'};
553 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
554 $CPAN::Frontend->myprint(qq{
556 Your configuration suggests that CPAN.pm should use a working
558 $CPAN::Config->{cpan_home}
559 Unfortunately we could not create the lock file
561 due to permission problems.
563 Please make sure that the configuration variable
564 \$CPAN::Config->{cpan_home}
565 points to a directory where you can write a .lock file. You can set
566 this variable in either
573 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
575 $fh->print($$, "\n");
576 $fh->print(hostname(), "\n");
577 $self->{LOCK} = $lockfile;
581 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
586 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
587 print "Caught SIGINT\n";
591 # From: Larry Wall <larry@wall.org>
592 # Subject: Re: deprecating SIGDIE
593 # To: perl5-porters@perl.org
594 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
596 # The original intent of __DIE__ was only to allow you to substitute one
597 # kind of death for another on an application-wide basis without respect
598 # to whether you were in an eval or not. As a global backstop, it should
599 # not be used any more lightly (or any more heavily :-) than class
600 # UNIVERSAL. Any attempt to build a general exception model on it should
601 # be politely squashed. Any bug that causes every eval {} to have to be
602 # modified should be not so politely squashed.
604 # Those are my current opinions. It is also my optinion that polite
605 # arguments degenerate to personal arguments far too frequently, and that
606 # when they do, it's because both people wanted it to, or at least didn't
607 # sufficiently want it not to.
611 # global backstop to cleanup if we should really die
612 $SIG{__DIE__} = \&cleanup;
613 $self->debug("Signal handler set.") if $CPAN::DEBUG;
616 #-> sub CPAN::DESTROY ;
618 &cleanup; # need an eval?
621 #-> sub CPAN::anycwd ;
624 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
629 sub cwd {Cwd::cwd();}
631 #-> sub CPAN::getcwd ;
632 sub getcwd {Cwd::getcwd();}
634 #-> sub CPAN::exists ;
636 my($mgr,$class,$id) = @_;
637 CPAN::Config->load unless $CPAN::Config_loaded++;
639 ### Carp::croak "exists called without class argument" unless $class;
641 exists $META->{readonly}{$class}{$id} or
642 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
645 #-> sub CPAN::delete ;
647 my($mgr,$class,$id) = @_;
648 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
649 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
652 #-> sub CPAN::has_usable
653 # has_inst is sometimes too optimistic, we should replace it with this
654 # has_usable whenever a case is given
656 my($self,$mod,$message) = @_;
657 return 1 if $HAS_USABLE->{$mod};
658 my $has_inst = $self->has_inst($mod,$message);
659 return unless $has_inst;
662 LWP => [ # we frequently had "Can't locate object
663 # method "new" via package "LWP::UserAgent" at
664 # (eval 69) line 2006
666 sub {require LWP::UserAgent},
667 sub {require HTTP::Request},
668 sub {require URI::URL},
671 sub {require Net::FTP},
672 sub {require Net::Config},
675 if ($usable->{$mod}) {
676 for my $c (0..$#{$usable->{$mod}}) {
677 my $code = $usable->{$mod}[$c];
678 my $ret = eval { &$code() };
680 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
685 return $HAS_USABLE->{$mod} = 1;
688 #-> sub CPAN::has_inst
690 my($self,$mod,$message) = @_;
691 Carp::croak("CPAN->has_inst() called without an argument")
693 if (defined $message && $message eq "no"
695 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
697 exists $CPAN::Config->{dontload_hash}{$mod}
699 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
705 $file =~ s|/|\\|g if $^O eq 'MSWin32';
708 # checking %INC is wrong, because $INC{LWP} may be true
709 # although $INC{"URI/URL.pm"} may have failed. But as
710 # I really want to say "bla loaded OK", I have to somehow
712 ### warn "$file in %INC"; #debug
714 } elsif (eval { require $file }) {
715 # eval is good: if we haven't yet read the database it's
716 # perfect and if we have installed the module in the meantime,
717 # it tries again. The second require is only a NOOP returning
718 # 1 if we had success, otherwise it's retrying
720 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
721 if ($mod eq "CPAN::WAIT") {
722 push @CPAN::Shell::ISA, CPAN::WAIT;
725 } elsif ($mod eq "Net::FTP") {
726 $CPAN::Frontend->mywarn(qq{
727 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
729 install Bundle::libnet
731 }) unless $Have_warned->{"Net::FTP"}++;
733 } elsif ($mod eq "Digest::MD5"){
734 $CPAN::Frontend->myprint(qq{
735 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
736 Please consider installing the Digest::MD5 module.
741 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
746 #-> sub CPAN::instance ;
748 my($mgr,$class,$id) = @_;
751 # unsafe meta access, ok?
752 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
753 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
761 #-> sub CPAN::cleanup ;
763 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
764 local $SIG{__DIE__} = '';
769 0 && # disabled, try reload cpan with it
770 $] > 5.004_60 # thereabouts
775 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
777 $subroutine eq '(eval)';
780 return if $ineval && !$End;
781 return unless defined $META->{LOCK}; # unsafe meta access, ok
782 return unless -f $META->{LOCK}; # unsafe meta access, ok
783 unlink $META->{LOCK}; # unsafe meta access, ok
785 # Carp::cluck("DEBUGGING");
786 $CPAN::Frontend->mywarn("Lockfile removed.\n");
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::Frontent->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::Frontent->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::Frontent->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 delete $self->{later};
4802 for my $c ( $self->contains ) {
4803 my $obj = CPAN::Shell->expandany($c) or next;
4808 #-> sub CPAN::Bundle::color_cmd_tmps ;
4809 sub color_cmd_tmps {
4811 my($depth) = shift || 0;
4812 my($color) = shift || 0;
4813 # a module needs to recurse to its cpan_file, a distribution needs
4814 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4816 return if exists $self->{incommandcolor}
4817 && $self->{incommandcolor}==$color;
4818 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4819 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4824 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4826 for my $c ( $self->contains ) {
4827 my $obj = CPAN::Shell->expandany($c) or next;
4828 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4829 $obj->color_cmd_tmps($depth+1,$color);
4832 delete $self->{badtestcnt};
4834 $self->{incommandcolor} = $color;
4837 #-> sub CPAN::Bundle::as_string ;
4841 # following line must be "=", not "||=" because we have a moving target
4842 $self->{INST_VERSION} = $self->inst_version;
4843 return $self->SUPER::as_string;
4846 #-> sub CPAN::Bundle::contains ;
4849 my($inst_file) = $self->inst_file || "";
4850 my($id) = $self->id;
4851 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4852 unless ($inst_file) {
4853 # Try to get at it in the cpan directory
4854 $self->debug("no inst_file") if $CPAN::DEBUG;
4856 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4857 $cpan_file = $self->cpan_file;
4858 if ($cpan_file eq "N/A") {
4859 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4860 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4862 my $dist = $CPAN::META->instance('CPAN::Distribution',
4865 $self->debug($dist->as_string) if $CPAN::DEBUG;
4866 my($todir) = $CPAN::Config->{'cpan_home'};
4867 my(@me,$from,$to,$me);
4868 @me = split /::/, $self->id;
4870 $me = File::Spec->catfile(@me);
4871 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4872 $to = File::Spec->catfile($todir,$me);
4873 File::Path::mkpath(File::Basename::dirname($to));
4874 File::Copy::copy($from, $to)
4875 or Carp::confess("Couldn't copy $from to $to: $!");
4879 my $fh = FileHandle->new;
4881 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4883 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4885 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4886 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4887 next unless $in_cont;
4892 push @result, (split " ", $_, 2)[0];
4895 delete $self->{STATUS};
4896 $self->{CONTAINS} = \@result;
4897 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4899 $CPAN::Frontend->mywarn(qq{
4900 The bundle file "$inst_file" may be a broken
4901 bundlefile. It seems not to contain any bundle definition.
4902 Please check the file and if it is bogus, please delete it.
4903 Sorry for the inconvenience.
4909 #-> sub CPAN::Bundle::find_bundle_file
4910 sub find_bundle_file {
4911 my($self,$where,$what) = @_;
4912 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4913 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4914 ### my $bu = File::Spec->catfile($where,$what);
4915 ### return $bu if -f $bu;
4916 my $manifest = File::Spec->catfile($where,"MANIFEST");
4917 unless (-f $manifest) {
4918 require ExtUtils::Manifest;
4919 my $cwd = CPAN::anycwd();
4920 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4921 ExtUtils::Manifest::mkmanifest();
4922 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4924 my $fh = FileHandle->new($manifest)
4925 or Carp::croak("Couldn't open $manifest: $!");
4928 if ($^O eq 'MacOS') {
4931 $what2 =~ s/:Bundle://;
4934 $what2 =~ s|Bundle[/\\]||;
4939 my($file) = /(\S+)/;
4940 if ($file =~ m|\Q$what\E$|) {
4942 # return File::Spec->catfile($where,$bu); # bad
4945 # retry if she managed to
4946 # have no Bundle directory
4947 $bu = $file if $file =~ m|\Q$what2\E$|;
4949 $bu =~ tr|/|:| if $^O eq 'MacOS';
4950 return File::Spec->catfile($where, $bu) if $bu;
4951 Carp::croak("Couldn't find a Bundle file in $where");
4954 # needs to work quite differently from Module::inst_file because of
4955 # cpan_home/Bundle/ directory and the possibility that we have
4956 # shadowing effect. As it makes no sense to take the first in @INC for
4957 # Bundles, we parse them all for $VERSION and take the newest.
4959 #-> sub CPAN::Bundle::inst_file ;
4964 @me = split /::/, $self->id;
4967 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
4968 my $bfile = File::Spec->catfile($incdir, @me);
4969 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4970 next unless -f $bfile;
4971 my $foundv = MM->parse_version($bfile);
4972 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4973 $self->{INST_FILE} = $bfile;
4974 $self->{INST_VERSION} = $bestv = $foundv;
4980 #-> sub CPAN::Bundle::inst_version ;
4983 $self->inst_file; # finds INST_VERSION as side effect
4984 $self->{INST_VERSION};
4987 #-> sub CPAN::Bundle::rematein ;
4989 my($self,$meth) = @_;
4990 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4991 my($id) = $self->id;
4992 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4993 unless $self->inst_file || $self->cpan_file;
4995 for $s ($self->contains) {
4996 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4997 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4998 if ($type eq 'CPAN::Distribution') {
4999 $CPAN::Frontend->mywarn(qq{
5000 The Bundle }.$self->id.qq{ contains
5001 explicitly a file $s.
5005 # possibly noisy action:
5006 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5007 my $obj = $CPAN::META->instance($type,$s);
5009 if ($obj->isa(CPAN::Bundle)
5011 exists $obj->{install_failed}
5013 ref($obj->{install_failed}) eq "HASH"
5015 for (keys %{$obj->{install_failed}}) {
5016 $self->{install_failed}{$_} = undef; # propagate faiure up
5019 $fail{$s} = 1; # the bundle itself may have succeeded but
5024 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5025 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5027 delete $self->{install_failed}{$s};
5034 # recap with less noise
5035 if ( $meth eq "install" ) {
5038 my $raw = sprintf(qq{Bundle summary:
5039 The following items in bundle %s had installation problems:},
5042 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5043 $CPAN::Frontend->myprint("\n");
5046 for $s ($self->contains) {
5048 $paragraph .= "$s ";
5049 $self->{install_failed}{$s} = undef;
5050 $reported{$s} = undef;
5053 my $report_propagated;
5054 for $s (sort keys %{$self->{install_failed}}) {
5055 next if exists $reported{$s};
5056 $paragraph .= "and the following items had problems
5057 during recursive bundle calls: " unless $report_propagated++;
5058 $paragraph .= "$s ";
5060 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5061 $CPAN::Frontend->myprint("\n");
5063 $self->{'install'} = 'YES';
5068 #sub CPAN::Bundle::xs_file
5070 # If a bundle contains another that contains an xs_file we have
5071 # here, we just don't bother I suppose
5075 #-> sub CPAN::Bundle::force ;
5076 sub force { shift->rematein('force',@_); }
5077 #-> sub CPAN::Bundle::get ;
5078 sub get { shift->rematein('get',@_); }
5079 #-> sub CPAN::Bundle::make ;
5080 sub make { shift->rematein('make',@_); }
5081 #-> sub CPAN::Bundle::test ;
5084 $self->{badtestcnt} ||= 0;
5085 $self->rematein('test',@_);
5087 #-> sub CPAN::Bundle::install ;
5090 $self->rematein('install',@_);
5092 #-> sub CPAN::Bundle::clean ;
5093 sub clean { shift->rematein('clean',@_); }
5095 #-> sub CPAN::Bundle::uptodate ;
5098 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5100 foreach $c ($self->contains) {
5101 my $obj = CPAN::Shell->expandany($c);
5102 return 0 unless $obj->uptodate;
5107 #-> sub CPAN::Bundle::readme ;
5110 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5111 No File found for bundle } . $self->id . qq{\n}), return;
5112 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5113 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5116 package CPAN::Module;
5119 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5122 return unless exists $self->{RO}; # should never happen
5123 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5125 sub description { shift->{RO}{description} }
5129 delete $self->{later};
5130 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5135 #-> sub CPAN::Module::color_cmd_tmps ;
5136 sub color_cmd_tmps {
5138 my($depth) = shift || 0;
5139 my($color) = shift || 0;
5140 # a module needs to recurse to its cpan_file
5142 return if exists $self->{incommandcolor}
5143 && $self->{incommandcolor}==$color;
5144 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5145 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5150 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5152 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5153 $dist->color_cmd_tmps($depth+1,$color);
5156 delete $self->{badtestcnt};
5158 $self->{incommandcolor} = $color;
5161 #-> sub CPAN::Module::as_glimpse ;
5165 my $class = ref($self);
5166 $class =~ s/^CPAN:://;
5170 $CPAN::Shell::COLOR_REGISTERED
5172 $CPAN::META->has_inst("Term::ANSIColor")
5174 $self->{RO}{description}
5176 $color_on = Term::ANSIColor::color("green");
5177 $color_off = Term::ANSIColor::color("reset");
5179 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5188 #-> sub CPAN::Module::as_string ;
5192 CPAN->debug($self) if $CPAN::DEBUG;
5193 my $class = ref($self);
5194 $class =~ s/^CPAN:://;
5196 push @m, $class, " id = $self->{ID}\n";
5197 my $sprintf = " %-12s %s\n";
5198 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5199 if $self->description;
5200 my $sprintf2 = " %-12s %s (%s)\n";
5202 if ($userid = $self->cpan_userid || $self->userid){
5204 if ($author = CPAN::Shell->expand('Author',$userid)) {
5207 if ($m = $author->email) {
5214 $author->fullname . $email
5218 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5219 if $self->cpan_version;
5220 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5221 if $self->cpan_file;
5222 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5223 my(%statd,%stats,%statl,%stati);
5224 @statd{qw,? i c a b R M S,} = qw,unknown idea
5225 pre-alpha alpha beta released mature standard,;
5226 @stats{qw,? m d u n,} = qw,unknown mailing-list
5227 developer comp.lang.perl.* none,;
5228 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5229 @stati{qw,? f r O h,} = qw,unknown functions
5230 references+ties object-oriented hybrid,;
5231 $statd{' '} = 'unknown';
5232 $stats{' '} = 'unknown';
5233 $statl{' '} = 'unknown';
5234 $stati{' '} = 'unknown';
5242 $statd{$self->{RO}{statd}},
5243 $stats{$self->{RO}{stats}},
5244 $statl{$self->{RO}{statl}},
5245 $stati{$self->{RO}{stati}}
5246 ) if $self->{RO}{statd};
5247 my $local_file = $self->inst_file;
5248 unless ($self->{MANPAGE}) {
5250 $self->{MANPAGE} = $self->manpage_headline($local_file);
5252 # If we have already untarred it, we should look there
5253 my $dist = $CPAN::META->instance('CPAN::Distribution',
5255 # warn "dist[$dist]";
5256 # mff=manifest file; mfh=manifest handle
5261 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5263 $mfh = FileHandle->new($mff)
5265 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5266 my $lfre = $self->id; # local file RE
5269 my($lfl); # local file file
5271 my(@mflines) = <$mfh>;
5276 while (length($lfre)>5 and !$lfl) {
5277 ($lfl) = grep /$lfre/, @mflines;
5278 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5281 $lfl =~ s/\s.*//; # remove comments
5282 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5283 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5284 # warn "lfl_abs[$lfl_abs]";
5286 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5292 for $item (qw/MANPAGE/) {
5293 push @m, sprintf($sprintf, $item, $self->{$item})
5294 if exists $self->{$item};
5296 for $item (qw/CONTAINS/) {
5297 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5298 if exists $self->{$item} && @{$self->{$item}};
5300 push @m, sprintf($sprintf, 'INST_FILE',
5301 $local_file || "(not installed)");
5302 push @m, sprintf($sprintf, 'INST_VERSION',
5303 $self->inst_version) if $local_file;
5307 sub manpage_headline {
5308 my($self,$local_file) = @_;
5309 my(@local_file) = $local_file;
5310 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5311 push @local_file, $local_file;
5313 for $locf (@local_file) {
5314 next unless -f $locf;
5315 my $fh = FileHandle->new($locf)
5316 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5320 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
5321 m/^=head1\s+NAME/ ? 1 : $inpod;
5334 #-> sub CPAN::Module::cpan_file ;
5335 # Note: also inherited by CPAN::Bundle
5338 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5339 unless (defined $self->{RO}{CPAN_FILE}) {
5340 CPAN::Index->reload;
5342 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5343 return $self->{RO}{CPAN_FILE};
5345 my $userid = $self->userid;
5347 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5348 my $author = $CPAN::META->instance("CPAN::Author",
5350 my $fullname = $author->fullname;
5351 my $email = $author->email;
5352 unless (defined $fullname && defined $email) {
5353 return sprintf("Contact Author %s",
5357 return "Contact Author $fullname <$email>";
5359 return "UserID $userid";
5367 #-> sub CPAN::Module::cpan_version ;
5371 $self->{RO}{CPAN_VERSION} = 'undef'
5372 unless defined $self->{RO}{CPAN_VERSION};
5373 # I believe this is always a bug in the index and should be reported
5374 # as such, but usually I find out such an error and do not want to
5375 # provoke too many bugreports
5377 $self->{RO}{CPAN_VERSION};
5380 #-> sub CPAN::Module::force ;
5383 $self->{'force_update'}++;
5386 #-> sub CPAN::Module::rematein ;
5388 my($self,$meth) = @_;
5389 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5392 my $cpan_file = $self->cpan_file;
5393 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5394 $CPAN::Frontend->mywarn(sprintf qq{
5395 The module %s isn\'t available on CPAN.
5397 Either the module has not yet been uploaded to CPAN, or it is
5398 temporary unavailable. Please contact the author to find out
5399 more about the status. Try 'i %s'.
5406 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5407 $pack->called_for($self->id);
5408 $pack->force($meth) if exists $self->{'force_update'};
5410 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5411 delete $self->{'force_update'};
5414 #-> sub CPAN::Module::readme ;
5415 sub readme { shift->rematein('readme') }
5416 #-> sub CPAN::Module::look ;
5417 sub look { shift->rematein('look') }
5418 #-> sub CPAN::Module::cvs_import ;
5419 sub cvs_import { shift->rematein('cvs_import') }
5420 #-> sub CPAN::Module::get ;
5421 sub get { shift->rematein('get',@_); }
5422 #-> sub CPAN::Module::make ;
5425 $self->rematein('make');
5427 #-> sub CPAN::Module::test ;
5430 $self->{badtestcnt} ||= 0;
5431 $self->rematein('test',@_);
5433 #-> sub CPAN::Module::uptodate ;
5436 my($latest) = $self->cpan_version;
5438 my($inst_file) = $self->inst_file;
5440 if (defined $inst_file) {
5441 $have = $self->inst_version;
5446 ! CPAN::Version->vgt($latest, $have)
5448 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5449 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5454 #-> sub CPAN::Module::install ;
5460 not exists $self->{'force_update'}
5462 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5466 $self->rematein('install') if $doit;
5468 #-> sub CPAN::Module::clean ;
5469 sub clean { shift->rematein('clean') }
5471 #-> sub CPAN::Module::inst_file ;
5475 @packpath = split /::/, $self->{ID};
5476 $packpath[-1] .= ".pm";
5477 foreach $dir (@INC) {
5478 my $pmfile = File::Spec->catfile($dir,@packpath);
5486 #-> sub CPAN::Module::xs_file ;
5490 @packpath = split /::/, $self->{ID};
5491 push @packpath, $packpath[-1];
5492 $packpath[-1] .= "." . $Config::Config{'dlext'};
5493 foreach $dir (@INC) {
5494 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5502 #-> sub CPAN::Module::inst_version ;
5505 my $parsefile = $self->inst_file or return;
5506 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5509 # there was a bug in 5.6.0 that let lots of unini warnings out of
5510 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5511 # the following workaround after 5.6.1 is out.
5512 local($SIG{__WARN__}) = sub { my $w = shift;
5513 return if $w =~ /uninitialized/i;
5517 $have = MM->parse_version($parsefile) || "undef";
5518 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5519 $have =~ s/ $//; # trailing whitespace happens all the time
5521 # My thoughts about why %vd processing should happen here
5523 # Alt1 maintain it as string with leading v:
5524 # read index files do nothing
5525 # compare it use utility for compare
5526 # print it do nothing
5528 # Alt2 maintain it as what it is
5529 # read index files convert
5530 # compare it use utility because there's still a ">" vs "gt" issue
5531 # print it use CPAN::Version for print
5533 # Seems cleaner to hold it in memory as a string starting with a "v"
5535 # If the author of this module made a mistake and wrote a quoted
5536 # "v1.13" instead of v1.13, we simply leave it at that with the
5537 # effect that *we* will treat it like a v-tring while the rest of
5538 # perl won't. Seems sensible when we consider that any action we
5539 # could take now would just add complexity.
5541 $have = CPAN::Version->readable($have);
5543 $have =~ s/\s*//g; # stringify to float around floating point issues
5544 $have; # no stringify needed, \s* above matches always
5547 package CPAN::Tarzip;
5549 # CPAN::Tarzip::gzip
5551 my($class,$read,$write) = @_;
5552 if ($CPAN::META->has_inst("Compress::Zlib")) {
5554 $fhw = FileHandle->new($read)
5555 or $CPAN::Frontend->mydie("Could not open $read: $!");
5556 my $gz = Compress::Zlib::gzopen($write, "wb")
5557 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5558 $gz->gzwrite($buffer)
5559 while read($fhw,$buffer,4096) > 0 ;
5564 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5569 # CPAN::Tarzip::gunzip
5571 my($class,$read,$write) = @_;
5572 if ($CPAN::META->has_inst("Compress::Zlib")) {
5574 $fhw = FileHandle->new(">$write")
5575 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5576 my $gz = Compress::Zlib::gzopen($read, "rb")
5577 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5578 $fhw->print($buffer)
5579 while $gz->gzread($buffer) > 0 ;
5580 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5581 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5586 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5591 # CPAN::Tarzip::gtest
5593 my($class,$read) = @_;
5594 # After I had reread the documentation in zlib.h, I discovered that
5595 # uncompressed files do not lead to an gzerror (anymore?).
5596 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5599 my $gz = Compress::Zlib::gzopen($read, "rb")
5600 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5602 $Compress::Zlib::gzerrno));
5603 while ($gz->gzread($buffer) > 0 ){
5604 $len += length($buffer);
5607 my $err = $gz->gzerror;
5608 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5609 if ($len == -s $read){
5611 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5614 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5617 return system("$CPAN::Config->{gzip} -dt $read")==0;
5622 # CPAN::Tarzip::TIEHANDLE
5624 my($class,$file) = @_;
5626 $class->debug("file[$file]");
5627 if ($CPAN::META->has_inst("Compress::Zlib")) {
5628 my $gz = Compress::Zlib::gzopen($file,"rb") or
5629 die "Could not gzopen $file";
5630 $ret = bless {GZ => $gz}, $class;
5632 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5633 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5635 $ret = bless {FH => $fh}, $class;
5641 # CPAN::Tarzip::READLINE
5644 if (exists $self->{GZ}) {
5645 my $gz = $self->{GZ};
5646 my($line,$bytesread);
5647 $bytesread = $gz->gzreadline($line);
5648 return undef if $bytesread <= 0;
5651 my $fh = $self->{FH};
5652 return scalar <$fh>;
5657 # CPAN::Tarzip::READ
5659 my($self,$ref,$length,$offset) = @_;
5660 die "read with offset not implemented" if defined $offset;
5661 if (exists $self->{GZ}) {
5662 my $gz = $self->{GZ};
5663 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5666 my $fh = $self->{FH};
5667 return read($fh,$$ref,$length);
5672 # CPAN::Tarzip::DESTROY
5675 if (exists $self->{GZ}) {
5676 my $gz = $self->{GZ};
5677 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5678 # to be undef ever. AK, 2000-09
5680 my $fh = $self->{FH};
5681 $fh->close if defined $fh;
5687 # CPAN::Tarzip::untar
5689 my($class,$file) = @_;
5692 if (0) { # makes changing order easier
5693 } elsif ($BUGHUNTING){
5695 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5697 MM->maybe_command($CPAN::Config->{'tar'})) {
5698 # should be default until Archive::Tar is fixed
5701 $CPAN::META->has_inst("Archive::Tar")
5703 $CPAN::META->has_inst("Compress::Zlib") ) {
5706 $CPAN::Frontend->mydie(qq{
5707 CPAN.pm needs either both external programs tar and gzip installed or
5708 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5709 is available. Can\'t continue.
5712 if ($prefer==1) { # 1 => external gzip+tar
5714 my $is_compressed = $class->gtest($file);
5715 if ($is_compressed) {
5716 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5717 "< $file | $CPAN::Config->{tar} xvf -";
5719 $system = "$CPAN::Config->{tar} xvf $file";
5721 if (system($system) != 0) {
5722 # people find the most curious tar binaries that cannot handle
5724 if ($is_compressed) {
5725 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5726 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5727 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5729 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5733 $system = "$CPAN::Config->{tar} xvf $file";
5734 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5735 if (system($system)==0) {
5736 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5738 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5744 } elsif ($prefer==2) { # 2 => modules
5745 my $tar = Archive::Tar->new($file,1);
5746 my $af; # archive file
5749 # RCS 1.337 had this code, it turned out unacceptable slow but
5750 # it revealed a bug in Archive::Tar. Code is only here to hunt
5751 # the bug again. It should never be enabled in published code.
5752 # GDGraph3d-0.53 was an interesting case according to Larry
5754 warn(">>>Bughunting code enabled<<< " x 20);
5755 for $af ($tar->list_files) {
5756 if ($af =~ m!^(/|\.\./)!) {
5757 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5758 "illegal member [$af]");
5760 $CPAN::Frontend->myprint("$af\n");
5761 $tar->extract($af); # slow but effective for finding the bug
5762 return if $CPAN::Signal;
5765 for $af ($tar->list_files) {
5766 if ($af =~ m!^(/|\.\./)!) {
5767 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5768 "illegal member [$af]");
5770 $CPAN::Frontend->myprint("$af\n");
5772 return if $CPAN::Signal;
5777 Mac::BuildTools::convert_files([$tar->list_files], 1)
5778 if ($^O eq 'MacOS');
5785 my($class,$file) = @_;
5786 if ($CPAN::META->has_inst("Archive::Zip")) {
5787 # blueprint of the code from Archive::Zip::Tree::extractTree();
5788 my $zip = Archive::Zip->new();
5790 $status = $zip->read($file);
5791 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5792 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5793 my @members = $zip->members();
5794 for my $member ( @members ) {
5795 my $af = $member->fileName();
5796 if ($af =~ m!^(/|\.\./)!) {
5797 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5798 "illegal member [$af]");
5800 my $status = $member->extractToFileNamed( $af );
5801 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5802 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5803 $status != Archive::Zip::AZ_OK();
5804 return if $CPAN::Signal;
5808 my $unzip = $CPAN::Config->{unzip} or
5809 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5810 my @system = ($unzip, $file);
5811 return system(@system) == 0;
5816 package CPAN::Version;
5817 # CPAN::Version::vcmp courtesy Jost Krieger
5819 my($self,$l,$r) = @_;
5821 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5823 return 0 if $l eq $r; # short circuit for quicker success
5825 if ($l=~/^v/ <=> $r=~/^v/) {
5828 $_ = $self->float2vv($_);
5833 ($l ne "undef") <=> ($r ne "undef") ||
5837 $self->vstring($l) cmp $self->vstring($r)) ||
5843 my($self,$l,$r) = @_;
5844 $self->vcmp($l,$r) > 0;
5849 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5850 pack "U*", split /\./, $n;
5853 # vv => visible vstring
5858 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5859 # architecture influence
5861 $mantissa .= "0" while length($mantissa)%3;
5862 my $ret = "v" . $rev;
5864 $mantissa =~ s/(\d{1,3})// or
5865 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5866 $ret .= ".".int($1);
5868 # warn "n[$n]ret[$ret]";
5874 $n =~ /^([\w\-\+\.]+)/;
5876 return $1 if defined $1 && length($1)>0;
5877 # if the first user reaches version v43, he will be treated as "+".
5878 # We'll have to decide about a new rule here then, depending on what
5879 # will be the prevailing versioning behavior then.
5881 if ($] < 5.006) { # or whenever v-strings were introduced
5882 # we get them wrong anyway, whatever we do, because 5.005 will
5883 # have already interpreted 0.2.4 to be "0.24". So even if he
5884 # indexer sends us something like "v0.2.4" we compare wrongly.
5886 # And if they say v1.2, then the old perl takes it as "v12"
5888 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5891 my $better = sprintf "v%vd", $n;
5892 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5904 CPAN - query, download and build perl modules from CPAN sites
5910 perl -MCPAN -e shell;
5916 autobundle, clean, install, make, recompile, test
5920 The CPAN module is designed to automate the make and install of perl
5921 modules and extensions. It includes some searching capabilities and
5922 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5923 to fetch the raw data from the net.
5925 Modules are fetched from one or more of the mirrored CPAN
5926 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5929 The CPAN module also supports the concept of named and versioned
5930 I<bundles> of modules. Bundles simplify the handling of sets of
5931 related modules. See Bundles below.
5933 The package contains a session manager and a cache manager. There is
5934 no status retained between sessions. The session manager keeps track
5935 of what has been fetched, built and installed in the current
5936 session. The cache manager keeps track of the disk space occupied by
5937 the make processes and deletes excess space according to a simple FIFO
5940 For extended searching capabilities there's a plugin for CPAN available,
5941 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5942 that indexes all documents available in CPAN authors directories. If
5943 C<CPAN::WAIT> is installed on your system, the interactive shell of
5944 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5945 which send queries to the WAIT server that has been configured for your
5948 All other methods provided are accessible in a programmer style and in an
5949 interactive shell style.
5951 =head2 Interactive Mode
5953 The interactive mode is entered by running
5955 perl -MCPAN -e shell
5957 which puts you into a readline interface. You will have the most fun if
5958 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5961 Once you are on the command line, type 'h' and the rest should be
5964 The function call C<shell> takes two optional arguments, one is the
5965 prompt, the second is the default initial command line (the latter
5966 only works if a real ReadLine interface module is installed).
5968 The most common uses of the interactive modes are
5972 =item Searching for authors, bundles, distribution files and modules
5974 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5975 for each of the four categories and another, C<i> for any of the
5976 mentioned four. Each of the four entities is implemented as a class
5977 with slightly differing methods for displaying an object.
5979 Arguments you pass to these commands are either strings exactly matching
5980 the identification string of an object or regular expressions that are
5981 then matched case-insensitively against various attributes of the
5982 objects. The parser recognizes a regular expression only if you
5983 enclose it between two slashes.
5985 The principle is that the number of found objects influences how an
5986 item is displayed. If the search finds one item, the result is
5987 displayed with the rather verbose method C<as_string>, but if we find
5988 more than one, we display each object with the terse method
5991 =item make, test, install, clean modules or distributions
5993 These commands take any number of arguments and investigate what is
5994 necessary to perform the action. If the argument is a distribution
5995 file name (recognized by embedded slashes), it is processed. If it is
5996 a module, CPAN determines the distribution file in which this module
5997 is included and processes that, following any dependencies named in
5998 the module's Makefile.PL (this behavior is controlled by
5999 I<prerequisites_policy>.)
6001 Any C<make> or C<test> are run unconditionally. An
6003 install <distribution_file>
6005 also is run unconditionally. But for
6009 CPAN checks if an install is actually needed for it and prints
6010 I<module up to date> in the case that the distribution file containing
6011 the module doesn't need to be updated.
6013 CPAN also keeps track of what it has done within the current session
6014 and doesn't try to build a package a second time regardless if it
6015 succeeded or not. The C<force> command takes as a first argument the
6016 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6017 command from scratch.
6021 cpan> install OpenGL
6022 OpenGL is up to date.
6023 cpan> force install OpenGL
6026 OpenGL-0.4/COPYRIGHT
6029 A C<clean> command results in a
6033 being executed within the distribution file's working directory.
6035 =item get, readme, look module or distribution
6037 C<get> downloads a distribution file without further action. C<readme>
6038 displays the README file of the associated distribution. C<Look> gets
6039 and untars (if not yet done) the distribution file, changes to the
6040 appropriate directory and opens a subshell process in that directory.
6044 C<ls> lists all distribution files in and below an author's CPAN
6045 directory. Only those files that contain modules are listed and if
6046 there is more than one for any given module, only the most recent one
6051 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6052 in the cpan-shell it is intended that you can press C<^C> anytime and
6053 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6054 to clean up and leave the shell loop. You can emulate the effect of a
6055 SIGTERM by sending two consecutive SIGINTs, which usually means by
6056 pressing C<^C> twice.
6058 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6059 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6065 The commands that are available in the shell interface are methods in
6066 the package CPAN::Shell. If you enter the shell command, all your
6067 input is split by the Text::ParseWords::shellwords() routine which
6068 acts like most shells do. The first word is being interpreted as the
6069 method to be called and the rest of the words are treated as arguments
6070 to this method. Continuation lines are supported if a line ends with a
6075 C<autobundle> writes a bundle file into the
6076 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6077 a list of all modules that are both available from CPAN and currently
6078 installed within @INC. The name of the bundle file is based on the
6079 current date and a counter.
6083 recompile() is a very special command in that it takes no argument and
6084 runs the make/test/install cycle with brute force over all installed
6085 dynamically loadable extensions (aka XS modules) with 'force' in
6086 effect. The primary purpose of this command is to finish a network
6087 installation. Imagine, you have a common source tree for two different
6088 architectures. You decide to do a completely independent fresh
6089 installation. You start on one architecture with the help of a Bundle
6090 file produced earlier. CPAN installs the whole Bundle for you, but
6091 when you try to repeat the job on the second architecture, CPAN
6092 responds with a C<"Foo up to date"> message for all modules. So you
6093 invoke CPAN's recompile on the second architecture and you're done.
6095 Another popular use for C<recompile> is to act as a rescue in case your
6096 perl breaks binary compatibility. If one of the modules that CPAN uses
6097 is in turn depending on binary compatibility (so you cannot run CPAN
6098 commands), then you should try the CPAN::Nox module for recovery.
6100 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6102 Although it may be considered internal, the class hierarchy does matter
6103 for both users and programmer. CPAN.pm deals with above mentioned four
6104 classes, and all those classes share a set of methods. A classical
6105 single polymorphism is in effect. A metaclass object registers all
6106 objects of all kinds and indexes them with a string. The strings
6107 referencing objects have a separated namespace (well, not completely
6112 words containing a "/" (slash) Distribution
6113 words starting with Bundle:: Bundle
6114 everything else Module or Author
6116 Modules know their associated Distribution objects. They always refer
6117 to the most recent official release. Developers may mark their releases
6118 as unstable development versions (by inserting an underbar into the
6119 module version number which will also be reflected in the distribution
6120 name when you run 'make dist'), so the really hottest and newest
6121 distribution is not always the default. If a module Foo circulates
6122 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6123 way to install version 1.23 by saying
6127 This would install the complete distribution file (say
6128 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6129 like to install version 1.23_90, you need to know where the
6130 distribution file resides on CPAN relative to the authors/id/
6131 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6132 so you would have to say
6134 install BAR/Foo-1.23_90.tar.gz
6136 The first example will be driven by an object of the class
6137 CPAN::Module, the second by an object of class CPAN::Distribution.
6139 =head2 Programmer's interface
6141 If you do not enter the shell, the available shell commands are both
6142 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6143 functions in the calling package (C<install(...)>).
6145 There's currently only one class that has a stable interface -
6146 CPAN::Shell. All commands that are available in the CPAN shell are
6147 methods of the class CPAN::Shell. Each of the commands that produce
6148 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6149 the IDs of all modules within the list.
6153 =item expand($type,@things)
6155 The IDs of all objects available within a program are strings that can
6156 be expanded to the corresponding real objects with the
6157 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6158 list of CPAN::Module objects according to the C<@things> arguments
6159 given. In scalar context it only returns the first element of the
6162 =item expandany(@things)
6164 Like expand, but returns objects of the appropriate type, i.e.
6165 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6166 CPAN::Distribution objects fro distributions.
6168 =item Programming Examples
6170 This enables the programmer to do operations that combine
6171 functionalities that are available in the shell.
6173 # install everything that is outdated on my disk:
6174 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6176 # install my favorite programs if necessary:
6177 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6178 my $obj = CPAN::Shell->expand('Module',$mod);
6182 # list all modules on my disk that have no VERSION number
6183 for $mod (CPAN::Shell->expand("Module","/./")){
6184 next unless $mod->inst_file;
6185 # MakeMaker convention for undefined $VERSION:
6186 next unless $mod->inst_version eq "undef";
6187 print "No VERSION in ", $mod->id, "\n";
6190 # find out which distribution on CPAN contains a module:
6191 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6193 Or if you want to write a cronjob to watch The CPAN, you could list
6194 all modules that need updating. First a quick and dirty way:
6196 perl -e 'use CPAN; CPAN::Shell->r;'
6198 If you don't want to get any output in the case that all modules are
6199 up to date, you can parse the output of above command for the regular
6200 expression //modules are up to date// and decide to mail the output
6201 only if it doesn't match. Ick?
6203 If you prefer to do it more in a programmer style in one single
6204 process, maybe something like this suits you better:
6206 # list all modules on my disk that have newer versions on CPAN
6207 for $mod (CPAN::Shell->expand("Module","/./")){
6208 next unless $mod->inst_file;
6209 next if $mod->uptodate;
6210 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6211 $mod->id, $mod->inst_version, $mod->cpan_version;
6214 If that gives you too much output every day, you maybe only want to
6215 watch for three modules. You can write
6217 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6219 as the first line instead. Or you can combine some of the above
6222 # watch only for a new mod_perl module
6223 $mod = CPAN::Shell->expand("Module","mod_perl");
6224 exit if $mod->uptodate;
6225 # new mod_perl arrived, let me know all update recommendations
6230 =head2 Methods in the other Classes
6232 The programming interface for the classes CPAN::Module,
6233 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6234 beta and partially even alpha. In the following paragraphs only those
6235 methods are documented that have proven useful over a longer time and
6236 thus are unlikely to change.
6240 =item CPAN::Author::as_glimpse()
6242 Returns a one-line description of the author
6244 =item CPAN::Author::as_string()
6246 Returns a multi-line description of the author
6248 =item CPAN::Author::email()
6250 Returns the author's email address
6252 =item CPAN::Author::fullname()
6254 Returns the author's name
6256 =item CPAN::Author::name()
6258 An alias for fullname
6260 =item CPAN::Bundle::as_glimpse()
6262 Returns a one-line description of the bundle
6264 =item CPAN::Bundle::as_string()
6266 Returns a multi-line description of the bundle
6268 =item CPAN::Bundle::clean()
6270 Recursively runs the C<clean> method on all items contained in the bundle.
6272 =item CPAN::Bundle::contains()
6274 Returns a list of objects' IDs contained in a bundle. The associated
6275 objects may be bundles, modules or distributions.
6277 =item CPAN::Bundle::force($method,@args)
6279 Forces CPAN to perform a task that normally would have failed. Force
6280 takes as arguments a method name to be called and any number of
6281 additional arguments that should be passed to the called method. The
6282 internals of the object get the needed changes so that CPAN.pm does
6283 not refuse to take the action. The C<force> is passed recursively to
6284 all contained objects.
6286 =item CPAN::Bundle::get()
6288 Recursively runs the C<get> method on all items contained in the bundle
6290 =item CPAN::Bundle::inst_file()
6292 Returns the highest installed version of the bundle in either @INC or
6293 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6294 CPAN::Module::inst_file.
6296 =item CPAN::Bundle::inst_version()
6298 Like CPAN::Bundle::inst_file, but returns the $VERSION
6300 =item CPAN::Bundle::uptodate()
6302 Returns 1 if the bundle itself and all its members are uptodate.
6304 =item CPAN::Bundle::install()
6306 Recursively runs the C<install> method on all items contained in the bundle
6308 =item CPAN::Bundle::make()
6310 Recursively runs the C<make> method on all items contained in the bundle
6312 =item CPAN::Bundle::readme()
6314 Recursively runs the C<readme> method on all items contained in the bundle
6316 =item CPAN::Bundle::test()
6318 Recursively runs the C<test> method on all items contained in the bundle
6320 =item CPAN::Distribution::as_glimpse()
6322 Returns a one-line description of the distribution
6324 =item CPAN::Distribution::as_string()
6326 Returns a multi-line description of the distribution
6328 =item CPAN::Distribution::clean()
6330 Changes to the directory where the distribution has been unpacked and
6331 runs C<make clean> there.
6333 =item CPAN::Distribution::containsmods()
6335 Returns a list of IDs of modules contained in a distribution file.
6336 Only works for distributions listed in the 02packages.details.txt.gz
6337 file. This typically means that only the most recent version of a
6338 distribution is covered.
6340 =item CPAN::Distribution::cvs_import()
6342 Changes to the directory where the distribution has been unpacked and
6345 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6349 =item CPAN::Distribution::dir()
6351 Returns the directory into which this distribution has been unpacked.
6353 =item CPAN::Distribution::force($method,@args)
6355 Forces CPAN to perform a task that normally would have failed. Force
6356 takes as arguments a method name to be called and any number of
6357 additional arguments that should be passed to the called method. The
6358 internals of the object get the needed changes so that CPAN.pm does
6359 not refuse to take the action.
6361 =item CPAN::Distribution::get()
6363 Downloads the distribution from CPAN and unpacks it. Does nothing if
6364 the distribution has already been downloaded and unpacked within the
6367 =item CPAN::Distribution::install()
6369 Changes to the directory where the distribution has been unpacked and
6370 runs the external command C<make install> there. If C<make> has not
6371 yet been run, it will be run first. A C<make test> will be issued in
6372 any case and if this fails, the install will be canceled. The
6373 cancellation can be avoided by letting C<force> run the C<install> for
6376 =item CPAN::Distribution::isa_perl()
6378 Returns 1 if this distribution file seems to be a perl distribution.
6379 Normally this is derived from the file name only, but the index from
6380 CPAN can contain a hint to achieve a return value of true for other
6383 =item CPAN::Distribution::look()
6385 Changes to the directory where the distribution has been unpacked and
6386 opens a subshell there. Exiting the subshell returns.
6388 =item CPAN::Distribution::make()
6390 First runs the C<get> method to make sure the distribution is
6391 downloaded and unpacked. Changes to the directory where the
6392 distribution has been unpacked and runs the external commands C<perl
6393 Makefile.PL> and C<make> there.
6395 =item CPAN::Distribution::prereq_pm()
6397 Returns the hash reference that has been announced by a distribution
6398 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6399 attempt has been made to C<make> the distribution. Returns undef
6402 =item CPAN::Distribution::readme()
6404 Downloads the README file associated with a distribution and runs it
6405 through the pager specified in C<$CPAN::Config->{pager}>.
6407 =item CPAN::Distribution::test()
6409 Changes to the directory where the distribution has been unpacked and
6410 runs C<make test> there.
6412 =item CPAN::Distribution::uptodate()
6414 Returns 1 if all the modules contained in the distribution are
6415 uptodate. Relies on containsmods.
6417 =item CPAN::Index::force_reload()
6419 Forces a reload of all indices.
6421 =item CPAN::Index::reload()
6423 Reloads all indices if they have been read more than
6424 C<$CPAN::Config->{index_expire}> days.
6426 =item CPAN::InfoObj::dump()
6428 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6429 inherit this method. It prints the data structure associated with an
6430 object. Useful for debugging. Note: the data structure is considered
6431 internal and thus subject to change without notice.
6433 =item CPAN::Module::as_glimpse()
6435 Returns a one-line description of the module
6437 =item CPAN::Module::as_string()
6439 Returns a multi-line description of the module
6441 =item CPAN::Module::clean()
6443 Runs a clean on the distribution associated with this module.
6445 =item CPAN::Module::cpan_file()
6447 Returns the filename on CPAN that is associated with the module.
6449 =item CPAN::Module::cpan_version()
6451 Returns the latest version of this module available on CPAN.
6453 =item CPAN::Module::cvs_import()
6455 Runs a cvs_import on the distribution associated with this module.
6457 =item CPAN::Module::description()
6459 Returns a 44 character description of this module. Only available for
6460 modules listed in The Module List (CPAN/modules/00modlist.long.html
6461 or 00modlist.long.txt.gz)
6463 =item CPAN::Module::force($method,@args)
6465 Forces CPAN to perform a task that normally would have failed. Force
6466 takes as arguments a method name to be called and any number of
6467 additional arguments that should be passed to the called method. The
6468 internals of the object get the needed changes so that CPAN.pm does
6469 not refuse to take the action.
6471 =item CPAN::Module::get()
6473 Runs a get on the distribution associated with this module.
6475 =item CPAN::Module::inst_file()
6477 Returns the filename of the module found in @INC. The first file found
6478 is reported just like perl itself stops searching @INC when it finds a
6481 =item CPAN::Module::inst_version()
6483 Returns the version number of the module in readable format.
6485 =item CPAN::Module::install()
6487 Runs an C<install> on the distribution associated with this module.
6489 =item CPAN::Module::look()
6491 Changes to the directory where the distribution associated with this
6492 module has been unpacked and opens a subshell there. Exiting the
6495 =item CPAN::Module::make()
6497 Runs a C<make> on the distribution associated with this module.
6499 =item CPAN::Module::manpage_headline()
6501 If module is installed, peeks into the module's manpage, reads the
6502 headline and returns it. Moreover, if the module has been downloaded
6503 within this session, does the equivalent on the downloaded module even
6504 if it is not installed.
6506 =item CPAN::Module::readme()
6508 Runs a C<readme> on the distribution associated with this module.
6510 =item CPAN::Module::test()
6512 Runs a C<test> on the distribution associated with this module.
6514 =item CPAN::Module::uptodate()
6516 Returns 1 if the module is installed and up-to-date.
6518 =item CPAN::Module::userid()
6520 Returns the author's ID of the module.
6524 =head2 Cache Manager
6526 Currently the cache manager only keeps track of the build directory
6527 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6528 deletes complete directories below C<build_dir> as soon as the size of
6529 all directories there gets bigger than $CPAN::Config->{build_cache}
6530 (in MB). The contents of this cache may be used for later
6531 re-installations that you intend to do manually, but will never be
6532 trusted by CPAN itself. This is due to the fact that the user might
6533 use these directories for building modules on different architectures.
6535 There is another directory ($CPAN::Config->{keep_source_where}) where
6536 the original distribution files are kept. This directory is not
6537 covered by the cache manager and must be controlled by the user. If
6538 you choose to have the same directory as build_dir and as
6539 keep_source_where directory, then your sources will be deleted with
6540 the same fifo mechanism.
6544 A bundle is just a perl module in the namespace Bundle:: that does not
6545 define any functions or methods. It usually only contains documentation.
6547 It starts like a perl module with a package declaration and a $VERSION
6548 variable. After that the pod section looks like any other pod with the
6549 only difference being that I<one special pod section> exists starting with
6554 In this pod section each line obeys the format
6556 Module_Name [Version_String] [- optional text]
6558 The only required part is the first field, the name of a module
6559 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6560 of the line is optional. The comment part is delimited by a dash just
6561 as in the man page header.
6563 The distribution of a bundle should follow the same convention as
6564 other distributions.
6566 Bundles are treated specially in the CPAN package. If you say 'install
6567 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6568 the modules in the CONTENTS section of the pod. You can install your
6569 own Bundles locally by placing a conformant Bundle file somewhere into
6570 your @INC path. The autobundle() command which is available in the
6571 shell interface does that for you by including all currently installed
6572 modules in a snapshot bundle file.
6574 =head2 Prerequisites
6576 If you have a local mirror of CPAN and can access all files with
6577 "file:" URLs, then you only need a perl better than perl5.003 to run
6578 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6579 required for non-UNIX systems or if your nearest CPAN site is
6580 associated with a URL that is not C<ftp:>.
6582 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6583 implemented for an external ftp command or for an external lynx
6586 =head2 Finding packages and VERSION
6588 This module presumes that all packages on CPAN
6594 declare their $VERSION variable in an easy to parse manner. This
6595 prerequisite can hardly be relaxed because it consumes far too much
6596 memory to load all packages into the running program just to determine
6597 the $VERSION variable. Currently all programs that are dealing with
6598 version use something like this
6600 perl -MExtUtils::MakeMaker -le \
6601 'print MM->parse_version(shift)' filename
6603 If you are author of a package and wonder if your $VERSION can be
6604 parsed, please try the above method.
6608 come as compressed or gzipped tarfiles or as zip files and contain a
6609 Makefile.PL (well, we try to handle a bit more, but without much
6616 The debugging of this module is a bit complex, because we have
6617 interferences of the software producing the indices on CPAN, of the
6618 mirroring process on CPAN, of packaging, of configuration, of
6619 synchronicity, and of bugs within CPAN.pm.
6621 For code debugging in interactive mode you can try "o debug" which
6622 will list options for debugging the various parts of the code. You
6623 should know that "o debug" has built-in completion support.
6625 For data debugging there is the C<dump> command which takes the same
6626 arguments as make/test/install and outputs the object's Data::Dumper
6629 =head2 Floppy, Zip, Offline Mode
6631 CPAN.pm works nicely without network too. If you maintain machines
6632 that are not networked at all, you should consider working with file:
6633 URLs. Of course, you have to collect your modules somewhere first. So
6634 you might use CPAN.pm to put together all you need on a networked
6635 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6636 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6637 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6638 with this floppy. See also below the paragraph about CD-ROM support.
6640 =head1 CONFIGURATION
6642 When the CPAN module is installed, a site wide configuration file is
6643 created as CPAN/Config.pm. The default values defined there can be
6644 overridden in another configuration file: CPAN/MyConfig.pm. You can
6645 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6646 $HOME/.cpan is added to the search path of the CPAN module before the
6647 use() or require() statements.
6649 Currently the following keys in the hash reference $CPAN::Config are
6652 build_cache size of cache for directories to build modules
6653 build_dir locally accessible directory to build modules
6654 index_expire after this many days refetch index files
6655 cache_metadata use serializer to cache metadata
6656 cpan_home local directory reserved for this package
6657 dontload_hash anonymous hash: modules in the keys will not be
6658 loaded by the CPAN::has_inst() routine
6659 gzip location of external program gzip
6660 inactivity_timeout breaks interactive Makefile.PLs after this
6661 many seconds inactivity. Set to 0 to never break.
6662 inhibit_startup_message
6663 if true, does not print the startup message
6664 keep_source_where directory in which to keep the source (if we do)
6665 make location of external make program
6666 make_arg arguments that should always be passed to 'make'
6667 make_install_arg same as make_arg for 'make install'
6668 makepl_arg arguments passed to 'perl Makefile.PL'
6669 pager location of external program more (or any pager)
6670 prerequisites_policy
6671 what to do if you are missing module prerequisites
6672 ('follow' automatically, 'ask' me, or 'ignore')
6673 proxy_user username for accessing an authenticating proxy
6674 proxy_pass password for accessing an authenticating proxy
6675 scan_cache controls scanning of cache ('atstart' or 'never')
6676 tar location of external program tar
6677 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6678 (and nonsense for characters outside latin range)
6679 unzip location of external program unzip
6680 urllist arrayref to nearby CPAN sites (or equivalent locations)
6681 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6682 ftp_proxy, } the three usual variables for configuring
6683 http_proxy, } proxy requests. Both as CPAN::Config variables
6684 no_proxy } and as environment variables configurable.
6686 You can set and query each of these options interactively in the cpan
6687 shell with the command set defined within the C<o conf> command:
6691 =item C<o conf E<lt>scalar optionE<gt>>
6693 prints the current value of the I<scalar option>
6695 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6697 Sets the value of the I<scalar option> to I<value>
6699 =item C<o conf E<lt>list optionE<gt>>
6701 prints the current value of the I<list option> in MakeMaker's
6704 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6706 shifts or pops the array in the I<list option> variable
6708 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6710 works like the corresponding perl commands.
6714 =head2 Note on urllist parameter's format
6716 urllist parameters are URLs according to RFC 1738. We do a little
6717 guessing if your URL is not compliant, but if you have problems with
6718 file URLs, please try the correct format. Either:
6720 file://localhost/whatever/ftp/pub/CPAN/
6724 file:///home/ftp/pub/CPAN/
6726 =head2 urllist parameter has CD-ROM support
6728 The C<urllist> parameter of the configuration table contains a list of
6729 URLs that are to be used for downloading. If the list contains any
6730 C<file> URLs, CPAN always tries to get files from there first. This
6731 feature is disabled for index files. So the recommendation for the
6732 owner of a CD-ROM with CPAN contents is: include your local, possibly
6733 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6735 o conf urllist push file://localhost/CDROM/CPAN
6737 CPAN.pm will then fetch the index files from one of the CPAN sites
6738 that come at the beginning of urllist. It will later check for each
6739 module if there is a local copy of the most recent version.
6741 Another peculiarity of urllist is that the site that we could
6742 successfully fetch the last file from automatically gets a preference
6743 token and is tried as the first site for the next request. So if you
6744 add a new site at runtime it may happen that the previously preferred
6745 site will be tried another time. This means that if you want to disallow
6746 a site for the next transfer, it must be explicitly removed from
6751 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6752 install foreign, unmasked, unsigned code on your machine. We compare
6753 to a checksum that comes from the net just as the distribution file
6754 itself. If somebody has managed to tamper with the distribution file,
6755 they may have as well tampered with the CHECKSUMS file. Future
6756 development will go towards strong authentication.
6760 Most functions in package CPAN are exported per default. The reason
6761 for this is that the primary use is intended for the cpan shell or for
6764 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6766 Populating a freshly installed perl with my favorite modules is pretty
6767 easy if you maintain a private bundle definition file. To get a useful
6768 blueprint of a bundle definition file, the command autobundle can be used
6769 on the CPAN shell command line. This command writes a bundle definition
6770 file for all modules that are installed for the currently running perl
6771 interpreter. It's recommended to run this command only once and from then
6772 on maintain the file manually under a private name, say
6773 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6775 cpan> install Bundle::my_bundle
6777 then answer a few questions and then go out for a coffee.
6779 Maintaining a bundle definition file means keeping track of two
6780 things: dependencies and interactivity. CPAN.pm sometimes fails on
6781 calculating dependencies because not all modules define all MakeMaker
6782 attributes correctly, so a bundle definition file should specify
6783 prerequisites as early as possible. On the other hand, it's a bit
6784 annoying that many distributions need some interactive configuring. So
6785 what I try to accomplish in my private bundle file is to have the
6786 packages that need to be configured early in the file and the gentle
6787 ones later, so I can go out after a few minutes and leave CPAN.pm
6790 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6792 Thanks to Graham Barr for contributing the following paragraphs about
6793 the interaction between perl, and various firewall configurations. For
6794 further informations on firewalls, it is recommended to consult the
6795 documentation that comes with the ncftp program. If you are unable to
6796 go through the firewall with a simple Perl setup, it is very likely
6797 that you can configure ncftp so that it works for your firewall.
6799 =head2 Three basic types of firewalls
6801 Firewalls can be categorized into three basic types.
6807 This is where the firewall machine runs a web server and to access the
6808 outside world you must do it via the web server. If you set environment
6809 variables like http_proxy or ftp_proxy to a values beginning with http://
6810 or in your web browser you have to set proxy information then you know
6811 you are running an http firewall.
6813 To access servers outside these types of firewalls with perl (even for
6814 ftp) you will need to use LWP.
6818 This where the firewall machine runs an ftp server. This kind of
6819 firewall will only let you access ftp servers outside the firewall.
6820 This is usually done by connecting to the firewall with ftp, then
6821 entering a username like "user@outside.host.com"
6823 To access servers outside these type of firewalls with perl you
6824 will need to use Net::FTP.
6826 =item One way visibility
6828 I say one way visibility as these firewalls try to make themselves look
6829 invisible to the users inside the firewall. An FTP data connection is
6830 normally created by sending the remote server your IP address and then
6831 listening for the connection. But the remote server will not be able to
6832 connect to you because of the firewall. So for these types of firewall
6833 FTP connections need to be done in a passive mode.
6835 There are two that I can think off.
6841 If you are using a SOCKS firewall you will need to compile perl and link
6842 it with the SOCKS library, this is what is normally called a 'socksified'
6843 perl. With this executable you will be able to connect to servers outside
6844 the firewall as if it is not there.
6848 This is the firewall implemented in the Linux kernel, it allows you to
6849 hide a complete network behind one IP address. With this firewall no
6850 special compiling is needed as you can access hosts directly.
6856 =head2 Configuring lynx or ncftp for going through a firewall
6858 If you can go through your firewall with e.g. lynx, presumably with a
6861 /usr/local/bin/lynx -pscott:tiger
6863 then you would configure CPAN.pm with the command
6865 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6867 That's all. Similarly for ncftp or ftp, you would configure something
6870 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6872 Your mileage may vary...
6880 I installed a new version of module X but CPAN keeps saying,
6881 I have the old version installed
6883 Most probably you B<do> have the old version installed. This can
6884 happen if a module installs itself into a different directory in the
6885 @INC path than it was previously installed. This is not really a
6886 CPAN.pm problem, you would have the same problem when installing the
6887 module manually. The easiest way to prevent this behaviour is to add
6888 the argument C<UNINST=1> to the C<make install> call, and that is why
6889 many people add this argument permanently by configuring
6891 o conf make_install_arg UNINST=1
6895 So why is UNINST=1 not the default?
6897 Because there are people who have their precise expectations about who
6898 may install where in the @INC path and who uses which @INC array. In
6899 fine tuned environments C<UNINST=1> can cause damage.
6903 I want to clean up my mess, and install a new perl along with
6904 all modules I have. How do I go about it?
6906 Run the autobundle command for your old perl and optionally rename the
6907 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6908 with the Configure option prefix, e.g.
6910 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6912 Install the bundle file you produced in the first step with something like
6914 cpan> install Bundle::mybundle
6920 When I install bundles or multiple modules with one command
6921 there is too much output to keep track of.
6923 You may want to configure something like
6925 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6926 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6928 so that STDOUT is captured in a file for later inspection.
6933 I am not root, how can I install a module in a personal directory?
6935 You will most probably like something like this:
6937 o conf makepl_arg "LIB=~/myperl/lib \
6938 INSTALLMAN1DIR=~/myperl/man/man1 \
6939 INSTALLMAN3DIR=~/myperl/man/man3"
6940 install Sybase::Sybperl
6942 You can make this setting permanent like all C<o conf> settings with
6945 You will have to add ~/myperl/man to the MANPATH environment variable
6946 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6949 use lib "$ENV{HOME}/myperl/lib";
6951 or setting the PERL5LIB environment variable.
6953 Another thing you should bear in mind is that the UNINST parameter
6954 should never be set if you are not root.
6958 How to get a package, unwrap it, and make a change before building it?
6960 look Sybase::Sybperl
6964 I installed a Bundle and had a couple of fails. When I
6965 retried, everything resolved nicely. Can this be fixed to work
6968 The reason for this is that CPAN does not know the dependencies of all
6969 modules when it starts out. To decide about the additional items to
6970 install, it just uses data found in the generated Makefile. An
6971 undetected missing piece breaks the process. But it may well be that
6972 your Bundle installs some prerequisite later than some depending item
6973 and thus your second try is able to resolve everything. Please note,
6974 CPAN.pm does not know the dependency tree in advance and cannot sort
6975 the queue of things to install in a topologically correct order. It
6976 resolves perfectly well IFF all modules declare the prerequisites
6977 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6978 fail and you need to install often, it is recommended sort the Bundle
6979 definition file manually. It is planned to improve the metadata
6980 situation for dependencies on CPAN in general, but this will still
6985 In our intranet we have many modules for internal use. How
6986 can I integrate these modules with CPAN.pm but without uploading
6987 the modules to CPAN?
6989 Have a look at the CPAN::Site module.
6993 When I run CPAN's shell, I get error msg about line 1 to 4,
6994 setting meta input/output via the /etc/inputrc file.
6996 Some versions of readline are picky about capitalization in the
6997 /etc/inputrc file and specifically RedHat 6.2 comes with a
6998 /etc/inputrc that contains the word C<on> in lowercase. Change the
6999 occurrences of C<on> to C<On> and the bug should disappear.
7003 Some authors have strange characters in their names.
7005 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7006 expecting ISO-8859-1 charset, a converter can be activated by setting
7007 term_is_latin to a true value in your config file. One way of doing so
7010 cpan> ! $CPAN::Config->{term_is_latin}=1
7012 Extended support for converters will be made available as soon as perl
7013 becomes stable with regard to charset issues.
7019 We should give coverage for B<all> of the CPAN and not just the PAUSE
7020 part, right? In this discussion CPAN and PAUSE have become equal --
7021 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7022 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7024 Future development should be directed towards a better integration of
7027 If a Makefile.PL requires special customization of libraries, prompts
7028 the user for special input, etc. then you may find CPAN is not able to
7029 build the distribution. In that case, you should attempt the
7030 traditional method of building a Perl module package from a shell.
7034 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7038 Kawai,Takanori provides a Japanese translation of this manpage at
7039 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7043 perl(1), CPAN::Nox(3)