2 use vars qw{$Try_autoload
4 $META $Signal $Cwd $End
11 # $Id: CPAN.pm,v 1.314 2000/08/21 12:37:43 k Exp $
13 # only used during development:
15 # $Revision = "[".substr(q$Revision: 1.314 $, 10)."]";
22 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
23 use File::Basename ();
29 use Text::ParseWords ();
32 no lib "."; # we need to run chdir all over and we would get at wrong
35 END { $End++; &cleanup; }
57 $CPAN::Frontend ||= "CPAN::Shell";
58 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
61 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term);
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 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
85 # $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
87 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
96 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
97 CPAN::Config->load unless $CPAN::Config_loaded++;
99 CPAN::Index->read_metadata_cache;
101 my $prompt = "cpan> ";
103 unless ($Suppress_readline) {
104 require Term::ReadLine;
105 # import Term::ReadLine;
106 $term = Term::ReadLine->new('CPAN Monitor');
107 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
108 my $attribs = $term->Attribs;
109 # $attribs->{completion_entry_function} =
110 # $attribs->{'list_completion_function'};
111 $attribs->{attempted_completion_function} = sub {
112 &CPAN::Complete::gnu_cpl;
114 # $attribs->{completion_word} =
115 # [qw(help me somebody to find out how
116 # to use completion with GNU)];
118 $readline::rl_completion_function =
119 $readline::rl_completion_function = 'CPAN::Complete::cpl';
121 # $term->OUT is autoflushed anyway
122 my $odef = select STDERR;
132 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
133 my $cwd = CPAN->$getcwd();
134 my $try_detect_readline;
135 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
136 my $rl_avail = $Suppress_readline ? "suppressed" :
137 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
138 "available (try ``install Bundle::CPAN'')";
140 $CPAN::Frontend->myprint(
142 cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
143 ReadLine support $rl_avail
145 }) unless $CPAN::Config->{'inhibit_startup_message'} ;
146 my($continuation) = "";
148 if ($Suppress_readline) {
150 last unless defined ($_ = <> );
153 last unless defined ($_ = $term->readline($prompt));
155 $_ = "$continuation$_" if $continuation;
158 $_ = 'h' if /^\s*\?/;
159 if (/^(?:q(?:uit)?|bye|exit)$/i) {
169 use vars qw($import_done);
170 CPAN->import(':DEFAULT') unless $import_done++;
171 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
178 if ($] < 5.00322) { # parsewords had a bug until recently
181 eval { @line = Text::ParseWords::shellwords($_) };
182 warn($@), next if $@;
184 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
185 my $command = shift @line;
186 eval { CPAN::Shell->$command(@line) };
188 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
189 $CPAN::Frontend->myprint("\n");
195 CPAN::Queue->nullify_queue;
196 if ($try_detect_readline) {
197 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
199 $CPAN::META->has_inst("Term::ReadLine::Perl")
201 delete $INC{"Term/ReadLine.pm"};
203 local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef);
204 require Term::ReadLine;
205 $CPAN::Frontend->myprint("\n$redef subroutines in ".
206 "Term::ReadLine redefined\n");
213 package CPAN::CacheMgr;
214 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
217 package CPAN::Config;
218 use vars qw(%can $dot_cpan);
221 'commit' => "Commit changes to disk",
222 'defaults' => "Reload defaults from disk",
223 'init' => "Interactive setting of all options",
227 use vars qw($Ua $Thesite $Themethod);
228 @CPAN::FTP::ISA = qw(CPAN::Debug);
230 package CPAN::Complete;
231 @CPAN::Complete::ISA = qw(CPAN::Debug);
234 use vars qw($last_time $date_of_03);
235 @CPAN::Index::ISA = qw(CPAN::Debug);
239 package CPAN::InfoObj;
240 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
242 package CPAN::Author;
243 @CPAN::Author::ISA = qw(CPAN::InfoObj);
245 package CPAN::Distribution;
246 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
248 package CPAN::Bundle;
249 @CPAN::Bundle::ISA = qw(CPAN::Module);
251 package CPAN::Module;
252 @CPAN::Module::ISA = qw(CPAN::InfoObj);
255 use vars qw($AUTOLOAD $redef @ISA);
256 @CPAN::Shell::ISA = qw(CPAN::Debug);
258 #-> sub CPAN::Shell::AUTOLOAD ;
260 my($autoload) = $AUTOLOAD;
261 my $class = shift(@_);
262 # warn "autoload[$autoload] class[$class]";
263 $autoload =~ s/.*:://;
264 if ($autoload =~ /^w/) {
265 if ($CPAN::META->has_inst('CPAN::WAIT')) {
266 CPAN::WAIT->$autoload(@_);
268 $CPAN::Frontend->mywarn(qq{
269 Commands starting with "w" require CPAN::WAIT to be installed.
270 Please consider installing CPAN::WAIT to use the fulltext index.
271 For this you just need to type
276 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
280 # $CPAN::Frontend->mywarn("Could not autoload $autoload");
282 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
288 #-> CPAN::Shell::try_dot_al
290 my($class,$autoload) = @_;
291 return unless $CPAN::Try_autoload;
292 # I don't see how to re-use that from the AutoLoader...
294 # Braces used to preserve $1 et al.
296 my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
298 if (defined($name=$INC{"$pkg.pm"}))
300 $name =~ s|^(.*)$pkg\.pm(?!\n)\Z|$1auto/$pkg/$func.al|s;
301 $name = undef unless (-r $name);
303 unless (defined $name)
305 $name = "auto/$autoload.al";
310 eval {local $SIG{__DIE__};require $name};
312 if (substr($autoload,-9) eq '::DESTROY') {
316 if ($name =~ s{(\w{12,})\.al(?!\n)\Z}{substr($1,0,11).".al"}e){
317 eval {local $SIG{__DIE__};require $name};
332 # my $lm = Carp::longmess();
333 # warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
337 #### autoloader is experimental
338 #### to try it we have to set $Try_autoload and uncomment
339 #### the use statement and uncomment the __END__ below
340 #### You also need AutoSplit 1.01 available. MakeMaker will
341 #### then build CPAN with all the AutoLoad stuff.
345 if ($CPAN::Try_autoload) {
348 CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
349 CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
350 CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
352 *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
356 package CPAN::Tarzip;
357 use vars qw($AUTOLOAD @ISA);
358 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
362 # One use of the queue is to determine if we should or shouldn't
363 # announce the availability of a new CPAN module
365 # Now we try to use it for dependency tracking. For that to happen
366 # we need to draw a dependency tree and do the leaves first. This can
367 # easily be reached by running CPAN.pm recursively, but we don't want
368 # to waste memory and run into deep recursion. So what we can do is
371 # CPAN::Queue is the package where the queue is maintained. Dependencies
372 # often have high priority and must be brought to the head of the queue,
373 # possibly by jumping the queue if they are already there. My first code
374 # attempt tried to be extremely correct. Whenever a module needed
375 # immediate treatment, I either unshifted it to the front of the queue,
376 # or, if it was already in the queue, I spliced and let it bypass the
377 # others. This became a too correct model that made it impossible to put
378 # an item more than once into the queue. Why would you need that? Well,
379 # you need temporary duplicates as the manager of the queue is a loop
382 # (1) looks at the first item in the queue without shifting it off
384 # (2) cares for the item
386 # (3) removes the item from the queue, *even if its agenda failed and
387 # even if the item isn't the first in the queue anymore* (that way
388 # protecting against never ending queues)
390 # So if an item has prerequisites, the installation fails now, but we
391 # want to retry later. That's easy if we have it twice in the queue.
393 # I also expect insane dependency situations where an item gets more
394 # than two lives in the queue. Simplest example is triggered by 'install
395 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
396 # get in the way. I wanted the queue manager to be a dumb servant, not
397 # one that knows everything.
399 # Who would I tell in this model that the user wants to be asked before
400 # processing? I can't attach that information to the module object,
401 # because not modules are installed but distributions. So I'd have to
402 # tell the distribution object that it should ask the user before
403 # processing. Where would the question be triggered then? Most probably
404 # in CPAN::Distribution::rematein.
405 # Hope that makes sense, my head is a bit off:-) -- AK
410 my($class,$mod) = @_;
411 my $self = bless {mod => $mod}, $class;
413 # my @all = map { $_->{mod} } @All;
414 # warn "Adding Queue object for mod[$mod] all[@all]";
424 my($class,$what) = @_;
426 for my $i (0..$#All) {
427 if ( $All[$i]->{mod} eq $what ) {
438 WHAT: for my $what (reverse @what) {
440 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
441 if ($All[$i]->{mod} eq $what){
443 if ($jumped > 100) { # one's OK if e.g. just processing now;
444 # more are OK if user typed it several
446 $CPAN::Frontend->mywarn(
447 qq{Object [$what] queued more than 100 times, ignoring}
453 my $obj = bless { mod => $what }, $class;
459 my($self,$what) = @_;
460 my @all = map { $_->{mod} } @All;
461 my $exists = grep { $_->{mod} eq $what } @All;
462 # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]";
468 @All = grep { $_->{mod} ne $mod } @All;
469 # my @all = map { $_->{mod} } @All;
470 # warn "Deleting Queue object for mod[$mod] all[@all]";
481 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
485 # __END__ # uncomment this and AutoSplit version 1.01 will split it
487 #-> sub CPAN::autobundle ;
489 #-> sub CPAN::bundle ;
491 #-> sub CPAN::expand ;
493 #-> sub CPAN::force ;
495 #-> sub CPAN::install ;
499 #-> sub CPAN::clean ;
506 my($mgr,$class) = @_;
507 CPAN::Config->load unless $CPAN::Config_loaded++;
508 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
510 values %{ $META->{$class} };
512 *all = \&all_objects;
514 # Called by shell, not in batch mode. Not clean XXX
515 #-> sub CPAN::checklock ;
518 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
519 if (-f $lockfile && -M _ > 0) {
520 my $fh = FileHandle->new($lockfile);
523 if (defined $other && $other) {
525 return if $$==$other; # should never happen
526 $CPAN::Frontend->mywarn(
528 There seems to be running another CPAN process ($other). Contacting...
530 if (kill 0, $other) {
531 $CPAN::Frontend->mydie(qq{Other job is running.
532 You may want to kill it and delete the lockfile, maybe. On UNIX try:
536 } elsif (-w $lockfile) {
538 ExtUtils::MakeMaker::prompt
539 (qq{Other job not responding. Shall I overwrite }.
540 qq{the lockfile? (Y/N)},"y");
541 $CPAN::Frontend->myexit("Ok, bye\n")
542 unless $ans =~ /^y/i;
545 qq{Lockfile $lockfile not writeable by you. }.
546 qq{Cannot proceed.\n}.
549 qq{ and then rerun us.\n}
554 my $dotcpan = $CPAN::Config->{cpan_home};
555 eval { File::Path::mkpath($dotcpan);};
557 # A special case at least for Jarkko.
562 $symlinkcpan = readlink $dotcpan;
563 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
564 eval { File::Path::mkpath($symlinkcpan); };
568 $CPAN::Frontend->mywarn(qq{
569 Working directory $symlinkcpan created.
573 unless (-d $dotcpan) {
575 Your configuration suggests "$dotcpan" as your
576 CPAN.pm working directory. I could not create this directory due
577 to this error: $firsterror\n};
579 As "$dotcpan" is a symlink to "$symlinkcpan",
580 I tried to create that, but I failed with this error: $seconderror
583 Please make sure the directory exists and is writable.
585 $CPAN::Frontend->mydie($diemess);
589 unless ($fh = FileHandle->new(">$lockfile")) {
590 if ($! =~ /Permission/) {
591 my $incc = $INC{'CPAN/Config.pm'};
592 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
593 $CPAN::Frontend->myprint(qq{
595 Your configuration suggests that CPAN.pm should use a working
597 $CPAN::Config->{cpan_home}
598 Unfortunately we could not create the lock file
600 due to permission problems.
602 Please make sure that the configuration variable
603 \$CPAN::Config->{cpan_home}
604 points to a directory where you can write a .lock file. You can set
605 this variable in either
612 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
614 $fh->print($$, "\n");
615 $self->{LOCK} = $lockfile;
619 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
624 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
625 print "Caught SIGINT\n";
629 # From: Larry Wall <larry@wall.org>
630 # Subject: Re: deprecating SIGDIE
631 # To: perl5-porters@perl.org
632 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
634 # The original intent of __DIE__ was only to allow you to substitute one
635 # kind of death for another on an application-wide basis without respect
636 # to whether you were in an eval or not. As a global backstop, it should
637 # not be used any more lightly (or any more heavily :-) than class
638 # UNIVERSAL. Any attempt to build a general exception model on it should
639 # be politely squashed. Any bug that causes every eval {} to have to be
640 # modified should be not so politely squashed.
642 # Those are my current opinions. It is also my optinion that polite
643 # arguments degenerate to personal arguments far too frequently, and that
644 # when they do, it's because both people wanted it to, or at least didn't
645 # sufficiently want it not to.
649 $SIG{'__DIE__'} = \&cleanup;
650 $self->debug("Signal handler set.") if $CPAN::DEBUG;
653 #-> sub CPAN::DESTROY ;
655 &cleanup; # need an eval?
659 sub cwd {Cwd::cwd();}
661 #-> sub CPAN::getcwd ;
662 sub getcwd {Cwd::getcwd();}
664 #-> sub CPAN::exists ;
666 my($mgr,$class,$id) = @_;
668 ### Carp::croak "exists called without class argument" unless $class;
670 exists $META->{$class}{$id};
673 #-> sub CPAN::delete ;
675 my($mgr,$class,$id) = @_;
676 delete $META->{$class}{$id};
679 #-> sub CPAN::has_usable
680 # has_inst is sometimes too optimistic, we should replace it with this
681 # has_usable whenever a case is given
683 my($self,$mod,$message) = @_;
684 return 1 if $HAS_USABLE->{$mod};
685 my $has_inst = $self->has_inst($mod,$message);
686 return unless $has_inst;
689 LWP => [ # we frequently had "Can't locate object
690 # method "new" via package
691 # "LWP::UserAgent" at (eval 69) line
694 sub {require LWP::UserAgent},
695 sub {require HTTP::Request},
696 sub {require URI::URL},
699 sub {require Net::FTP},
700 sub {require Net::Config},
703 if ($capabilities->{$mod}) {
704 for my $c (0..$#{$capabilities->{$mod}}) {
705 my $code = $capabilities->{$mod}[$c];
706 my $ret = eval { &$code() };
708 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
713 return $HAS_USABLE->{$mod} = 1;
716 #-> sub CPAN::has_inst
718 my($self,$mod,$message) = @_;
719 Carp::croak("CPAN->has_inst() called without an argument")
721 if (defined $message && $message eq "no"
723 exists $CPAN::META->{dontload_hash}{$mod}
725 exists $CPAN::Config->{dontload_hash}{$mod}
727 $CPAN::META->{dontload_hash}{$mod}||=1;
733 $file =~ s|/|\\|g if $^O eq 'MSWin32';
736 # checking %INC is wrong, because $INC{LWP} may be true
737 # although $INC{"URI/URL.pm"} may have failed. But as
738 # I really want to say "bla loaded OK", I have to somehow
740 ### warn "$file in %INC"; #debug
742 } elsif (eval { require $file }) {
743 # eval is good: if we haven't yet read the database it's
744 # perfect and if we have installed the module in the meantime,
745 # it tries again. The second require is only a NOOP returning
746 # 1 if we had success, otherwise it's retrying
748 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
749 if ($mod eq "CPAN::WAIT") {
750 push @CPAN::Shell::ISA, CPAN::WAIT;
753 } elsif ($mod eq "Net::FTP") {
755 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
757 install Bundle::libnet
761 } elsif ($mod eq "MD5"){
762 $CPAN::Frontend->myprint(qq{
763 CPAN: MD5 security checks disabled because MD5 not installed.
764 Please consider installing the MD5 module.
769 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
774 #-> sub CPAN::instance ;
776 my($mgr,$class,$id) = @_;
779 $META->{$class}{$id} ||= $class->new(ID => $id );
787 #-> sub CPAN::cleanup ;
789 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
790 local $SIG{__DIE__} = '';
795 0 && # disabled, try reload cpan with it
796 $] > 5.004_60 # thereabouts
801 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
803 $subroutine eq '(eval)';
806 return if $ineval && !$End;
807 return unless defined $META->{'LOCK'};
808 return unless -f $META->{'LOCK'};
809 unlink $META->{'LOCK'};
811 # Carp::cluck("DEBUGGING");
812 $CPAN::Frontend->mywarn("Lockfile removed.\n");
815 package CPAN::CacheMgr;
817 #-> sub CPAN::CacheMgr::as_string ;
819 eval { require Data::Dumper };
821 return shift->SUPER::as_string;
823 return Data::Dumper::Dumper(shift);
827 #-> sub CPAN::CacheMgr::cachesize ;
834 return unless -d $self->{ID};
835 while ($self->{DU} > $self->{'MAX'} ) {
836 my($toremove) = shift @{$self->{FIFO}};
837 $CPAN::Frontend->myprint(sprintf(
838 "Deleting from cache".
839 ": $toremove (%.1f>%.1f MB)\n",
840 $self->{DU}, $self->{'MAX'})
842 return if $CPAN::Signal;
843 $self->force_clean_cache($toremove);
844 return if $CPAN::Signal;
848 #-> sub CPAN::CacheMgr::dir ;
853 #-> sub CPAN::CacheMgr::entries ;
856 return unless defined $dir;
857 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
858 $dir ||= $self->{ID};
860 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
861 my($cwd) = CPAN->$getcwd();
862 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
863 my $dh = DirHandle->new(File::Spec->curdir)
864 or Carp::croak("Couldn't opendir $dir: $!");
867 next if $_ eq "." || $_ eq "..";
869 push @entries, MM->catfile($dir,$_);
871 push @entries, MM->catdir($dir,$_);
873 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
876 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
877 sort { -M $b <=> -M $a} @entries;
880 #-> sub CPAN::CacheMgr::disk_usage ;
883 return if exists $self->{SIZE}{$dir};
884 return if $CPAN::Signal;
888 $File::Find::prune++ if $CPAN::Signal;
890 if ($^O eq 'MacOS') {
892 my $cat = Mac::Files::FSpGetCatInfo($_);
893 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
900 return if $CPAN::Signal;
901 $self->{SIZE}{$dir} = $Du/1024/1024;
902 push @{$self->{FIFO}}, $dir;
903 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
904 $self->{DU} += $Du/1024/1024;
908 #-> sub CPAN::CacheMgr::force_clean_cache ;
909 sub force_clean_cache {
911 return unless -e $dir;
912 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
914 File::Path::rmtree($dir);
915 $self->{DU} -= $self->{SIZE}{$dir};
916 delete $self->{SIZE}{$dir};
919 #-> sub CPAN::CacheMgr::new ;
926 ID => $CPAN::Config->{'build_dir'},
927 MAX => $CPAN::Config->{'build_cache'},
928 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
931 File::Path::mkpath($self->{ID});
932 my $dh = DirHandle->new($self->{ID});
936 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
938 CPAN->debug($debug) if $CPAN::DEBUG;
942 #-> sub CPAN::CacheMgr::scan_cache ;
945 return if $self->{SCAN} eq 'never';
946 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
947 unless $self->{SCAN} eq 'atstart';
948 $CPAN::Frontend->myprint(
949 sprintf("Scanning cache %s for sizes\n",
952 for $e ($self->entries($self->{ID})) {
953 next if $e eq ".." || $e eq ".";
954 $self->disk_usage($e);
955 return if $CPAN::Signal;
962 #-> sub CPAN::Debug::debug ;
965 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
966 # Complete, caller(1)
968 ($caller) = caller(0);
970 $arg = "" unless defined $arg;
971 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
972 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
973 if ($arg and ref $arg) {
974 eval { require Data::Dumper };
976 $CPAN::Frontend->myprint($arg->as_string);
978 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
981 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
986 package CPAN::Config;
988 #-> sub CPAN::Config::edit ;
989 # returns true on successful action
991 my($self,@args) = @_;
993 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
994 my($o,$str,$func,$args,$key_exists);
1000 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1001 if ($o =~ /list$/) {
1002 $func = shift @args;
1004 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1006 # Let's avoid eval, it's easier to comprehend without.
1007 if ($func eq "push") {
1008 push @{$CPAN::Config->{$o}}, @args;
1010 } elsif ($func eq "pop") {
1011 pop @{$CPAN::Config->{$o}};
1013 } elsif ($func eq "shift") {
1014 shift @{$CPAN::Config->{$o}};
1016 } elsif ($func eq "unshift") {
1017 unshift @{$CPAN::Config->{$o}}, @args;
1019 } elsif ($func eq "splice") {
1020 splice @{$CPAN::Config->{$o}}, @args;
1023 $CPAN::Config->{$o} = [@args];
1026 $self->prettyprint($o);
1028 if ($o eq "urllist" && $changed) {
1029 # reset the cached values
1030 undef $CPAN::FTP::Thesite;
1031 undef $CPAN::FTP::Themethod;
1035 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1036 $self->prettyprint($o);
1043 my $v = $CPAN::Config->{$k};
1045 my(@report) = ref $v eq "ARRAY" ?
1047 map { sprintf(" %-18s => %s\n",
1049 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1051 $CPAN::Frontend->myprint(
1058 map {"\t$_\n"} @report
1061 } elsif (defined $v) {
1062 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1064 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1068 #-> sub CPAN::Config::commit ;
1070 my($self,$configpm) = @_;
1071 unless (defined $configpm){
1072 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1073 $configpm ||= $INC{"CPAN/Config.pm"};
1074 $configpm || Carp::confess(q{
1075 CPAN::Config::commit called without an argument.
1076 Please specify a filename where to save the configuration or try
1077 "o conf init" to have an interactive course through configing.
1082 $mode = (stat $configpm)[2];
1083 if ($mode && ! -w _) {
1084 Carp::confess("$configpm is not writable");
1089 $msg = <<EOF unless $configpm =~ /MyConfig/;
1091 # This is CPAN.pm's systemwide configuration file. This file provides
1092 # defaults for users, and the values can be changed in a per-user
1093 # configuration file. The user-config file is being looked for as
1094 # ~/.cpan/CPAN/MyConfig.pm.
1098 my($fh) = FileHandle->new;
1099 rename $configpm, "$configpm~" if -f $configpm;
1100 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
1101 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1102 foreach (sort keys %$CPAN::Config) {
1105 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1110 $fh->print("};\n1;\n__END__\n");
1113 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1114 #chmod $mode, $configpm;
1115 ###why was that so? $self->defaults;
1116 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1120 *default = \&defaults;
1121 #-> sub CPAN::Config::defaults ;
1131 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1140 #-> sub CPAN::Config::load ;
1145 eval {require CPAN::Config;}; # We eval because of some
1146 # MakeMaker problems
1147 unless ($dot_cpan++){
1148 unshift @INC, MM->catdir($ENV{HOME},".cpan");
1149 eval {require CPAN::MyConfig;}; # where you can override
1150 # system wide settings
1153 return unless @miss = $self->not_loaded;
1154 # XXX better check for arrayrefs too
1155 require CPAN::FirstTime;
1156 my($configpm,$fh,$redo,$theycalled);
1158 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1159 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1160 $configpm = $INC{"CPAN/Config.pm"};
1162 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1163 $configpm = $INC{"CPAN/MyConfig.pm"};
1166 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1167 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1168 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1169 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1170 if (-w $configpmtest) {
1171 $configpm = $configpmtest;
1172 } elsif (-w $configpmdir) {
1173 #_#_# following code dumped core on me with 5.003_11, a.k.
1174 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1175 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1176 my $fh = FileHandle->new;
1177 if ($fh->open(">$configpmtest")) {
1179 $configpm = $configpmtest;
1181 # Should never happen
1182 Carp::confess("Cannot open >$configpmtest");
1186 unless ($configpm) {
1187 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1188 File::Path::mkpath($configpmdir);
1189 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1190 if (-w $configpmtest) {
1191 $configpm = $configpmtest;
1192 } elsif (-w $configpmdir) {
1193 #_#_# following code dumped core on me with 5.003_11, a.k.
1194 my $fh = FileHandle->new;
1195 if ($fh->open(">$configpmtest")) {
1197 $configpm = $configpmtest;
1199 # Should never happen
1200 Carp::confess("Cannot open >$configpmtest");
1203 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1204 qq{create a configuration file.});
1209 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1210 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1214 $CPAN::Frontend->myprint(qq{
1215 $configpm initialized.
1218 CPAN::FirstTime::init($configpm);
1221 #-> sub CPAN::Config::not_loaded ;
1225 cpan_home keep_source_where build_dir build_cache scan_cache
1226 index_expire gzip tar unzip make pager makepl_arg make_arg
1227 make_install_arg urllist inhibit_startup_message
1228 ftp_proxy http_proxy no_proxy prerequisites_policy
1231 push @miss, $_ unless defined $CPAN::Config->{$_};
1236 #-> sub CPAN::Config::unload ;
1238 delete $INC{'CPAN/MyConfig.pm'};
1239 delete $INC{'CPAN/Config.pm'};
1242 #-> sub CPAN::Config::help ;
1244 $CPAN::Frontend->myprint(q[
1246 defaults reload default config values from disk
1247 commit commit session changes to disk
1248 init go through a dialog to set all parameters
1250 You may edit key values in the follow fashion (the "o" is a literal
1253 o conf build_cache 15
1255 o conf build_dir "/foo/bar"
1257 o conf urllist shift
1259 o conf urllist unshift ftp://ftp.foo.bar/
1262 undef; #don't reprint CPAN::Config
1265 #-> sub CPAN::Config::cpl ;
1267 my($word,$line,$pos) = @_;
1269 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1270 my(@words) = split " ", substr($line,0,$pos+1);
1275 $words[2] =~ /list$/ && @words == 3
1277 $words[2] =~ /list$/ && @words == 4 && length($word)
1280 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1281 } elsif (@words >= 4) {
1284 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1285 return grep /^\Q$word\E/, @o_conf;
1288 package CPAN::Shell;
1290 #-> sub CPAN::Shell::h ;
1292 my($class,$about) = @_;
1293 if (defined $about) {
1294 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1296 $CPAN::Frontend->myprint(q{
1299 b string display bundles
1300 d or info distributions
1301 m /regex/ about modules
1302 i or anything of above
1303 r none reinstall recommendations
1304 u uninstalled distributions
1306 Download, Test, Make, Install...
1308 make make (implies get)
1309 test modules, make test (implies make)
1310 install dists, bundles make install (implies test)
1312 look open subshell in these dists' directories
1313 readme display these dists' README files
1316 h,? display this menu ! perl-code eval a perl command
1317 o conf [opt] set and query options q quit the cpan shell
1318 reload cpan load CPAN.pm again reload index load newer indices
1319 autobundle Snapshot force cmd unconditionally do cmd});
1325 #-> sub CPAN::Shell::a ;
1327 my($self,@arg) = @_;
1328 # authors are always UPPERCASE
1332 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1334 #-> sub CPAN::Shell::b ;
1336 my($self,@which) = @_;
1337 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1338 my($incdir,$bdir,$dh);
1339 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1340 $bdir = MM->catdir($incdir,"Bundle");
1341 if ($dh = DirHandle->new($bdir)) { # may fail
1343 for $entry ($dh->read) {
1344 next if -d MM->catdir($bdir,$entry);
1345 next unless $entry =~ s/\.pm(?!\n)\Z//;
1346 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1350 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1352 #-> sub CPAN::Shell::d ;
1353 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1354 #-> sub CPAN::Shell::m ;
1355 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1356 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1359 #-> sub CPAN::Shell::i ;
1364 @type = qw/Author Bundle Distribution Module/;
1365 @args = '/./' unless @args;
1368 push @result, $self->expand($type,@args);
1370 my $result = @result == 1 ?
1371 $result[0]->as_string :
1372 join "", map {$_->as_glimpse} @result;
1373 $result ||= "No objects found of any type for argument @args\n";
1374 $CPAN::Frontend->myprint($result);
1377 #-> sub CPAN::Shell::o ;
1379 # CPAN::Shell::o and CPAN::Config::edit are closely related. I suspect
1380 # some code duplication
1382 my($self,$o_type,@o_what) = @_;
1384 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1385 if ($o_type eq 'conf') {
1386 shift @o_what if @o_what && $o_what[0] eq 'help';
1387 if (!@o_what) { # print all things, "o conf"
1389 $CPAN::Frontend->myprint("CPAN::Config options");
1390 if (exists $INC{'CPAN/Config.pm'}) {
1391 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1393 if (exists $INC{'CPAN/MyConfig.pm'}) {
1394 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1396 $CPAN::Frontend->myprint(":\n");
1397 for $k (sort keys %CPAN::Config::can) {
1398 $v = $CPAN::Config::can{$k};
1399 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1401 $CPAN::Frontend->myprint("\n");
1402 for $k (sort keys %$CPAN::Config) {
1403 CPAN::Config->prettyprint($k);
1405 $CPAN::Frontend->myprint("\n");
1406 } elsif (!CPAN::Config->edit(@o_what)) {
1407 $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
1409 } elsif ($o_type eq 'debug') {
1411 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1414 my($what) = shift @o_what;
1415 if ( exists $CPAN::DEBUG{$what} ) {
1416 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1417 } elsif ($what =~ /^\d/) {
1418 $CPAN::DEBUG = $what;
1419 } elsif (lc $what eq 'all') {
1421 for (values %CPAN::DEBUG) {
1424 $CPAN::DEBUG = $max;
1427 for (keys %CPAN::DEBUG) {
1428 next unless lc($_) eq lc($what);
1429 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1432 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1437 my $raw = "Valid options for debug are ".
1438 join(", ",sort(keys %CPAN::DEBUG), 'all').
1439 qq{ or a number. Completion works on the options. }.
1440 qq{Case is ignored.};
1442 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1443 $CPAN::Frontend->myprint("\n\n");
1446 $CPAN::Frontend->myprint("Options set for debugging:\n");
1448 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1449 $v = $CPAN::DEBUG{$k};
1450 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1451 if $v & $CPAN::DEBUG;
1454 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1457 $CPAN::Frontend->myprint(qq{
1459 conf set or get configuration variables
1460 debug set or get debugging options
1465 sub dotdot_onreload {
1468 if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1472 # $CPAN::Frontend->myprint(".($subr)");
1473 $CPAN::Frontend->myprint(".");
1480 #-> sub CPAN::Shell::reload ;
1482 my($self,$command,@arg) = @_;
1484 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1485 if ($command =~ /cpan/i) {
1486 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1487 my $fh = FileHandle->new($INC{'CPAN.pm'});
1490 local($SIG{__WARN__}) = dotdot_onreload(\$redef);
1493 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1494 } elsif ($command =~ /index/) {
1495 CPAN::Index->force_reload;
1497 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1498 index re-reads the index files\n});
1502 #-> sub CPAN::Shell::_binary_extensions ;
1503 sub _binary_extensions {
1504 my($self) = shift @_;
1505 my(@result,$module,%seen,%need,$headerdone);
1506 for $module ($self->expand('Module','/./')) {
1507 my $file = $module->cpan_file;
1508 next if $file eq "N/A";
1509 next if $file =~ /^Contact Author/;
1510 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1511 next if $dist->isa_perl;
1512 next unless $module->xs_file;
1514 $CPAN::Frontend->myprint(".");
1515 push @result, $module;
1517 # print join " | ", @result;
1518 $CPAN::Frontend->myprint("\n");
1522 #-> sub CPAN::Shell::recompile ;
1524 my($self) = shift @_;
1525 my($module,@module,$cpan_file,%dist);
1526 @module = $self->_binary_extensions();
1527 for $module (@module){ # we force now and compile later, so we
1529 $cpan_file = $module->cpan_file;
1530 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1532 $dist{$cpan_file}++;
1534 for $cpan_file (sort keys %dist) {
1535 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1536 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1538 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1539 # stop a package from recompiling,
1540 # e.g. IO-1.12 when we have perl5.003_10
1544 #-> sub CPAN::Shell::_u_r_common ;
1546 my($self) = shift @_;
1547 my($what) = shift @_;
1548 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1549 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1550 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1552 @args = '/./' unless @args;
1553 my(@result,$module,%seen,%need,$headerdone,
1554 $version_undefs,$version_zeroes);
1555 $version_undefs = $version_zeroes = 0;
1556 my $sprintf = "%-25s %9s %9s %s\n";
1557 for $module ($self->expand('Module',@args)) {
1558 my $file = $module->cpan_file;
1559 next unless defined $file; # ??
1560 my($latest) = $module->cpan_version; # %vd not needed
1561 my($inst_file) = $module->inst_file;
1563 return if $CPAN::Signal;
1566 $have = $module->inst_version; # %vd already applied
1567 } elsif ($what eq "r") {
1568 $have = $module->inst_version; # %vd already applied
1570 if ($have eq "undef"){
1572 } elsif ($have == 0){
1575 next unless CPAN::Version->vgt($latest, $have);
1576 # to be pedantic we should probably say:
1577 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1578 # to catch the case where CPAN has a version 0 and we have a version undef
1579 } elsif ($what eq "u") {
1585 } elsif ($what eq "r") {
1587 } elsif ($what eq "u") {
1591 return if $CPAN::Signal; # this is sometimes lengthy
1594 push @result, sprintf "%s %s\n", $module->id, $have;
1595 } elsif ($what eq "r") {
1596 push @result, $module->id;
1597 next if $seen{$file}++;
1598 } elsif ($what eq "u") {
1599 push @result, $module->id;
1600 next if $seen{$file}++;
1601 next if $file =~ /^Contact/;
1603 unless ($headerdone++){
1604 $CPAN::Frontend->myprint("\n");
1605 $CPAN::Frontend->myprint(sprintf(
1607 "Package namespace",
1613 #### for ($have,$latest) {
1614 #### # $_ = CPAN::Version->readable($_); # %vd already applied
1615 #### if (length($_) > 8){
1616 #### my $trunc = substr($_,0,8);
1617 #### $CPAN::Frontend->mywarn("Truncating VERSION from [$_] to [$trunc]\n");
1621 $CPAN::Frontend->myprint(sprintf $sprintf,
1626 $need{$module->id}++;
1630 $CPAN::Frontend->myprint("No modules found for @args\n");
1631 } elsif ($what eq "r") {
1632 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1636 if ($version_zeroes) {
1637 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1638 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1639 qq{a version number of 0\n});
1641 if ($version_undefs) {
1642 my $s_has = $version_undefs > 1 ? "s have" : " has";
1643 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1644 qq{parseable version number\n});
1650 #-> sub CPAN::Shell::r ;
1652 shift->_u_r_common("r",@_);
1655 #-> sub CPAN::Shell::u ;
1657 shift->_u_r_common("u",@_);
1660 #-> sub CPAN::Shell::autobundle ;
1663 CPAN::Config->load unless $CPAN::Config_loaded++;
1664 my(@bundle) = $self->_u_r_common("a",@_);
1665 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1666 File::Path::mkpath($todir);
1667 unless (-d $todir) {
1668 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1671 my($y,$m,$d) = (localtime)[5,4,3];
1675 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1676 my($to) = MM->catfile($todir,"$me.pm");
1678 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1679 $to = MM->catfile($todir,"$me.pm");
1681 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1683 "package Bundle::$me;\n\n",
1684 "\$VERSION = '0.01';\n\n",
1688 "Bundle::$me - Snapshot of installation on ",
1689 $Config::Config{'myhostname'},
1692 "\n\n=head1 SYNOPSIS\n\n",
1693 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1694 "=head1 CONTENTS\n\n",
1695 join("\n", @bundle),
1696 "\n\n=head1 CONFIGURATION\n\n",
1698 "\n\n=head1 AUTHOR\n\n",
1699 "This Bundle has been generated automatically ",
1700 "by the autobundle routine in CPAN.pm.\n",
1703 $CPAN::Frontend->myprint("\nWrote bundle file
1707 #-> sub CPAN::Shell::expand ;
1710 my($type,@args) = @_;
1714 if ($arg =~ m|^/(.*)/$|) {
1717 my $class = "CPAN::$type";
1719 if (defined $regex) {
1723 $CPAN::META->all_objects($class)
1726 # BUG, we got an empty object somewhere
1727 CPAN->debug(sprintf(
1728 "Empty id on obj[%s]%%[%s]",
1735 if $obj->id =~ /$regex/i
1739 $] < 5.00303 ### provide sort of
1740 ### compatibility with 5.003
1745 $obj->name =~ /$regex/i
1750 if ( $type eq 'Bundle' ) {
1751 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1753 if ($CPAN::META->exists($class,$xarg)) {
1754 $obj = $CPAN::META->instance($class,$xarg);
1755 } elsif ($CPAN::META->exists($class,$arg)) {
1756 $obj = $CPAN::META->instance($class,$arg);
1763 return wantarray ? @m : $m[0];
1766 #-> sub CPAN::Shell::format_result ;
1769 my($type,@args) = @_;
1770 @args = '/./' unless @args;
1771 my(@result) = $self->expand($type,@args);
1772 my $result = @result == 1 ?
1773 $result[0]->as_string :
1774 join "", map {$_->as_glimpse} @result;
1775 $result ||= "No objects of type $type found for argument @args\n";
1779 # The only reason for this method is currently to have a reliable
1780 # debugging utility that reveals which output is going through which
1781 # channel. No, I don't like the colors ;-)
1782 sub print_ornamented {
1783 my($self,$what,$ornament) = @_;
1785 my $ornamenting = 0; # turn the colors on
1788 unless (defined &color) {
1789 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1790 import Term::ANSIColor "color";
1792 *color = sub { return "" };
1796 for $line (split /\n/, $what) {
1797 $longest = length($line) if length($line) > $longest;
1799 my $sprintf = "%-" . $longest . "s";
1801 $what =~ s/(.*\n?)//m;
1804 my($nl) = chomp $line ? "\n" : "";
1805 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1806 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1814 my($self,$what) = @_;
1815 $self->print_ornamented($what, 'bold blue on_yellow');
1819 my($self,$what) = @_;
1820 $self->myprint($what);
1825 my($self,$what) = @_;
1826 $self->print_ornamented($what, 'bold red on_yellow');
1830 my($self,$what) = @_;
1831 $self->print_ornamented($what, 'bold red on_white');
1832 Carp::confess "died";
1836 my($self,$what) = @_;
1837 $self->print_ornamented($what, 'bold red on_white');
1842 return if -t STDOUT;
1843 my $odef = select STDERR;
1850 #-> sub CPAN::Shell::rematein ;
1851 # RE-adme||MA-ke||TE-st||IN-stall
1854 my($meth,@some) = @_;
1856 if ($meth eq 'force') {
1858 $meth = shift @some;
1861 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1863 foreach $s (@some) {
1864 CPAN::Queue->new($s);
1866 while ($s = CPAN::Queue->first) {
1870 } elsif ($s =~ m|/|) { # looks like a file
1871 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1872 } elsif ($s =~ m|^Bundle::|) {
1873 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1875 $obj = $CPAN::META->instance('CPAN::Module',$s)
1876 if $CPAN::META->exists('CPAN::Module',$s);
1880 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1888 ($] < 5.00303 || $obj->can($pragma)); ###
1892 if ($]>=5.00303 && $obj->can('called_for')) {
1893 $obj->called_for($s);
1895 CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1898 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1899 $obj = $CPAN::META->instance('CPAN::Author',$s);
1900 $CPAN::Frontend->myprint(
1902 "Don't be silly, you can't $meth ",
1908 ->myprint(qq{Warning: Cannot $meth $s, }.
1909 qq{don\'t know what it is.
1914 to find objects with similar identifiers.
1917 CPAN::Queue->delete_first($s);
1921 #-> sub CPAN::Shell::force ;
1922 sub force { shift->rematein('force',@_); }
1923 #-> sub CPAN::Shell::get ;
1924 sub get { shift->rematein('get',@_); }
1925 #-> sub CPAN::Shell::readme ;
1926 sub readme { shift->rematein('readme',@_); }
1927 #-> sub CPAN::Shell::make ;
1928 sub make { shift->rematein('make',@_); }
1929 #-> sub CPAN::Shell::test ;
1930 sub test { shift->rematein('test',@_); }
1931 #-> sub CPAN::Shell::install ;
1932 sub install { shift->rematein('install',@_); }
1933 #-> sub CPAN::Shell::clean ;
1934 sub clean { shift->rematein('clean',@_); }
1935 #-> sub CPAN::Shell::look ;
1936 sub look { shift->rematein('look',@_); }
1937 #-> sub CPAN::Shell::cvs_import ;
1938 sub cvs_import { shift->rematein('cvs_import',@_); }
1942 #-> sub CPAN::FTP::ftp_get ;
1944 my($class,$host,$dir,$file,$target) = @_;
1946 qq[Going to fetch file [$file] from dir [$dir]
1947 on host [$host] as local [$target]\n]
1949 my $ftp = Net::FTP->new($host);
1950 return 0 unless defined $ftp;
1951 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1952 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1953 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1954 warn "Couldn't login on $host";
1957 unless ( $ftp->cwd($dir) ){
1958 warn "Couldn't cwd $dir";
1962 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1963 unless ( $ftp->get($file,$target) ){
1964 warn "Couldn't fetch $file from $host\n";
1967 $ftp->quit; # it's ok if this fails
1971 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1973 # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
1974 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997
1975 # leach,> ***************
1976 # leach,> *** 1562,1567 ****
1977 # leach,> --- 1562,1580 ----
1978 # leach,> return 1 if substr($url,0,4) eq "file";
1979 # leach,> return 1 unless $url =~ m|://([^/]+)|;
1980 # leach,> my $host = $1;
1981 # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1982 # leach,> + if ($proxy) {
1983 # leach,> + $proxy =~ m|://([^/:]+)|;
1984 # leach,> + $proxy = $1;
1985 # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1986 # leach,> + if ($noproxy) {
1987 # leach,> + if ($host !~ /$noproxy$/) {
1988 # leach,> + $host = $proxy;
1990 # leach,> + } else {
1991 # leach,> + $host = $proxy;
1994 # leach,> require Net::Ping;
1995 # leach,> return 1 unless $Net::Ping::VERSION >= 2;
1999 # this is quite optimistic and returns one on several occasions where
2000 # inappropriate. But this does no harm. It would do harm if we were
2001 # too pessimistic (as I was before the http_proxy
2003 my($self,$url) = @_;
2004 return 1; # we can't simply roll our own, firewalls may break ping
2005 return 0 unless $url;
2006 return 1 if substr($url,0,4) eq "file";
2007 return 1 unless $url =~ m|^(\w+)://([^/]+)|;
2008 my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
2010 return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
2012 return 1 unless $Net::Ping::VERSION >= 2;
2014 # 1.3101 had it different: only if the first eval raised an
2015 # exception we tried it with TCP. Now we are happy if icmp wins
2016 # the order and return, we don't even check for $@. Thanks to
2017 # thayer@uis.edu for the suggestion.
2018 eval {$p = Net::Ping->new("icmp");};
2019 return 1 if $p && ref($p) && $p->ping($host, 10);
2020 eval {$p = Net::Ping->new("tcp");};
2021 $CPAN::Frontend->mydie($@) if $@;
2022 return $p->ping($host, 10);
2025 #-> sub CPAN::FTP::localize ;
2026 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
2029 my($self,$file,$aslocal,$force) = @_;
2031 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2032 unless defined $aslocal;
2033 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2036 if ($^O eq 'MacOS') {
2037 my($name, $path) = File::Basename::fileparse($aslocal, '');
2038 if (length($name) > 31) {
2039 $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
2041 my $size = 31 - length($suf);
2042 while (length($name) > $size) {
2046 $aslocal = File::Spec->catfile($path, $name);
2050 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2053 rename $aslocal, "$aslocal.bak";
2057 my($aslocal_dir) = File::Basename::dirname($aslocal);
2058 File::Path::mkpath($aslocal_dir);
2059 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2060 qq{directory "$aslocal_dir".
2061 I\'ll continue, but if you encounter problems, they may be due
2062 to insufficient permissions.\n}) unless -w $aslocal_dir;
2064 # Inheritance is not easier to manage than a few if/else branches
2065 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2067 $Ua = LWP::UserAgent->new;
2069 $Ua->proxy('ftp', $var)
2070 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
2071 $Ua->proxy('http', $var)
2072 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2074 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2078 # Try the list of urls for each single object. We keep a record
2079 # where we did get a file from
2080 my(@reordered,$last);
2081 $CPAN::Config->{urllist} ||= [];
2082 $last = $#{$CPAN::Config->{urllist}};
2083 if ($force & 2) { # local cpans probably out of date, don't reorder
2084 @reordered = (0..$last);
2088 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2090 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2101 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2103 @levels = qw/easy hard hardest/;
2105 @levels = qw/easy/ if $^O eq 'MacOS';
2106 for $level (@levels) {
2107 my $method = "host$level";
2108 my @host_seq = $level eq "easy" ?
2109 @reordered : 0..$last; # reordered has CDROM up front
2110 @host_seq = (0) unless @host_seq;
2111 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2113 $Themethod = $level;
2115 # utime $now, $now, $aslocal; # too bad, if we do that, we
2116 # might alter a local mirror
2117 $self->debug("level[$level]") if $CPAN::DEBUG;
2125 qq{Please check, if the URLs I found in your configuration file \(}.
2126 join(", ", @{$CPAN::Config->{urllist}}).
2127 qq{\) are valid. The urllist can be edited.},
2128 qq{E.g. with ``o conf urllist push ftp://myurl/''};
2129 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2131 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
2133 rename "$aslocal.bak", $aslocal;
2134 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2135 $self->ls($aslocal));
2142 my($self,$host_seq,$file,$aslocal) = @_;
2144 HOSTEASY: for $i (@$host_seq) {
2145 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2146 unless ($self->is_reachable($url)) {
2147 $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
2151 $url .= "/" unless substr($url,-1) eq "/";
2153 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2154 if ($url =~ /^file:/) {
2156 if ($CPAN::META->has_inst('URI::URL')) {
2157 my $u = URI::URL->new($url);
2159 } else { # works only on Unix, is poorly constructed, but
2160 # hopefully better than nothing.
2161 # RFC 1738 says fileurl BNF is
2162 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2163 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2165 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2166 $l =~ s|^file:||; # assume they
2169 $l =~ s|^/||s unless -f $l; # e.g. /P:
2171 if ( -f $l && -r _) {
2175 # Maybe mirror has compressed it?
2177 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2178 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2185 if ($CPAN::META->has_usable('LWP')) {
2186 $CPAN::Frontend->myprint("Fetching with LWP:
2190 require LWP::UserAgent;
2191 $Ua = LWP::UserAgent->new;
2193 my $res = $Ua->mirror($url, $aslocal);
2194 if ($res->is_success) {
2197 utime $now, $now, $aslocal; # download time is more
2198 # important than upload time
2200 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2201 my $gzurl = "$url.gz";
2202 $CPAN::Frontend->myprint("Fetching with LWP:
2205 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2206 if ($res->is_success &&
2207 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2215 # Alan Burlison informed me that in firewall envs Net::FTP
2216 # can still succeed where LWP fails. So we do not skip
2217 # Net::FTP anymore when LWP is available.
2221 $self->debug("LWP not installed") if $CPAN::DEBUG;
2223 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2224 # that's the nice and easy way thanks to Graham
2225 my($host,$dir,$getfile) = ($1,$2,$3);
2226 if ($CPAN::META->has_usable('Net::FTP')) {
2228 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2231 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2232 "aslocal[$aslocal]") if $CPAN::DEBUG;
2233 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2237 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2238 my $gz = "$aslocal.gz";
2239 $CPAN::Frontend->myprint("Fetching with Net::FTP
2242 if (CPAN::FTP->ftp_get($host,
2246 CPAN::Tarzip->gunzip($gz,$aslocal)
2259 my($self,$host_seq,$file,$aslocal) = @_;
2261 # Came back if Net::FTP couldn't establish connection (or
2262 # failed otherwise) Maybe they are behind a firewall, but they
2263 # gave us a socksified (or other) ftp program...
2266 my($devnull) = $CPAN::Config->{devnull} || "";
2268 my($aslocal_dir) = File::Basename::dirname($aslocal);
2269 File::Path::mkpath($aslocal_dir);
2270 HOSTHARD: for $i (@$host_seq) {
2271 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2272 unless ($self->is_reachable($url)) {
2273 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2276 $url .= "/" unless substr($url,-1) eq "/";
2278 my($proto,$host,$dir,$getfile);
2280 # Courtesy Mark Conty mark_conty@cargill.com change from
2281 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2283 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2284 # proto not yet used
2285 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2287 next HOSTHARD; # who said, we could ftp anything except ftp?
2290 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2292 for $f ('lynx','ncftpget','ncftp') {
2293 next unless exists $CPAN::Config->{$f};
2294 $funkyftp = $CPAN::Config->{$f};
2295 next unless defined $funkyftp;
2296 next if $funkyftp =~ /^\s*$/;
2297 my($asl_ungz, $asl_gz);
2298 ($asl_ungz = $aslocal) =~ s/\.gz//;
2299 $asl_gz = "$asl_ungz.gz";
2300 my($src_switch) = "";
2302 $src_switch = " -source";
2303 } elsif ($f eq "ncftp"){
2304 $src_switch = " -c";
2307 my($stdout_redir) = " > $asl_ungz";
2308 if ($f eq "ncftpget"){
2309 $chdir = "cd $aslocal_dir && ";
2312 $CPAN::Frontend->myprint(
2314 Trying with "$funkyftp$src_switch" to get
2318 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2319 $self->debug("system[$system]") if $CPAN::DEBUG;
2321 if (($wstatus = system($system)) == 0
2324 -s $asl_ungz # lynx returns 0 on my
2325 # system even if it fails
2331 } elsif ($asl_ungz ne $aslocal) {
2332 # test gzip integrity
2334 CPAN::Tarzip->gtest($asl_ungz)
2336 rename $asl_ungz, $aslocal;
2338 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2343 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2345 -f $asl_ungz && -s _ == 0;
2346 my $gz = "$aslocal.gz";
2347 my $gzurl = "$url.gz";
2348 $CPAN::Frontend->myprint(
2350 Trying with "$funkyftp$src_switch" to get
2353 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2354 $self->debug("system[$system]") if $CPAN::DEBUG;
2356 if (($wstatus = system($system)) == 0
2360 # test gzip integrity
2361 if (CPAN::Tarzip->gtest($asl_gz)) {
2362 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2364 rename $asl_ungz, $aslocal;
2369 unlink $asl_gz if -f $asl_gz;
2372 my $estatus = $wstatus >> 8;
2373 my $size = -f $aslocal ?
2374 ", left\n$aslocal with size ".-s _ :
2375 "\nWarning: expected file [$aslocal] doesn't exist";
2376 $CPAN::Frontend->myprint(qq{
2377 System call "$system"
2378 returned status $estatus (wstat $wstatus)$size
2386 my($self,$host_seq,$file,$aslocal) = @_;
2389 my($aslocal_dir) = File::Basename::dirname($aslocal);
2390 File::Path::mkpath($aslocal_dir);
2391 HOSTHARDEST: for $i (@$host_seq) {
2392 unless (length $CPAN::Config->{'ftp'}) {
2393 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2396 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2397 unless ($self->is_reachable($url)) {
2398 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2401 $url .= "/" unless substr($url,-1) eq "/";
2403 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2404 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2407 my($host,$dir,$getfile) = ($1,$2,$3);
2409 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2410 $ctime,$blksize,$blocks) = stat($aslocal);
2411 $timestamp = $mtime ||= 0;
2412 my($netrc) = CPAN::FTP::netrc->new;
2413 my($netrcfile) = $netrc->netrc;
2414 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2415 my $targetfile = File::Basename::basename($aslocal);
2421 map("cd $_", split "/", $dir), # RFC 1738
2423 "get $getfile $targetfile",
2427 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2428 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2429 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2431 $netrc->contains($host))) if $CPAN::DEBUG;
2432 if ($netrc->protected) {
2433 $CPAN::Frontend->myprint(qq{
2434 Trying with external ftp to get
2436 As this requires some features that are not thoroughly tested, we\'re
2437 not sure, that we get it right....
2441 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2443 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2444 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2446 if ($mtime > $timestamp) {
2447 $CPAN::Frontend->myprint("GOT $aslocal\n");
2451 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2454 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2455 qq{correctly protected.\n});
2458 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2459 nor does it have a default entry\n");
2462 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2463 # then and login manually to host, using e-mail as
2465 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2469 "user anonymous $Config::Config{'cf_email'}"
2471 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2472 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2473 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2475 if ($mtime > $timestamp) {
2476 $CPAN::Frontend->myprint("GOT $aslocal\n");
2480 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2482 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2488 my($self,$command,@dialog) = @_;
2489 my $fh = FileHandle->new;
2490 $fh->open("|$command") or die "Couldn't open ftp: $!";
2491 foreach (@dialog) { $fh->print("$_\n") }
2492 $fh->close; # Wait for process to complete
2494 my $estatus = $wstatus >> 8;
2495 $CPAN::Frontend->myprint(qq{
2496 Subprocess "|$command"
2497 returned status $estatus (wstat $wstatus)
2501 # find2perl needs modularization, too, all the following is stolen
2505 my($self,$name) = @_;
2506 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2507 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2509 my($perms,%user,%group);
2513 $blocks = int(($blocks + 1) / 2);
2516 $blocks = int(($sizemm + 1023) / 1024);
2519 if (-f _) { $perms = '-'; }
2520 elsif (-d _) { $perms = 'd'; }
2521 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2522 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2523 elsif (-p _) { $perms = 'p'; }
2524 elsif (-S _) { $perms = 's'; }
2525 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2527 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2528 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2529 my $tmpmode = $mode;
2530 my $tmp = $rwx[$tmpmode & 7];
2532 $tmp = $rwx[$tmpmode & 7] . $tmp;
2534 $tmp = $rwx[$tmpmode & 7] . $tmp;
2535 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2536 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2537 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2540 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2541 my $group = $group{$gid} || $gid;
2543 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2545 my($moname) = $moname[$mon];
2546 if (-M _ > 365.25 / 2) {
2547 $timeyear = $year + 1900;
2550 $timeyear = sprintf("%02d:%02d", $hour, $min);
2553 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2567 package CPAN::FTP::netrc;
2571 my $file = MM->catfile($ENV{HOME},".netrc");
2573 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2574 $atime,$mtime,$ctime,$blksize,$blocks)
2579 my($fh,@machines,$hasdefault);
2581 $fh = FileHandle->new or die "Could not create a filehandle";
2583 if($fh->open($file)){
2584 $protected = ($mode & 077) == 0;
2586 NETRC: while (<$fh>) {
2587 my(@tokens) = split " ", $_;
2588 TOKEN: while (@tokens) {
2589 my($t) = shift @tokens;
2590 if ($t eq "default"){
2594 last TOKEN if $t eq "macdef";
2595 if ($t eq "machine") {
2596 push @machines, shift @tokens;
2601 $file = $hasdefault = $protected = "";
2605 'mach' => [@machines],
2607 'hasdefault' => $hasdefault,
2608 'protected' => $protected,
2612 sub hasdefault { shift->{'hasdefault'} }
2613 sub netrc { shift->{'netrc'} }
2614 sub protected { shift->{'protected'} }
2616 my($self,$mach) = @_;
2617 for ( @{$self->{'mach'}} ) {
2618 return 1 if $_ eq $mach;
2623 package CPAN::Complete;
2626 my($text, $line, $start, $end) = @_;
2627 my(@perlret) = cpl($text, $line, $start);
2628 # find longest common match. Can anybody show me how to peruse
2629 # T::R::Gnu to have this done automatically? Seems expensive.
2630 return () unless @perlret;
2631 my($newtext) = $text;
2632 for (my $i = length($text)+1;;$i++) {
2633 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2634 my $try = substr($perlret[0],0,$i);
2635 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2636 # warn "try[$try]tries[@tries]";
2637 if (@tries == @perlret) {
2643 ($newtext,@perlret);
2646 #-> sub CPAN::Complete::cpl ;
2648 my($word,$line,$pos) = @_;
2652 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2654 if ($line =~ s/^(force\s*)//) {
2662 ! a b d h i m o q r u autobundle clean
2663 make test install force reload look cvs_import
2666 } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
2668 } elsif ($line =~ /^a\s/) {
2669 @return = cplx('CPAN::Author',$word);
2670 } elsif ($line =~ /^b\s/) {
2671 @return = cplx('CPAN::Bundle',$word);
2672 } elsif ($line =~ /^d\s/) {
2673 @return = cplx('CPAN::Distribution',$word);
2674 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) {
2675 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2676 } elsif ($line =~ /^i\s/) {
2677 @return = cpl_any($word);
2678 } elsif ($line =~ /^reload\s/) {
2679 @return = cpl_reload($word,$line,$pos);
2680 } elsif ($line =~ /^o\s/) {
2681 @return = cpl_option($word,$line,$pos);
2688 #-> sub CPAN::Complete::cplx ;
2690 my($class, $word) = @_;
2691 # I believed for many years that this was sorted, today I
2692 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2693 # make it sorted again. Maybe sort was dropped when GNU-readline
2694 # support came in? The RCS file is difficult to read on that:-(
2695 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2698 #-> sub CPAN::Complete::cpl_any ;
2702 cplx('CPAN::Author',$word),
2703 cplx('CPAN::Bundle',$word),
2704 cplx('CPAN::Distribution',$word),
2705 cplx('CPAN::Module',$word),
2709 #-> sub CPAN::Complete::cpl_reload ;
2711 my($word,$line,$pos) = @_;
2713 my(@words) = split " ", $line;
2714 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2715 my(@ok) = qw(cpan index);
2716 return @ok if @words == 1;
2717 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2720 #-> sub CPAN::Complete::cpl_option ;
2722 my($word,$line,$pos) = @_;
2724 my(@words) = split " ", $line;
2725 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2726 my(@ok) = qw(conf debug);
2727 return @ok if @words == 1;
2728 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2730 } elsif ($words[1] eq 'index') {
2732 } elsif ($words[1] eq 'conf') {
2733 return CPAN::Config::cpl(@_);
2734 } elsif ($words[1] eq 'debug') {
2735 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2739 package CPAN::Index;
2741 #-> sub CPAN::Index::force_reload ;
2744 $CPAN::Index::last_time = 0;
2748 #-> sub CPAN::Index::reload ;
2750 my($cl,$force) = @_;
2753 # XXX check if a newer one is available. (We currently read it
2754 # from time to time)
2755 for ($CPAN::Config->{index_expire}) {
2756 $_ = 0.001 unless $_ && $_ > 0.001;
2758 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2760 ## IFF we are developing, it helps to wipe out the memory between
2761 ## reloads, otherwise it is not what a user expects.
2763 ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2764 ## $CPAN::META = CPAN->new;
2768 my $needshort = $^O eq "dos";
2770 $cl->rd_authindex($cl
2772 "authors/01mailrc.txt.gz",
2774 File::Spec->catfile('authors', '01mailrc.gz') :
2775 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2778 $debug = "timing reading 01[".($t2 - $time)."]";
2780 return if $CPAN::Signal; # this is sometimes lengthy
2781 $cl->rd_modpacks($cl
2783 "modules/02packages.details.txt.gz",
2785 File::Spec->catfile('modules', '02packag.gz') :
2786 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2789 $debug .= "02[".($t2 - $time)."]";
2791 return if $CPAN::Signal; # this is sometimes lengthy
2794 "modules/03modlist.data.gz",
2796 File::Spec->catfile('modules', '03mlist.gz') :
2797 File::Spec->catfile('modules', '03modlist.data.gz'),
2799 $cl->write_metadata_cache;
2801 $debug .= "03[".($t2 - $time)."]";
2803 CPAN->debug($debug) if $CPAN::DEBUG;
2806 #-> sub CPAN::Index::reload_x ;
2808 my($cl,$wanted,$localname,$force) = @_;
2809 $force |= 2; # means we're dealing with an index here
2810 CPAN::Config->load; # we should guarantee loading wherever we rely
2812 $localname ||= $wanted;
2813 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2817 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2820 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2821 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2822 qq{day$s. I\'ll use that.});
2825 $force |= 1; # means we're quite serious about it.
2827 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2830 #-> sub CPAN::Index::rd_authindex ;
2832 my($cl, $index_target) = @_;
2834 return unless defined $index_target;
2835 $CPAN::Frontend->myprint("Going to read $index_target\n");
2836 # my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2837 # while ($_ = $fh->READLINE) {
2840 tie *FH, CPAN::Tarzip, $index_target;
2842 push @lines, split /\012/ while <FH>;
2844 my($userid,$fullname,$email) =
2845 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2846 next unless $userid && $fullname && $email;
2848 # instantiate an author object
2849 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2850 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2851 return if $CPAN::Signal;
2856 my($self,$dist) = @_;
2857 $dist = $self->{'id'} unless defined $dist;
2858 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2862 #-> sub CPAN::Index::rd_modpacks ;
2864 my($self, $index_target) = @_;
2866 return unless defined $index_target;
2867 $CPAN::Frontend->myprint("Going to read $index_target\n");
2868 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2870 while ($_ = $fh->READLINE) {
2872 my @ls = map {"$_\n"} split /\n/, $_;
2873 unshift @ls, "\n" x length($1) if /^(\n+)/;
2879 my $shift = shift(@lines);
2880 $shift =~ /^Line-Count:\s+(\d+)/;
2881 $line_count = $1 if $1;
2882 last if $shift =~ /^\s*$/;
2884 if (not defined $line_count) {
2886 warn qq{Warning: Your $index_target does not contain a Line-Count header.
2887 Please check the validity of the index file by comparing it to more
2888 than one CPAN mirror. I'll continue but problems seem likely to
2893 } elsif ($line_count != scalar @lines) {
2895 warn sprintf qq{Warning: Your %s
2896 contains a Line-Count header of %d but I see %d lines there. Please
2897 check the validity of the index file by comparing it to more than one
2898 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
2899 $index_target, $line_count, scalar(@lines);
2904 # before 1.56 we split into 3 and discarded the rest. From
2905 # 1.57 we assign remaining text to $comment thus allowing to
2906 # influence isa_perl
2907 my($mod,$version,$dist,$comment) = split " ", $_, 4;
2908 ### $version =~ s/^\+//;
2910 # if it is a bundle, instantiate a bundle object
2911 my($bundle,$id,$userid);
2913 if ($mod eq 'CPAN' &&
2915 CPAN::Queue->exists('Bundle::CPAN') ||
2916 CPAN::Queue->exists('CPAN')
2920 if ($version > $CPAN::VERSION){
2921 $CPAN::Frontend->myprint(qq{
2922 There\'s a new CPAN.pm version (v$version) available!
2923 [Current version is v$CPAN::VERSION]
2924 You might want to try
2925 install Bundle::CPAN
2927 without quitting the current session. It should be a seamless upgrade
2928 while we are running...
2931 $CPAN::Frontend->myprint(qq{\n});
2933 last if $CPAN::Signal;
2934 } elsif ($mod =~ /^Bundle::(.*)/) {
2939 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2940 # warn "made mod[$mod]a bundle";
2941 # Let's make it a module too, because bundles have so much
2942 # in common with modules
2943 $CPAN::META->instance('CPAN::Module',$mod);
2944 # warn "made mod[$mod]a module";
2946 # This "next" makes us faster but if the job is running long, we ignore
2947 # rereads which is bad. So we have to be a bit slower again.
2948 # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2953 # instantiate a module object
2954 $id = $CPAN::META->instance('CPAN::Module',$mod);
2957 if ($id->cpan_file ne $dist){ # update only if file is
2958 # different. CPAN prohibits same
2959 # name with different version
2960 $userid = $self->userid($dist);
2962 'CPAN_USERID' => $userid,
2963 'CPAN_VERSION' => $version, # %vd not needed
2964 'CPAN_FILE' => $dist,
2965 'CPAN_COMMENT' => $comment,
2969 # instantiate a distribution object
2970 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2971 # we do not need CONTAINSMODS unless we do something with
2972 # this dist, so we better produce it on demand.
2974 ## my $obj = $CPAN::META->instance(
2975 ## 'CPAN::Distribution' => $dist
2977 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
2979 $CPAN::META->instance(
2980 'CPAN::Distribution' => $dist
2982 'CPAN_USERID' => $userid
2986 return if $CPAN::Signal;
2991 #-> sub CPAN::Index::rd_modlist ;
2993 my($cl,$index_target) = @_;
2994 return unless defined $index_target;
2995 $CPAN::Frontend->myprint("Going to read $index_target\n");
2996 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2999 while ($_ = $fh->READLINE) {
3001 my @ls = map {"$_\n"} split /\n/, $_;
3002 unshift @ls, "\n" x length($1) if /^(\n+)/;
3006 my $shift = shift(@eval);
3007 if ($shift =~ /^Date:\s+(.*)/){
3008 return if $date_of_03 eq $1;
3011 last if $shift =~ /^\s*$/;
3014 push @eval, q{CPAN::Modulelist->data;};
3016 my($comp) = Safe->new("CPAN::Safe1");
3017 my($eval) = join("", @eval);
3018 my $ret = $comp->reval($eval);
3019 Carp::confess($@) if $@;
3020 return if $CPAN::Signal;
3022 my $obj = $CPAN::META->instance(CPAN::Module,$_);
3023 $obj->set(%{$ret->{$_}});
3024 return if $CPAN::Signal;
3028 #-> sub CPAN::Index::write_metadata_cache ;
3029 sub write_metadata_cache {
3031 return unless $CPAN::Config->{'cache_metadata'};
3032 return unless $CPAN::META->has_usable("Storable");
3034 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3035 CPAN::Distribution)) {
3036 $cache->{$k} = $CPAN::META->{$k};
3038 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3039 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3040 $cache->{last_time} = $last_time;
3041 eval { Storable::store($cache, $metadata_file) };
3042 $CPAN::Frontent->mywarn($@) if $@;
3045 #-> sub CPAN::Index::read_metadata_cache ;
3046 sub read_metadata_cache {
3048 return unless $CPAN::Config->{'cache_metadata'};
3049 return unless $CPAN::META->has_usable("Storable");
3050 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3051 return unless -r $metadata_file and -f $metadata_file;
3052 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3054 eval { $cache = Storable::retrieve($metadata_file) };
3055 $CPAN::Frontend->mywarn($@) if $@;
3056 return if (!$cache || ref $cache ne 'HASH');
3057 while(my($k,$v) = each %$cache) {
3058 next unless $k =~ /^CPAN::/;
3059 $CPAN::META->{$k} = $v;
3061 $last_time = $cache->{last_time};
3064 package CPAN::InfoObj;
3066 #-> sub CPAN::InfoObj::new ;
3067 sub new { my $this = bless {}, shift; %$this = @_; $this }
3069 #-> sub CPAN::InfoObj::set ;
3071 my($self,%att) = @_;
3072 my(%oldatt) = %$self;
3073 %$self = (%oldatt, %att);
3076 #-> sub CPAN::InfoObj::id ;
3077 sub id { shift->{'ID'} }
3079 #-> sub CPAN::InfoObj::as_glimpse ;
3083 my $class = ref($self);
3084 $class =~ s/^CPAN:://;
3085 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3089 #-> sub CPAN::InfoObj::as_string ;
3093 my $class = ref($self);
3094 $class =~ s/^CPAN:://;
3095 push @m, $class, " id = $self->{ID}\n";
3096 for (sort keys %$self) {
3099 if ($_ eq "CPAN_USERID") {
3100 $extra .= " (".$self->author;
3101 my $email; # old perls!
3102 if ($email = $CPAN::META->instance(CPAN::Author,
3105 $extra .= " <$email>";
3107 $extra .= " <no email>";
3111 if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
3112 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
3113 } elsif (ref($self->{$_}) eq "HASH") {
3117 join(" ",keys %{$self->{$_}}),
3120 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
3126 #-> sub CPAN::InfoObj::author ;
3129 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
3134 require Data::Dumper;
3135 Data::Dumper::Dumper($self);
3138 package CPAN::Author;
3140 #-> sub CPAN::Author::as_glimpse ;
3144 my $class = ref($self);
3145 $class =~ s/^CPAN:://;
3146 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3150 # Dead code, I would have liked to have,,, but it was never reached,,,
3153 # return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
3156 #-> sub CPAN::Author::fullname ;
3157 sub fullname { shift->{'FULLNAME'} }
3160 #-> sub CPAN::Author::email ;
3161 sub email { shift->{'EMAIL'} }
3163 package CPAN::Distribution;
3165 #-> sub CPAN::Distribution::as_string ;
3168 $self->containsmods;
3169 $self->SUPER::as_string(@_);
3172 #-> sub CPAN::Distribution::containsmods ;
3175 return if exists $self->{CONTAINSMODS};
3176 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3177 my $mod_file = $mod->{CPAN_FILE} or next;
3178 my $dist_id = $self->{ID} or next;
3179 my $mod_id = $mod->{ID} or next;
3180 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3184 #-> sub CPAN::Distribution::called_for ;
3187 $self->{'CALLED_FOR'} = $id if defined $id;
3188 return $self->{'CALLED_FOR'};
3191 #-> sub CPAN::Distribution::get ;
3196 exists $self->{'build_dir'} and push @e,
3197 "Unwrapped into directory $self->{'build_dir'}";
3198 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3203 $CPAN::Config->{keep_source_where},
3206 split("/",$self->{ID})
3209 $self->debug("Doing localize") if $CPAN::DEBUG;
3211 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3212 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
3213 $self->{localfile} = $local_file;
3214 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3215 my $builddir = $CPAN::META->{cachemgr}->dir;
3216 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3217 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3220 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3221 if ($CPAN::META->has_inst('MD5')) {
3222 $self->debug("MD5 is installed, verifying");
3225 $self->debug("MD5 is NOT installed");
3227 $self->debug("Removing tmp") if $CPAN::DEBUG;
3228 File::Path::rmtree("tmp");
3229 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3230 chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
3231 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
3232 if (! $local_file) {
3233 Carp::croak "bad download, can't do anything :-(\n";
3234 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3235 $self->untar_me($local_file);
3236 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3237 $self->unzip_me($local_file);
3238 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3239 $self->pm2dir_me($local_file);
3241 $self->{archived} = "NO";
3243 my $cwd = File::Spec->updir;
3244 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
3245 if ($self->{archived} ne 'NO') {
3246 $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
3247 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3248 # Let's check if the package has its own directory.
3249 my $dh = DirHandle->new(File::Spec->curdir)
3250 or Carp::croak("Couldn't opendir .: $!");
3251 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3253 my ($distdir,$packagedir);
3254 if (@readdir == 1 && -d $readdir[0]) {
3255 $distdir = $readdir[0];
3256 $packagedir = MM->catdir($builddir,$distdir);
3257 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
3258 File::Path::rmtree($packagedir);
3259 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3261 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
3262 $pragmatic_dir =~ s/\W_//g;
3263 $pragmatic_dir++ while -d "../$pragmatic_dir";
3264 $packagedir = MM->catdir($builddir,$pragmatic_dir);
3265 File::Path::mkpath($packagedir);
3267 for $f (@readdir) { # is already without "." and ".."
3268 my $to = MM->catdir($packagedir,$f);
3269 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3272 $self->{'build_dir'} = $packagedir;
3273 $cwd = File::Spec->updir;
3274 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3276 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
3278 File::Path::rmtree("tmp");
3279 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
3280 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
3281 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3283 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
3284 unless (-f $makefilepl) {
3285 my($configure) = MM->catfile($packagedir,"Configure");
3286 if (-f $configure) {
3287 # do we have anything to do?
3288 $self->{'configure'} = $configure;
3289 } elsif (-f MM->catfile($packagedir,"Makefile")) {
3290 $CPAN::Frontend->myprint(qq{
3291 Package comes with a Makefile and without a Makefile.PL.
3292 We\'ll try to build it with that Makefile then.
3294 $self->{writemakefile} = "YES";
3297 my $fh = FileHandle->new(">$makefilepl")
3298 or Carp::croak("Could not open >$makefilepl");
3299 my $cf = $self->called_for || "unknown";
3301 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3302 # because there was no Makefile.PL supplied.
3303 # Autogenerated on: }.scalar localtime().qq{
3305 use ExtUtils::MakeMaker;
3306 WriteMakefile(NAME => q[$cf]);
3309 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
3310 Writing one on our own (calling it $cf)\n});
3318 my($self,$local_file) = @_;
3319 $self->{archived} = "tar";
3320 if (CPAN::Tarzip->untar($local_file)) {
3321 $self->{unwrapped} = "YES";
3323 $self->{unwrapped} = "NO";
3328 my($self,$local_file) = @_;
3329 $self->{archived} = "zip";
3330 if ($CPAN::META->has_inst("Archive::Zip")) {
3331 if (CPAN::Tarzip->unzip($local_file)) {
3332 $self->{unwrapped} = "YES";
3334 $self->{unwrapped} = "NO";
3338 my $unzip = $CPAN::Config->{unzip} or
3339 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
3340 my @system = ($unzip, $local_file);
3341 if (system(@system) == 0) {
3342 $self->{unwrapped} = "YES";
3344 $self->{unwrapped} = "NO";
3349 my($self,$local_file) = @_;
3350 $self->{archived} = "pm";
3351 my $to = File::Basename::basename($local_file);
3352 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3353 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3354 $self->{unwrapped} = "YES";
3356 $self->{unwrapped} = "NO";
3360 #-> sub CPAN::Distribution::new ;
3362 my($class,%att) = @_;
3364 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3366 my $this = { %att };
3367 return bless $this, $class;
3370 #-> sub CPAN::Distribution::look ;
3374 if ($^O eq 'MacOS') {
3375 $self->ExtUtils::MM_MacOS::look;
3379 if ( $CPAN::Config->{'shell'} ) {
3380 $CPAN::Frontend->myprint(qq{
3381 Trying to open a subshell in the build directory...
3384 $CPAN::Frontend->myprint(qq{
3385 Your configuration does not define a value for subshells.
3386 Please define it with "o conf shell <your shell>"
3390 my $dist = $self->id;
3391 my $dir = $self->dir or $self->get;
3394 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3395 my $pwd = CPAN->$getcwd();
3396 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3397 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3398 system($CPAN::Config->{'shell'}) == 0
3399 or $CPAN::Frontend->mydie("Subprocess shell error");
3400 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3406 my $dir = $self->dir;
3408 my $package = $self->called_for;
3409 my $module = $CPAN::META->instance('CPAN::Module', $package);
3410 my $version = $module->cpan_version; # %vd not needed
3412 my $userid = $self->{CPAN_USERID};
3414 my $cvs_dir = (split '/', $dir)[-1];
3415 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
3417 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3419 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3420 if ($cvs_site_perl) {
3421 $cvs_dir = "$cvs_site_perl/$cvs_dir";
3423 my $cvs_log = qq{"imported $package $version sources"};
3424 $version =~ s/\./_/g;
3425 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3426 "$cvs_dir", $userid, "v$version");
3429 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3430 my $pwd = CPAN->$getcwd();
3431 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3433 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3435 $CPAN::Frontend->myprint(qq{@cmd\n});
3436 system(@cmd) == 0 or
3437 $CPAN::Frontend->mydie("cvs import failed");
3438 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3441 #-> sub CPAN::Distribution::readme ;
3444 my($dist) = $self->id;
3445 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3446 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3450 $CPAN::Config->{keep_source_where},
3453 split("/","$sans.readme"),
3455 $self->debug("Doing localize") if $CPAN::DEBUG;
3456 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3458 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3460 if ($^O eq 'MacOS') {
3461 ExtUtils::MM_MacOS::launch_file($local_file);
3465 my $fh_pager = FileHandle->new;
3466 local($SIG{PIPE}) = "IGNORE";
3467 $fh_pager->open("|$CPAN::Config->{'pager'}")
3468 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3469 my $fh_readme = FileHandle->new;
3470 $fh_readme->open($local_file)
3471 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3472 $CPAN::Frontend->myprint(qq{
3475 with pager "$CPAN::Config->{'pager'}"
3478 $fh_pager->print(<$fh_readme>);
3481 #-> sub CPAN::Distribution::verifyMD5 ;
3486 $self->{MD5_STATUS} ||= "";
3487 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3488 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3490 my($lc_want,$lc_file,@local,$basename);
3491 @local = split("/",$self->{ID});
3493 push @local, "CHECKSUMS";
3495 MM->catfile($CPAN::Config->{keep_source_where},
3496 "authors", "id", @local);
3501 $self->MD5_check_file($lc_want)
3503 return $self->{MD5_STATUS} = "OK";
3505 $lc_file = CPAN::FTP->localize("authors/id/@local",
3508 $local[-1] .= ".gz";
3509 $lc_file = CPAN::FTP->localize("authors/id/@local",
3512 $lc_file =~ s/\.gz(?!\n)\Z//;
3513 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3518 $self->MD5_check_file($lc_file);
3521 #-> sub CPAN::Distribution::MD5_check_file ;
3522 sub MD5_check_file {
3523 my($self,$chk_file) = @_;
3524 my($cksum,$file,$basename);
3525 $file = $self->{localfile};
3526 $basename = File::Basename::basename($file);
3527 my $fh = FileHandle->new;
3528 if (open $fh, $chk_file){
3531 $eval =~ s/\015?\012/\n/g;
3533 my($comp) = Safe->new();
3534 $cksum = $comp->reval($eval);
3536 rename $chk_file, "$chk_file.bad";
3537 Carp::confess($@) if $@;
3540 Carp::carp "Could not open $chk_file for reading";
3543 if (exists $cksum->{$basename}{md5}) {
3544 $self->debug("Found checksum for $basename:" .
3545 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3549 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3551 $fh = CPAN::Tarzip->TIEHANDLE($file);
3554 # had to inline it, when I tied it, the tiedness got lost on
3555 # the call to eq_MD5. (Jan 1998)
3559 while ($fh->READ($ref, 4096) > 0){
3562 my $hexdigest = $md5->hexdigest;
3563 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3567 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3568 return $self->{MD5_STATUS} = "OK";
3570 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
3571 qq{distribution file. }.
3572 qq{Please investigate.\n\n}.
3574 $CPAN::META->instance(
3576 $self->{CPAN_USERID}
3579 my $wrap = qq{I\'d recommend removing $file. Its MD5
3580 checksum is incorrect. Maybe you have configured your \`urllist\' with
3581 a bad URL. Please check this array with \`o conf urllist\', and
3584 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3585 $CPAN::Frontend->myprint("\n\n");
3589 # close $fh if fileno($fh);
3591 $self->{MD5_STATUS} ||= "";
3592 if ($self->{MD5_STATUS} eq "NIL") {
3593 $CPAN::Frontend->myprint(qq{
3594 No md5 checksum for $basename in local $chk_file.
3597 unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
3600 $self->{MD5_STATUS} = "NIL";
3605 #-> sub CPAN::Distribution::eq_MD5 ;
3607 my($self,$fh,$expectMD5) = @_;
3610 while (read($fh, $data, 4096)){
3613 # $md5->addfile($fh);
3614 my $hexdigest = $md5->hexdigest;
3615 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3616 $hexdigest eq $expectMD5;
3619 #-> sub CPAN::Distribution::force ;
3622 $self->{'force_update'}++;
3624 MD5_STATUS archived build_dir localfile make install unwrapped
3627 delete $self->{$att};
3631 #-> sub CPAN::Distribution::isa_perl ;
3634 my $file = File::Basename::basename($self->id);
3635 if ($file =~ m{ ^ perl
3648 } elsif ($self->{'CPAN_COMMENT'} && $self->{'CPAN_COMMENT'} =~ /isa_perl\(.+?\)/){
3653 #-> sub CPAN::Distribution::perl ;
3656 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3657 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3658 my $pwd = CPAN->$getcwd();
3659 my $candidate = MM->catfile($pwd,$^X);
3660 $perl ||= $candidate if MM->maybe_command($candidate);
3662 my ($component,$perl_name);
3663 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3664 PATH_COMPONENT: foreach $component (MM->path(),
3665 $Config::Config{'binexp'}) {
3666 next unless defined($component) && $component;
3667 my($abs) = MM->catfile($component,$perl_name);
3668 if (MM->maybe_command($abs)) {
3678 #-> sub CPAN::Distribution::make ;
3681 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3682 # Emergency brake if they said install Pippi and get newest perl
3683 if ($self->isa_perl) {
3685 $self->called_for ne $self->id && ! $self->{'force_update'}
3687 # if we die here, we break bundles
3688 $CPAN::Frontend->mywarn(sprintf qq{
3689 The most recent version "%s" of the module "%s"
3690 comes with the current version of perl (%s).
3691 I\'ll build that only if you ask for something like
3696 $CPAN::META->instance(
3699 )->cpan_version, # %vd not needed
3710 $self->{archived} eq "NO" and push @e,
3711 "Is neither a tar nor a zip archive.";
3713 $self->{unwrapped} eq "NO" and push @e,
3714 "had problems unarchiving. Please build manually";
3716 exists $self->{writemakefile} &&
3717 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3718 $1 || "Had some problem writing Makefile";
3720 defined $self->{'make'} and push @e,
3721 "Has already been processed within this session";
3723 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3725 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
3726 my $builddir = $self->dir;
3727 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3728 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3730 if ($^O eq 'MacOS') {
3731 ExtUtils::MM_MacOS::make($self);
3736 if ($self->{'configure'}) {
3737 $system = $self->{'configure'};
3739 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3741 # This needs a handler that can be turned on or off:
3742 # $switch = "-MExtUtils::MakeMaker ".
3743 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3745 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3747 unless (exists $self->{writemakefile}) {
3748 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3751 if ($CPAN::Config->{inactivity_timeout}) {
3753 alarm $CPAN::Config->{inactivity_timeout};
3754 local $SIG{CHLD}; # = sub { wait };
3755 if (defined($pid = fork)) {
3760 # note, this exec isn't necessary if
3761 # inactivity_timeout is 0. On the Mac I'd
3762 # suggest, we set it always to 0.
3766 $CPAN::Frontend->myprint("Cannot fork: $!");
3774 $CPAN::Frontend->myprint($@);
3775 $self->{writemakefile} = "NO $@";
3780 $ret = system($system);
3782 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
3786 if (-f "Makefile") {
3787 $self->{writemakefile} = "YES";
3789 $self->{writemakefile} =
3790 qq{NO Makefile.PL refused to write a Makefile.};
3791 # It's probably worth to record the reason, so let's retry
3793 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
3794 # $self->{writemakefile} .= <$fh>;
3797 return if $CPAN::Signal;
3798 if (my @prereq = $self->needs_prereq){
3800 $CPAN::Frontend->myprint("---- Dependencies detected ".
3801 "during [$id] -----\n");
3803 for my $p (@prereq) {
3804 $CPAN::Frontend->myprint(" $p\n");
3807 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3809 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3810 require ExtUtils::MakeMaker;
3811 my $answer = ExtUtils::MakeMaker::prompt(
3812 "Shall I follow them and prepend them to the queue
3813 of modules we are processing right now?", "yes");
3814 $follow = $answer =~ /^\s*y/i;
3818 myprint(" Ignoring dependencies on modules @prereq\n");
3821 CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3825 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3826 if (system($system) == 0) {
3827 $CPAN::Frontend->myprint(" $system -- OK\n");
3828 $self->{'make'} = "YES";
3830 $self->{writemakefile} ||= "YES";
3831 $self->{'make'} = "NO";
3832 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3836 #-> sub CPAN::Distribution::needs_prereq ;
3839 return unless -f "Makefile"; # we cannot say much
3840 my $fh = FileHandle->new("<Makefile") or
3841 $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3844 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
3848 last if /MakeMaker post_initialize section/;
3850 \s+PREREQ_PM\s+=>\s+(.+)
3853 # warn "Found prereq expr[$p]";
3855 # Regexp modified by A.Speer to remember actual version of file
3856 # PREREQ_PM hash key wants, then add to
3857 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
3858 # In case a prereq is mentioned twice, complain.
3859 if ( defined $p{$1} ) {
3860 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
3866 NEED: while (my($module, $need_version) = each %p) {
3867 my $mo = $CPAN::META->instance("CPAN::Module",$module);
3868 # we were too demanding:
3869 # next if $mo->uptodate;
3871 # We only want to install prereqs if either they're not installed
3872 # or if the installed version is too old. We cannot omit this
3873 # check, because if 'force' is in effect, nobody else will check.
3877 defined $mo->inst_file &&
3878 ! CPAN::Version->vgt($need_version, $mo->inst_version)
3880 CPAN->debug(sprintf "inst_file[%s]inst_version[%s]need_version[%s]",
3883 CPAN::Version->readable($need_version)
3889 if ($self->{have_sponsored}{$module}++){
3890 # We have already sponsored it and for some reason it's still
3891 # not available. So we do nothing. Or what should we do?
3892 # if we push it again, we have a potential infinite loop
3895 push @need, $module;
3900 #-> sub CPAN::Distribution::test ;
3904 return if $CPAN::Signal;
3905 $CPAN::Frontend->myprint("Running make test\n");
3908 exists $self->{'make'} or push @e,
3909 "Make had some problems, maybe interrupted? Won't test";
3911 exists $self->{'make'} and
3912 $self->{'make'} eq 'NO' and
3913 push @e, "Oops, make had returned bad status";
3915 exists $self->{'build_dir'} or push @e, "Has no own directory";
3916 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3918 chdir $self->{'build_dir'} or
3919 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3920 $self->debug("Changed directory to $self->{'build_dir'}")
3923 if ($^O eq 'MacOS') {
3924 ExtUtils::MM_MacOS::make_test($self);
3928 my $system = join " ", $CPAN::Config->{'make'}, "test";
3929 if (system($system) == 0) {
3930 $CPAN::Frontend->myprint(" $system -- OK\n");
3931 $self->{'make_test'} = "YES";
3933 $self->{'make_test'} = "NO";
3934 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3938 #-> sub CPAN::Distribution::clean ;
3941 $CPAN::Frontend->myprint("Running make clean\n");
3944 exists $self->{'build_dir'} or push @e, "Has no own directory";
3945 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3947 chdir $self->{'build_dir'} or
3948 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3949 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3951 if ($^O eq 'MacOS') {
3952 ExtUtils::MM_MacOS::make_clean($self);
3956 my $system = join " ", $CPAN::Config->{'make'}, "clean";
3957 if (system($system) == 0) {
3958 $CPAN::Frontend->myprint(" $system -- OK\n");
3961 # Hmmm, what to do if make clean failed?
3965 #-> sub CPAN::Distribution::install ;
3969 return if $CPAN::Signal;
3970 $CPAN::Frontend->myprint("Running make install\n");
3973 exists $self->{'build_dir'} or push @e, "Has no own directory";
3975 exists $self->{'make'} or push @e,
3976 "Make had some problems, maybe interrupted? Won't install";
3978 exists $self->{'make'} and
3979 $self->{'make'} eq 'NO' and
3980 push @e, "Oops, make had returned bad status";
3982 push @e, "make test had returned bad status, ".
3983 "won't install without force"
3984 if exists $self->{'make_test'} and
3985 $self->{'make_test'} eq 'NO' and
3986 ! $self->{'force_update'};
3988 exists $self->{'install'} and push @e,
3989 $self->{'install'} eq "YES" ?
3990 "Already done" : "Already tried without success";
3992 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3994 chdir $self->{'build_dir'} or
3995 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3996 $self->debug("Changed directory to $self->{'build_dir'}")
3999 if ($^O eq 'MacOS') {
4000 ExtUtils::MM_MacOS::make_install($self);
4004 my $system = join(" ", $CPAN::Config->{'make'},
4005 "install", $CPAN::Config->{make_install_arg});
4006 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4007 my($pipe) = FileHandle->new("$system $stderr |");
4010 $CPAN::Frontend->myprint($_);
4015 $CPAN::Frontend->myprint(" $system -- OK\n");
4016 return $self->{'install'} = "YES";
4018 $self->{'install'} = "NO";
4019 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4020 if ($makeout =~ /permission/s && $> > 0) {
4021 $CPAN::Frontend->myprint(qq{ You may have to su }.
4022 qq{to root to install the package\n});
4027 #-> sub CPAN::Distribution::dir ;
4029 shift->{'build_dir'};
4032 package CPAN::Bundle;
4034 #-> sub CPAN::Bundle::as_string ;
4038 # following line must be "=", not "||=" because we have a moving target
4039 $self->{INST_VERSION} = $self->inst_version; # %vd already applied
4040 return $self->SUPER::as_string;
4043 #-> sub CPAN::Bundle::contains ;
4046 my($parsefile) = $self->inst_file;
4047 my($id) = $self->id;
4048 $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
4049 unless ($parsefile) {
4050 # Try to get at it in the cpan directory
4051 $self->debug("no parsefile") if $CPAN::DEBUG;
4052 Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
4053 my $dist = $CPAN::META->instance('CPAN::Distribution',
4054 $self->{CPAN_FILE});
4056 $self->debug($dist->as_string) if $CPAN::DEBUG;
4057 my($todir) = $CPAN::Config->{'cpan_home'};
4058 my(@me,$from,$to,$me);
4059 @me = split /::/, $self->id;
4061 $me = MM->catfile(@me);
4062 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4063 $to = MM->catfile($todir,$me);
4064 File::Path::mkpath(File::Basename::dirname($to));
4065 File::Copy::copy($from, $to)
4066 or Carp::confess("Couldn't copy $from to $to: $!");
4070 my $fh = FileHandle->new;
4072 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
4074 $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
4076 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4077 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4078 next unless $in_cont;
4083 push @result, (split " ", $_, 2)[0];
4086 delete $self->{STATUS};
4087 $self->{CONTAINS} = join ", ", @result;
4088 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4090 $CPAN::Frontend->mywarn(qq{
4091 The bundle file "$parsefile" may be a broken
4092 bundlefile. It seems not to contain any bundle definition.
4093 Please check the file and if it is bogus, please delete it.
4094 Sorry for the inconvenience.
4100 #-> sub CPAN::Bundle::find_bundle_file
4101 sub find_bundle_file {
4102 my($self,$where,$what) = @_;
4103 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4104 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4105 ### my $bu = MM->catfile($where,$what);
4106 ### return $bu if -f $bu;
4107 my $manifest = MM->catfile($where,"MANIFEST");
4108 unless (-f $manifest) {
4109 require ExtUtils::Manifest;
4110 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
4111 my $cwd = CPAN->$getcwd();
4112 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4113 ExtUtils::Manifest::mkmanifest();
4114 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4116 my $fh = FileHandle->new($manifest)
4117 or Carp::croak("Couldn't open $manifest: $!");
4120 if ($^O eq 'MacOS') {
4123 $what2 =~ s/:Bundle://;
4126 $what2 =~ s|Bundle[/\\]||;
4131 my($file) = /(\S+)/;
4132 if ($file =~ m|\Q$what\E$|) {
4134 # return MM->catfile($where,$bu); # bad
4137 # retry if she managed to
4138 # have no Bundle directory
4139 $bu = $file if $file =~ m|\Q$what2\E$|;
4141 $bu =~ tr|/|:| if $^O eq 'MacOS';
4142 return MM->catfile($where, $bu) if $bu;
4143 Carp::croak("Couldn't find a Bundle file in $where");
4146 #-> sub CPAN::Bundle::inst_file ;
4150 ($me = $self->id) =~ s/.*://;
4151 ## my(@me,$inst_file);
4152 ## @me = split /::/, $self->id;
4153 ## $me[-1] .= ".pm";
4154 $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
4155 "Bundle", "$me.pm");
4157 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4159 $self->SUPER::inst_file;
4160 # return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4161 # return $self->{'INST_FILE'}; # even if undefined?
4164 #-> sub CPAN::Bundle::rematein ;
4166 my($self,$meth) = @_;
4167 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4168 my($id) = $self->id;
4169 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4170 unless $self->inst_file || $self->{CPAN_FILE};
4172 for $s ($self->contains) {
4173 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4174 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4175 if ($type eq 'CPAN::Distribution') {
4176 $CPAN::Frontend->mywarn(qq{
4177 The Bundle }.$self->id.qq{ contains
4178 explicitly a file $s.
4182 # possibly noisy action:
4183 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4184 my $obj = $CPAN::META->instance($type,$s);
4186 if ($obj->isa(CPAN::Bundle)
4188 exists $obj->{install_failed}
4190 ref($obj->{install_failed}) eq "HASH"
4192 for (keys %{$obj->{install_failed}}) {
4193 $self->{install_failed}{$_} = undef; # propagate faiure up
4196 $fail{$s} = 1; # the bundle itself may have succeeded but
4201 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4202 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4204 delete $self->{install_failed}{$s};
4211 # recap with less noise
4212 if ( $meth eq "install" ) {
4215 my $raw = sprintf(qq{Bundle summary:
4216 The following items in bundle %s had installation problems:},
4219 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4220 $CPAN::Frontend->myprint("\n");
4223 for $s ($self->contains) {
4225 $paragraph .= "$s ";
4226 $self->{install_failed}{$s} = undef;
4227 $reported{$s} = undef;
4230 my $report_propagated;
4231 for $s (sort keys %{$self->{install_failed}}) {
4232 next if exists $reported{$s};
4233 $paragraph .= "and the following items had problems
4234 during recursive bundle calls: " unless $report_propagated++;
4235 $paragraph .= "$s ";
4237 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
4238 $CPAN::Frontend->myprint("\n");
4240 $self->{'install'} = 'YES';
4245 #sub CPAN::Bundle::xs_file
4247 # If a bundle contains another that contains an xs_file we have
4248 # here, we just don't bother I suppose
4252 #-> sub CPAN::Bundle::force ;
4253 sub force { shift->rematein('force',@_); }
4254 #-> sub CPAN::Bundle::get ;
4255 sub get { shift->rematein('get',@_); }
4256 #-> sub CPAN::Bundle::make ;
4257 sub make { shift->rematein('make',@_); }
4258 #-> sub CPAN::Bundle::test ;
4259 sub test { shift->rematein('test',@_); }
4260 #-> sub CPAN::Bundle::install ;
4263 $self->rematein('install',@_);
4265 #-> sub CPAN::Bundle::clean ;
4266 sub clean { shift->rematein('clean',@_); }
4268 #-> sub CPAN::Bundle::readme ;
4271 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
4272 No File found for bundle } . $self->id . qq{\n}), return;
4273 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
4274 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
4277 package CPAN::Module;
4279 #-> sub CPAN::Module::as_glimpse ;
4283 my $class = ref($self);
4284 $class =~ s/^CPAN:://;
4285 push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
4290 #-> sub CPAN::Module::as_string ;
4294 CPAN->debug($self) if $CPAN::DEBUG;
4295 my $class = ref($self);
4296 $class =~ s/^CPAN:://;
4298 push @m, $class, " id = $self->{ID}\n";
4299 my $sprintf = " %-12s %s\n";
4300 push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
4301 if $self->{description};
4302 my $sprintf2 = " %-12s %s (%s)\n";
4304 if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
4306 if ($author = CPAN::Shell->expand('Author',$userid)) {
4309 if ($m = $author->email) {
4316 $author->fullname . $email
4320 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) # %vd not needed
4321 if $self->{CPAN_VERSION}; # %vd not needed
4322 push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
4323 if $self->{CPAN_FILE};
4324 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
4325 my(%statd,%stats,%statl,%stati);
4326 @statd{qw,? i c a b R M S,} = qw,unknown idea
4327 pre-alpha alpha beta released mature standard,;
4328 @stats{qw,? m d u n,} = qw,unknown mailing-list
4329 developer comp.lang.perl.* none,;
4330 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
4331 @stati{qw,? f r O h,} = qw,unknown functions
4332 references+ties object-oriented hybrid,;
4333 $statd{' '} = 'unknown';
4334 $stats{' '} = 'unknown';
4335 $statl{' '} = 'unknown';
4336 $stati{' '} = 'unknown';
4344 $statd{$self->{statd}},
4345 $stats{$self->{stats}},
4346 $statl{$self->{statl}},
4347 $stati{$self->{stati}}
4348 ) if $self->{statd};
4349 my $local_file = $self->inst_file;
4351 $self->{MANPAGE} ||= $self->manpage_headline($local_file);
4354 for $item (qw/MANPAGE CONTAINS/) {
4355 push @m, sprintf($sprintf, $item, $self->{$item})
4356 if exists $self->{$item};
4358 push @m, sprintf($sprintf, 'INST_FILE',
4359 $local_file || "(not installed)");
4360 push @m, sprintf($sprintf, 'INST_VERSION',
4361 $self->inst_version) if $local_file; #%vd already applied
4365 sub manpage_headline {
4366 my($self,$local_file) = @_;
4367 my(@local_file) = $local_file;
4368 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
4369 push @local_file, $local_file;
4371 for $locf (@local_file) {
4372 next unless -f $locf;
4373 my $fh = FileHandle->new($locf)
4374 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
4378 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
4379 m/^=head1\s+NAME/ ? 1 : $inpod;
4392 #-> sub CPAN::Module::cpan_file ;
4395 CPAN->debug($self->id) if $CPAN::DEBUG;
4396 unless (defined $self->{'CPAN_FILE'}) {
4397 CPAN::Index->reload;
4399 if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
4400 return $self->{'CPAN_FILE'};
4401 } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
4402 my $fullname = $CPAN::META->instance(CPAN::Author,
4403 $self->{'userid'})->fullname;
4404 my $email = $CPAN::META->instance(CPAN::Author,
4405 $self->{'userid'})->email;
4406 unless (defined $fullname && defined $email) {
4407 return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
4409 return "Contact Author $fullname <$email>";
4415 *name = \&cpan_file;
4417 #-> sub CPAN::Module::cpan_version ;
4420 $self->{'CPAN_VERSION'} = 'undef'
4421 unless defined $self->{'CPAN_VERSION'}; # I believe this is
4422 # always a bug in the
4423 # index and should be
4425 # but usually I find
4427 # and do not want to
4430 $self->{'CPAN_VERSION'}; # %vd not needed
4433 #-> sub CPAN::Module::force ;
4436 $self->{'force_update'}++;
4439 #-> sub CPAN::Module::rematein ;
4441 my($self,$meth) = @_;
4442 $self->debug($self->id) if $CPAN::DEBUG;
4443 my $cpan_file = $self->cpan_file;
4444 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
4445 $CPAN::Frontend->mywarn(sprintf qq{
4446 The module %s isn\'t available on CPAN.
4448 Either the module has not yet been uploaded to CPAN, or it is
4449 temporary unavailable. Please contact the author to find out
4450 more about the status. Try ``i %s''.
4457 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
4458 $pack->called_for($self->id);
4459 $pack->force if exists $self->{'force_update'};
4461 delete $self->{'force_update'};
4464 #-> sub CPAN::Module::readme ;
4465 sub readme { shift->rematein('readme') }
4466 #-> sub CPAN::Module::look ;
4467 sub look { shift->rematein('look') }
4468 #-> sub CPAN::Module::cvs_import ;
4469 sub cvs_import { shift->rematein('cvs_import') }
4470 #-> sub CPAN::Module::get ;
4471 sub get { shift->rematein('get',@_); }
4472 #-> sub CPAN::Module::make ;
4473 sub make { shift->rematein('make') }
4474 #-> sub CPAN::Module::test ;
4475 sub test { shift->rematein('test') }
4476 #-> sub CPAN::Module::uptodate ;
4479 my($latest) = $self->cpan_version; # %vd not needed
4481 my($inst_file) = $self->inst_file;
4483 if (defined $inst_file) {
4484 $have = $self->inst_version; # %vd already applied
4489 ! CPAN::Version->vgt($latest, $have)
4495 #-> sub CPAN::Module::install ;
4501 not exists $self->{'force_update'}
4503 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
4507 $self->rematein('install') if $doit;
4509 #-> sub CPAN::Module::clean ;
4510 sub clean { shift->rematein('clean') }
4512 #-> sub CPAN::Module::inst_file ;
4516 @packpath = split /::/, $self->{ID};
4517 $packpath[-1] .= ".pm";
4518 foreach $dir (@INC) {
4519 my $pmfile = MM->catfile($dir,@packpath);
4527 #-> sub CPAN::Module::xs_file ;
4531 @packpath = split /::/, $self->{ID};
4532 push @packpath, $packpath[-1];
4533 $packpath[-1] .= "." . $Config::Config{'dlext'};
4534 foreach $dir (@INC) {
4535 my $xsfile = MM->catfile($dir,'auto',@packpath);
4543 #-> sub CPAN::Module::inst_version ;
4546 my $parsefile = $self->inst_file or return;
4547 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4549 # local($SIG{__WARN__}) = sub { warn "1. have[$have]"; };
4551 # there was a bug in 5.6.0 that let lots of unini warnings out of
4552 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
4553 # this workaround after 5.6.1 is out.
4554 local($SIG{__WARN__}) = sub { my $w = shift;
4555 return if $w =~ /uninitialized/i;
4558 $have = MM->parse_version($parsefile) || "undef";
4559 $have =~ s/^ //; # since the %vd hack these two lines here are needed
4560 $have =~ s/ $//; # trailing whitespace happens all the time
4562 # local($SIG{__WARN__}) = sub { warn "2. have[$have]"; };
4564 # Should %vd hack happen here? Must we not maintain the original
4565 # version string until it is used? Do we for printing make it
4566 # human readable? Or do we maintain it in a human readable form?
4569 # OK, let's discuss the pros and cons:
4570 #-maintain it as string with leading v:
4571 # read index files do nothing
4572 # compare it use utility for compare
4573 # print it do nothing
4575 # maintain it as what is is
4576 # read index files convert
4577 # compare it use utility because there's still a ">" vs "gt" issue
4578 # print it use CPAN::Version for print
4580 # Seems cleaner to hold it in memory as a string starting with a "v"
4582 $have = CPAN::Version->readable($have);
4583 $have =~ s/\s*//g; # stringify to float around floating point issues
4584 $have; # no stringify needed, \s* above matches always
4587 package CPAN::Tarzip;
4589 # CPAN::Tarzip::gzip
4591 my($class,$read,$write) = @_;
4592 if ($CPAN::META->has_inst("Compress::Zlib")) {
4594 $fhw = FileHandle->new($read)
4595 or $CPAN::Frontend->mydie("Could not open $read: $!");
4596 my $gz = Compress::Zlib::gzopen($write, "wb")
4597 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
4598 $gz->gzwrite($buffer)
4599 while read($fhw,$buffer,4096) > 0 ;
4604 system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
4609 # CPAN::Tarzip::gunzip
4611 my($class,$read,$write) = @_;
4612 if ($CPAN::META->has_inst("Compress::Zlib")) {
4614 $fhw = FileHandle->new(">$write")
4615 or $CPAN::Frontend->mydie("Could not open >$write: $!");
4616 my $gz = Compress::Zlib::gzopen($read, "rb")
4617 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
4618 $fhw->print($buffer)
4619 while $gz->gzread($buffer) > 0 ;
4620 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4621 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4626 system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
4631 # CPAN::Tarzip::gtest
4633 my($class,$read) = @_;
4634 if ($CPAN::META->has_inst("Compress::Zlib")) {
4636 my $gz = Compress::Zlib::gzopen($read, "rb")
4637 or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
4638 1 while $gz->gzread($buffer) > 0 ;
4639 my $err = $gz->gzerror;
4640 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
4642 $class->debug("err[$err]success[$success]") if $CPAN::DEBUG;
4645 return system("$CPAN::Config->{'gzip'} -dt $read")==0;
4650 # CPAN::Tarzip::TIEHANDLE
4652 my($class,$file) = @_;
4654 $class->debug("file[$file]");
4655 if ($CPAN::META->has_inst("Compress::Zlib")) {
4656 my $gz = Compress::Zlib::gzopen($file,"rb") or
4657 die "Could not gzopen $file";
4658 $ret = bless {GZ => $gz}, $class;
4660 my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
4661 my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
4663 $ret = bless {FH => $fh}, $class;
4669 # CPAN::Tarzip::READLINE
4672 if (exists $self->{GZ}) {
4673 my $gz = $self->{GZ};
4674 my($line,$bytesread);
4675 $bytesread = $gz->gzreadline($line);
4676 return undef if $bytesread <= 0;
4679 my $fh = $self->{FH};
4680 return scalar <$fh>;
4685 # CPAN::Tarzip::READ
4687 my($self,$ref,$length,$offset) = @_;
4688 die "read with offset not implemented" if defined $offset;
4689 if (exists $self->{GZ}) {
4690 my $gz = $self->{GZ};
4691 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
4694 my $fh = $self->{FH};
4695 return read($fh,$$ref,$length);
4700 # CPAN::Tarzip::DESTROY
4703 if (exists $self->{GZ}) {
4704 my $gz = $self->{GZ};
4707 my $fh = $self->{FH};
4708 $fh->close if defined $fh;
4714 # CPAN::Tarzip::untar
4716 my($class,$file) = @_;
4717 # had to disable, because version 0.07 seems to be buggy
4718 if (MM->maybe_command($CPAN::Config->{'gzip'})
4720 MM->maybe_command($CPAN::Config->{'tar'})) {
4721 my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
4722 "< $file | $CPAN::Config->{tar} xvf -";
4723 if (system($system) != 0) {
4724 # people find the most curious tar binaries that cannot handle
4726 my $system = "$CPAN::Config->{'gzip'} --decompress $file";
4727 if (system($system)==0) {
4728 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
4730 $CPAN::Frontend->mydie(
4731 qq{Couldn\'t uncompress $file\n}
4734 $file =~ s/\.gz(?!\n)\Z//;
4735 $system = "$CPAN::Config->{tar} xvf $file";
4736 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
4737 if (system($system)==0) {
4738 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
4740 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
4746 } elsif ($CPAN::META->has_inst("Archive::Tar")
4748 $CPAN::META->has_inst("Compress::Zlib") ) {
4749 my $tar = Archive::Tar->new($file,1);
4750 $tar->extract($tar->list_files); # I'm pretty sure we have nothing
4751 # that isn't compressed
4753 ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
4754 if ($^O eq 'MacOS');
4758 $CPAN::Frontend->mydie(qq{
4759 CPAN.pm needs either both external programs tar and gzip installed or
4760 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
4761 is available. Can\'t continue.
4767 my($class,$file) = @_;
4768 return unless $CPAN::META->has_inst("Archive::Zip");
4769 # blueprint of the code from Archive::Zip::Tree::extractTree();
4770 my $zip = Archive::Zip->new();
4772 $status = $zip->read($file);
4773 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
4774 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
4775 my @members = $zip->members();
4776 for my $member ( @members ) {
4777 my $f = $member->fileName();
4778 my $status = $member->extractToFileNamed( $f );
4779 $CPAN::META->debug("f[$f]status[$status]") if $CPAN::DEBUG;
4780 die "Extracting of file[$f] from zipfile[$file] failed\n" if
4781 $status != Archive::Zip::AZ_OK();
4786 package CPAN::Version;
4789 my($self,$l,$r) = @_;
4791 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
4792 return 1 if $r eq "undef" && $l ne "undef";
4793 return if $l eq "undef" && $r ne "undef";
4794 return 1 if $] >= 5.006 && $l =~ /^v/ && $r =~ /^v/ &&
4795 $self->vstring($l) gt $self->vstring($r);
4796 return 1 if $l > $r;
4797 return 1 if $l gt $r;
4803 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid argument [$n]";
4804 pack "U*", split /\./, $n;
4809 return $n if $n =~ /^[\w\-\+\.]+$/;
4810 if ($] < 5.006) { # or whenever v-strings were introduced
4811 # we get them wrong anyway, whatever we do, because 5.005 will
4812 # have already interpreted 0.2.4 to be "0.24". So even if he
4813 # indexer sends us something like "v0.2.4" we compare wrongly.
4815 # And if they say v1.2, then the old perl takes it as "v12"
4817 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
4820 my $better = sprintf "v%vd", $n;
4821 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
4833 CPAN - query, download and build perl modules from CPAN sites
4839 perl -MCPAN -e shell;
4845 autobundle, clean, install, make, recompile, test
4849 The CPAN module is designed to automate the make and install of perl
4850 modules and extensions. It includes some searching capabilities and
4851 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
4852 to fetch the raw data from the net.
4854 Modules are fetched from one or more of the mirrored CPAN
4855 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
4858 The CPAN module also supports the concept of named and versioned
4859 I<bundles> of modules. Bundles simplify the handling of sets of
4860 related modules. See Bundles below.
4862 The package contains a session manager and a cache manager. There is
4863 no status retained between sessions. The session manager keeps track
4864 of what has been fetched, built and installed in the current
4865 session. The cache manager keeps track of the disk space occupied by
4866 the make processes and deletes excess space according to a simple FIFO
4869 For extended searching capabilities there's a plugin for CPAN available,
4870 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
4871 all documents available in CPAN authors directories. If C<CPAN::WAIT>
4872 is installed on your system, the interactive shell of <CPAN.pm> will
4873 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
4874 queries to the WAIT server that has been configured for your
4877 All other methods provided are accessible in a programmer style and in an
4878 interactive shell style.
4880 =head2 Interactive Mode
4882 The interactive mode is entered by running
4884 perl -MCPAN -e shell
4886 which puts you into a readline interface. You will have the most fun if
4887 you install Term::ReadKey and Term::ReadLine to enjoy both history and
4890 Once you are on the command line, type 'h' and the rest should be
4893 The most common uses of the interactive modes are
4897 =item Searching for authors, bundles, distribution files and modules
4899 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
4900 for each of the four categories and another, C<i> for any of the
4901 mentioned four. Each of the four entities is implemented as a class
4902 with slightly differing methods for displaying an object.
4904 Arguments you pass to these commands are either strings exactly matching
4905 the identification string of an object or regular expressions that are
4906 then matched case-insensitively against various attributes of the
4907 objects. The parser recognizes a regular expression only if you
4908 enclose it between two slashes.
4910 The principle is that the number of found objects influences how an
4911 item is displayed. If the search finds one item, the result is
4912 displayed with the rather verbose method C<as_string>, but if we find
4913 more than one, we display each object with the terse method
4916 =item make, test, install, clean modules or distributions
4918 These commands take any number of arguments and investigate what is
4919 necessary to perform the action. If the argument is a distribution
4920 file name (recognized by embedded slashes), it is processed. If it is
4921 a module, CPAN determines the distribution file in which this module
4922 is included and processes that, following any dependencies named in
4923 the module's Makefile.PL (this behavior is controlled by
4924 I<prerequisites_policy>.)
4926 Any C<make> or C<test> are run unconditionally. An
4928 install <distribution_file>
4930 also is run unconditionally. But for
4934 CPAN checks if an install is actually needed for it and prints
4935 I<module up to date> in the case that the distribution file containing
4936 the module doesn't need to be updated.
4938 CPAN also keeps track of what it has done within the current session
4939 and doesn't try to build a package a second time regardless if it
4940 succeeded or not. The C<force> command takes as a first argument the
4941 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
4942 command from scratch.
4946 cpan> install OpenGL
4947 OpenGL is up to date.
4948 cpan> force install OpenGL
4951 OpenGL-0.4/COPYRIGHT
4954 A C<clean> command results in a
4958 being executed within the distribution file's working directory.
4960 =item get, readme, look module or distribution
4962 C<get> downloads a distribution file without further action. C<readme>
4963 displays the README file of the associated distribution. C<Look> gets
4964 and untars (if not yet done) the distribution file, changes to the
4965 appropriate directory and opens a subshell process in that directory.
4969 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4970 in the cpan-shell it is intended that you can press C<^C> anytime and
4971 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4972 to clean up and leave the shell loop. You can emulate the effect of a
4973 SIGTERM by sending two consecutive SIGINTs, which usually means by
4974 pressing C<^C> twice.
4976 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4977 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4983 The commands that are available in the shell interface are methods in
4984 the package CPAN::Shell. If you enter the shell command, all your
4985 input is split by the Text::ParseWords::shellwords() routine which
4986 acts like most shells do. The first word is being interpreted as the
4987 method to be called and the rest of the words are treated as arguments
4988 to this method. Continuation lines are supported if a line ends with a
4993 C<autobundle> writes a bundle file into the
4994 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4995 a list of all modules that are both available from CPAN and currently
4996 installed within @INC. The name of the bundle file is based on the
4997 current date and a counter.
5001 recompile() is a very special command in that it takes no argument and
5002 runs the make/test/install cycle with brute force over all installed
5003 dynamically loadable extensions (aka XS modules) with 'force' in
5004 effect. The primary purpose of this command is to finish a network
5005 installation. Imagine, you have a common source tree for two different
5006 architectures. You decide to do a completely independent fresh
5007 installation. You start on one architecture with the help of a Bundle
5008 file produced earlier. CPAN installs the whole Bundle for you, but
5009 when you try to repeat the job on the second architecture, CPAN
5010 responds with a C<"Foo up to date"> message for all modules. So you
5011 invoke CPAN's recompile on the second architecture and you're done.
5013 Another popular use for C<recompile> is to act as a rescue in case your
5014 perl breaks binary compatibility. If one of the modules that CPAN uses
5015 is in turn depending on binary compatibility (so you cannot run CPAN
5016 commands), then you should try the CPAN::Nox module for recovery.
5018 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
5020 Although it may be considered internal, the class hierarchy does matter
5021 for both users and programmer. CPAN.pm deals with above mentioned four
5022 classes, and all those classes share a set of methods. A classical
5023 single polymorphism is in effect. A metaclass object registers all
5024 objects of all kinds and indexes them with a string. The strings
5025 referencing objects have a separated namespace (well, not completely
5030 words containing a "/" (slash) Distribution
5031 words starting with Bundle:: Bundle
5032 everything else Module or Author
5034 Modules know their associated Distribution objects. They always refer
5035 to the most recent official release. Developers may mark their releases
5036 as unstable development versions (by inserting an underbar into the
5037 visible version number), so the really hottest and newest distribution
5038 file is not always the default. If a module Foo circulates on CPAN in
5039 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
5040 install version 1.23 by saying
5044 This would install the complete distribution file (say
5045 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
5046 like to install version 1.23_90, you need to know where the
5047 distribution file resides on CPAN relative to the authors/id/
5048 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
5049 so you would have to say
5051 install BAR/Foo-1.23_90.tar.gz
5053 The first example will be driven by an object of the class
5054 CPAN::Module, the second by an object of class CPAN::Distribution.
5056 =head2 Programmer's interface
5058 If you do not enter the shell, the available shell commands are both
5059 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
5060 functions in the calling package (C<install(...)>).
5062 There's currently only one class that has a stable interface -
5063 CPAN::Shell. All commands that are available in the CPAN shell are
5064 methods of the class CPAN::Shell. Each of the commands that produce
5065 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
5066 the IDs of all modules within the list.
5070 =item expand($type,@things)
5072 The IDs of all objects available within a program are strings that can
5073 be expanded to the corresponding real objects with the
5074 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
5075 list of CPAN::Module objects according to the C<@things> arguments
5076 given. In scalar context it only returns the first element of the
5079 =item Programming Examples
5081 This enables the programmer to do operations that combine
5082 functionalities that are available in the shell.
5084 # install everything that is outdated on my disk:
5085 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
5087 # install my favorite programs if necessary:
5088 for $mod (qw(Net::FTP MD5 Data::Dumper)){
5089 my $obj = CPAN::Shell->expand('Module',$mod);
5093 # list all modules on my disk that have no VERSION number
5094 for $mod (CPAN::Shell->expand("Module","/./")){
5095 next unless $mod->inst_file;
5096 # MakeMaker convention for undefined $VERSION:
5097 next unless $mod->inst_version eq "undef";
5098 print "No VERSION in ", $mod->id, "\n";
5101 # find out which distribution on CPAN contains a module:
5102 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
5104 Or if you want to write a cronjob to watch The CPAN, you could list
5105 all modules that need updating. First a quick and dirty way:
5107 perl -e 'use CPAN; CPAN::Shell->r;'
5109 If you don't want to get any output if all modules are up to date, you
5110 can parse the output of above command for the regular expression
5111 //modules are up to date// and decide to mail the output only if it
5114 If you prefer to do it more in a programmer style in one single
5115 process, maybe something like this suites you better:
5117 # list all modules on my disk that have newer versions on CPAN
5118 for $mod (CPAN::Shell->expand("Module","/./")){
5119 next unless $mod->inst_file;
5120 next if $mod->uptodate;
5121 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
5122 $mod->id, $mod->inst_version, $mod->cpan_version;
5125 If that gives you too much output every day, you maybe only want to
5126 watch for three modules. You can write
5128 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
5130 as the first line instead. Or you can combine some of the above
5133 # watch only for a new mod_perl module
5134 $mod = CPAN::Shell->expand("Module","mod_perl");
5135 exit if $mod->uptodate;
5136 # new mod_perl arrived, let me know all update recommendations
5141 =head2 Methods in the four Classes
5143 =head2 Cache Manager
5145 Currently the cache manager only keeps track of the build directory
5146 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
5147 deletes complete directories below C<build_dir> as soon as the size of
5148 all directories there gets bigger than $CPAN::Config->{build_cache}
5149 (in MB). The contents of this cache may be used for later
5150 re-installations that you intend to do manually, but will never be
5151 trusted by CPAN itself. This is due to the fact that the user might
5152 use these directories for building modules on different architectures.
5154 There is another directory ($CPAN::Config->{keep_source_where}) where
5155 the original distribution files are kept. This directory is not
5156 covered by the cache manager and must be controlled by the user. If
5157 you choose to have the same directory as build_dir and as
5158 keep_source_where directory, then your sources will be deleted with
5159 the same fifo mechanism.
5163 A bundle is just a perl module in the namespace Bundle:: that does not
5164 define any functions or methods. It usually only contains documentation.
5166 It starts like a perl module with a package declaration and a $VERSION
5167 variable. After that the pod section looks like any other pod with the
5168 only difference being that I<one special pod section> exists starting with
5173 In this pod section each line obeys the format
5175 Module_Name [Version_String] [- optional text]
5177 The only required part is the first field, the name of a module
5178 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
5179 of the line is optional. The comment part is delimited by a dash just
5180 as in the man page header.
5182 The distribution of a bundle should follow the same convention as
5183 other distributions.
5185 Bundles are treated specially in the CPAN package. If you say 'install
5186 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
5187 the modules in the CONTENTS section of the pod. You can install your
5188 own Bundles locally by placing a conformant Bundle file somewhere into
5189 your @INC path. The autobundle() command which is available in the
5190 shell interface does that for you by including all currently installed
5191 modules in a snapshot bundle file.
5193 =head2 Prerequisites
5195 If you have a local mirror of CPAN and can access all files with
5196 "file:" URLs, then you only need a perl better than perl5.003 to run
5197 this module. Otherwise Net::FTP is strongly recommended. LWP may be
5198 required for non-UNIX systems or if your nearest CPAN site is
5199 associated with an URL that is not C<ftp:>.
5201 If you have neither Net::FTP nor LWP, there is a fallback mechanism
5202 implemented for an external ftp command or for an external lynx
5205 =head2 Finding packages and VERSION
5207 This module presumes that all packages on CPAN
5213 declare their $VERSION variable in an easy to parse manner. This
5214 prerequisite can hardly be relaxed because it consumes far too much
5215 memory to load all packages into the running program just to determine
5216 the $VERSION variable. Currently all programs that are dealing with
5217 version use something like this
5219 perl -MExtUtils::MakeMaker -le \
5220 'print MM->parse_version(shift)' filename
5222 If you are author of a package and wonder if your $VERSION can be
5223 parsed, please try the above method.
5227 come as compressed or gzipped tarfiles or as zip files and contain a
5228 Makefile.PL (well, we try to handle a bit more, but without much
5235 The debugging of this module is pretty difficult, because we have
5236 interferences of the software producing the indices on CPAN, of the
5237 mirroring process on CPAN, of packaging, of configuration, of
5238 synchronicity, and of bugs within CPAN.pm.
5240 In interactive mode you can try "o debug" which will list options for
5241 debugging the various parts of the package. The output may not be very
5242 useful for you as it's just a by-product of my own testing, but if you
5243 have an idea which part of the package may have a bug, it's sometimes
5244 worth to give it a try and send me more specific output. You should
5245 know that "o debug" has built-in completion support.
5247 =head2 Floppy, Zip, Offline Mode
5249 CPAN.pm works nicely without network too. If you maintain machines
5250 that are not networked at all, you should consider working with file:
5251 URLs. Of course, you have to collect your modules somewhere first. So
5252 you might use CPAN.pm to put together all you need on a networked
5253 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
5254 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
5255 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
5256 with this floppy. See also below the paragraph about CD-ROM support.
5258 =head1 CONFIGURATION
5260 When the CPAN module is installed, a site wide configuration file is
5261 created as CPAN/Config.pm. The default values defined there can be
5262 overridden in another configuration file: CPAN/MyConfig.pm. You can
5263 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
5264 $HOME/.cpan is added to the search path of the CPAN module before the
5265 use() or require() statements.
5267 Currently the following keys in the hash reference $CPAN::Config are
5270 build_cache size of cache for directories to build modules
5271 build_dir locally accessible directory to build modules
5272 index_expire after this many days refetch index files
5273 cache_metadata use serializer to cache metadata
5274 cpan_home local directory reserved for this package
5275 dontload_hash anonymous hash: modules in the keys will not be
5276 loaded by the CPAN::has_inst() routine
5277 gzip location of external program gzip
5278 inactivity_timeout breaks interactive Makefile.PLs after this
5279 many seconds inactivity. Set to 0 to never break.
5280 inhibit_startup_message
5281 if true, does not print the startup message
5282 keep_source_where directory in which to keep the source (if we do)
5283 make location of external make program
5284 make_arg arguments that should always be passed to 'make'
5285 make_install_arg same as make_arg for 'make install'
5286 makepl_arg arguments passed to 'perl Makefile.PL'
5287 pager location of external program more (or any pager)
5288 prerequisites_policy
5289 what to do if you are missing module prerequisites
5290 ('follow' automatically, 'ask' me, or 'ignore')
5291 scan_cache controls scanning of cache ('atstart' or 'never')
5292 tar location of external program tar
5293 unzip location of external program unzip
5294 urllist arrayref to nearby CPAN sites (or equivalent locations)
5295 wait_list arrayref to a wait server to try (See CPAN::WAIT)
5296 ftp_proxy, } the three usual variables for configuring
5297 http_proxy, } proxy requests. Both as CPAN::Config variables
5298 no_proxy } and as environment variables configurable.
5300 You can set and query each of these options interactively in the cpan
5301 shell with the command set defined within the C<o conf> command:
5305 =item C<o conf E<lt>scalar optionE<gt>>
5307 prints the current value of the I<scalar option>
5309 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
5311 Sets the value of the I<scalar option> to I<value>
5313 =item C<o conf E<lt>list optionE<gt>>
5315 prints the current value of the I<list option> in MakeMaker's
5318 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
5320 shifts or pops the array in the I<list option> variable
5322 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
5324 works like the corresponding perl commands.
5328 =head2 Note on urllist parameter's format
5330 urllist parameters are URLs according to RFC 1738. We do a little
5331 guessing if your URL is not compliant, but if you have problems with
5332 file URLs, please try the correct format. Either:
5334 file://localhost/whatever/ftp/pub/CPAN/
5338 file:///home/ftp/pub/CPAN/
5340 =head2 urllist parameter has CD-ROM support
5342 The C<urllist> parameter of the configuration table contains a list of
5343 URLs that are to be used for downloading. If the list contains any
5344 C<file> URLs, CPAN always tries to get files from there first. This
5345 feature is disabled for index files. So the recommendation for the
5346 owner of a CD-ROM with CPAN contents is: include your local, possibly
5347 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
5349 o conf urllist push file://localhost/CDROM/CPAN
5351 CPAN.pm will then fetch the index files from one of the CPAN sites
5352 that come at the beginning of urllist. It will later check for each
5353 module if there is a local copy of the most recent version.
5355 Another peculiarity of urllist is that the site that we could
5356 successfully fetch the last file from automatically gets a preference
5357 token and is tried as the first site for the next request. So if you
5358 add a new site at runtime it may happen that the previously preferred
5359 site will be tried another time. This means that if you want to disallow
5360 a site for the next transfer, it must be explicitly removed from
5365 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
5366 install foreign, unmasked, unsigned code on your machine. We compare
5367 to a checksum that comes from the net just as the distribution file
5368 itself. If somebody has managed to tamper with the distribution file,
5369 they may have as well tampered with the CHECKSUMS file. Future
5370 development will go towards strong authentication.
5374 Most functions in package CPAN are exported per default. The reason
5375 for this is that the primary use is intended for the cpan shell or for
5378 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
5380 To populate a freshly installed perl with my favorite modules is pretty
5381 easiest by maintaining a private bundle definition file. To get a useful
5382 blueprint of a bundle definition file, the command autobundle can be used
5383 on the CPAN shell command line. This command writes a bundle definition
5384 file for all modules that are installed for the currently running perl
5385 interpreter. It's recommended to run this command only once and from then
5386 on maintain the file manually under a private name, say
5387 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
5389 cpan> install Bundle::my_bundle
5391 then answer a few questions and then go out for a coffee.
5393 Maintaining a bundle definition file means to keep track of two
5394 things: dependencies and interactivity. CPAN.pm sometimes fails on
5395 calculating dependencies because not all modules define all MakeMaker
5396 attributes correctly, so a bundle definition file should specify
5397 prerequisites as early as possible. On the other hand, it's a bit
5398 annoying that many distributions need some interactive configuring. So
5399 what I try to accomplish in my private bundle file is to have the
5400 packages that need to be configured early in the file and the gentle
5401 ones later, so I can go out after a few minutes and leave CPAN.pm
5404 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
5406 Thanks to Graham Barr for contributing the following paragraphs about
5407 the interaction between perl, and various firewall configurations. For
5408 further informations on firewalls, it is recommended to consult the
5409 documentation that comes with the ncftp program. If you are unable to
5410 go through the firewall with a simple Perl setup, it is very likely
5411 that you can configure ncftp so that it works for your firewall.
5413 =head2 Three basic types of firewalls
5415 Firewalls can be categorized into three basic types.
5421 This is where the firewall machine runs a web server and to access the
5422 outside world you must do it via the web server. If you set environment
5423 variables like http_proxy or ftp_proxy to a values beginning with http://
5424 or in your web browser you have to set proxy information then you know
5425 you are running a http firewall.
5427 To access servers outside these types of firewalls with perl (even for
5428 ftp) you will need to use LWP.
5432 This where the firewall machine runs a ftp server. This kind of
5433 firewall will only let you access ftp servers outside the firewall.
5434 This is usually done by connecting to the firewall with ftp, then
5435 entering a username like "user@outside.host.com"
5437 To access servers outside these type of firewalls with perl you
5438 will need to use Net::FTP.
5440 =item One way visibility
5442 I say one way visibility as these firewalls try to make themselve look
5443 invisible to the users inside the firewall. An FTP data connection is
5444 normally created by sending the remote server your IP address and then
5445 listening for the connection. But the remote server will not be able to
5446 connect to you because of the firewall. So for these types of firewall
5447 FTP connections need to be done in a passive mode.
5449 There are two that I can think off.
5455 If you are using a SOCKS firewall you will need to compile perl and link
5456 it with the SOCKS library, this is what is normally called a ``socksified''
5457 perl. With this executable you will be able to connect to servers outside
5458 the firewall as if it is not there.
5462 This is the firewall implemented in the Linux kernel, it allows you to
5463 hide a complete network behind one IP address. With this firewall no
5464 special compiling is need as you can access hosts directly.
5470 =head2 Configuring lynx or ncftp for going throught the firewall
5472 If you can go through your firewall with e.g. lynx, presumably with a
5475 /usr/local/bin/lynx -pscott:tiger
5477 then you would configure CPAN.pm with the command
5479 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
5481 That's all. Similarly for ncftp or ftp, you would configure something
5484 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
5486 Your milage may vary...
5492 =item I installed a new version of module X but CPAN keeps saying, I
5493 have the old version installed
5495 Most probably you B<do> have the old version installed. This can
5496 happen if a module installs itself into a different directory in the
5497 @INC path than it was previously installed. This is not really a
5498 CPAN.pm problem, you would have the same problem when installing the
5499 module manually. The easiest way to prevent this behaviour is to add
5500 the argument C<UNINST=1> to the C<make install> call, and that is why
5501 many people add this argument permanently by configuring
5503 o conf make_install_arg UNINST=1
5505 =item So why is UNINST=1 not the default?
5507 Because there are people who have their precise expectations about who
5508 may install where in the @INC path and who uses which @INC array. In
5509 fine tuned environments C<UNINST=1> can cause damage.
5511 =item When I install bundles or multiple modules with one command
5512 there is too much output to keep track of
5514 You may want to configure something like
5516 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
5517 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
5519 so that STDOUT is captured in a file for later inspection.
5525 We should give coverage for B<all> of the CPAN and not just the PAUSE
5526 part, right? In this discussion CPAN and PAUSE have become equal --
5527 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
5528 the clpa/, doc/, misc/, ports/, src/, scripts/.
5530 Future development should be directed towards a better integration of
5533 If a Makefile.PL requires special customization of libraries, prompts
5534 the user for special input, etc. then you may find CPAN is not able to
5535 build the distribution. In that case, you should attempt the
5536 traditional method of building a Perl module package from a shell.
5540 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
5544 perl(1), CPAN::Nox(3)