1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 # $Id: CPAN.pm,v 1.397 2003/02/06 09:44:40 k Exp $
6 # only used during development:
8 # $Revision = "[".substr(q$Revision: 1.397 $, 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 if (my $histfile = $CPAN::Config->{'histfile'}) {{
116 unless ($term->can("AddHistory")) {
117 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
120 my($fh) = FileHandle->new;
121 open $fh, "<$histfile" or last;
125 $term->AddHistory($_);
129 # $term->OUT is autoflushed anyway
130 my $odef = select STDERR;
137 # no strict; # I do not recall why no strict was here (2000-09-03)
139 my $cwd = CPAN::anycwd();
140 my $try_detect_readline;
141 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
142 my $rl_avail = $Suppress_readline ? "suppressed" :
143 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
144 "available (try 'install Bundle::CPAN')";
146 $CPAN::Frontend->myprint(
148 cpan shell -- CPAN exploration and modules installation (v%s%s)
156 unless $CPAN::Config->{'inhibit_startup_message'} ;
157 my($continuation) = "";
158 SHELLCOMMAND: while () {
159 if ($Suppress_readline) {
161 last SHELLCOMMAND unless defined ($_ = <> );
164 last SHELLCOMMAND unless
165 defined ($_ = $term->readline($prompt, $commandline));
167 $_ = "$continuation$_" if $continuation;
169 next SHELLCOMMAND if /^$/;
170 $_ = 'h' if /^\s*\?/;
171 if (/^(?:q(?:uit)?|bye|exit)$/i) {
181 use vars qw($import_done);
182 CPAN->import(':DEFAULT') unless $import_done++;
183 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
190 if ($] < 5.00322) { # parsewords had a bug until recently
193 eval { @line = Text::ParseWords::shellwords($_) };
194 warn($@), next SHELLCOMMAND if $@;
195 warn("Text::Parsewords could not parse the line [$_]"),
196 next SHELLCOMMAND unless @line;
198 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
199 my $command = shift @line;
200 eval { CPAN::Shell->$command(@line) };
202 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
203 $CPAN::Frontend->myprint("\n");
208 $commandline = ""; # I do want to be able to pass a default to
209 # shell, but on the second command I see no
212 CPAN::Queue->nullify_queue;
213 if ($try_detect_readline) {
214 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
216 $CPAN::META->has_inst("Term::ReadLine::Perl")
218 delete $INC{"Term/ReadLine.pm"};
220 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
221 require Term::ReadLine;
222 $CPAN::Frontend->myprint("\n$redef subroutines in ".
223 "Term::ReadLine redefined\n");
229 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
232 package CPAN::CacheMgr;
233 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
236 package CPAN::Config;
237 use vars qw(%can $dot_cpan);
240 'commit' => "Commit changes to disk",
241 'defaults' => "Reload defaults from disk",
242 'init' => "Interactive setting of all options",
246 use vars qw($Ua $Thesite $Themethod);
247 @CPAN::FTP::ISA = qw(CPAN::Debug);
249 package CPAN::LWP::UserAgent;
250 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
251 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
253 package CPAN::Complete;
254 @CPAN::Complete::ISA = qw(CPAN::Debug);
255 @CPAN::Complete::COMMANDS = sort qw(
256 ! a b d h i m o q r u autobundle clean dump
257 make test install force readme reload look
259 ) unless @CPAN::Complete::COMMANDS;
262 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
263 @CPAN::Index::ISA = qw(CPAN::Debug);
266 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
269 package CPAN::InfoObj;
270 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
272 package CPAN::Author;
273 @CPAN::Author::ISA = qw(CPAN::InfoObj);
275 package CPAN::Distribution;
276 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
278 package CPAN::Bundle;
279 @CPAN::Bundle::ISA = qw(CPAN::Module);
281 package CPAN::Module;
282 @CPAN::Module::ISA = qw(CPAN::InfoObj);
285 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
286 @CPAN::Shell::ISA = qw(CPAN::Debug);
287 $COLOR_REGISTERED ||= 0;
288 $PRINT_ORNAMENTING ||= 0;
290 #-> sub CPAN::Shell::AUTOLOAD ;
292 my($autoload) = $AUTOLOAD;
293 my $class = shift(@_);
294 # warn "autoload[$autoload] class[$class]";
295 $autoload =~ s/.*:://;
296 if ($autoload =~ /^w/) {
297 if ($CPAN::META->has_inst('CPAN::WAIT')) {
298 CPAN::WAIT->$autoload(@_);
300 $CPAN::Frontend->mywarn(qq{
301 Commands starting with "w" require CPAN::WAIT to be installed.
302 Please consider installing CPAN::WAIT to use the fulltext index.
303 For this you just need to type
308 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
314 package CPAN::Tarzip;
315 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
316 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
317 $BUGHUNTING = 0; # released code must have turned off
321 # One use of the queue is to determine if we should or shouldn't
322 # announce the availability of a new CPAN module
324 # Now we try to use it for dependency tracking. For that to happen
325 # we need to draw a dependency tree and do the leaves first. This can
326 # easily be reached by running CPAN.pm recursively, but we don't want
327 # to waste memory and run into deep recursion. So what we can do is
330 # CPAN::Queue is the package where the queue is maintained. Dependencies
331 # often have high priority and must be brought to the head of the queue,
332 # possibly by jumping the queue if they are already there. My first code
333 # attempt tried to be extremely correct. Whenever a module needed
334 # immediate treatment, I either unshifted it to the front of the queue,
335 # or, if it was already in the queue, I spliced and let it bypass the
336 # others. This became a too correct model that made it impossible to put
337 # an item more than once into the queue. Why would you need that? Well,
338 # you need temporary duplicates as the manager of the queue is a loop
341 # (1) looks at the first item in the queue without shifting it off
343 # (2) cares for the item
345 # (3) removes the item from the queue, *even if its agenda failed and
346 # even if the item isn't the first in the queue anymore* (that way
347 # protecting against never ending queues)
349 # So if an item has prerequisites, the installation fails now, but we
350 # want to retry later. That's easy if we have it twice in the queue.
352 # I also expect insane dependency situations where an item gets more
353 # than two lives in the queue. Simplest example is triggered by 'install
354 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
355 # get in the way. I wanted the queue manager to be a dumb servant, not
356 # one that knows everything.
358 # Who would I tell in this model that the user wants to be asked before
359 # processing? I can't attach that information to the module object,
360 # because not modules are installed but distributions. So I'd have to
361 # tell the distribution object that it should ask the user before
362 # processing. Where would the question be triggered then? Most probably
363 # in CPAN::Distribution::rematein.
364 # Hope that makes sense, my head is a bit off:-) -- AK
371 my $self = bless { qmod => $s }, $class;
376 # CPAN::Queue::first ;
382 # CPAN::Queue::delete_first ;
384 my($class,$what) = @_;
386 for my $i (0..$#All) {
387 if ( $All[$i]->{qmod} eq $what ) {
394 # CPAN::Queue::jumpqueue ;
398 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
399 join(",",map {$_->{qmod}} @All),
402 WHAT: for my $what (reverse @what) {
404 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
405 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
406 if ($All[$i]->{qmod} eq $what){
408 if ($jumped > 100) { # one's OK if e.g. just
409 # processing now; more are OK if
410 # user typed it several times
411 $CPAN::Frontend->mywarn(
412 qq{Object [$what] queued more than 100 times, ignoring}
418 my $obj = bless { qmod => $what }, $class;
421 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
422 join(",",map {$_->{qmod}} @All),
427 # CPAN::Queue::exists ;
429 my($self,$what) = @_;
430 my @all = map { $_->{qmod} } @All;
431 my $exists = grep { $_->{qmod} eq $what } @All;
432 # warn "in exists what[$what] all[@all] exists[$exists]";
436 # CPAN::Queue::delete ;
439 @All = grep { $_->{qmod} ne $mod } @All;
442 # CPAN::Queue::nullify_queue ;
451 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
453 # from here on only subs.
454 ################################################################################
456 #-> sub CPAN::all_objects ;
458 my($mgr,$class) = @_;
459 CPAN::Config->load unless $CPAN::Config_loaded++;
460 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
462 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
464 *all = \&all_objects;
466 # Called by shell, not in batch mode. In batch mode I see no risk in
467 # having many processes updating something as installations are
468 # continually checked at runtime. In shell mode I suspect it is
469 # unintentional to open more than one shell at a time
471 #-> sub CPAN::checklock ;
474 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
475 if (-f $lockfile && -M _ > 0) {
476 my $fh = FileHandle->new($lockfile) or
477 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
478 my $otherpid = <$fh>;
479 my $otherhost = <$fh>;
481 if (defined $otherpid && $otherpid) {
484 if (defined $otherhost && $otherhost) {
487 my $thishost = hostname();
488 if (defined $otherhost && defined $thishost &&
489 $otherhost ne '' && $thishost ne '' &&
490 $otherhost ne $thishost) {
491 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
492 "reports other host $otherhost and other process $otherpid.\n".
493 "Cannot proceed.\n"));
495 elsif (defined $otherpid && $otherpid) {
496 return if $$ == $otherpid; # should never happen
497 $CPAN::Frontend->mywarn(
499 There seems to be running another CPAN process (pid $otherpid). Contacting...
501 if (kill 0, $otherpid) {
502 $CPAN::Frontend->mydie(qq{Other job is running.
503 You may want to kill it and delete the lockfile, maybe. On UNIX try:
507 } elsif (-w $lockfile) {
509 ExtUtils::MakeMaker::prompt
510 (qq{Other job not responding. Shall I overwrite }.
511 qq{the lockfile? (Y/N)},"y");
512 $CPAN::Frontend->myexit("Ok, bye\n")
513 unless $ans =~ /^y/i;
516 qq{Lockfile $lockfile not writeable by you. }.
517 qq{Cannot proceed.\n}.
520 qq{ and then rerun us.\n}
524 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
525 "reports other process with ID ".
526 "$otherpid. Cannot proceed.\n"));
529 my $dotcpan = $CPAN::Config->{cpan_home};
530 eval { File::Path::mkpath($dotcpan);};
532 # A special case at least for Jarkko.
537 $symlinkcpan = readlink $dotcpan;
538 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
539 eval { File::Path::mkpath($symlinkcpan); };
543 $CPAN::Frontend->mywarn(qq{
544 Working directory $symlinkcpan created.
548 unless (-d $dotcpan) {
550 Your configuration suggests "$dotcpan" as your
551 CPAN.pm working directory. I could not create this directory due
552 to this error: $firsterror\n};
554 As "$dotcpan" is a symlink to "$symlinkcpan",
555 I tried to create that, but I failed with this error: $seconderror
558 Please make sure the directory exists and is writable.
560 $CPAN::Frontend->mydie($diemess);
564 unless ($fh = FileHandle->new(">$lockfile")) {
565 if ($! =~ /Permission/) {
566 my $incc = $INC{'CPAN/Config.pm'};
567 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
568 $CPAN::Frontend->myprint(qq{
570 Your configuration suggests that CPAN.pm should use a working
572 $CPAN::Config->{cpan_home}
573 Unfortunately we could not create the lock file
575 due to permission problems.
577 Please make sure that the configuration variable
578 \$CPAN::Config->{cpan_home}
579 points to a directory where you can write a .lock file. You can set
580 this variable in either
587 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
589 $fh->print($$, "\n");
590 $fh->print(hostname(), "\n");
591 $self->{LOCK} = $lockfile;
595 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
600 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
601 print "Caught SIGINT\n";
605 # From: Larry Wall <larry@wall.org>
606 # Subject: Re: deprecating SIGDIE
607 # To: perl5-porters@perl.org
608 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
610 # The original intent of __DIE__ was only to allow you to substitute one
611 # kind of death for another on an application-wide basis without respect
612 # to whether you were in an eval or not. As a global backstop, it should
613 # not be used any more lightly (or any more heavily :-) than class
614 # UNIVERSAL. Any attempt to build a general exception model on it should
615 # be politely squashed. Any bug that causes every eval {} to have to be
616 # modified should be not so politely squashed.
618 # Those are my current opinions. It is also my optinion that polite
619 # arguments degenerate to personal arguments far too frequently, and that
620 # when they do, it's because both people wanted it to, or at least didn't
621 # sufficiently want it not to.
625 # global backstop to cleanup if we should really die
626 $SIG{__DIE__} = \&cleanup;
627 $self->debug("Signal handler set.") if $CPAN::DEBUG;
630 #-> sub CPAN::DESTROY ;
632 &cleanup; # need an eval?
635 #-> sub CPAN::anycwd ;
638 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
643 sub cwd {Cwd::cwd();}
645 #-> sub CPAN::getcwd ;
646 sub getcwd {Cwd::getcwd();}
648 #-> sub CPAN::exists ;
650 my($mgr,$class,$id) = @_;
651 CPAN::Config->load unless $CPAN::Config_loaded++;
653 ### Carp::croak "exists called without class argument" unless $class;
655 exists $META->{readonly}{$class}{$id} or
656 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
659 #-> sub CPAN::delete ;
661 my($mgr,$class,$id) = @_;
662 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
663 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
666 #-> sub CPAN::has_usable
667 # has_inst is sometimes too optimistic, we should replace it with this
668 # has_usable whenever a case is given
670 my($self,$mod,$message) = @_;
671 return 1 if $HAS_USABLE->{$mod};
672 my $has_inst = $self->has_inst($mod,$message);
673 return unless $has_inst;
676 LWP => [ # we frequently had "Can't locate object
677 # method "new" via package "LWP::UserAgent" at
678 # (eval 69) line 2006
680 sub {require LWP::UserAgent},
681 sub {require HTTP::Request},
682 sub {require URI::URL},
685 sub {require Net::FTP},
686 sub {require Net::Config},
689 if ($usable->{$mod}) {
690 for my $c (0..$#{$usable->{$mod}}) {
691 my $code = $usable->{$mod}[$c];
692 my $ret = eval { &$code() };
694 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
699 return $HAS_USABLE->{$mod} = 1;
702 #-> sub CPAN::has_inst
704 my($self,$mod,$message) = @_;
705 Carp::croak("CPAN->has_inst() called without an argument")
707 if (defined $message && $message eq "no"
709 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
711 exists $CPAN::Config->{dontload_hash}{$mod}
713 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
719 $file =~ s|/|\\|g if $^O eq 'MSWin32';
722 # checking %INC is wrong, because $INC{LWP} may be true
723 # although $INC{"URI/URL.pm"} may have failed. But as
724 # I really want to say "bla loaded OK", I have to somehow
726 ### warn "$file in %INC"; #debug
728 } elsif (eval { require $file }) {
729 # eval is good: if we haven't yet read the database it's
730 # perfect and if we have installed the module in the meantime,
731 # it tries again. The second require is only a NOOP returning
732 # 1 if we had success, otherwise it's retrying
734 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
735 if ($mod eq "CPAN::WAIT") {
736 push @CPAN::Shell::ISA, CPAN::WAIT;
739 } elsif ($mod eq "Net::FTP") {
740 $CPAN::Frontend->mywarn(qq{
741 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
743 install Bundle::libnet
745 }) unless $Have_warned->{"Net::FTP"}++;
747 } elsif ($mod eq "Digest::MD5"){
748 $CPAN::Frontend->myprint(qq{
749 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
750 Please consider installing the Digest::MD5 module.
755 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
760 #-> sub CPAN::instance ;
762 my($mgr,$class,$id) = @_;
765 # unsafe meta access, ok?
766 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
767 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
775 #-> sub CPAN::cleanup ;
777 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
778 local $SIG{__DIE__} = '';
783 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
785 $subroutine eq '(eval)';
787 return if $ineval && !$End;
788 return unless defined $META->{LOCK};
789 return unless -f $META->{LOCK};
791 unlink $META->{LOCK};
793 # Carp::cluck("DEBUGGING");
794 $CPAN::Frontend->mywarn("Lockfile removed.\n");
797 #-> sub CPAN::savehist
800 my($histfile,$histsize);
801 unless ($histfile = $CPAN::Config->{'histfile'}){
802 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
805 $histsize = $CPAN::Config->{'histsize'} || 100;
806 unless ($CPAN::term->can("GetHistory")) {
807 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
810 my @h = $CPAN::term->GetHistory;
811 splice @h, 0, @h-$histsize if @h>$histsize;
812 my($fh) = FileHandle->new;
813 open $fh, ">$histfile" or mydie("Couldn't open >$histfile: $!");
814 local $\ = local $, = "\n";
820 my($self,$what) = @_;
821 $self->{is_tested}{$what} = 1;
825 my($self,$what) = @_;
826 delete $self->{is_tested}{$what};
831 $self->{is_tested} ||= {};
832 return unless %{$self->{is_tested}};
833 my $env = $ENV{PERL5LIB};
834 $env = $ENV{PERLLIB} unless defined $env;
836 push @env, $env if defined $env and length $env;
837 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
838 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
839 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
842 package CPAN::CacheMgr;
844 #-> sub CPAN::CacheMgr::as_string ;
846 eval { require Data::Dumper };
848 return shift->SUPER::as_string;
850 return Data::Dumper::Dumper(shift);
854 #-> sub CPAN::CacheMgr::cachesize ;
859 #-> sub CPAN::CacheMgr::tidyup ;
862 return unless -d $self->{ID};
863 while ($self->{DU} > $self->{'MAX'} ) {
864 my($toremove) = shift @{$self->{FIFO}};
865 $CPAN::Frontend->myprint(sprintf(
866 "Deleting from cache".
867 ": $toremove (%.1f>%.1f MB)\n",
868 $self->{DU}, $self->{'MAX'})
870 return if $CPAN::Signal;
871 $self->force_clean_cache($toremove);
872 return if $CPAN::Signal;
876 #-> sub CPAN::CacheMgr::dir ;
881 #-> sub CPAN::CacheMgr::entries ;
884 return unless defined $dir;
885 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
886 $dir ||= $self->{ID};
887 my($cwd) = CPAN::anycwd();
888 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
889 my $dh = DirHandle->new(File::Spec->curdir)
890 or Carp::croak("Couldn't opendir $dir: $!");
893 next if $_ eq "." || $_ eq "..";
895 push @entries, File::Spec->catfile($dir,$_);
897 push @entries, File::Spec->catdir($dir,$_);
899 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
902 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
903 sort { -M $b <=> -M $a} @entries;
906 #-> sub CPAN::CacheMgr::disk_usage ;
909 return if exists $self->{SIZE}{$dir};
910 return if $CPAN::Signal;
914 $File::Find::prune++ if $CPAN::Signal;
916 if ($^O eq 'MacOS') {
918 my $cat = Mac::Files::FSpGetCatInfo($_);
919 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
926 return if $CPAN::Signal;
927 $self->{SIZE}{$dir} = $Du/1024/1024;
928 push @{$self->{FIFO}}, $dir;
929 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
930 $self->{DU} += $Du/1024/1024;
934 #-> sub CPAN::CacheMgr::force_clean_cache ;
935 sub force_clean_cache {
937 return unless -e $dir;
938 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
940 File::Path::rmtree($dir);
941 $self->{DU} -= $self->{SIZE}{$dir};
942 delete $self->{SIZE}{$dir};
945 #-> sub CPAN::CacheMgr::new ;
952 ID => $CPAN::Config->{'build_dir'},
953 MAX => $CPAN::Config->{'build_cache'},
954 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
957 File::Path::mkpath($self->{ID});
958 my $dh = DirHandle->new($self->{ID});
962 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
964 CPAN->debug($debug) if $CPAN::DEBUG;
968 #-> sub CPAN::CacheMgr::scan_cache ;
971 return if $self->{SCAN} eq 'never';
972 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
973 unless $self->{SCAN} eq 'atstart';
974 $CPAN::Frontend->myprint(
975 sprintf("Scanning cache %s for sizes\n",
978 for $e ($self->entries($self->{ID})) {
979 next if $e eq ".." || $e eq ".";
980 $self->disk_usage($e);
981 return if $CPAN::Signal;
988 #-> sub CPAN::Debug::debug ;
991 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
992 # Complete, caller(1)
994 ($caller) = caller(0);
996 $arg = "" unless defined $arg;
997 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
998 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
999 if ($arg and ref $arg) {
1000 eval { require Data::Dumper };
1002 $CPAN::Frontend->myprint($arg->as_string);
1004 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
1007 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
1012 package CPAN::Config;
1014 #-> sub CPAN::Config::edit ;
1015 # returns true on successful action
1017 my($self,@args) = @_;
1018 return unless @args;
1019 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
1020 my($o,$str,$func,$args,$key_exists);
1026 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1027 if ($o =~ /list$/) {
1028 $func = shift @args;
1030 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1032 # Let's avoid eval, it's easier to comprehend without.
1033 if ($func eq "push") {
1034 push @{$CPAN::Config->{$o}}, @args;
1036 } elsif ($func eq "pop") {
1037 pop @{$CPAN::Config->{$o}};
1039 } elsif ($func eq "shift") {
1040 shift @{$CPAN::Config->{$o}};
1042 } elsif ($func eq "unshift") {
1043 unshift @{$CPAN::Config->{$o}}, @args;
1045 } elsif ($func eq "splice") {
1046 splice @{$CPAN::Config->{$o}}, @args;
1049 $CPAN::Config->{$o} = [@args];
1052 $self->prettyprint($o);
1054 if ($o eq "urllist" && $changed) {
1055 # reset the cached values
1056 undef $CPAN::FTP::Thesite;
1057 undef $CPAN::FTP::Themethod;
1061 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1062 $self->prettyprint($o);
1069 my $v = $CPAN::Config->{$k};
1071 my(@report) = ref $v eq "ARRAY" ?
1073 map { sprintf(" %-18s => %s\n",
1075 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1077 $CPAN::Frontend->myprint(
1084 map {"\t$_\n"} @report
1087 } elsif (defined $v) {
1088 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1090 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1094 #-> sub CPAN::Config::commit ;
1096 my($self,$configpm) = @_;
1097 unless (defined $configpm){
1098 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1099 $configpm ||= $INC{"CPAN/Config.pm"};
1100 $configpm || Carp::confess(q{
1101 CPAN::Config::commit called without an argument.
1102 Please specify a filename where to save the configuration or try
1103 "o conf init" to have an interactive course through configing.
1108 $mode = (stat $configpm)[2];
1109 if ($mode && ! -w _) {
1110 Carp::confess("$configpm is not writable");
1115 $msg = <<EOF unless $configpm =~ /MyConfig/;
1117 # This is CPAN.pm's systemwide configuration file. This file provides
1118 # defaults for users, and the values can be changed in a per-user
1119 # configuration file. The user-config file is being looked for as
1120 # ~/.cpan/CPAN/MyConfig.pm.
1124 my($fh) = FileHandle->new;
1125 rename $configpm, "$configpm~" if -f $configpm;
1126 open $fh, ">$configpm" or
1127 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1128 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1129 foreach (sort keys %$CPAN::Config) {
1132 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1137 $fh->print("};\n1;\n__END__\n");
1140 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1141 #chmod $mode, $configpm;
1142 ###why was that so? $self->defaults;
1143 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1147 *default = \&defaults;
1148 #-> sub CPAN::Config::defaults ;
1158 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1167 # This is a piece of repeated code that is abstracted here for
1168 # maintainability. RMB
1171 my($configpmdir, $configpmtest) = @_;
1172 if (-w $configpmtest) {
1173 return $configpmtest;
1174 } elsif (-w $configpmdir) {
1175 #_#_# following code dumped core on me with 5.003_11, a.k.
1176 my $configpm_bak = "$configpmtest.bak";
1177 unlink $configpm_bak if -f $configpm_bak;
1178 if( -f $configpmtest ) {
1179 if( rename $configpmtest, $configpm_bak ) {
1180 $CPAN::Frontend->mywarn(<<END)
1181 Old configuration file $configpmtest
1182 moved to $configpm_bak
1186 my $fh = FileHandle->new;
1187 if ($fh->open(">$configpmtest")) {
1189 return $configpmtest;
1191 # Should never happen
1192 Carp::confess("Cannot open >$configpmtest");
1197 #-> sub CPAN::Config::load ;
1202 eval {require CPAN::Config;}; # We eval because of some
1203 # MakeMaker problems
1204 unless ($dot_cpan++){
1205 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1206 eval {require CPAN::MyConfig;}; # where you can override
1207 # system wide settings
1210 return unless @miss = $self->missing_config_data;
1212 require CPAN::FirstTime;
1213 my($configpm,$fh,$redo,$theycalled);
1215 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1216 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1217 $configpm = $INC{"CPAN/Config.pm"};
1219 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1220 $configpm = $INC{"CPAN/MyConfig.pm"};
1223 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1224 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1225 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1226 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1227 $configpm = _configpmtest($configpmdir,$configpmtest);
1229 unless ($configpm) {
1230 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1231 File::Path::mkpath($configpmdir);
1232 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1233 $configpm = _configpmtest($configpmdir,$configpmtest);
1234 unless ($configpm) {
1235 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1236 qq{create a configuration file.});
1241 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1242 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1246 $CPAN::Frontend->myprint(qq{
1247 $configpm initialized.
1250 CPAN::FirstTime::init($configpm);
1253 #-> sub CPAN::Config::missing_config_data ;
1254 sub missing_config_data {
1257 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1258 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1260 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1261 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1262 "prerequisites_policy",
1265 push @miss, $_ unless defined $CPAN::Config->{$_};
1270 #-> sub CPAN::Config::unload ;
1272 delete $INC{'CPAN/MyConfig.pm'};
1273 delete $INC{'CPAN/Config.pm'};
1276 #-> sub CPAN::Config::help ;
1278 $CPAN::Frontend->myprint(q[
1280 defaults reload default config values from disk
1281 commit commit session changes to disk
1282 init go through a dialog to set all parameters
1284 You may edit key values in the follow fashion (the "o" is a literal
1287 o conf build_cache 15
1289 o conf build_dir "/foo/bar"
1291 o conf urllist shift
1293 o conf urllist unshift ftp://ftp.foo.bar/
1296 undef; #don't reprint CPAN::Config
1299 #-> sub CPAN::Config::cpl ;
1301 my($word,$line,$pos) = @_;
1303 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1304 my(@words) = split " ", substr($line,0,$pos+1);
1309 $words[2] =~ /list$/ && @words == 3
1311 $words[2] =~ /list$/ && @words == 4 && length($word)
1314 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1315 } elsif (@words >= 4) {
1318 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1319 return grep /^\Q$word\E/, @o_conf;
1322 package CPAN::Shell;
1324 #-> sub CPAN::Shell::h ;
1326 my($class,$about) = @_;
1327 if (defined $about) {
1328 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1330 $CPAN::Frontend->myprint(q{
1332 command argument description
1333 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1334 i WORD or /REGEXP/ about anything of above
1335 r NONE reinstall recommendations
1336 ls AUTHOR about files in the author's directory
1338 Download, Test, Make, Install...
1340 make make (implies get)
1341 test MODULES, make test (implies make)
1342 install DISTS, BUNDLES make install (implies test)
1344 look open subshell in these dists' directories
1345 readme display these dists' README files
1348 h,? display this menu ! perl-code eval a perl command
1349 o conf [opt] set and query options q quit the cpan shell
1350 reload cpan load CPAN.pm again reload index load newer indices
1351 autobundle Snapshot force cmd unconditionally do cmd});
1357 #-> sub CPAN::Shell::a ;
1359 my($self,@arg) = @_;
1360 # authors are always UPPERCASE
1362 $_ = uc $_ unless /=/;
1364 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1367 #-> sub CPAN::Shell::ls ;
1369 my($self,@arg) = @_;
1372 unless (/^[A-Z\-]+$/i) {
1373 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1376 push @accept, uc $_;
1378 for my $a (@accept){
1379 my $author = $self->expand('Author',$a) or die "No author found for $a";
1384 #-> sub CPAN::Shell::local_bundles ;
1386 my($self,@which) = @_;
1387 my($incdir,$bdir,$dh);
1388 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1389 my @bbase = "Bundle";
1390 while (my $bbase = shift @bbase) {
1391 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1392 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1393 if ($dh = DirHandle->new($bdir)) { # may fail
1395 for $entry ($dh->read) {
1396 next if $entry =~ /^\./;
1397 if (-d File::Spec->catdir($bdir,$entry)){
1398 push @bbase, "$bbase\::$entry";
1400 next unless $entry =~ s/\.pm(?!\n)\Z//;
1401 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1409 #-> sub CPAN::Shell::b ;
1411 my($self,@which) = @_;
1412 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1413 $self->local_bundles;
1414 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1417 #-> sub CPAN::Shell::d ;
1418 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1420 #-> sub CPAN::Shell::m ;
1421 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1422 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1425 #-> sub CPAN::Shell::i ;
1430 @type = qw/Author Bundle Distribution Module/;
1431 @args = '/./' unless @args;
1434 push @result, $self->expand($type,@args);
1436 my $result = @result == 1 ?
1437 $result[0]->as_string :
1439 "No objects found of any type for argument @args\n" :
1441 (map {$_->as_glimpse} @result),
1442 scalar @result, " items found\n",
1444 $CPAN::Frontend->myprint($result);
1447 #-> sub CPAN::Shell::o ;
1449 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1450 # should have been called set and 'o debug' maybe 'set debug'
1452 my($self,$o_type,@o_what) = @_;
1454 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1455 if ($o_type eq 'conf') {
1456 shift @o_what if @o_what && $o_what[0] eq 'help';
1457 if (!@o_what) { # print all things, "o conf"
1459 $CPAN::Frontend->myprint("CPAN::Config options");
1460 if (exists $INC{'CPAN/Config.pm'}) {
1461 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1463 if (exists $INC{'CPAN/MyConfig.pm'}) {
1464 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1466 $CPAN::Frontend->myprint(":\n");
1467 for $k (sort keys %CPAN::Config::can) {
1468 $v = $CPAN::Config::can{$k};
1469 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1471 $CPAN::Frontend->myprint("\n");
1472 for $k (sort keys %$CPAN::Config) {
1473 CPAN::Config->prettyprint($k);
1475 $CPAN::Frontend->myprint("\n");
1476 } elsif (!CPAN::Config->edit(@o_what)) {
1477 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1478 qq{edit options\n\n});
1480 } elsif ($o_type eq 'debug') {
1482 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1485 my($what) = shift @o_what;
1486 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1487 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1490 if ( exists $CPAN::DEBUG{$what} ) {
1491 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1492 } elsif ($what =~ /^\d/) {
1493 $CPAN::DEBUG = $what;
1494 } elsif (lc $what eq 'all') {
1496 for (values %CPAN::DEBUG) {
1499 $CPAN::DEBUG = $max;
1502 for (keys %CPAN::DEBUG) {
1503 next unless lc($_) eq lc($what);
1504 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1507 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1512 my $raw = "Valid options for debug are ".
1513 join(", ",sort(keys %CPAN::DEBUG), 'all').
1514 qq{ or a number. Completion works on the options. }.
1515 qq{Case is ignored.};
1517 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1518 $CPAN::Frontend->myprint("\n\n");
1521 $CPAN::Frontend->myprint("Options set for debugging:\n");
1523 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1524 $v = $CPAN::DEBUG{$k};
1525 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1526 if $v & $CPAN::DEBUG;
1529 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1532 $CPAN::Frontend->myprint(qq{
1534 conf set or get configuration variables
1535 debug set or get debugging options
1540 sub paintdots_onreload {
1543 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1547 # $CPAN::Frontend->myprint(".($subr)");
1548 $CPAN::Frontend->myprint(".");
1555 #-> sub CPAN::Shell::reload ;
1557 my($self,$command,@arg) = @_;
1559 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1560 if ($command =~ /cpan/i) {
1561 for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1562 next unless $INC{$f};
1563 CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
1564 my $fh = FileHandle->new($INC{$f});
1567 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1570 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1572 } elsif ($command =~ /index/) {
1573 CPAN::Index->force_reload;
1575 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1576 index re-reads the index files\n});
1580 #-> sub CPAN::Shell::_binary_extensions ;
1581 sub _binary_extensions {
1582 my($self) = shift @_;
1583 my(@result,$module,%seen,%need,$headerdone);
1584 for $module ($self->expand('Module','/./')) {
1585 my $file = $module->cpan_file;
1586 next if $file eq "N/A";
1587 next if $file =~ /^Contact Author/;
1588 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1589 next if $dist->isa_perl;
1590 next unless $module->xs_file;
1592 $CPAN::Frontend->myprint(".");
1593 push @result, $module;
1595 # print join " | ", @result;
1596 $CPAN::Frontend->myprint("\n");
1600 #-> sub CPAN::Shell::recompile ;
1602 my($self) = shift @_;
1603 my($module,@module,$cpan_file,%dist);
1604 @module = $self->_binary_extensions();
1605 for $module (@module){ # we force now and compile later, so we
1607 $cpan_file = $module->cpan_file;
1608 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1610 $dist{$cpan_file}++;
1612 for $cpan_file (sort keys %dist) {
1613 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1614 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1616 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1617 # stop a package from recompiling,
1618 # e.g. IO-1.12 when we have perl5.003_10
1622 #-> sub CPAN::Shell::_u_r_common ;
1624 my($self) = shift @_;
1625 my($what) = shift @_;
1626 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1627 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1628 $what && $what =~ /^[aru]$/;
1630 @args = '/./' unless @args;
1631 my(@result,$module,%seen,%need,$headerdone,
1632 $version_undefs,$version_zeroes);
1633 $version_undefs = $version_zeroes = 0;
1634 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1635 my @expand = $self->expand('Module',@args);
1636 my $expand = scalar @expand;
1637 if (0) { # Looks like noise to me, was very useful for debugging
1638 # for metadata cache
1639 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1641 for $module (@expand) {
1642 my $file = $module->cpan_file;
1643 next unless defined $file; # ??
1644 my($latest) = $module->cpan_version;
1645 my($inst_file) = $module->inst_file;
1647 return if $CPAN::Signal;
1650 $have = $module->inst_version;
1651 } elsif ($what eq "r") {
1652 $have = $module->inst_version;
1654 if ($have eq "undef"){
1656 } elsif ($have == 0){
1659 next unless CPAN::Version->vgt($latest, $have);
1660 # to be pedantic we should probably say:
1661 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1662 # to catch the case where CPAN has a version 0 and we have a version undef
1663 } elsif ($what eq "u") {
1669 } elsif ($what eq "r") {
1671 } elsif ($what eq "u") {
1675 return if $CPAN::Signal; # this is sometimes lengthy
1678 push @result, sprintf "%s %s\n", $module->id, $have;
1679 } elsif ($what eq "r") {
1680 push @result, $module->id;
1681 next if $seen{$file}++;
1682 } elsif ($what eq "u") {
1683 push @result, $module->id;
1684 next if $seen{$file}++;
1685 next if $file =~ /^Contact/;
1687 unless ($headerdone++){
1688 $CPAN::Frontend->myprint("\n");
1689 $CPAN::Frontend->myprint(sprintf(
1692 "Package namespace",
1704 $CPAN::META->has_inst("Term::ANSIColor")
1706 $module->{RO}{description}
1708 $color_on = Term::ANSIColor::color("green");
1709 $color_off = Term::ANSIColor::color("reset");
1711 $CPAN::Frontend->myprint(sprintf $sprintf,
1718 $need{$module->id}++;
1722 $CPAN::Frontend->myprint("No modules found for @args\n");
1723 } elsif ($what eq "r") {
1724 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1728 if ($version_zeroes) {
1729 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1730 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1731 qq{a version number of 0\n});
1733 if ($version_undefs) {
1734 my $s_has = $version_undefs > 1 ? "s have" : " has";
1735 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1736 qq{parseable version number\n});
1742 #-> sub CPAN::Shell::r ;
1744 shift->_u_r_common("r",@_);
1747 #-> sub CPAN::Shell::u ;
1749 shift->_u_r_common("u",@_);
1752 #-> sub CPAN::Shell::autobundle ;
1755 CPAN::Config->load unless $CPAN::Config_loaded++;
1756 my(@bundle) = $self->_u_r_common("a",@_);
1757 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1758 File::Path::mkpath($todir);
1759 unless (-d $todir) {
1760 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1763 my($y,$m,$d) = (localtime)[5,4,3];
1767 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1768 my($to) = File::Spec->catfile($todir,"$me.pm");
1770 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1771 $to = File::Spec->catfile($todir,"$me.pm");
1773 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1775 "package Bundle::$me;\n\n",
1776 "\$VERSION = '0.01';\n\n",
1780 "Bundle::$me - Snapshot of installation on ",
1781 $Config::Config{'myhostname'},
1784 "\n\n=head1 SYNOPSIS\n\n",
1785 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1786 "=head1 CONTENTS\n\n",
1787 join("\n", @bundle),
1788 "\n\n=head1 CONFIGURATION\n\n",
1790 "\n\n=head1 AUTHOR\n\n",
1791 "This Bundle has been generated automatically ",
1792 "by the autobundle routine in CPAN.pm.\n",
1795 $CPAN::Frontend->myprint("\nWrote bundle file
1799 #-> sub CPAN::Shell::expandany ;
1802 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1803 if ($s =~ m|/|) { # looks like a file
1804 $s = CPAN::Distribution->normalize($s);
1805 return $CPAN::META->instance('CPAN::Distribution',$s);
1806 # Distributions spring into existence, not expand
1807 } elsif ($s =~ m|^Bundle::|) {
1808 $self->local_bundles; # scanning so late for bundles seems
1809 # both attractive and crumpy: always
1810 # current state but easy to forget
1812 return $self->expand('Bundle',$s);
1814 return $self->expand('Module',$s)
1815 if $CPAN::META->exists('CPAN::Module',$s);
1820 #-> sub CPAN::Shell::expand ;
1823 my($type,@args) = @_;
1825 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1827 my($regex,$command);
1828 if ($arg =~ m|^/(.*)/$|) {
1830 } elsif ($arg =~ m/=/) {
1833 my $class = "CPAN::$type";
1835 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1837 defined $regex ? $regex : "UNDEFINED",
1838 $command || "UNDEFINED",
1840 if (defined $regex) {
1844 $CPAN::META->all_objects($class)
1847 # BUG, we got an empty object somewhere
1848 require Data::Dumper;
1849 CPAN->debug(sprintf(
1850 "Bug in CPAN: Empty id on obj[%s][%s]",
1852 Data::Dumper::Dumper($obj)
1857 if $obj->id =~ /$regex/i
1861 $] < 5.00303 ### provide sort of
1862 ### compatibility with 5.003
1867 $obj->name =~ /$regex/i
1870 } elsif ($command) {
1871 die "equal sign in command disabled (immature interface), ".
1873 ! \$CPAN::Shell::ADVANCED_QUERY=1
1874 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1875 that may go away anytime.\n"
1876 unless $ADVANCED_QUERY;
1877 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1878 my($matchcrit) = $criterion =~ m/^~(.+)/;
1882 $CPAN::META->all_objects($class)
1884 my $lhs = $self->$method() or next; # () for 5.00503
1886 push @m, $self if $lhs =~ m/$matchcrit/;
1888 push @m, $self if $lhs eq $criterion;
1893 if ( $type eq 'Bundle' ) {
1894 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1895 } elsif ($type eq "Distribution") {
1896 $xarg = CPAN::Distribution->normalize($arg);
1898 if ($CPAN::META->exists($class,$xarg)) {
1899 $obj = $CPAN::META->instance($class,$xarg);
1900 } elsif ($CPAN::META->exists($class,$arg)) {
1901 $obj = $CPAN::META->instance($class,$arg);
1908 return wantarray ? @m : $m[0];
1911 #-> sub CPAN::Shell::format_result ;
1914 my($type,@args) = @_;
1915 @args = '/./' unless @args;
1916 my(@result) = $self->expand($type,@args);
1917 my $result = @result == 1 ?
1918 $result[0]->as_string :
1920 "No objects of type $type found for argument @args\n" :
1922 (map {$_->as_glimpse} @result),
1923 scalar @result, " items found\n",
1928 # The only reason for this method is currently to have a reliable
1929 # debugging utility that reveals which output is going through which
1930 # channel. No, I don't like the colors ;-)
1932 #-> sub CPAN::Shell::print_ornameted ;
1933 sub print_ornamented {
1934 my($self,$what,$ornament) = @_;
1936 return unless defined $what;
1938 if ($CPAN::Config->{term_is_latin}){
1941 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1943 if ($PRINT_ORNAMENTING) {
1944 unless (defined &color) {
1945 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1946 import Term::ANSIColor "color";
1948 *color = sub { return "" };
1952 for $line (split /\n/, $what) {
1953 $longest = length($line) if length($line) > $longest;
1955 my $sprintf = "%-" . $longest . "s";
1957 $what =~ s/(.*\n?)//m;
1960 my($nl) = chomp $line ? "\n" : "";
1961 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1962 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1966 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
1972 my($self,$what) = @_;
1974 $self->print_ornamented($what, 'bold blue on_yellow');
1978 my($self,$what) = @_;
1979 $self->myprint($what);
1984 my($self,$what) = @_;
1985 $self->print_ornamented($what, 'bold red on_yellow');
1989 my($self,$what) = @_;
1990 $self->print_ornamented($what, 'bold red on_white');
1991 Carp::confess "died";
1995 my($self,$what) = @_;
1996 $self->print_ornamented($what, 'bold red on_white');
2001 return if -t STDOUT;
2002 my $odef = select STDERR;
2009 #-> sub CPAN::Shell::rematein ;
2010 # RE-adme||MA-ke||TE-st||IN-stall
2013 my($meth,@some) = @_;
2015 if ($meth eq 'force') {
2017 $meth = shift @some;
2020 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
2022 # Here is the place to set "test_count" on all involved parties to
2023 # 0. We then can pass this counter on to the involved
2024 # distributions and those can refuse to test if test_count > X. In
2025 # the first stab at it we could use a 1 for "X".
2027 # But when do I reset the distributions to start with 0 again?
2028 # Jost suggested to have a random or cycling interaction ID that
2029 # we pass through. But the ID is something that is just left lying
2030 # around in addition to the counter, so I'd prefer to set the
2031 # counter to 0 now, and repeat at the end of the loop. But what
2032 # about dependencies? They appear later and are not reset, they
2033 # enter the queue but not its copy. How do they get a sensible
2036 # construct the queue
2038 foreach $s (@some) {
2041 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2043 } elsif ($s =~ m|^/|) { # looks like a regexp
2044 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2049 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2050 $obj = CPAN::Shell->expandany($s);
2053 $obj->color_cmd_tmps(0,1);
2054 CPAN::Queue->new($obj->id);
2056 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2057 $obj = $CPAN::META->instance('CPAN::Author',$s);
2058 if ($meth =~ /^(dump|ls)$/) {
2061 $CPAN::Frontend->myprint(
2063 "Don't be silly, you can't $meth ",
2071 ->myprint(qq{Warning: Cannot $meth $s, }.
2072 qq{don\'t know what it is.
2077 to find objects with matching identifiers.
2083 # queuerunner (please be warned: when I started to change the
2084 # queue to hold objects instead of names, I made one or two
2085 # mistakes and never found which. I reverted back instead)
2086 while ($s = CPAN::Queue->first) {
2089 $obj = $s; # I do not believe, we would survive if this happened
2091 $obj = CPAN::Shell->expandany($s);
2095 ($] < 5.00303 || $obj->can($pragma))){
2096 ### compatibility with 5.003
2097 $obj->$pragma($meth); # the pragma "force" in
2098 # "CPAN::Distribution" must know
2099 # what we are intending
2101 if ($]>=5.00303 && $obj->can('called_for')) {
2102 $obj->called_for($s);
2105 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2111 CPAN::Queue->delete($s);
2113 CPAN->debug("failed");
2117 CPAN::Queue->delete_first($s);
2119 for my $obj (@qcopy) {
2120 $obj->color_cmd_tmps(0,0);
2124 #-> sub CPAN::Shell::dump ;
2125 sub dump { shift->rematein('dump',@_); }
2126 #-> sub CPAN::Shell::force ;
2127 sub force { shift->rematein('force',@_); }
2128 #-> sub CPAN::Shell::get ;
2129 sub get { shift->rematein('get',@_); }
2130 #-> sub CPAN::Shell::readme ;
2131 sub readme { shift->rematein('readme',@_); }
2132 #-> sub CPAN::Shell::make ;
2133 sub make { shift->rematein('make',@_); }
2134 #-> sub CPAN::Shell::test ;
2135 sub test { shift->rematein('test',@_); }
2136 #-> sub CPAN::Shell::install ;
2137 sub install { shift->rematein('install',@_); }
2138 #-> sub CPAN::Shell::clean ;
2139 sub clean { shift->rematein('clean',@_); }
2140 #-> sub CPAN::Shell::look ;
2141 sub look { shift->rematein('look',@_); }
2142 #-> sub CPAN::Shell::cvs_import ;
2143 sub cvs_import { shift->rematein('cvs_import',@_); }
2145 package CPAN::LWP::UserAgent;
2148 return if $SETUPDONE;
2149 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2150 require LWP::UserAgent;
2151 @ISA = qw(Exporter LWP::UserAgent);
2154 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2158 sub get_basic_credentials {
2159 my($self, $realm, $uri, $proxy) = @_;
2160 return unless $proxy;
2161 if ($USER && $PASSWD) {
2162 } elsif (defined $CPAN::Config->{proxy_user} &&
2163 defined $CPAN::Config->{proxy_pass}) {
2164 $USER = $CPAN::Config->{proxy_user};
2165 $PASSWD = $CPAN::Config->{proxy_pass};
2167 require ExtUtils::MakeMaker;
2168 ExtUtils::MakeMaker->import(qw(prompt));
2169 $USER = prompt("Proxy authentication needed!
2170 (Note: to permanently configure username and password run
2171 o conf proxy_user your_username
2172 o conf proxy_pass your_password
2174 if ($CPAN::META->has_inst("Term::ReadKey")) {
2175 Term::ReadKey::ReadMode("noecho");
2177 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2179 $PASSWD = prompt("Password:");
2180 if ($CPAN::META->has_inst("Term::ReadKey")) {
2181 Term::ReadKey::ReadMode("restore");
2183 $CPAN::Frontend->myprint("\n\n");
2185 return($USER,$PASSWD);
2189 my($self,$url,$aslocal) = @_;
2190 my $result = $self->SUPER::mirror($url,$aslocal);
2191 if ($result->code == 407) {
2194 $result = $self->SUPER::mirror($url,$aslocal);
2201 #-> sub CPAN::FTP::ftp_get ;
2203 my($class,$host,$dir,$file,$target) = @_;
2205 qq[Going to fetch file [$file] from dir [$dir]
2206 on host [$host] as local [$target]\n]
2208 my $ftp = Net::FTP->new($host);
2209 return 0 unless defined $ftp;
2210 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2211 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2212 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2213 warn "Couldn't login on $host";
2216 unless ( $ftp->cwd($dir) ){
2217 warn "Couldn't cwd $dir";
2221 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2222 unless ( $ftp->get($file,$target) ){
2223 warn "Couldn't fetch $file from $host\n";
2226 $ftp->quit; # it's ok if this fails
2230 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2232 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2233 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2235 # > *** 1562,1567 ****
2236 # > --- 1562,1580 ----
2237 # > return 1 if substr($url,0,4) eq "file";
2238 # > return 1 unless $url =~ m|://([^/]+)|;
2240 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2242 # > + $proxy =~ m|://([^/:]+)|;
2244 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2245 # > + if ($noproxy) {
2246 # > + if ($host !~ /$noproxy$/) {
2247 # > + $host = $proxy;
2250 # > + $host = $proxy;
2253 # > require Net::Ping;
2254 # > return 1 unless $Net::Ping::VERSION >= 2;
2258 #-> sub CPAN::FTP::localize ;
2260 my($self,$file,$aslocal,$force) = @_;
2262 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2263 unless defined $aslocal;
2264 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2267 if ($^O eq 'MacOS') {
2268 # Comment by AK on 2000-09-03: Uniq short filenames would be
2269 # available in CHECKSUMS file
2270 my($name, $path) = File::Basename::fileparse($aslocal, '');
2271 if (length($name) > 31) {
2282 my $size = 31 - length($suf);
2283 while (length($name) > $size) {
2287 $aslocal = File::Spec->catfile($path, $name);
2291 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2294 rename $aslocal, "$aslocal.bak";
2298 my($aslocal_dir) = File::Basename::dirname($aslocal);
2299 File::Path::mkpath($aslocal_dir);
2300 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2301 qq{directory "$aslocal_dir".
2302 I\'ll continue, but if you encounter problems, they may be due
2303 to insufficient permissions.\n}) unless -w $aslocal_dir;
2305 # Inheritance is not easier to manage than a few if/else branches
2306 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2308 CPAN::LWP::UserAgent->config;
2309 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2311 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2315 $Ua->proxy('ftp', $var)
2316 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2317 $Ua->proxy('http', $var)
2318 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2321 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2323 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2324 # > use ones that require basic autorization.
2326 # > Example of when I use it manually in my own stuff:
2328 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2329 # > $req->proxy_authorization_basic("username","password");
2330 # > $res = $ua->request($req);
2334 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2338 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2339 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2340 if $CPAN::Config->{http_proxy};
2341 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2343 # Try the list of urls for each single object. We keep a record
2344 # where we did get a file from
2345 my(@reordered,$last);
2346 $CPAN::Config->{urllist} ||= [];
2347 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2348 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2350 $last = $#{$CPAN::Config->{urllist}};
2351 if ($force & 2) { # local cpans probably out of date, don't reorder
2352 @reordered = (0..$last);
2356 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2358 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2369 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2371 @levels = qw/easy hard hardest/;
2373 @levels = qw/easy/ if $^O eq 'MacOS';
2375 for $levelno (0..$#levels) {
2376 my $level = $levels[$levelno];
2377 my $method = "host$level";
2378 my @host_seq = $level eq "easy" ?
2379 @reordered : 0..$last; # reordered has CDROM up front
2380 @host_seq = (0) unless @host_seq;
2381 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2383 $Themethod = $level;
2385 # utime $now, $now, $aslocal; # too bad, if we do that, we
2386 # might alter a local mirror
2387 $self->debug("level[$level]") if $CPAN::DEBUG;
2391 last if $CPAN::Signal; # need to cleanup
2394 unless ($CPAN::Signal) {
2397 qq{Please check, if the URLs I found in your configuration file \(}.
2398 join(", ", @{$CPAN::Config->{urllist}}).
2399 qq{\) are valid. The urllist can be edited.},
2400 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2401 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2403 $CPAN::Frontend->myprint("Could not fetch $file\n");
2406 rename "$aslocal.bak", $aslocal;
2407 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2408 $self->ls($aslocal));
2415 my($self,$host_seq,$file,$aslocal) = @_;
2417 HOSTEASY: for $i (@$host_seq) {
2418 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2419 $url .= "/" unless substr($url,-1) eq "/";
2421 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2422 if ($url =~ /^file:/) {
2424 if ($CPAN::META->has_inst('URI::URL')) {
2425 my $u = URI::URL->new($url);
2427 } else { # works only on Unix, is poorly constructed, but
2428 # hopefully better than nothing.
2429 # RFC 1738 says fileurl BNF is
2430 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2431 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2433 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2434 $l =~ s|^file:||; # assume they
2437 $l =~ s|^/||s unless -f $l; # e.g. /P:
2438 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2440 if ( -f $l && -r _) {
2444 # Maybe mirror has compressed it?
2446 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2447 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2454 if ($CPAN::META->has_usable('LWP')) {
2455 $CPAN::Frontend->myprint("Fetching with LWP:
2459 CPAN::LWP::UserAgent->config;
2460 eval { $Ua = CPAN::LWP::UserAgent->new; };
2462 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2465 my $res = $Ua->mirror($url, $aslocal);
2466 if ($res->is_success) {
2469 utime $now, $now, $aslocal; # download time is more
2470 # important than upload time
2472 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2473 my $gzurl = "$url.gz";
2474 $CPAN::Frontend->myprint("Fetching with LWP:
2477 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2478 if ($res->is_success &&
2479 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2485 $CPAN::Frontend->myprint(sprintf(
2486 "LWP failed with code[%s] message[%s]\n",
2490 # Alan Burlison informed me that in firewall environments
2491 # Net::FTP can still succeed where LWP fails. So we do not
2492 # skip Net::FTP anymore when LWP is available.
2495 $CPAN::Frontend->myprint("LWP not available\n");
2497 return if $CPAN::Signal;
2498 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2499 # that's the nice and easy way thanks to Graham
2500 my($host,$dir,$getfile) = ($1,$2,$3);
2501 if ($CPAN::META->has_usable('Net::FTP')) {
2503 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2506 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2507 "aslocal[$aslocal]") if $CPAN::DEBUG;
2508 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2512 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2513 my $gz = "$aslocal.gz";
2514 $CPAN::Frontend->myprint("Fetching with Net::FTP
2517 if (CPAN::FTP->ftp_get($host,
2521 CPAN::Tarzip->gunzip($gz,$aslocal)
2530 return if $CPAN::Signal;
2535 my($self,$host_seq,$file,$aslocal) = @_;
2537 # Came back if Net::FTP couldn't establish connection (or
2538 # failed otherwise) Maybe they are behind a firewall, but they
2539 # gave us a socksified (or other) ftp program...
2542 my($devnull) = $CPAN::Config->{devnull} || "";
2544 my($aslocal_dir) = File::Basename::dirname($aslocal);
2545 File::Path::mkpath($aslocal_dir);
2546 HOSTHARD: for $i (@$host_seq) {
2547 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2548 $url .= "/" unless substr($url,-1) eq "/";
2550 my($proto,$host,$dir,$getfile);
2552 # Courtesy Mark Conty mark_conty@cargill.com change from
2553 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2555 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2556 # proto not yet used
2557 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2559 next HOSTHARD; # who said, we could ftp anything except ftp?
2561 next HOSTHARD if $proto eq "file"; # file URLs would have had
2562 # success above. Likely a bogus URL
2564 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2566 for $f ('lynx','ncftpget','ncftp','wget') {
2567 next unless exists $CPAN::Config->{$f};
2568 $funkyftp = $CPAN::Config->{$f};
2569 next unless defined $funkyftp;
2570 next if $funkyftp =~ /^\s*$/;
2571 my($asl_ungz, $asl_gz);
2572 ($asl_ungz = $aslocal) =~ s/\.gz//;
2573 $asl_gz = "$asl_ungz.gz";
2574 my($src_switch) = "";
2576 $src_switch = " -source";
2577 } elsif ($f eq "ncftp"){
2578 $src_switch = " -c";
2579 } elsif ($f eq "wget"){
2580 $src_switch = " -O -";
2583 my($stdout_redir) = " > $asl_ungz";
2584 if ($f eq "ncftpget"){
2585 $chdir = "cd $aslocal_dir && ";
2588 $CPAN::Frontend->myprint(
2590 Trying with "$funkyftp$src_switch" to get
2594 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2595 $self->debug("system[$system]") if $CPAN::DEBUG;
2597 if (($wstatus = system($system)) == 0
2600 -s $asl_ungz # lynx returns 0 when it fails somewhere
2606 } elsif ($asl_ungz ne $aslocal) {
2607 # test gzip integrity
2608 if (CPAN::Tarzip->gtest($asl_ungz)) {
2609 # e.g. foo.tar is gzipped --> foo.tar.gz
2610 rename $asl_ungz, $aslocal;
2612 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2617 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2619 -f $asl_ungz && -s _ == 0;
2620 my $gz = "$aslocal.gz";
2621 my $gzurl = "$url.gz";
2622 $CPAN::Frontend->myprint(
2624 Trying with "$funkyftp$src_switch" to get
2627 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2628 $self->debug("system[$system]") if $CPAN::DEBUG;
2630 if (($wstatus = system($system)) == 0
2634 # test gzip integrity
2635 if (CPAN::Tarzip->gtest($asl_gz)) {
2636 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2638 # somebody uncompressed file for us?
2639 rename $asl_ungz, $aslocal;
2644 unlink $asl_gz if -f $asl_gz;
2647 my $estatus = $wstatus >> 8;
2648 my $size = -f $aslocal ?
2649 ", left\n$aslocal with size ".-s _ :
2650 "\nWarning: expected file [$aslocal] doesn't exist";
2651 $CPAN::Frontend->myprint(qq{
2652 System call "$system"
2653 returned status $estatus (wstat $wstatus)$size
2656 return if $CPAN::Signal;
2657 } # lynx,ncftpget,ncftp
2662 my($self,$host_seq,$file,$aslocal) = @_;
2665 my($aslocal_dir) = File::Basename::dirname($aslocal);
2666 File::Path::mkpath($aslocal_dir);
2667 HOSTHARDEST: for $i (@$host_seq) {
2668 unless (length $CPAN::Config->{'ftp'}) {
2669 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2672 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2673 $url .= "/" unless substr($url,-1) eq "/";
2675 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2676 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2679 my($host,$dir,$getfile) = ($1,$2,$3);
2681 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2682 $ctime,$blksize,$blocks) = stat($aslocal);
2683 $timestamp = $mtime ||= 0;
2684 my($netrc) = CPAN::FTP::netrc->new;
2685 my($netrcfile) = $netrc->netrc;
2686 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2687 my $targetfile = File::Basename::basename($aslocal);
2693 map("cd $_", split /\//, $dir), # RFC 1738
2695 "get $getfile $targetfile",
2699 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2700 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2701 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2703 $netrc->contains($host))) if $CPAN::DEBUG;
2704 if ($netrc->protected) {
2705 $CPAN::Frontend->myprint(qq{
2706 Trying with external ftp to get
2708 As this requires some features that are not thoroughly tested, we\'re
2709 not sure, that we get it right....
2713 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2715 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2716 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2718 if ($mtime > $timestamp) {
2719 $CPAN::Frontend->myprint("GOT $aslocal\n");
2723 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2725 return if $CPAN::Signal;
2727 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2728 qq{correctly protected.\n});
2731 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2732 nor does it have a default entry\n");
2735 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2736 # then and login manually to host, using e-mail as
2738 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2742 "user anonymous $Config::Config{'cf_email'}"
2744 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2745 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2746 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2748 if ($mtime > $timestamp) {
2749 $CPAN::Frontend->myprint("GOT $aslocal\n");
2753 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2755 return if $CPAN::Signal;
2756 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2762 my($self,$command,@dialog) = @_;
2763 my $fh = FileHandle->new;
2764 $fh->open("|$command") or die "Couldn't open ftp: $!";
2765 foreach (@dialog) { $fh->print("$_\n") }
2766 $fh->close; # Wait for process to complete
2768 my $estatus = $wstatus >> 8;
2769 $CPAN::Frontend->myprint(qq{
2770 Subprocess "|$command"
2771 returned status $estatus (wstat $wstatus)
2775 # find2perl needs modularization, too, all the following is stolen
2779 my($self,$name) = @_;
2780 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2781 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2783 my($perms,%user,%group);
2787 $blocks = int(($blocks + 1) / 2);
2790 $blocks = int(($sizemm + 1023) / 1024);
2793 if (-f _) { $perms = '-'; }
2794 elsif (-d _) { $perms = 'd'; }
2795 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2796 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2797 elsif (-p _) { $perms = 'p'; }
2798 elsif (-S _) { $perms = 's'; }
2799 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2801 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2802 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2803 my $tmpmode = $mode;
2804 my $tmp = $rwx[$tmpmode & 7];
2806 $tmp = $rwx[$tmpmode & 7] . $tmp;
2808 $tmp = $rwx[$tmpmode & 7] . $tmp;
2809 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2810 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2811 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2814 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2815 my $group = $group{$gid} || $gid;
2817 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2819 my($moname) = $moname[$mon];
2820 if (-M _ > 365.25 / 2) {
2821 $timeyear = $year + 1900;
2824 $timeyear = sprintf("%02d:%02d", $hour, $min);
2827 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2841 package CPAN::FTP::netrc;
2845 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2847 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2848 $atime,$mtime,$ctime,$blksize,$blocks)
2853 my($fh,@machines,$hasdefault);
2855 $fh = FileHandle->new or die "Could not create a filehandle";
2857 if($fh->open($file)){
2858 $protected = ($mode & 077) == 0;
2860 NETRC: while (<$fh>) {
2861 my(@tokens) = split " ", $_;
2862 TOKEN: while (@tokens) {
2863 my($t) = shift @tokens;
2864 if ($t eq "default"){
2868 last TOKEN if $t eq "macdef";
2869 if ($t eq "machine") {
2870 push @machines, shift @tokens;
2875 $file = $hasdefault = $protected = "";
2879 'mach' => [@machines],
2881 'hasdefault' => $hasdefault,
2882 'protected' => $protected,
2886 # CPAN::FTP::hasdefault;
2887 sub hasdefault { shift->{'hasdefault'} }
2888 sub netrc { shift->{'netrc'} }
2889 sub protected { shift->{'protected'} }
2891 my($self,$mach) = @_;
2892 for ( @{$self->{'mach'}} ) {
2893 return 1 if $_ eq $mach;
2898 package CPAN::Complete;
2901 my($text, $line, $start, $end) = @_;
2902 my(@perlret) = cpl($text, $line, $start);
2903 # find longest common match. Can anybody show me how to peruse
2904 # T::R::Gnu to have this done automatically? Seems expensive.
2905 return () unless @perlret;
2906 my($newtext) = $text;
2907 for (my $i = length($text)+1;;$i++) {
2908 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2909 my $try = substr($perlret[0],0,$i);
2910 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2911 # warn "try[$try]tries[@tries]";
2912 if (@tries == @perlret) {
2918 ($newtext,@perlret);
2921 #-> sub CPAN::Complete::cpl ;
2923 my($word,$line,$pos) = @_;
2927 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2929 if ($line =~ s/^(force\s*)//) {
2934 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2935 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2937 } elsif ($line =~ /^(a|ls)\s/) {
2938 @return = cplx('CPAN::Author',uc($word));
2939 } elsif ($line =~ /^b\s/) {
2940 CPAN::Shell->local_bundles;
2941 @return = cplx('CPAN::Bundle',$word);
2942 } elsif ($line =~ /^d\s/) {
2943 @return = cplx('CPAN::Distribution',$word);
2944 } elsif ($line =~ m/^(
2945 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2947 if ($word =~ /^Bundle::/) {
2948 CPAN::Shell->local_bundles;
2950 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2951 } elsif ($line =~ /^i\s/) {
2952 @return = cpl_any($word);
2953 } elsif ($line =~ /^reload\s/) {
2954 @return = cpl_reload($word,$line,$pos);
2955 } elsif ($line =~ /^o\s/) {
2956 @return = cpl_option($word,$line,$pos);
2957 } elsif ($line =~ m/^\S+\s/ ) {
2958 # fallback for future commands and what we have forgotten above
2959 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2966 #-> sub CPAN::Complete::cplx ;
2968 my($class, $word) = @_;
2969 # I believed for many years that this was sorted, today I
2970 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2971 # make it sorted again. Maybe sort was dropped when GNU-readline
2972 # support came in? The RCS file is difficult to read on that:-(
2973 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2976 #-> sub CPAN::Complete::cpl_any ;
2980 cplx('CPAN::Author',$word),
2981 cplx('CPAN::Bundle',$word),
2982 cplx('CPAN::Distribution',$word),
2983 cplx('CPAN::Module',$word),
2987 #-> sub CPAN::Complete::cpl_reload ;
2989 my($word,$line,$pos) = @_;
2991 my(@words) = split " ", $line;
2992 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2993 my(@ok) = qw(cpan index);
2994 return @ok if @words == 1;
2995 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2998 #-> sub CPAN::Complete::cpl_option ;
3000 my($word,$line,$pos) = @_;
3002 my(@words) = split " ", $line;
3003 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3004 my(@ok) = qw(conf debug);
3005 return @ok if @words == 1;
3006 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3008 } elsif ($words[1] eq 'index') {
3010 } elsif ($words[1] eq 'conf') {
3011 return CPAN::Config::cpl(@_);
3012 } elsif ($words[1] eq 'debug') {
3013 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
3017 package CPAN::Index;
3019 #-> sub CPAN::Index::force_reload ;
3022 $CPAN::Index::LAST_TIME = 0;
3026 #-> sub CPAN::Index::reload ;
3028 my($cl,$force) = @_;
3031 # XXX check if a newer one is available. (We currently read it
3032 # from time to time)
3033 for ($CPAN::Config->{index_expire}) {
3034 $_ = 0.001 unless $_ && $_ > 0.001;
3036 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3037 # debug here when CPAN doesn't seem to read the Metadata
3039 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3041 unless ($CPAN::META->{PROTOCOL}) {
3042 $cl->read_metadata_cache;
3043 $CPAN::META->{PROTOCOL} ||= "1.0";
3045 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3046 # warn "Setting last_time to 0";
3047 $LAST_TIME = 0; # No warning necessary
3049 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3052 # IFF we are developing, it helps to wipe out the memory
3053 # between reloads, otherwise it is not what a user expects.
3054 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3055 $CPAN::META = CPAN->new;
3059 local $LAST_TIME = $time;
3060 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3062 my $needshort = $^O eq "dos";
3064 $cl->rd_authindex($cl
3066 "authors/01mailrc.txt.gz",
3068 File::Spec->catfile('authors', '01mailrc.gz') :
3069 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3072 $debug = "timing reading 01[".($t2 - $time)."]";
3074 return if $CPAN::Signal; # this is sometimes lengthy
3075 $cl->rd_modpacks($cl
3077 "modules/02packages.details.txt.gz",
3079 File::Spec->catfile('modules', '02packag.gz') :
3080 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3083 $debug .= "02[".($t2 - $time)."]";
3085 return if $CPAN::Signal; # this is sometimes lengthy
3088 "modules/03modlist.data.gz",
3090 File::Spec->catfile('modules', '03mlist.gz') :
3091 File::Spec->catfile('modules', '03modlist.data.gz'),
3093 $cl->write_metadata_cache;
3095 $debug .= "03[".($t2 - $time)."]";
3097 CPAN->debug($debug) if $CPAN::DEBUG;
3100 $CPAN::META->{PROTOCOL} = PROTOCOL;
3103 #-> sub CPAN::Index::reload_x ;
3105 my($cl,$wanted,$localname,$force) = @_;
3106 $force |= 2; # means we're dealing with an index here
3107 CPAN::Config->load; # we should guarantee loading wherever we rely
3109 $localname ||= $wanted;
3110 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3114 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3117 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3118 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3119 qq{day$s. I\'ll use that.});
3122 $force |= 1; # means we're quite serious about it.
3124 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3127 #-> sub CPAN::Index::rd_authindex ;
3129 my($cl, $index_target) = @_;
3131 return unless defined $index_target;
3132 $CPAN::Frontend->myprint("Going to read $index_target\n");
3134 tie *FH, CPAN::Tarzip, $index_target;
3136 push @lines, split /\012/ while <FH>;
3138 my($userid,$fullname,$email) =
3139 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3140 next unless $userid && $fullname && $email;
3142 # instantiate an author object
3143 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3144 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3145 return if $CPAN::Signal;
3150 my($self,$dist) = @_;
3151 $dist = $self->{'id'} unless defined $dist;
3152 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3156 #-> sub CPAN::Index::rd_modpacks ;
3158 my($self, $index_target) = @_;
3160 return unless defined $index_target;
3161 $CPAN::Frontend->myprint("Going to read $index_target\n");
3162 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3164 while ($_ = $fh->READLINE) {
3166 my @ls = map {"$_\n"} split /\n/, $_;
3167 unshift @ls, "\n" x length($1) if /^(\n+)/;
3171 my($line_count,$last_updated);
3173 my $shift = shift(@lines);
3174 last if $shift =~ /^\s*$/;
3175 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3176 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3178 if (not defined $line_count) {
3180 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3181 Please check the validity of the index file by comparing it to more
3182 than one CPAN mirror. I'll continue but problems seem likely to
3187 } elsif ($line_count != scalar @lines) {
3189 warn sprintf qq{Warning: Your %s
3190 contains a Line-Count header of %d but I see %d lines there. Please
3191 check the validity of the index file by comparing it to more than one
3192 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3193 $index_target, $line_count, scalar(@lines);
3196 if (not defined $last_updated) {
3198 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3199 Please check the validity of the index file by comparing it to more
3200 than one CPAN mirror. I'll continue but problems seem likely to
3208 ->myprint(sprintf qq{ Database was generated on %s\n},
3210 $DATE_OF_02 = $last_updated;
3212 if ($CPAN::META->has_inst(HTTP::Date)) {
3214 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3219 qq{Warning: This index file is %d days old.
3220 Please check the host you chose as your CPAN mirror for staleness.
3221 I'll continue but problems seem likely to happen.\a\n},
3226 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3231 # A necessity since we have metadata_cache: delete what isn't
3233 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3234 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3238 # before 1.56 we split into 3 and discarded the rest. From
3239 # 1.57 we assign remaining text to $comment thus allowing to
3240 # influence isa_perl
3241 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3242 my($bundle,$id,$userid);
3244 if ($mod eq 'CPAN' &&
3246 CPAN::Queue->exists('Bundle::CPAN') ||
3247 CPAN::Queue->exists('CPAN')
3251 if ($version > $CPAN::VERSION){
3252 $CPAN::Frontend->myprint(qq{
3253 There's a new CPAN.pm version (v$version) available!
3254 [Current version is v$CPAN::VERSION]
3255 You might want to try
3256 install Bundle::CPAN
3258 without quitting the current session. It should be a seamless upgrade
3259 while we are running...
3262 $CPAN::Frontend->myprint(qq{\n});
3264 last if $CPAN::Signal;
3265 } elsif ($mod =~ /^Bundle::(.*)/) {
3270 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3271 # Let's make it a module too, because bundles have so much
3272 # in common with modules.
3274 # Changed in 1.57_63: seems like memory bloat now without
3275 # any value, so commented out
3277 # $CPAN::META->instance('CPAN::Module',$mod);
3281 # instantiate a module object
3282 $id = $CPAN::META->instance('CPAN::Module',$mod);
3286 if ($id->cpan_file ne $dist){ # update only if file is
3287 # different. CPAN prohibits same
3288 # name with different version
3289 $userid = $self->userid($dist);
3291 'CPAN_USERID' => $userid,
3292 'CPAN_VERSION' => $version,
3293 'CPAN_FILE' => $dist,
3297 # instantiate a distribution object
3298 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3299 # we do not need CONTAINSMODS unless we do something with
3300 # this dist, so we better produce it on demand.
3302 ## my $obj = $CPAN::META->instance(
3303 ## 'CPAN::Distribution' => $dist
3305 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3307 $CPAN::META->instance(
3308 'CPAN::Distribution' => $dist
3310 'CPAN_USERID' => $userid,
3311 'CPAN_COMMENT' => $comment,
3315 for my $name ($mod,$dist) {
3316 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3317 $exists{$name} = undef;
3320 return if $CPAN::Signal;
3324 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3325 for my $o ($CPAN::META->all_objects($class)) {
3326 next if exists $exists{$o->{ID}};
3327 $CPAN::META->delete($class,$o->{ID});
3328 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3335 #-> sub CPAN::Index::rd_modlist ;
3337 my($cl,$index_target) = @_;
3338 return unless defined $index_target;
3339 $CPAN::Frontend->myprint("Going to read $index_target\n");
3340 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3343 while ($_ = $fh->READLINE) {
3345 my @ls = map {"$_\n"} split /\n/, $_;
3346 unshift @ls, "\n" x length($1) if /^(\n+)/;
3350 my $shift = shift(@eval);
3351 if ($shift =~ /^Date:\s+(.*)/){
3352 return if $DATE_OF_03 eq $1;
3355 last if $shift =~ /^\s*$/;
3358 push @eval, q{CPAN::Modulelist->data;};
3360 my($comp) = Safe->new("CPAN::Safe1");
3361 my($eval) = join("", @eval);
3362 my $ret = $comp->reval($eval);
3363 Carp::confess($@) if $@;
3364 return if $CPAN::Signal;
3366 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3367 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3368 $obj->set(%{$ret->{$_}});
3369 return if $CPAN::Signal;
3373 #-> sub CPAN::Index::write_metadata_cache ;
3374 sub write_metadata_cache {
3376 return unless $CPAN::Config->{'cache_metadata'};
3377 return unless $CPAN::META->has_usable("Storable");
3379 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3380 CPAN::Distribution)) {
3381 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3383 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3384 $cache->{last_time} = $LAST_TIME;
3385 $cache->{DATE_OF_02} = $DATE_OF_02;
3386 $cache->{PROTOCOL} = PROTOCOL;
3387 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3388 eval { Storable::nstore($cache, $metadata_file) };
3389 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3392 #-> sub CPAN::Index::read_metadata_cache ;
3393 sub read_metadata_cache {
3395 return unless $CPAN::Config->{'cache_metadata'};
3396 return unless $CPAN::META->has_usable("Storable");
3397 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3398 return unless -r $metadata_file and -f $metadata_file;
3399 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3401 eval { $cache = Storable::retrieve($metadata_file) };
3402 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3403 if (!$cache || ref $cache ne 'HASH'){
3407 if (exists $cache->{PROTOCOL}) {
3408 if (PROTOCOL > $cache->{PROTOCOL}) {
3409 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3410 "with protocol v%s, requiring v%s\n",
3417 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3418 "with protocol v1.0\n");
3423 while(my($class,$v) = each %$cache) {
3424 next unless $class =~ /^CPAN::/;
3425 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3426 while (my($id,$ro) = each %$v) {
3427 $CPAN::META->{readwrite}{$class}{$id} ||=
3428 $class->new(ID=>$id, RO=>$ro);
3433 unless ($clcnt) { # sanity check
3434 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3437 if ($idcnt < 1000) {
3438 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3439 "in $metadata_file\n");
3442 $CPAN::META->{PROTOCOL} ||=
3443 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3444 # does initialize to some protocol
3445 $LAST_TIME = $cache->{last_time};
3446 $DATE_OF_02 = $cache->{DATE_OF_02};
3447 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3448 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3452 package CPAN::InfoObj;
3455 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3456 sub id { shift->{ID}; }
3458 #-> sub CPAN::InfoObj::new ;
3460 my $this = bless {}, shift;
3465 # The set method may only be used by code that reads index data or
3466 # otherwise "objective" data from the outside world. All session
3467 # related material may do anything else with instance variables but
3468 # must not touch the hash under the RO attribute. The reason is that
3469 # the RO hash gets written to Metadata file and is thus persistent.
3471 #-> sub CPAN::InfoObj::set ;
3473 my($self,%att) = @_;
3474 my $class = ref $self;
3476 # This must be ||=, not ||, because only if we write an empty
3477 # reference, only then the set method will write into the readonly
3478 # area. But for Distributions that spring into existence, maybe
3479 # because of a typo, we do not like it that they are written into
3480 # the readonly area and made permanent (at least for a while) and
3481 # that is why we do not "allow" other places to call ->set.
3482 unless ($self->id) {
3483 CPAN->debug("Bug? Empty ID, rejecting");
3486 my $ro = $self->{RO} =
3487 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3489 while (my($k,$v) = each %att) {
3494 #-> sub CPAN::InfoObj::as_glimpse ;
3498 my $class = ref($self);
3499 $class =~ s/^CPAN:://;
3500 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3504 #-> sub CPAN::InfoObj::as_string ;
3508 my $class = ref($self);
3509 $class =~ s/^CPAN:://;
3510 push @m, $class, " id = $self->{ID}\n";
3511 for (sort keys %{$self->{RO}}) {
3512 # next if m/^(ID|RO)$/;
3514 if ($_ eq "CPAN_USERID") {
3515 $extra .= " (".$self->author;
3516 my $email; # old perls!
3517 if ($email = $CPAN::META->instance("CPAN::Author",
3520 $extra .= " <$email>";
3522 $extra .= " <no email>";
3525 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3526 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3529 next unless defined $self->{RO}{$_};
3530 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3532 for (sort keys %$self) {
3533 next if m/^(ID|RO)$/;
3534 if (ref($self->{$_}) eq "ARRAY") {
3535 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3536 } elsif (ref($self->{$_}) eq "HASH") {
3540 join(" ",keys %{$self->{$_}}),
3543 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3549 #-> sub CPAN::InfoObj::author ;
3552 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3555 #-> sub CPAN::InfoObj::dump ;
3558 require Data::Dumper;
3559 print Data::Dumper::Dumper($self);
3562 package CPAN::Author;
3564 #-> sub CPAN::Author::id
3567 my $id = $self->{ID};
3568 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3572 #-> sub CPAN::Author::as_glimpse ;
3576 my $class = ref($self);
3577 $class =~ s/^CPAN:://;
3578 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3586 #-> sub CPAN::Author::fullname ;
3588 shift->{RO}{FULLNAME};
3592 #-> sub CPAN::Author::email ;
3593 sub email { shift->{RO}{EMAIL}; }
3595 #-> sub CPAN::Author::ls ;
3600 # adapted from CPAN::Distribution::verifyMD5 ;
3601 my(@csf); # chksumfile
3602 @csf = $self->id =~ /(.)(.)(.*)/;
3603 $csf[1] = join "", @csf[0,1];
3604 $csf[2] = join "", @csf[1,2];
3606 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3607 unless (grep {$_->[2] eq $csf[1]} @dl) {
3608 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3611 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3612 unless (grep {$_->[2] eq $csf[2]} @dl) {
3613 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3616 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3617 $CPAN::Frontend->myprint(join "", map {
3618 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3619 } sort { $a->[2] cmp $b->[2] } @dl);
3622 # returns an array of arrays, the latter contain (size,mtime,filename)
3623 #-> sub CPAN::Author::dir_listing ;
3626 my $chksumfile = shift;
3627 my $recursive = shift;
3629 File::Spec->catfile($CPAN::Config->{keep_source_where},
3630 "authors", "id", @$chksumfile);
3632 # connect "force" argument with "index_expire".
3634 if (my @stat = stat $lc_want) {
3635 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3637 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3640 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3641 $chksumfile->[-1] .= ".gz";
3642 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3645 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3646 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3652 # adapted from CPAN::Distribution::MD5_check_file ;
3653 my $fh = FileHandle->new;
3655 if (open $fh, $lc_file){
3658 $eval =~ s/\015?\012/\n/g;
3660 my($comp) = Safe->new();
3661 $cksum = $comp->reval($eval);
3663 rename $lc_file, "$lc_file.bad";
3664 Carp::confess($@) if $@;
3667 Carp::carp "Could not open $lc_file for reading";
3670 for $f (sort keys %$cksum) {
3671 if (exists $cksum->{$f}{isdir}) {
3673 my(@dir) = @$chksumfile;
3675 push @dir, $f, "CHECKSUMS";
3677 [$_->[0], $_->[1], "$f/$_->[2]"]
3678 } $self->dir_listing(\@dir,1);
3680 push @result, [ 0, "-", $f ];
3684 ($cksum->{$f}{"size"}||0),
3685 $cksum->{$f}{"mtime"}||"---",
3693 package CPAN::Distribution;
3696 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3700 delete $self->{later};
3703 # CPAN::Distribution::normalize
3706 $s = $self->id unless defined $s;
3710 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3712 return $s if $s =~ m:^N/A|^Contact Author: ;
3713 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3714 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3715 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3720 #-> sub CPAN::Distribution::color_cmd_tmps ;
3721 sub color_cmd_tmps {
3723 my($depth) = shift || 0;
3724 my($color) = shift || 0;
3725 # a distribution needs to recurse into its prereq_pms
3727 return if exists $self->{incommandcolor}
3728 && $self->{incommandcolor}==$color;
3729 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3730 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3735 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3736 my $prereq_pm = $self->prereq_pm;
3737 if (defined $prereq_pm) {
3738 for my $pre (keys %$prereq_pm) {
3739 my $premo = CPAN::Shell->expand("Module",$pre);
3740 $premo->color_cmd_tmps($depth+1,$color);
3744 delete $self->{sponsored_mods};
3745 delete $self->{badtestcnt};
3747 $self->{incommandcolor} = $color;
3750 #-> sub CPAN::Distribution::as_string ;
3753 $self->containsmods;
3754 $self->SUPER::as_string(@_);
3757 #-> sub CPAN::Distribution::containsmods ;
3760 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3761 my $dist_id = $self->{ID};
3762 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3763 my $mod_file = $mod->cpan_file or next;
3764 my $mod_id = $mod->{ID} or next;
3765 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3767 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3769 keys %{$self->{CONTAINSMODS}};
3772 #-> sub CPAN::Distribution::uptodate ;
3776 foreach $c ($self->containsmods) {
3777 my $obj = CPAN::Shell->expandany($c);
3778 return 0 unless $obj->uptodate;
3783 #-> sub CPAN::Distribution::called_for ;
3786 $self->{CALLED_FOR} = $id if defined $id;
3787 return $self->{CALLED_FOR};
3790 #-> sub CPAN::Distribution::safe_chdir ;
3792 my($self,$todir) = @_;
3793 # we die if we cannot chdir and we are debuggable
3794 Carp::confess("safe_chdir called without todir argument")
3795 unless defined $todir and length $todir;
3797 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3800 my $cwd = CPAN::anycwd();
3801 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3802 qq{to todir[$todir]: $!});
3806 #-> sub CPAN::Distribution::get ;
3811 exists $self->{'build_dir'} and push @e,
3812 "Is already unwrapped into directory $self->{'build_dir'}";
3813 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3815 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3818 # Get the file on local disk
3823 File::Spec->catfile(
3824 $CPAN::Config->{keep_source_where},
3827 split(/\//,$self->id)
3830 $self->debug("Doing localize") if $CPAN::DEBUG;
3831 unless ($local_file =
3832 CPAN::FTP->localize("authors/id/$self->{ID}",
3835 if ($CPAN::Index::DATE_OF_02) {
3836 $note = "Note: Current database in memory was generated ".
3837 "on $CPAN::Index::DATE_OF_02\n";
3839 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3841 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3842 $self->{localfile} = $local_file;
3843 return if $CPAN::Signal;
3848 if ($CPAN::META->has_inst("Digest::MD5")) {
3849 $self->debug("Digest::MD5 is installed, verifying");
3852 $self->debug("Digest::MD5 is NOT installed");
3854 return if $CPAN::Signal;
3857 # Create a clean room and go there
3859 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3860 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3861 $self->safe_chdir($builddir);
3862 $self->debug("Removing tmp") if $CPAN::DEBUG;
3863 File::Path::rmtree("tmp");
3864 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3866 $self->safe_chdir($sub_wd);
3869 $self->safe_chdir("tmp");
3874 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3875 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3876 $self->untar_me($local_file);
3877 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3878 $self->unzip_me($local_file);
3879 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3880 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3881 $self->pm2dir_me($local_file);
3883 $self->{archived} = "NO";
3884 $self->safe_chdir($sub_wd);
3888 # we are still in the tmp directory!
3889 # Let's check if the package has its own directory.
3890 my $dh = DirHandle->new(File::Spec->curdir)
3891 or Carp::croak("Couldn't opendir .: $!");
3892 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3894 my ($distdir,$packagedir);
3895 if (@readdir == 1 && -d $readdir[0]) {
3896 $distdir = $readdir[0];
3897 $packagedir = File::Spec->catdir($builddir,$distdir);
3898 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3900 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3902 File::Path::rmtree($packagedir);
3903 rename($distdir,$packagedir) or
3904 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3905 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3912 my $userid = $self->cpan_userid;
3914 CPAN->debug("no userid? self[$self]");
3917 my $pragmatic_dir = $userid . '000';
3918 $pragmatic_dir =~ s/\W_//g;
3919 $pragmatic_dir++ while -d "../$pragmatic_dir";
3920 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3921 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3922 File::Path::mkpath($packagedir);
3924 for $f (@readdir) { # is already without "." and ".."
3925 my $to = File::Spec->catdir($packagedir,$f);
3926 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3930 $self->safe_chdir($sub_wd);
3934 $self->{'build_dir'} = $packagedir;
3935 $self->safe_chdir(File::Spec->updir);
3936 File::Path::rmtree("tmp");
3938 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3939 my($mpl_exists) = -f $mpl;
3940 unless ($mpl_exists) {
3941 # NFS has been reported to have racing problems after the
3942 # renaming of a directory in some environments.
3945 my $mpldh = DirHandle->new($packagedir)
3946 or Carp::croak("Couldn't opendir $packagedir: $!");
3947 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3950 unless ($mpl_exists) {
3951 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3955 my($configure) = File::Spec->catfile($packagedir,"Configure");
3956 if (-f $configure) {
3957 # do we have anything to do?
3958 $self->{'configure'} = $configure;
3959 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
3960 $CPAN::Frontend->myprint(qq{
3961 Package comes with a Makefile and without a Makefile.PL.
3962 We\'ll try to build it with that Makefile then.
3964 $self->{writemakefile} = "YES";
3967 my $cf = $self->called_for || "unknown";
3972 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3973 $cf = "unknown" unless length($cf);
3974 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3975 (The test -f "$mpl" returned false.)
3976 Writing one on our own (setting NAME to $cf)\a\n});
3977 $self->{had_no_makefile_pl}++;
3980 # Writing our own Makefile.PL
3982 my $fh = FileHandle->new;
3984 or Carp::croak("Could not open >$mpl: $!");
3986 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3987 # because there was no Makefile.PL supplied.
3988 # Autogenerated on: }.scalar localtime().qq{
3990 use ExtUtils::MakeMaker;
3991 WriteMakefile(NAME => q[$cf]);
4001 # CPAN::Distribution::untar_me ;
4003 my($self,$local_file) = @_;
4004 $self->{archived} = "tar";
4005 if (CPAN::Tarzip->untar($local_file)) {
4006 $self->{unwrapped} = "YES";
4008 $self->{unwrapped} = "NO";
4012 # CPAN::Distribution::unzip_me ;
4014 my($self,$local_file) = @_;
4015 $self->{archived} = "zip";
4016 if (CPAN::Tarzip->unzip($local_file)) {
4017 $self->{unwrapped} = "YES";
4019 $self->{unwrapped} = "NO";
4025 my($self,$local_file) = @_;
4026 $self->{archived} = "pm";
4027 my $to = File::Basename::basename($local_file);
4028 $to =~ s/\.(gz|Z)(?!\n)\Z//;
4029 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4030 $self->{unwrapped} = "YES";
4032 $self->{unwrapped} = "NO";
4036 #-> sub CPAN::Distribution::new ;
4038 my($class,%att) = @_;
4040 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4042 my $this = { %att };
4043 return bless $this, $class;
4046 #-> sub CPAN::Distribution::look ;
4050 if ($^O eq 'MacOS') {
4051 $self->Mac::BuildTools::look;
4055 if ( $CPAN::Config->{'shell'} ) {
4056 $CPAN::Frontend->myprint(qq{
4057 Trying to open a subshell in the build directory...
4060 $CPAN::Frontend->myprint(qq{
4061 Your configuration does not define a value for subshells.
4062 Please define it with "o conf shell <your shell>"
4066 my $dist = $self->id;
4068 unless ($dir = $self->dir) {
4071 unless ($dir ||= $self->dir) {
4072 $CPAN::Frontend->mywarn(qq{
4073 Could not determine which directory to use for looking at $dist.
4077 my $pwd = CPAN::anycwd();
4078 $self->safe_chdir($dir);
4079 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4080 system($CPAN::Config->{'shell'}) == 0
4081 or $CPAN::Frontend->mydie("Subprocess shell error");
4082 $self->safe_chdir($pwd);
4085 # CPAN::Distribution::cvs_import ;
4089 my $dir = $self->dir;
4091 my $package = $self->called_for;
4092 my $module = $CPAN::META->instance('CPAN::Module', $package);
4093 my $version = $module->cpan_version;
4095 my $userid = $self->cpan_userid;
4097 my $cvs_dir = (split /\//, $dir)[-1];
4098 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4100 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4102 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4103 if ($cvs_site_perl) {
4104 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4106 my $cvs_log = qq{"imported $package $version sources"};
4107 $version =~ s/\./_/g;
4108 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4109 "$cvs_dir", $userid, "v$version");
4111 my $pwd = CPAN::anycwd();
4112 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4114 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4116 $CPAN::Frontend->myprint(qq{@cmd\n});
4117 system(@cmd) == 0 or
4118 $CPAN::Frontend->mydie("cvs import failed");
4119 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4122 #-> sub CPAN::Distribution::readme ;
4125 my($dist) = $self->id;
4126 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4127 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4130 File::Spec->catfile(
4131 $CPAN::Config->{keep_source_where},
4134 split(/\//,"$sans.readme"),
4136 $self->debug("Doing localize") if $CPAN::DEBUG;
4137 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4139 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4141 if ($^O eq 'MacOS') {
4142 Mac::BuildTools::launch_file($local_file);
4146 my $fh_pager = FileHandle->new;
4147 local($SIG{PIPE}) = "IGNORE";
4148 $fh_pager->open("|$CPAN::Config->{'pager'}")
4149 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4150 my $fh_readme = FileHandle->new;
4151 $fh_readme->open($local_file)
4152 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4153 $CPAN::Frontend->myprint(qq{
4156 with pager "$CPAN::Config->{'pager'}"
4159 $fh_pager->print(<$fh_readme>);
4162 #-> sub CPAN::Distribution::verifyMD5 ;
4167 $self->{MD5_STATUS} ||= "";
4168 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4169 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4171 my($lc_want,$lc_file,@local,$basename);
4172 @local = split(/\//,$self->id);
4174 push @local, "CHECKSUMS";
4176 File::Spec->catfile($CPAN::Config->{keep_source_where},
4177 "authors", "id", @local);
4182 $self->MD5_check_file($lc_want)
4184 return $self->{MD5_STATUS} = "OK";
4186 $lc_file = CPAN::FTP->localize("authors/id/@local",
4189 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4190 $local[-1] .= ".gz";
4191 $lc_file = CPAN::FTP->localize("authors/id/@local",
4194 $lc_file =~ s/\.gz(?!\n)\Z//;
4195 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4200 $self->MD5_check_file($lc_file);
4203 #-> sub CPAN::Distribution::MD5_check_file ;
4204 sub MD5_check_file {
4205 my($self,$chk_file) = @_;
4206 my($cksum,$file,$basename);
4207 $file = $self->{localfile};
4208 $basename = File::Basename::basename($file);
4209 my $fh = FileHandle->new;
4210 if (open $fh, $chk_file){
4213 $eval =~ s/\015?\012/\n/g;
4215 my($comp) = Safe->new();
4216 $cksum = $comp->reval($eval);
4218 rename $chk_file, "$chk_file.bad";
4219 Carp::confess($@) if $@;
4222 Carp::carp "Could not open $chk_file for reading";
4225 if (exists $cksum->{$basename}{md5}) {
4226 $self->debug("Found checksum for $basename:" .
4227 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4231 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4233 $fh = CPAN::Tarzip->TIEHANDLE($file);
4236 # had to inline it, when I tied it, the tiedness got lost on
4237 # the call to eq_MD5. (Jan 1998)
4238 my $md5 = Digest::MD5->new;
4241 while ($fh->READ($ref, 4096) > 0){
4244 my $hexdigest = $md5->hexdigest;
4245 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4249 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4250 return $self->{MD5_STATUS} = "OK";
4252 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4253 qq{distribution file. }.
4254 qq{Please investigate.\n\n}.
4256 $CPAN::META->instance(
4261 my $wrap = qq{I\'d recommend removing $file. Its MD5
4262 checksum is incorrect. Maybe you have configured your 'urllist' with
4263 a bad URL. Please check this array with 'o conf urllist', and
4266 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4268 # former versions just returned here but this seems a
4269 # serious threat that deserves a die
4271 # $CPAN::Frontend->myprint("\n\n");
4275 # close $fh if fileno($fh);
4277 $self->{MD5_STATUS} ||= "";
4278 if ($self->{MD5_STATUS} eq "NIL") {
4279 $CPAN::Frontend->mywarn(qq{
4280 Warning: No md5 checksum for $basename in $chk_file.
4282 The cause for this may be that the file is very new and the checksum
4283 has not yet been calculated, but it may also be that something is
4284 going awry right now.
4286 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4287 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4289 $self->{MD5_STATUS} = "NIL";
4294 #-> sub CPAN::Distribution::eq_MD5 ;
4296 my($self,$fh,$expectMD5) = @_;
4297 my $md5 = Digest::MD5->new;
4299 while (read($fh, $data, 4096)){
4302 # $md5->addfile($fh);
4303 my $hexdigest = $md5->hexdigest;
4304 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4305 $hexdigest eq $expectMD5;
4308 #-> sub CPAN::Distribution::force ;
4310 # Both modules and distributions know if "force" is in effect by
4311 # autoinspection, not by inspecting a global variable. One of the
4312 # reason why this was chosen to work that way was the treatment of
4313 # dependencies. They should not autpomatically inherit the force
4314 # status. But this has the downside that ^C and die() will return to
4315 # the prompt but will not be able to reset the force_update
4316 # attributes. We try to correct for it currently in the read_metadata
4317 # routine, and immediately before we check for a Signal. I hope this
4318 # works out in one of v1.57_53ff
4321 my($self, $method) = @_;
4323 MD5_STATUS archived build_dir localfile make install unwrapped
4326 delete $self->{$att};
4328 if ($method && $method eq "install") {
4329 $self->{"force_update"}++; # name should probably have been force_install
4333 #-> sub CPAN::Distribution::unforce ;
4336 delete $self->{'force_update'};
4339 #-> sub CPAN::Distribution::isa_perl ;
4342 my $file = File::Basename::basename($self->id);
4343 if ($file =~ m{ ^ perl
4356 } elsif ($self->cpan_comment
4358 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4363 #-> sub CPAN::Distribution::perl ;
4366 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4367 my $pwd = CPAN::anycwd();
4368 my $candidate = File::Spec->catfile($pwd,$^X);
4369 $perl ||= $candidate if MM->maybe_command($candidate);
4371 my ($component,$perl_name);
4372 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4373 PATH_COMPONENT: foreach $component (File::Spec->path(),
4374 $Config::Config{'binexp'}) {
4375 next unless defined($component) && $component;
4376 my($abs) = File::Spec->catfile($component,$perl_name);
4377 if (MM->maybe_command($abs)) {
4387 #-> sub CPAN::Distribution::make ;
4390 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4391 # Emergency brake if they said install Pippi and get newest perl
4392 if ($self->isa_perl) {
4394 $self->called_for ne $self->id &&
4395 ! $self->{force_update}
4397 # if we die here, we break bundles
4398 $CPAN::Frontend->mywarn(sprintf qq{
4399 The most recent version "%s" of the module "%s"
4400 comes with the current version of perl (%s).
4401 I\'ll build that only if you ask for something like
4406 $CPAN::META->instance(
4420 $self->{archived} eq "NO" and push @e,
4421 "Is neither a tar nor a zip archive.";
4423 $self->{unwrapped} eq "NO" and push @e,
4424 "had problems unarchiving. Please build manually";
4426 exists $self->{writemakefile} &&
4427 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4428 $1 || "Had some problem writing Makefile";
4430 defined $self->{'make'} and push @e,
4431 "Has already been processed within this session";
4433 exists $self->{later} and length($self->{later}) and
4434 push @e, $self->{later};
4436 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4438 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4439 my $builddir = $self->dir;
4440 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4441 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4443 if ($^O eq 'MacOS') {
4444 Mac::BuildTools::make($self);
4449 if ($self->{'configure'}) {
4450 $system = $self->{'configure'};
4452 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4454 # This needs a handler that can be turned on or off:
4455 # $switch = "-MExtUtils::MakeMaker ".
4456 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4458 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4460 unless (exists $self->{writemakefile}) {
4461 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4464 if ($CPAN::Config->{inactivity_timeout}) {
4466 alarm $CPAN::Config->{inactivity_timeout};
4467 local $SIG{CHLD}; # = sub { wait };
4468 if (defined($pid = fork)) {
4473 # note, this exec isn't necessary if
4474 # inactivity_timeout is 0. On the Mac I'd
4475 # suggest, we set it always to 0.
4479 $CPAN::Frontend->myprint("Cannot fork: $!");
4487 $CPAN::Frontend->myprint($@);
4488 $self->{writemakefile} = "NO $@";
4493 $ret = system($system);
4495 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4499 if (-f "Makefile") {
4500 $self->{writemakefile} = "YES";
4501 delete $self->{make_clean}; # if cleaned before, enable next
4503 $self->{writemakefile} =
4504 qq{NO Makefile.PL refused to write a Makefile.};
4505 # It's probably worth it to record the reason, so let's retry
4507 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4508 # $self->{writemakefile} .= <$fh>;
4512 delete $self->{force_update};
4515 if (my @prereq = $self->unsat_prereq){
4516 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4518 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4519 if (system($system) == 0) {
4520 $CPAN::Frontend->myprint(" $system -- OK\n");
4521 $self->{'make'} = "YES";
4523 $self->{writemakefile} ||= "YES";
4524 $self->{'make'} = "NO";
4525 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4529 sub follow_prereqs {
4533 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4534 "during [$id] -----\n");
4536 for my $p (@prereq) {
4537 $CPAN::Frontend->myprint(" $p\n");
4540 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4542 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4543 require ExtUtils::MakeMaker;
4544 my $answer = ExtUtils::MakeMaker::prompt(
4545 "Shall I follow them and prepend them to the queue
4546 of modules we are processing right now?", "yes");
4547 $follow = $answer =~ /^\s*y/i;
4551 myprint(" Ignoring dependencies on modules @prereq\n");
4554 # color them as dirty
4555 for my $p (@prereq) {
4556 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4558 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4559 $self->{later} = "Delayed until after prerequisites";
4560 return 1; # signal success to the queuerunner
4564 #-> sub CPAN::Distribution::unsat_prereq ;
4567 my $prereq_pm = $self->prereq_pm or return;
4569 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4570 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4571 # we were too demanding:
4572 next if $nmo->uptodate;
4574 # if they have not specified a version, we accept any installed one
4575 if (not defined $need_version or
4576 $need_version == 0 or
4577 $need_version eq "undef") {
4578 next if defined $nmo->inst_file;
4581 # We only want to install prereqs if either they're not installed
4582 # or if the installed version is too old. We cannot omit this
4583 # check, because if 'force' is in effect, nobody else will check.
4587 defined $nmo->inst_file &&
4588 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4590 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4594 CPAN::Version->readable($need_version)
4600 if ($self->{sponsored_mods}{$need_module}++){
4601 # We have already sponsored it and for some reason it's still
4602 # not available. So we do nothing. Or what should we do?
4603 # if we push it again, we have a potential infinite loop
4606 push @need, $need_module;
4611 #-> sub CPAN::Distribution::prereq_pm ;
4614 return $self->{prereq_pm} if
4615 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4616 return unless $self->{writemakefile}; # no need to have succeeded
4617 # but we must have run it
4618 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4619 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4624 $fh = FileHandle->new("<$makefile\0")) {
4628 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4630 last if /MakeMaker post_initialize section/;
4632 \s+PREREQ_PM\s+=>\s+(.+)
4635 # warn "Found prereq expr[$p]";
4637 # Regexp modified by A.Speer to remember actual version of file
4638 # PREREQ_PM hash key wants, then add to
4639 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4640 # In case a prereq is mentioned twice, complain.
4641 if ( defined $p{$1} ) {
4642 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4649 $self->{prereq_pm_detected}++;
4650 return $self->{prereq_pm} = \%p;
4653 #-> sub CPAN::Distribution::test ;
4658 delete $self->{force_update};
4661 $CPAN::Frontend->myprint("Running make test\n");
4662 if (my @prereq = $self->unsat_prereq){
4663 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4667 exists $self->{make} or exists $self->{later} or push @e,
4668 "Make had some problems, maybe interrupted? Won't test";
4670 exists $self->{'make'} and
4671 $self->{'make'} eq 'NO' and
4672 push @e, "Can't test without successful make";
4674 exists $self->{build_dir} or push @e, "Has no own directory";
4675 $self->{badtestcnt} ||= 0;
4676 $self->{badtestcnt} > 0 and
4677 push @e, "Won't repeat unsuccessful test during this command";
4679 exists $self->{later} and length($self->{later}) and
4680 push @e, $self->{later};
4682 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4684 chdir $self->{'build_dir'} or
4685 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4686 $self->debug("Changed directory to $self->{'build_dir'}")
4689 if ($^O eq 'MacOS') {
4690 Mac::BuildTools::make_test($self);
4694 local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4695 $CPAN::META->set_perl5lib;
4696 my $system = join " ", $CPAN::Config->{'make'}, "test";
4697 if (system($system) == 0) {
4698 $CPAN::Frontend->myprint(" $system -- OK\n");
4699 $CPAN::META->is_tested($self->{'build_dir'});
4700 $self->{make_test} = "YES";
4702 $self->{make_test} = "NO";
4703 $self->{badtestcnt}++;
4704 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4708 #-> sub CPAN::Distribution::clean ;
4711 $CPAN::Frontend->myprint("Running make clean\n");
4714 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4715 push @e, "make clean already called once";
4716 exists $self->{build_dir} or push @e, "Has no own directory";
4717 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4719 chdir $self->{'build_dir'} or
4720 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4721 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4723 if ($^O eq 'MacOS') {
4724 Mac::BuildTools::make_clean($self);
4728 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4729 if (system($system) == 0) {
4730 $CPAN::Frontend->myprint(" $system -- OK\n");
4734 # Jost Krieger pointed out that this "force" was wrong because
4735 # it has the effect that the next "install" on this distribution
4736 # will untar everything again. Instead we should bring the
4737 # object's state back to where it is after untarring.
4739 delete $self->{force_update};
4740 delete $self->{install};
4741 delete $self->{writemakefile};
4742 delete $self->{make};
4743 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4744 $self->{make_clean} = "YES";
4747 # Hmmm, what to do if make clean failed?
4749 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4751 make clean did not succeed, marking directory as unusable for further work.
4753 $self->force("make"); # so that this directory won't be used again
4758 #-> sub CPAN::Distribution::install ;
4763 delete $self->{force_update};
4766 $CPAN::Frontend->myprint("Running make install\n");
4769 exists $self->{build_dir} or push @e, "Has no own directory";
4771 exists $self->{make} or exists $self->{later} or push @e,
4772 "Make had some problems, maybe interrupted? Won't install";
4774 exists $self->{'make'} and
4775 $self->{'make'} eq 'NO' and
4776 push @e, "make had returned bad status, install seems impossible";
4778 push @e, "make test had returned bad status, ".
4779 "won't install without force"
4780 if exists $self->{'make_test'} and
4781 $self->{'make_test'} eq 'NO' and
4782 ! $self->{'force_update'};
4784 exists $self->{'install'} and push @e,
4785 $self->{'install'} eq "YES" ?
4786 "Already done" : "Already tried without success";
4788 exists $self->{later} and length($self->{later}) and
4789 push @e, $self->{later};
4791 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4793 chdir $self->{'build_dir'} or
4794 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4795 $self->debug("Changed directory to $self->{'build_dir'}")
4798 if ($^O eq 'MacOS') {
4799 Mac::BuildTools::make_install($self);
4803 my $system = join(" ", $CPAN::Config->{'make'},
4804 "install", $CPAN::Config->{make_install_arg});
4805 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4806 my($pipe) = FileHandle->new("$system $stderr |");
4809 $CPAN::Frontend->myprint($_);
4814 $CPAN::Frontend->myprint(" $system -- OK\n");
4815 $CPAN::META->is_installed($self->{'build_dir'});
4816 return $self->{'install'} = "YES";
4818 $self->{'install'} = "NO";
4819 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4820 if ($makeout =~ /permission/s && $> > 0) {
4821 $CPAN::Frontend->myprint(qq{ You may have to su }.
4822 qq{to root to install the package\n});
4825 delete $self->{force_update};
4828 #-> sub CPAN::Distribution::dir ;
4830 shift->{'build_dir'};
4833 package CPAN::Bundle;
4837 $CPAN::Frontend->myprint(
4838 qq{ look() commmand on bundles not}.
4839 qq{ implemented (What should it do?)}
4845 delete $self->{later};
4846 for my $c ( $self->contains ) {
4847 my $obj = CPAN::Shell->expandany($c) or next;
4852 #-> sub CPAN::Bundle::color_cmd_tmps ;
4853 sub color_cmd_tmps {
4855 my($depth) = shift || 0;
4856 my($color) = shift || 0;
4857 # a module needs to recurse to its cpan_file, a distribution needs
4858 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4860 return if exists $self->{incommandcolor}
4861 && $self->{incommandcolor}==$color;
4862 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4863 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4868 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4870 for my $c ( $self->contains ) {
4871 my $obj = CPAN::Shell->expandany($c) or next;
4872 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4873 $obj->color_cmd_tmps($depth+1,$color);
4876 delete $self->{badtestcnt};
4878 $self->{incommandcolor} = $color;
4881 #-> sub CPAN::Bundle::as_string ;
4885 # following line must be "=", not "||=" because we have a moving target
4886 $self->{INST_VERSION} = $self->inst_version;
4887 return $self->SUPER::as_string;
4890 #-> sub CPAN::Bundle::contains ;
4893 my($inst_file) = $self->inst_file || "";
4894 my($id) = $self->id;
4895 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4896 unless ($inst_file) {
4897 # Try to get at it in the cpan directory
4898 $self->debug("no inst_file") if $CPAN::DEBUG;
4900 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4901 $cpan_file = $self->cpan_file;
4902 if ($cpan_file eq "N/A") {
4903 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4904 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4906 my $dist = $CPAN::META->instance('CPAN::Distribution',
4909 $self->debug($dist->as_string) if $CPAN::DEBUG;
4910 my($todir) = $CPAN::Config->{'cpan_home'};
4911 my(@me,$from,$to,$me);
4912 @me = split /::/, $self->id;
4914 $me = File::Spec->catfile(@me);
4915 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4916 $to = File::Spec->catfile($todir,$me);
4917 File::Path::mkpath(File::Basename::dirname($to));
4918 File::Copy::copy($from, $to)
4919 or Carp::confess("Couldn't copy $from to $to: $!");
4923 my $fh = FileHandle->new;
4925 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4927 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4929 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4930 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4931 next unless $in_cont;
4936 push @result, (split " ", $_, 2)[0];
4939 delete $self->{STATUS};
4940 $self->{CONTAINS} = \@result;
4941 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4943 $CPAN::Frontend->mywarn(qq{
4944 The bundle file "$inst_file" may be a broken
4945 bundlefile. It seems not to contain any bundle definition.
4946 Please check the file and if it is bogus, please delete it.
4947 Sorry for the inconvenience.
4953 #-> sub CPAN::Bundle::find_bundle_file
4954 sub find_bundle_file {
4955 my($self,$where,$what) = @_;
4956 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4957 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4958 ### my $bu = File::Spec->catfile($where,$what);
4959 ### return $bu if -f $bu;
4960 my $manifest = File::Spec->catfile($where,"MANIFEST");
4961 unless (-f $manifest) {
4962 require ExtUtils::Manifest;
4963 my $cwd = CPAN::anycwd();
4964 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4965 ExtUtils::Manifest::mkmanifest();
4966 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4968 my $fh = FileHandle->new($manifest)
4969 or Carp::croak("Couldn't open $manifest: $!");
4972 if ($^O eq 'MacOS') {
4975 $what2 =~ s/:Bundle://;
4978 $what2 =~ s|Bundle[/\\]||;
4983 my($file) = /(\S+)/;
4984 if ($file =~ m|\Q$what\E$|) {
4986 # return File::Spec->catfile($where,$bu); # bad
4989 # retry if she managed to
4990 # have no Bundle directory
4991 $bu = $file if $file =~ m|\Q$what2\E$|;
4993 $bu =~ tr|/|:| if $^O eq 'MacOS';
4994 return File::Spec->catfile($where, $bu) if $bu;
4995 Carp::croak("Couldn't find a Bundle file in $where");
4998 # needs to work quite differently from Module::inst_file because of
4999 # cpan_home/Bundle/ directory and the possibility that we have
5000 # shadowing effect. As it makes no sense to take the first in @INC for
5001 # Bundles, we parse them all for $VERSION and take the newest.
5003 #-> sub CPAN::Bundle::inst_file ;
5008 @me = split /::/, $self->id;
5011 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5012 my $bfile = File::Spec->catfile($incdir, @me);
5013 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5014 next unless -f $bfile;
5015 my $foundv = MM->parse_version($bfile);
5016 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5017 $self->{INST_FILE} = $bfile;
5018 $self->{INST_VERSION} = $bestv = $foundv;
5024 #-> sub CPAN::Bundle::inst_version ;
5027 $self->inst_file; # finds INST_VERSION as side effect
5028 $self->{INST_VERSION};
5031 #-> sub CPAN::Bundle::rematein ;
5033 my($self,$meth) = @_;
5034 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5035 my($id) = $self->id;
5036 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5037 unless $self->inst_file || $self->cpan_file;
5039 for $s ($self->contains) {
5040 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5041 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5042 if ($type eq 'CPAN::Distribution') {
5043 $CPAN::Frontend->mywarn(qq{
5044 The Bundle }.$self->id.qq{ contains
5045 explicitly a file $s.
5049 # possibly noisy action:
5050 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5051 my $obj = $CPAN::META->instance($type,$s);
5053 if ($obj->isa(CPAN::Bundle)
5055 exists $obj->{install_failed}
5057 ref($obj->{install_failed}) eq "HASH"
5059 for (keys %{$obj->{install_failed}}) {
5060 $self->{install_failed}{$_} = undef; # propagate faiure up
5063 $fail{$s} = 1; # the bundle itself may have succeeded but
5068 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5069 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5071 delete $self->{install_failed}{$s};
5078 # recap with less noise
5079 if ( $meth eq "install" ) {
5082 my $raw = sprintf(qq{Bundle summary:
5083 The following items in bundle %s had installation problems:},
5086 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5087 $CPAN::Frontend->myprint("\n");
5090 for $s ($self->contains) {
5092 $paragraph .= "$s ";
5093 $self->{install_failed}{$s} = undef;
5094 $reported{$s} = undef;
5097 my $report_propagated;
5098 for $s (sort keys %{$self->{install_failed}}) {
5099 next if exists $reported{$s};
5100 $paragraph .= "and the following items had problems
5101 during recursive bundle calls: " unless $report_propagated++;
5102 $paragraph .= "$s ";
5104 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5105 $CPAN::Frontend->myprint("\n");
5107 $self->{'install'} = 'YES';
5112 #sub CPAN::Bundle::xs_file
5114 # If a bundle contains another that contains an xs_file we have
5115 # here, we just don't bother I suppose
5119 #-> sub CPAN::Bundle::force ;
5120 sub force { shift->rematein('force',@_); }
5121 #-> sub CPAN::Bundle::get ;
5122 sub get { shift->rematein('get',@_); }
5123 #-> sub CPAN::Bundle::make ;
5124 sub make { shift->rematein('make',@_); }
5125 #-> sub CPAN::Bundle::test ;
5128 $self->{badtestcnt} ||= 0;
5129 $self->rematein('test',@_);
5131 #-> sub CPAN::Bundle::install ;
5134 $self->rematein('install',@_);
5136 #-> sub CPAN::Bundle::clean ;
5137 sub clean { shift->rematein('clean',@_); }
5139 #-> sub CPAN::Bundle::uptodate ;
5142 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5144 foreach $c ($self->contains) {
5145 my $obj = CPAN::Shell->expandany($c);
5146 return 0 unless $obj->uptodate;
5151 #-> sub CPAN::Bundle::readme ;
5154 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5155 No File found for bundle } . $self->id . qq{\n}), return;
5156 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5157 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5160 package CPAN::Module;
5163 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
5166 return unless exists $self->{RO}; # should never happen
5167 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
5169 sub description { shift->{RO}{description} }
5173 delete $self->{later};
5174 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5179 #-> sub CPAN::Module::color_cmd_tmps ;
5180 sub color_cmd_tmps {
5182 my($depth) = shift || 0;
5183 my($color) = shift || 0;
5184 # a module needs to recurse to its cpan_file
5186 return if exists $self->{incommandcolor}
5187 && $self->{incommandcolor}==$color;
5188 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5189 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5194 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5196 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5197 $dist->color_cmd_tmps($depth+1,$color);
5200 delete $self->{badtestcnt};
5202 $self->{incommandcolor} = $color;
5205 #-> sub CPAN::Module::as_glimpse ;
5209 my $class = ref($self);
5210 $class =~ s/^CPAN:://;
5214 $CPAN::Shell::COLOR_REGISTERED
5216 $CPAN::META->has_inst("Term::ANSIColor")
5218 $self->{RO}{description}
5220 $color_on = Term::ANSIColor::color("green");
5221 $color_off = Term::ANSIColor::color("reset");
5223 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5232 #-> sub CPAN::Module::as_string ;
5236 CPAN->debug($self) if $CPAN::DEBUG;
5237 my $class = ref($self);
5238 $class =~ s/^CPAN:://;
5240 push @m, $class, " id = $self->{ID}\n";
5241 my $sprintf = " %-12s %s\n";
5242 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5243 if $self->description;
5244 my $sprintf2 = " %-12s %s (%s)\n";
5246 if ($userid = $self->cpan_userid || $self->userid){
5248 if ($author = CPAN::Shell->expand('Author',$userid)) {
5251 if ($m = $author->email) {
5258 $author->fullname . $email
5262 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5263 if $self->cpan_version;
5264 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5265 if $self->cpan_file;
5266 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5267 my(%statd,%stats,%statl,%stati);
5268 @statd{qw,? i c a b R M S,} = qw,unknown idea
5269 pre-alpha alpha beta released mature standard,;
5270 @stats{qw,? m d u n,} = qw,unknown mailing-list
5271 developer comp.lang.perl.* none,;
5272 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5273 @stati{qw,? f r O h,} = qw,unknown functions
5274 references+ties object-oriented hybrid,;
5275 $statd{' '} = 'unknown';
5276 $stats{' '} = 'unknown';
5277 $statl{' '} = 'unknown';
5278 $stati{' '} = 'unknown';
5286 $statd{$self->{RO}{statd}},
5287 $stats{$self->{RO}{stats}},
5288 $statl{$self->{RO}{statl}},
5289 $stati{$self->{RO}{stati}}
5290 ) if $self->{RO}{statd};
5291 my $local_file = $self->inst_file;
5292 unless ($self->{MANPAGE}) {
5294 $self->{MANPAGE} = $self->manpage_headline($local_file);
5296 # If we have already untarred it, we should look there
5297 my $dist = $CPAN::META->instance('CPAN::Distribution',
5299 # warn "dist[$dist]";
5300 # mff=manifest file; mfh=manifest handle
5305 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5307 $mfh = FileHandle->new($mff)
5309 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5310 my $lfre = $self->id; # local file RE
5313 my($lfl); # local file file
5315 my(@mflines) = <$mfh>;
5320 while (length($lfre)>5 and !$lfl) {
5321 ($lfl) = grep /$lfre/, @mflines;
5322 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5325 $lfl =~ s/\s.*//; # remove comments
5326 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5327 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5328 # warn "lfl_abs[$lfl_abs]";
5330 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5336 for $item (qw/MANPAGE/) {
5337 push @m, sprintf($sprintf, $item, $self->{$item})
5338 if exists $self->{$item};
5340 for $item (qw/CONTAINS/) {
5341 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5342 if exists $self->{$item} && @{$self->{$item}};
5344 push @m, sprintf($sprintf, 'INST_FILE',
5345 $local_file || "(not installed)");
5346 push @m, sprintf($sprintf, 'INST_VERSION',
5347 $self->inst_version) if $local_file;
5351 sub manpage_headline {
5352 my($self,$local_file) = @_;
5353 my(@local_file) = $local_file;
5354 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5355 push @local_file, $local_file;
5357 for $locf (@local_file) {
5358 next unless -f $locf;
5359 my $fh = FileHandle->new($locf)
5360 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5364 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5365 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5378 #-> sub CPAN::Module::cpan_file ;
5379 # Note: also inherited by CPAN::Bundle
5382 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5383 unless (defined $self->{RO}{CPAN_FILE}) {
5384 CPAN::Index->reload;
5386 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5387 return $self->{RO}{CPAN_FILE};
5389 my $userid = $self->userid;
5391 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5392 my $author = $CPAN::META->instance("CPAN::Author",
5394 my $fullname = $author->fullname;
5395 my $email = $author->email;
5396 unless (defined $fullname && defined $email) {
5397 return sprintf("Contact Author %s",
5401 return "Contact Author $fullname <$email>";
5403 return "UserID $userid";
5411 #-> sub CPAN::Module::cpan_version ;
5415 $self->{RO}{CPAN_VERSION} = 'undef'
5416 unless defined $self->{RO}{CPAN_VERSION};
5417 # I believe this is always a bug in the index and should be reported
5418 # as such, but usually I find out such an error and do not want to
5419 # provoke too many bugreports
5421 $self->{RO}{CPAN_VERSION};
5424 #-> sub CPAN::Module::force ;
5427 $self->{'force_update'}++;
5430 #-> sub CPAN::Module::rematein ;
5432 my($self,$meth) = @_;
5433 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5436 my $cpan_file = $self->cpan_file;
5437 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5438 $CPAN::Frontend->mywarn(sprintf qq{
5439 The module %s isn\'t available on CPAN.
5441 Either the module has not yet been uploaded to CPAN, or it is
5442 temporary unavailable. Please contact the author to find out
5443 more about the status. Try 'i %s'.
5450 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5451 $pack->called_for($self->id);
5452 $pack->force($meth) if exists $self->{'force_update'};
5454 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5455 delete $self->{'force_update'};
5458 #-> sub CPAN::Module::readme ;
5459 sub readme { shift->rematein('readme') }
5460 #-> sub CPAN::Module::look ;
5461 sub look { shift->rematein('look') }
5462 #-> sub CPAN::Module::cvs_import ;
5463 sub cvs_import { shift->rematein('cvs_import') }
5464 #-> sub CPAN::Module::get ;
5465 sub get { shift->rematein('get',@_); }
5466 #-> sub CPAN::Module::make ;
5469 $self->rematein('make');
5471 #-> sub CPAN::Module::test ;
5474 $self->{badtestcnt} ||= 0;
5475 $self->rematein('test',@_);
5477 #-> sub CPAN::Module::uptodate ;
5480 my($latest) = $self->cpan_version;
5482 my($inst_file) = $self->inst_file;
5484 if (defined $inst_file) {
5485 $have = $self->inst_version;
5490 ! CPAN::Version->vgt($latest, $have)
5492 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5493 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5498 #-> sub CPAN::Module::install ;
5504 not exists $self->{'force_update'}
5506 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5510 $self->rematein('install') if $doit;
5512 #-> sub CPAN::Module::clean ;
5513 sub clean { shift->rematein('clean') }
5515 #-> sub CPAN::Module::inst_file ;
5519 @packpath = split /::/, $self->{ID};
5520 $packpath[-1] .= ".pm";
5521 foreach $dir (@INC) {
5522 my $pmfile = File::Spec->catfile($dir,@packpath);
5530 #-> sub CPAN::Module::xs_file ;
5534 @packpath = split /::/, $self->{ID};
5535 push @packpath, $packpath[-1];
5536 $packpath[-1] .= "." . $Config::Config{'dlext'};
5537 foreach $dir (@INC) {
5538 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5546 #-> sub CPAN::Module::inst_version ;
5549 my $parsefile = $self->inst_file or return;
5550 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5553 # there was a bug in 5.6.0 that let lots of unini warnings out of
5554 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5555 # the following workaround after 5.6.1 is out.
5556 local($SIG{__WARN__}) = sub { my $w = shift;
5557 return if $w =~ /uninitialized/i;
5561 $have = MM->parse_version($parsefile) || "undef";
5562 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5563 $have =~ s/ $//; # trailing whitespace happens all the time
5565 # My thoughts about why %vd processing should happen here
5567 # Alt1 maintain it as string with leading v:
5568 # read index files do nothing
5569 # compare it use utility for compare
5570 # print it do nothing
5572 # Alt2 maintain it as what it is
5573 # read index files convert
5574 # compare it use utility because there's still a ">" vs "gt" issue
5575 # print it use CPAN::Version for print
5577 # Seems cleaner to hold it in memory as a string starting with a "v"
5579 # If the author of this module made a mistake and wrote a quoted
5580 # "v1.13" instead of v1.13, we simply leave it at that with the
5581 # effect that *we* will treat it like a v-tring while the rest of
5582 # perl won't. Seems sensible when we consider that any action we
5583 # could take now would just add complexity.
5585 $have = CPAN::Version->readable($have);
5587 $have =~ s/\s*//g; # stringify to float around floating point issues
5588 $have; # no stringify needed, \s* above matches always
5591 package CPAN::Tarzip;
5593 # CPAN::Tarzip::gzip
5595 my($class,$read,$write) = @_;
5596 if ($CPAN::META->has_inst("Compress::Zlib")) {
5598 $fhw = FileHandle->new($read)
5599 or $CPAN::Frontend->mydie("Could not open $read: $!");
5600 my $gz = Compress::Zlib::gzopen($write, "wb")
5601 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5602 $gz->gzwrite($buffer)
5603 while read($fhw,$buffer,4096) > 0 ;
5608 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5613 # CPAN::Tarzip::gunzip
5615 my($class,$read,$write) = @_;
5616 if ($CPAN::META->has_inst("Compress::Zlib")) {
5618 $fhw = FileHandle->new(">$write")
5619 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5620 my $gz = Compress::Zlib::gzopen($read, "rb")
5621 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5622 $fhw->print($buffer)
5623 while $gz->gzread($buffer) > 0 ;
5624 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5625 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5630 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5635 # CPAN::Tarzip::gtest
5637 my($class,$read) = @_;
5638 # After I had reread the documentation in zlib.h, I discovered that
5639 # uncompressed files do not lead to an gzerror (anymore?).
5640 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5643 my $gz = Compress::Zlib::gzopen($read, "rb")
5644 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5646 $Compress::Zlib::gzerrno));
5647 while ($gz->gzread($buffer) > 0 ){
5648 $len += length($buffer);
5651 my $err = $gz->gzerror;
5652 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5653 if ($len == -s $read){
5655 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5658 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5661 return system("$CPAN::Config->{gzip} -dt $read")==0;
5666 # CPAN::Tarzip::TIEHANDLE
5668 my($class,$file) = @_;
5670 $class->debug("file[$file]");
5671 if ($CPAN::META->has_inst("Compress::Zlib")) {
5672 my $gz = Compress::Zlib::gzopen($file,"rb") or
5673 die "Could not gzopen $file";
5674 $ret = bless {GZ => $gz}, $class;
5676 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5677 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5679 $ret = bless {FH => $fh}, $class;
5685 # CPAN::Tarzip::READLINE
5688 if (exists $self->{GZ}) {
5689 my $gz = $self->{GZ};
5690 my($line,$bytesread);
5691 $bytesread = $gz->gzreadline($line);
5692 return undef if $bytesread <= 0;
5695 my $fh = $self->{FH};
5696 return scalar <$fh>;
5701 # CPAN::Tarzip::READ
5703 my($self,$ref,$length,$offset) = @_;
5704 die "read with offset not implemented" if defined $offset;
5705 if (exists $self->{GZ}) {
5706 my $gz = $self->{GZ};
5707 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5710 my $fh = $self->{FH};
5711 return read($fh,$$ref,$length);
5716 # CPAN::Tarzip::DESTROY
5719 if (exists $self->{GZ}) {
5720 my $gz = $self->{GZ};
5721 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5722 # to be undef ever. AK, 2000-09
5724 my $fh = $self->{FH};
5725 $fh->close if defined $fh;
5731 # CPAN::Tarzip::untar
5733 my($class,$file) = @_;
5736 if (0) { # makes changing order easier
5737 } elsif ($BUGHUNTING){
5739 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5741 MM->maybe_command($CPAN::Config->{'tar'})) {
5742 # should be default until Archive::Tar is fixed
5745 $CPAN::META->has_inst("Archive::Tar")
5747 $CPAN::META->has_inst("Compress::Zlib") ) {
5750 $CPAN::Frontend->mydie(qq{
5751 CPAN.pm needs either both external programs tar and gzip installed or
5752 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5753 is available. Can\'t continue.
5756 if ($prefer==1) { # 1 => external gzip+tar
5758 my $is_compressed = $class->gtest($file);
5759 if ($is_compressed) {
5760 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5761 "< $file | $CPAN::Config->{tar} xvf -";
5763 $system = "$CPAN::Config->{tar} xvf $file";
5765 if (system($system) != 0) {
5766 # people find the most curious tar binaries that cannot handle
5768 if ($is_compressed) {
5769 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5770 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5771 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5773 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5777 $system = "$CPAN::Config->{tar} xvf $file";
5778 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5779 if (system($system)==0) {
5780 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5782 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5788 } elsif ($prefer==2) { # 2 => modules
5789 my $tar = Archive::Tar->new($file,1);
5790 my $af; # archive file
5793 # RCS 1.337 had this code, it turned out unacceptable slow but
5794 # it revealed a bug in Archive::Tar. Code is only here to hunt
5795 # the bug again. It should never be enabled in published code.
5796 # GDGraph3d-0.53 was an interesting case according to Larry
5798 warn(">>>Bughunting code enabled<<< " x 20);
5799 for $af ($tar->list_files) {
5800 if ($af =~ m!^(/|\.\./)!) {
5801 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5802 "illegal member [$af]");
5804 $CPAN::Frontend->myprint("$af\n");
5805 $tar->extract($af); # slow but effective for finding the bug
5806 return if $CPAN::Signal;
5809 for $af ($tar->list_files) {
5810 if ($af =~ m!^(/|\.\./)!) {
5811 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5812 "illegal member [$af]");
5814 $CPAN::Frontend->myprint("$af\n");
5816 return if $CPAN::Signal;
5821 Mac::BuildTools::convert_files([$tar->list_files], 1)
5822 if ($^O eq 'MacOS');
5829 my($class,$file) = @_;
5830 if ($CPAN::META->has_inst("Archive::Zip")) {
5831 # blueprint of the code from Archive::Zip::Tree::extractTree();
5832 my $zip = Archive::Zip->new();
5834 $status = $zip->read($file);
5835 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5836 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5837 my @members = $zip->members();
5838 for my $member ( @members ) {
5839 my $af = $member->fileName();
5840 if ($af =~ m!^(/|\.\./)!) {
5841 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5842 "illegal member [$af]");
5844 my $status = $member->extractToFileNamed( $af );
5845 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5846 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5847 $status != Archive::Zip::AZ_OK();
5848 return if $CPAN::Signal;
5852 my $unzip = $CPAN::Config->{unzip} or
5853 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5854 my @system = ($unzip, $file);
5855 return system(@system) == 0;
5860 package CPAN::Version;
5861 # CPAN::Version::vcmp courtesy Jost Krieger
5863 my($self,$l,$r) = @_;
5865 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5867 return 0 if $l eq $r; # short circuit for quicker success
5869 if ($l=~/^v/ <=> $r=~/^v/) {
5872 $_ = $self->float2vv($_);
5877 ($l ne "undef") <=> ($r ne "undef") ||
5881 $self->vstring($l) cmp $self->vstring($r)) ||
5887 my($self,$l,$r) = @_;
5888 $self->vcmp($l,$r) > 0;
5893 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5894 pack "U*", split /\./, $n;
5897 # vv => visible vstring
5902 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5903 # architecture influence
5905 $mantissa .= "0" while length($mantissa)%3;
5906 my $ret = "v" . $rev;
5908 $mantissa =~ s/(\d{1,3})// or
5909 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5910 $ret .= ".".int($1);
5912 # warn "n[$n]ret[$ret]";
5918 $n =~ /^([\w\-\+\.]+)/;
5920 return $1 if defined $1 && length($1)>0;
5921 # if the first user reaches version v43, he will be treated as "+".
5922 # We'll have to decide about a new rule here then, depending on what
5923 # will be the prevailing versioning behavior then.
5925 if ($] < 5.006) { # or whenever v-strings were introduced
5926 # we get them wrong anyway, whatever we do, because 5.005 will
5927 # have already interpreted 0.2.4 to be "0.24". So even if he
5928 # indexer sends us something like "v0.2.4" we compare wrongly.
5930 # And if they say v1.2, then the old perl takes it as "v12"
5932 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
5935 my $better = sprintf "v%vd", $n;
5936 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5948 CPAN - query, download and build perl modules from CPAN sites
5954 perl -MCPAN -e shell;
5960 autobundle, clean, install, make, recompile, test
5964 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
5965 of a modern rewrite from ground up with greater extensibility and more
5966 features but no full compatibility. If you're new to CPAN.pm, you
5967 probably should investigate if CPANPLUS is the better choice for you.
5968 If you're already used to CPAN.pm you're welcome to continue using it,
5969 if you accept that its development is mostly (though not completely)
5974 The CPAN module is designed to automate the make and install of perl
5975 modules and extensions. It includes some searching capabilities and
5976 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5977 to fetch the raw data from the net.
5979 Modules are fetched from one or more of the mirrored CPAN
5980 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5983 The CPAN module also supports the concept of named and versioned
5984 I<bundles> of modules. Bundles simplify the handling of sets of
5985 related modules. See Bundles below.
5987 The package contains a session manager and a cache manager. There is
5988 no status retained between sessions. The session manager keeps track
5989 of what has been fetched, built and installed in the current
5990 session. The cache manager keeps track of the disk space occupied by
5991 the make processes and deletes excess space according to a simple FIFO
5994 For extended searching capabilities there's a plugin for CPAN available,
5995 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5996 that indexes all documents available in CPAN authors directories. If
5997 C<CPAN::WAIT> is installed on your system, the interactive shell of
5998 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5999 which send queries to the WAIT server that has been configured for your
6002 All other methods provided are accessible in a programmer style and in an
6003 interactive shell style.
6005 =head2 Interactive Mode
6007 The interactive mode is entered by running
6009 perl -MCPAN -e shell
6011 which puts you into a readline interface. You will have the most fun if
6012 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6015 Once you are on the command line, type 'h' and the rest should be
6018 The function call C<shell> takes two optional arguments, one is the
6019 prompt, the second is the default initial command line (the latter
6020 only works if a real ReadLine interface module is installed).
6022 The most common uses of the interactive modes are
6026 =item Searching for authors, bundles, distribution files and modules
6028 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6029 for each of the four categories and another, C<i> for any of the
6030 mentioned four. Each of the four entities is implemented as a class
6031 with slightly differing methods for displaying an object.
6033 Arguments you pass to these commands are either strings exactly matching
6034 the identification string of an object or regular expressions that are
6035 then matched case-insensitively against various attributes of the
6036 objects. The parser recognizes a regular expression only if you
6037 enclose it between two slashes.
6039 The principle is that the number of found objects influences how an
6040 item is displayed. If the search finds one item, the result is
6041 displayed with the rather verbose method C<as_string>, but if we find
6042 more than one, we display each object with the terse method
6045 =item make, test, install, clean modules or distributions
6047 These commands take any number of arguments and investigate what is
6048 necessary to perform the action. If the argument is a distribution
6049 file name (recognized by embedded slashes), it is processed. If it is
6050 a module, CPAN determines the distribution file in which this module
6051 is included and processes that, following any dependencies named in
6052 the module's Makefile.PL (this behavior is controlled by
6053 I<prerequisites_policy>.)
6055 Any C<make> or C<test> are run unconditionally. An
6057 install <distribution_file>
6059 also is run unconditionally. But for
6063 CPAN checks if an install is actually needed for it and prints
6064 I<module up to date> in the case that the distribution file containing
6065 the module doesn't need to be updated.
6067 CPAN also keeps track of what it has done within the current session
6068 and doesn't try to build a package a second time regardless if it
6069 succeeded or not. The C<force> command takes as a first argument the
6070 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6071 command from scratch.
6075 cpan> install OpenGL
6076 OpenGL is up to date.
6077 cpan> force install OpenGL
6080 OpenGL-0.4/COPYRIGHT
6083 A C<clean> command results in a
6087 being executed within the distribution file's working directory.
6089 =item get, readme, look module or distribution
6091 C<get> downloads a distribution file without further action. C<readme>
6092 displays the README file of the associated distribution. C<Look> gets
6093 and untars (if not yet done) the distribution file, changes to the
6094 appropriate directory and opens a subshell process in that directory.
6098 C<ls> lists all distribution files in and below an author's CPAN
6099 directory. Only those files that contain modules are listed and if
6100 there is more than one for any given module, only the most recent one
6105 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6106 in the cpan-shell it is intended that you can press C<^C> anytime and
6107 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6108 to clean up and leave the shell loop. You can emulate the effect of a
6109 SIGTERM by sending two consecutive SIGINTs, which usually means by
6110 pressing C<^C> twice.
6112 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6113 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6119 The commands that are available in the shell interface are methods in
6120 the package CPAN::Shell. If you enter the shell command, all your
6121 input is split by the Text::ParseWords::shellwords() routine which
6122 acts like most shells do. The first word is being interpreted as the
6123 method to be called and the rest of the words are treated as arguments
6124 to this method. Continuation lines are supported if a line ends with a
6129 C<autobundle> writes a bundle file into the
6130 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6131 a list of all modules that are both available from CPAN and currently
6132 installed within @INC. The name of the bundle file is based on the
6133 current date and a counter.
6137 recompile() is a very special command in that it takes no argument and
6138 runs the make/test/install cycle with brute force over all installed
6139 dynamically loadable extensions (aka XS modules) with 'force' in
6140 effect. The primary purpose of this command is to finish a network
6141 installation. Imagine, you have a common source tree for two different
6142 architectures. You decide to do a completely independent fresh
6143 installation. You start on one architecture with the help of a Bundle
6144 file produced earlier. CPAN installs the whole Bundle for you, but
6145 when you try to repeat the job on the second architecture, CPAN
6146 responds with a C<"Foo up to date"> message for all modules. So you
6147 invoke CPAN's recompile on the second architecture and you're done.
6149 Another popular use for C<recompile> is to act as a rescue in case your
6150 perl breaks binary compatibility. If one of the modules that CPAN uses
6151 is in turn depending on binary compatibility (so you cannot run CPAN
6152 commands), then you should try the CPAN::Nox module for recovery.
6154 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6156 Although it may be considered internal, the class hierarchy does matter
6157 for both users and programmer. CPAN.pm deals with above mentioned four
6158 classes, and all those classes share a set of methods. A classical
6159 single polymorphism is in effect. A metaclass object registers all
6160 objects of all kinds and indexes them with a string. The strings
6161 referencing objects have a separated namespace (well, not completely
6166 words containing a "/" (slash) Distribution
6167 words starting with Bundle:: Bundle
6168 everything else Module or Author
6170 Modules know their associated Distribution objects. They always refer
6171 to the most recent official release. Developers may mark their releases
6172 as unstable development versions (by inserting an underbar into the
6173 module version number which will also be reflected in the distribution
6174 name when you run 'make dist'), so the really hottest and newest
6175 distribution is not always the default. If a module Foo circulates
6176 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6177 way to install version 1.23 by saying
6181 This would install the complete distribution file (say
6182 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6183 like to install version 1.23_90, you need to know where the
6184 distribution file resides on CPAN relative to the authors/id/
6185 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6186 so you would have to say
6188 install BAR/Foo-1.23_90.tar.gz
6190 The first example will be driven by an object of the class
6191 CPAN::Module, the second by an object of class CPAN::Distribution.
6193 =head2 Programmer's interface
6195 If you do not enter the shell, the available shell commands are both
6196 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6197 functions in the calling package (C<install(...)>).
6199 There's currently only one class that has a stable interface -
6200 CPAN::Shell. All commands that are available in the CPAN shell are
6201 methods of the class CPAN::Shell. Each of the commands that produce
6202 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6203 the IDs of all modules within the list.
6207 =item expand($type,@things)
6209 The IDs of all objects available within a program are strings that can
6210 be expanded to the corresponding real objects with the
6211 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6212 list of CPAN::Module objects according to the C<@things> arguments
6213 given. In scalar context it only returns the first element of the
6216 =item expandany(@things)
6218 Like expand, but returns objects of the appropriate type, i.e.
6219 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6220 CPAN::Distribution objects fro distributions.
6222 =item Programming Examples
6224 This enables the programmer to do operations that combine
6225 functionalities that are available in the shell.
6227 # install everything that is outdated on my disk:
6228 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6230 # install my favorite programs if necessary:
6231 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6232 my $obj = CPAN::Shell->expand('Module',$mod);
6236 # list all modules on my disk that have no VERSION number
6237 for $mod (CPAN::Shell->expand("Module","/./")){
6238 next unless $mod->inst_file;
6239 # MakeMaker convention for undefined $VERSION:
6240 next unless $mod->inst_version eq "undef";
6241 print "No VERSION in ", $mod->id, "\n";
6244 # find out which distribution on CPAN contains a module:
6245 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6247 Or if you want to write a cronjob to watch The CPAN, you could list
6248 all modules that need updating. First a quick and dirty way:
6250 perl -e 'use CPAN; CPAN::Shell->r;'
6252 If you don't want to get any output in the case that all modules are
6253 up to date, you can parse the output of above command for the regular
6254 expression //modules are up to date// and decide to mail the output
6255 only if it doesn't match. Ick?
6257 If you prefer to do it more in a programmer style in one single
6258 process, maybe something like this suits you better:
6260 # list all modules on my disk that have newer versions on CPAN
6261 for $mod (CPAN::Shell->expand("Module","/./")){
6262 next unless $mod->inst_file;
6263 next if $mod->uptodate;
6264 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6265 $mod->id, $mod->inst_version, $mod->cpan_version;
6268 If that gives you too much output every day, you maybe only want to
6269 watch for three modules. You can write
6271 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6273 as the first line instead. Or you can combine some of the above
6276 # watch only for a new mod_perl module
6277 $mod = CPAN::Shell->expand("Module","mod_perl");
6278 exit if $mod->uptodate;
6279 # new mod_perl arrived, let me know all update recommendations
6284 =head2 Methods in the other Classes
6286 The programming interface for the classes CPAN::Module,
6287 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6288 beta and partially even alpha. In the following paragraphs only those
6289 methods are documented that have proven useful over a longer time and
6290 thus are unlikely to change.
6294 =item CPAN::Author::as_glimpse()
6296 Returns a one-line description of the author
6298 =item CPAN::Author::as_string()
6300 Returns a multi-line description of the author
6302 =item CPAN::Author::email()
6304 Returns the author's email address
6306 =item CPAN::Author::fullname()
6308 Returns the author's name
6310 =item CPAN::Author::name()
6312 An alias for fullname
6314 =item CPAN::Bundle::as_glimpse()
6316 Returns a one-line description of the bundle
6318 =item CPAN::Bundle::as_string()
6320 Returns a multi-line description of the bundle
6322 =item CPAN::Bundle::clean()
6324 Recursively runs the C<clean> method on all items contained in the bundle.
6326 =item CPAN::Bundle::contains()
6328 Returns a list of objects' IDs contained in a bundle. The associated
6329 objects may be bundles, modules or distributions.
6331 =item CPAN::Bundle::force($method,@args)
6333 Forces CPAN to perform a task that normally would have failed. Force
6334 takes as arguments a method name to be called and any number of
6335 additional arguments that should be passed to the called method. The
6336 internals of the object get the needed changes so that CPAN.pm does
6337 not refuse to take the action. The C<force> is passed recursively to
6338 all contained objects.
6340 =item CPAN::Bundle::get()
6342 Recursively runs the C<get> method on all items contained in the bundle
6344 =item CPAN::Bundle::inst_file()
6346 Returns the highest installed version of the bundle in either @INC or
6347 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6348 CPAN::Module::inst_file.
6350 =item CPAN::Bundle::inst_version()
6352 Like CPAN::Bundle::inst_file, but returns the $VERSION
6354 =item CPAN::Bundle::uptodate()
6356 Returns 1 if the bundle itself and all its members are uptodate.
6358 =item CPAN::Bundle::install()
6360 Recursively runs the C<install> method on all items contained in the bundle
6362 =item CPAN::Bundle::make()
6364 Recursively runs the C<make> method on all items contained in the bundle
6366 =item CPAN::Bundle::readme()
6368 Recursively runs the C<readme> method on all items contained in the bundle
6370 =item CPAN::Bundle::test()
6372 Recursively runs the C<test> method on all items contained in the bundle
6374 =item CPAN::Distribution::as_glimpse()
6376 Returns a one-line description of the distribution
6378 =item CPAN::Distribution::as_string()
6380 Returns a multi-line description of the distribution
6382 =item CPAN::Distribution::clean()
6384 Changes to the directory where the distribution has been unpacked and
6385 runs C<make clean> there.
6387 =item CPAN::Distribution::containsmods()
6389 Returns a list of IDs of modules contained in a distribution file.
6390 Only works for distributions listed in the 02packages.details.txt.gz
6391 file. This typically means that only the most recent version of a
6392 distribution is covered.
6394 =item CPAN::Distribution::cvs_import()
6396 Changes to the directory where the distribution has been unpacked and
6399 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6403 =item CPAN::Distribution::dir()
6405 Returns the directory into which this distribution has been unpacked.
6407 =item CPAN::Distribution::force($method,@args)
6409 Forces CPAN to perform a task that normally would have failed. Force
6410 takes as arguments a method name to be called and any number of
6411 additional arguments that should be passed to the called method. The
6412 internals of the object get the needed changes so that CPAN.pm does
6413 not refuse to take the action.
6415 =item CPAN::Distribution::get()
6417 Downloads the distribution from CPAN and unpacks it. Does nothing if
6418 the distribution has already been downloaded and unpacked within the
6421 =item CPAN::Distribution::install()
6423 Changes to the directory where the distribution has been unpacked and
6424 runs the external command C<make install> there. If C<make> has not
6425 yet been run, it will be run first. A C<make test> will be issued in
6426 any case and if this fails, the install will be canceled. The
6427 cancellation can be avoided by letting C<force> run the C<install> for
6430 =item CPAN::Distribution::isa_perl()
6432 Returns 1 if this distribution file seems to be a perl distribution.
6433 Normally this is derived from the file name only, but the index from
6434 CPAN can contain a hint to achieve a return value of true for other
6437 =item CPAN::Distribution::look()
6439 Changes to the directory where the distribution has been unpacked and
6440 opens a subshell there. Exiting the subshell returns.
6442 =item CPAN::Distribution::make()
6444 First runs the C<get> method to make sure the distribution is
6445 downloaded and unpacked. Changes to the directory where the
6446 distribution has been unpacked and runs the external commands C<perl
6447 Makefile.PL> and C<make> there.
6449 =item CPAN::Distribution::prereq_pm()
6451 Returns the hash reference that has been announced by a distribution
6452 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6453 attempt has been made to C<make> the distribution. Returns undef
6456 =item CPAN::Distribution::readme()
6458 Downloads the README file associated with a distribution and runs it
6459 through the pager specified in C<$CPAN::Config->{pager}>.
6461 =item CPAN::Distribution::test()
6463 Changes to the directory where the distribution has been unpacked and
6464 runs C<make test> there.
6466 =item CPAN::Distribution::uptodate()
6468 Returns 1 if all the modules contained in the distribution are
6469 uptodate. Relies on containsmods.
6471 =item CPAN::Index::force_reload()
6473 Forces a reload of all indices.
6475 =item CPAN::Index::reload()
6477 Reloads all indices if they have been read more than
6478 C<$CPAN::Config->{index_expire}> days.
6480 =item CPAN::InfoObj::dump()
6482 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6483 inherit this method. It prints the data structure associated with an
6484 object. Useful for debugging. Note: the data structure is considered
6485 internal and thus subject to change without notice.
6487 =item CPAN::Module::as_glimpse()
6489 Returns a one-line description of the module
6491 =item CPAN::Module::as_string()
6493 Returns a multi-line description of the module
6495 =item CPAN::Module::clean()
6497 Runs a clean on the distribution associated with this module.
6499 =item CPAN::Module::cpan_file()
6501 Returns the filename on CPAN that is associated with the module.
6503 =item CPAN::Module::cpan_version()
6505 Returns the latest version of this module available on CPAN.
6507 =item CPAN::Module::cvs_import()
6509 Runs a cvs_import on the distribution associated with this module.
6511 =item CPAN::Module::description()
6513 Returns a 44 character description of this module. Only available for
6514 modules listed in The Module List (CPAN/modules/00modlist.long.html
6515 or 00modlist.long.txt.gz)
6517 =item CPAN::Module::force($method,@args)
6519 Forces CPAN to perform a task that normally would have failed. Force
6520 takes as arguments a method name to be called and any number of
6521 additional arguments that should be passed to the called method. The
6522 internals of the object get the needed changes so that CPAN.pm does
6523 not refuse to take the action.
6525 =item CPAN::Module::get()
6527 Runs a get on the distribution associated with this module.
6529 =item CPAN::Module::inst_file()
6531 Returns the filename of the module found in @INC. The first file found
6532 is reported just like perl itself stops searching @INC when it finds a
6535 =item CPAN::Module::inst_version()
6537 Returns the version number of the module in readable format.
6539 =item CPAN::Module::install()
6541 Runs an C<install> on the distribution associated with this module.
6543 =item CPAN::Module::look()
6545 Changes to the directory where the distribution associated with this
6546 module has been unpacked and opens a subshell there. Exiting the
6549 =item CPAN::Module::make()
6551 Runs a C<make> on the distribution associated with this module.
6553 =item CPAN::Module::manpage_headline()
6555 If module is installed, peeks into the module's manpage, reads the
6556 headline and returns it. Moreover, if the module has been downloaded
6557 within this session, does the equivalent on the downloaded module even
6558 if it is not installed.
6560 =item CPAN::Module::readme()
6562 Runs a C<readme> on the distribution associated with this module.
6564 =item CPAN::Module::test()
6566 Runs a C<test> on the distribution associated with this module.
6568 =item CPAN::Module::uptodate()
6570 Returns 1 if the module is installed and up-to-date.
6572 =item CPAN::Module::userid()
6574 Returns the author's ID of the module.
6578 =head2 Cache Manager
6580 Currently the cache manager only keeps track of the build directory
6581 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6582 deletes complete directories below C<build_dir> as soon as the size of
6583 all directories there gets bigger than $CPAN::Config->{build_cache}
6584 (in MB). The contents of this cache may be used for later
6585 re-installations that you intend to do manually, but will never be
6586 trusted by CPAN itself. This is due to the fact that the user might
6587 use these directories for building modules on different architectures.
6589 There is another directory ($CPAN::Config->{keep_source_where}) where
6590 the original distribution files are kept. This directory is not
6591 covered by the cache manager and must be controlled by the user. If
6592 you choose to have the same directory as build_dir and as
6593 keep_source_where directory, then your sources will be deleted with
6594 the same fifo mechanism.
6598 A bundle is just a perl module in the namespace Bundle:: that does not
6599 define any functions or methods. It usually only contains documentation.
6601 It starts like a perl module with a package declaration and a $VERSION
6602 variable. After that the pod section looks like any other pod with the
6603 only difference being that I<one special pod section> exists starting with
6608 In this pod section each line obeys the format
6610 Module_Name [Version_String] [- optional text]
6612 The only required part is the first field, the name of a module
6613 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6614 of the line is optional. The comment part is delimited by a dash just
6615 as in the man page header.
6617 The distribution of a bundle should follow the same convention as
6618 other distributions.
6620 Bundles are treated specially in the CPAN package. If you say 'install
6621 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6622 the modules in the CONTENTS section of the pod. You can install your
6623 own Bundles locally by placing a conformant Bundle file somewhere into
6624 your @INC path. The autobundle() command which is available in the
6625 shell interface does that for you by including all currently installed
6626 modules in a snapshot bundle file.
6628 =head2 Prerequisites
6630 If you have a local mirror of CPAN and can access all files with
6631 "file:" URLs, then you only need a perl better than perl5.003 to run
6632 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6633 required for non-UNIX systems or if your nearest CPAN site is
6634 associated with a URL that is not C<ftp:>.
6636 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6637 implemented for an external ftp command or for an external lynx
6640 =head2 Finding packages and VERSION
6642 This module presumes that all packages on CPAN
6648 declare their $VERSION variable in an easy to parse manner. This
6649 prerequisite can hardly be relaxed because it consumes far too much
6650 memory to load all packages into the running program just to determine
6651 the $VERSION variable. Currently all programs that are dealing with
6652 version use something like this
6654 perl -MExtUtils::MakeMaker -le \
6655 'print MM->parse_version(shift)' filename
6657 If you are author of a package and wonder if your $VERSION can be
6658 parsed, please try the above method.
6662 come as compressed or gzipped tarfiles or as zip files and contain a
6663 Makefile.PL (well, we try to handle a bit more, but without much
6670 The debugging of this module is a bit complex, because we have
6671 interferences of the software producing the indices on CPAN, of the
6672 mirroring process on CPAN, of packaging, of configuration, of
6673 synchronicity, and of bugs within CPAN.pm.
6675 For code debugging in interactive mode you can try "o debug" which
6676 will list options for debugging the various parts of the code. You
6677 should know that "o debug" has built-in completion support.
6679 For data debugging there is the C<dump> command which takes the same
6680 arguments as make/test/install and outputs the object's Data::Dumper
6683 =head2 Floppy, Zip, Offline Mode
6685 CPAN.pm works nicely without network too. If you maintain machines
6686 that are not networked at all, you should consider working with file:
6687 URLs. Of course, you have to collect your modules somewhere first. So
6688 you might use CPAN.pm to put together all you need on a networked
6689 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6690 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6691 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6692 with this floppy. See also below the paragraph about CD-ROM support.
6694 =head1 CONFIGURATION
6696 When the CPAN module is installed, a site wide configuration file is
6697 created as CPAN/Config.pm. The default values defined there can be
6698 overridden in another configuration file: CPAN/MyConfig.pm. You can
6699 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6700 $HOME/.cpan is added to the search path of the CPAN module before the
6701 use() or require() statements.
6703 Currently the following keys in the hash reference $CPAN::Config are
6706 build_cache size of cache for directories to build modules
6707 build_dir locally accessible directory to build modules
6708 index_expire after this many days refetch index files
6709 cache_metadata use serializer to cache metadata
6710 cpan_home local directory reserved for this package
6711 dontload_hash anonymous hash: modules in the keys will not be
6712 loaded by the CPAN::has_inst() routine
6713 gzip location of external program gzip
6714 histfile file to maintain history between sessions
6715 histsize maximum number of lines to keep in histfile
6716 inactivity_timeout breaks interactive Makefile.PLs after this
6717 many seconds inactivity. Set to 0 to never break.
6718 inhibit_startup_message
6719 if true, does not print the startup message
6720 keep_source_where directory in which to keep the source (if we do)
6721 make location of external make program
6722 make_arg arguments that should always be passed to 'make'
6723 make_install_arg same as make_arg for 'make install'
6724 makepl_arg arguments passed to 'perl Makefile.PL'
6725 pager location of external program more (or any pager)
6726 prerequisites_policy
6727 what to do if you are missing module prerequisites
6728 ('follow' automatically, 'ask' me, or 'ignore')
6729 proxy_user username for accessing an authenticating proxy
6730 proxy_pass password for accessing an authenticating proxy
6731 scan_cache controls scanning of cache ('atstart' or 'never')
6732 tar location of external program tar
6733 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6734 (and nonsense for characters outside latin range)
6735 unzip location of external program unzip
6736 urllist arrayref to nearby CPAN sites (or equivalent locations)
6737 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6738 ftp_proxy, } the three usual variables for configuring
6739 http_proxy, } proxy requests. Both as CPAN::Config variables
6740 no_proxy } and as environment variables configurable.
6742 You can set and query each of these options interactively in the cpan
6743 shell with the command set defined within the C<o conf> command:
6747 =item C<o conf E<lt>scalar optionE<gt>>
6749 prints the current value of the I<scalar option>
6751 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6753 Sets the value of the I<scalar option> to I<value>
6755 =item C<o conf E<lt>list optionE<gt>>
6757 prints the current value of the I<list option> in MakeMaker's
6760 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6762 shifts or pops the array in the I<list option> variable
6764 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6766 works like the corresponding perl commands.
6770 =head2 Note on urllist parameter's format
6772 urllist parameters are URLs according to RFC 1738. We do a little
6773 guessing if your URL is not compliant, but if you have problems with
6774 file URLs, please try the correct format. Either:
6776 file://localhost/whatever/ftp/pub/CPAN/
6780 file:///home/ftp/pub/CPAN/
6782 =head2 urllist parameter has CD-ROM support
6784 The C<urllist> parameter of the configuration table contains a list of
6785 URLs that are to be used for downloading. If the list contains any
6786 C<file> URLs, CPAN always tries to get files from there first. This
6787 feature is disabled for index files. So the recommendation for the
6788 owner of a CD-ROM with CPAN contents is: include your local, possibly
6789 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6791 o conf urllist push file://localhost/CDROM/CPAN
6793 CPAN.pm will then fetch the index files from one of the CPAN sites
6794 that come at the beginning of urllist. It will later check for each
6795 module if there is a local copy of the most recent version.
6797 Another peculiarity of urllist is that the site that we could
6798 successfully fetch the last file from automatically gets a preference
6799 token and is tried as the first site for the next request. So if you
6800 add a new site at runtime it may happen that the previously preferred
6801 site will be tried another time. This means that if you want to disallow
6802 a site for the next transfer, it must be explicitly removed from
6807 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6808 install foreign, unmasked, unsigned code on your machine. We compare
6809 to a checksum that comes from the net just as the distribution file
6810 itself. If somebody has managed to tamper with the distribution file,
6811 they may have as well tampered with the CHECKSUMS file. Future
6812 development will go towards strong authentication.
6816 Most functions in package CPAN are exported per default. The reason
6817 for this is that the primary use is intended for the cpan shell or for
6820 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6822 Populating a freshly installed perl with my favorite modules is pretty
6823 easy if you maintain a private bundle definition file. To get a useful
6824 blueprint of a bundle definition file, the command autobundle can be used
6825 on the CPAN shell command line. This command writes a bundle definition
6826 file for all modules that are installed for the currently running perl
6827 interpreter. It's recommended to run this command only once and from then
6828 on maintain the file manually under a private name, say
6829 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6831 cpan> install Bundle::my_bundle
6833 then answer a few questions and then go out for a coffee.
6835 Maintaining a bundle definition file means keeping track of two
6836 things: dependencies and interactivity. CPAN.pm sometimes fails on
6837 calculating dependencies because not all modules define all MakeMaker
6838 attributes correctly, so a bundle definition file should specify
6839 prerequisites as early as possible. On the other hand, it's a bit
6840 annoying that many distributions need some interactive configuring. So
6841 what I try to accomplish in my private bundle file is to have the
6842 packages that need to be configured early in the file and the gentle
6843 ones later, so I can go out after a few minutes and leave CPAN.pm
6846 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6848 Thanks to Graham Barr for contributing the following paragraphs about
6849 the interaction between perl, and various firewall configurations. For
6850 further informations on firewalls, it is recommended to consult the
6851 documentation that comes with the ncftp program. If you are unable to
6852 go through the firewall with a simple Perl setup, it is very likely
6853 that you can configure ncftp so that it works for your firewall.
6855 =head2 Three basic types of firewalls
6857 Firewalls can be categorized into three basic types.
6863 This is where the firewall machine runs a web server and to access the
6864 outside world you must do it via the web server. If you set environment
6865 variables like http_proxy or ftp_proxy to a values beginning with http://
6866 or in your web browser you have to set proxy information then you know
6867 you are running an http firewall.
6869 To access servers outside these types of firewalls with perl (even for
6870 ftp) you will need to use LWP.
6874 This where the firewall machine runs an ftp server. This kind of
6875 firewall will only let you access ftp servers outside the firewall.
6876 This is usually done by connecting to the firewall with ftp, then
6877 entering a username like "user@outside.host.com"
6879 To access servers outside these type of firewalls with perl you
6880 will need to use Net::FTP.
6882 =item One way visibility
6884 I say one way visibility as these firewalls try to make themselves look
6885 invisible to the users inside the firewall. An FTP data connection is
6886 normally created by sending the remote server your IP address and then
6887 listening for the connection. But the remote server will not be able to
6888 connect to you because of the firewall. So for these types of firewall
6889 FTP connections need to be done in a passive mode.
6891 There are two that I can think off.
6897 If you are using a SOCKS firewall you will need to compile perl and link
6898 it with the SOCKS library, this is what is normally called a 'socksified'
6899 perl. With this executable you will be able to connect to servers outside
6900 the firewall as if it is not there.
6904 This is the firewall implemented in the Linux kernel, it allows you to
6905 hide a complete network behind one IP address. With this firewall no
6906 special compiling is needed as you can access hosts directly.
6908 For accessing ftp servers behind such firewalls you may need to set
6909 the environment variable C<FTP_PASSIVE> to a true value, e.g.
6911 env FTP_PASSIVE=1 perl -MCPAN -eshell
6915 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
6922 =head2 Configuring lynx or ncftp for going through a firewall
6924 If you can go through your firewall with e.g. lynx, presumably with a
6927 /usr/local/bin/lynx -pscott:tiger
6929 then you would configure CPAN.pm with the command
6931 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6933 That's all. Similarly for ncftp or ftp, you would configure something
6936 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6938 Your mileage may vary...
6946 I installed a new version of module X but CPAN keeps saying,
6947 I have the old version installed
6949 Most probably you B<do> have the old version installed. This can
6950 happen if a module installs itself into a different directory in the
6951 @INC path than it was previously installed. This is not really a
6952 CPAN.pm problem, you would have the same problem when installing the
6953 module manually. The easiest way to prevent this behaviour is to add
6954 the argument C<UNINST=1> to the C<make install> call, and that is why
6955 many people add this argument permanently by configuring
6957 o conf make_install_arg UNINST=1
6961 So why is UNINST=1 not the default?
6963 Because there are people who have their precise expectations about who
6964 may install where in the @INC path and who uses which @INC array. In
6965 fine tuned environments C<UNINST=1> can cause damage.
6969 I want to clean up my mess, and install a new perl along with
6970 all modules I have. How do I go about it?
6972 Run the autobundle command for your old perl and optionally rename the
6973 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6974 with the Configure option prefix, e.g.
6976 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6978 Install the bundle file you produced in the first step with something like
6980 cpan> install Bundle::mybundle
6986 When I install bundles or multiple modules with one command
6987 there is too much output to keep track of.
6989 You may want to configure something like
6991 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6992 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6994 so that STDOUT is captured in a file for later inspection.
6999 I am not root, how can I install a module in a personal directory?
7001 You will most probably like something like this:
7003 o conf makepl_arg "LIB=~/myperl/lib \
7004 INSTALLMAN1DIR=~/myperl/man/man1 \
7005 INSTALLMAN3DIR=~/myperl/man/man3"
7006 install Sybase::Sybperl
7008 You can make this setting permanent like all C<o conf> settings with
7011 You will have to add ~/myperl/man to the MANPATH environment variable
7012 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7015 use lib "$ENV{HOME}/myperl/lib";
7017 or setting the PERL5LIB environment variable.
7019 Another thing you should bear in mind is that the UNINST parameter
7020 should never be set if you are not root.
7024 How to get a package, unwrap it, and make a change before building it?
7026 look Sybase::Sybperl
7030 I installed a Bundle and had a couple of fails. When I
7031 retried, everything resolved nicely. Can this be fixed to work
7034 The reason for this is that CPAN does not know the dependencies of all
7035 modules when it starts out. To decide about the additional items to
7036 install, it just uses data found in the generated Makefile. An
7037 undetected missing piece breaks the process. But it may well be that
7038 your Bundle installs some prerequisite later than some depending item
7039 and thus your second try is able to resolve everything. Please note,
7040 CPAN.pm does not know the dependency tree in advance and cannot sort
7041 the queue of things to install in a topologically correct order. It
7042 resolves perfectly well IFF all modules declare the prerequisites
7043 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7044 fail and you need to install often, it is recommended sort the Bundle
7045 definition file manually. It is planned to improve the metadata
7046 situation for dependencies on CPAN in general, but this will still
7051 In our intranet we have many modules for internal use. How
7052 can I integrate these modules with CPAN.pm but without uploading
7053 the modules to CPAN?
7055 Have a look at the CPAN::Site module.
7059 When I run CPAN's shell, I get error msg about line 1 to 4,
7060 setting meta input/output via the /etc/inputrc file.
7062 Some versions of readline are picky about capitalization in the
7063 /etc/inputrc file and specifically RedHat 6.2 comes with a
7064 /etc/inputrc that contains the word C<on> in lowercase. Change the
7065 occurrences of C<on> to C<On> and the bug should disappear.
7069 Some authors have strange characters in their names.
7071 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7072 expecting ISO-8859-1 charset, a converter can be activated by setting
7073 term_is_latin to a true value in your config file. One way of doing so
7076 cpan> ! $CPAN::Config->{term_is_latin}=1
7078 Extended support for converters will be made available as soon as perl
7079 becomes stable with regard to charset issues.
7085 We should give coverage for B<all> of the CPAN and not just the PAUSE
7086 part, right? In this discussion CPAN and PAUSE have become equal --
7087 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7088 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7090 Future development should be directed towards a better integration of
7093 If a Makefile.PL requires special customization of libraries, prompts
7094 the user for special input, etc. then you may find CPAN is not able to
7095 build the distribution. In that case, you should attempt the
7096 traditional method of building a Perl module package from a shell.
7100 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7104 Kawai,Takanori provides a Japanese translation of this manpage at
7105 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7109 perl(1), CPAN::Nox(3)