2 use vars qw{$Try_autoload
4 $META $Signal $Cwd $End
11 # $Id: CPAN.pm,v 1.305 2000/08/16 12:42:32 k Exp $
13 # only used during development:
15 # $Revision = "[".substr(q$Revision: 1.305 $, 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; }
56 $CPAN::Frontend ||= "CPAN::Shell";
57 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
60 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term);
63 @CPAN::ISA = qw(CPAN::Debug Exporter);
66 autobundle bundle expand force get cvs_import
67 install make readme recompile shell test clean
70 #-> sub CPAN::AUTOLOAD ;
75 @EXPORT{@EXPORT} = '';
76 CPAN::Config->load unless $CPAN::Config_loaded++;
77 if (exists $EXPORT{$l}){
80 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
84 # $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
86 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
95 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
96 CPAN::Config->load unless $CPAN::Config_loaded++;
98 my $prompt = "cpan> ";
100 unless ($Suppress_readline) {
101 require Term::ReadLine;
102 # import Term::ReadLine;
103 $term = Term::ReadLine->new('CPAN Monitor');
104 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
105 my $attribs = $term->Attribs;
106 # $attribs->{completion_entry_function} =
107 # $attribs->{'list_completion_function'};
108 $attribs->{attempted_completion_function} = sub {
109 &CPAN::Complete::gnu_cpl;
111 # $attribs->{completion_word} =
112 # [qw(help me somebody to find out how
113 # to use completion with GNU)];
115 $readline::rl_completion_function =
116 $readline::rl_completion_function = 'CPAN::Complete::cpl';
118 # $term->OUT is autoflushed anyway
119 my $odef = select STDERR;
129 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
130 my $cwd = CPAN->$getcwd();
131 my $try_detect_readline;
132 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
133 my $rl_avail = $Suppress_readline ? "suppressed" :
134 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
135 "available (try ``install Bundle::CPAN'')";
137 $CPAN::Frontend->myprint(
139 cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
140 ReadLine support $rl_avail
142 }) unless $CPAN::Config->{'inhibit_startup_message'} ;
143 my($continuation) = "";
145 if ($Suppress_readline) {
147 last unless defined ($_ = <> );
150 last unless defined ($_ = $term->readline($prompt));
152 $_ = "$continuation$_" if $continuation;
155 $_ = 'h' if /^\s*\?/;
156 if (/^(?:q(?:uit)?|bye|exit)$/i) {
166 use vars qw($import_done);
167 CPAN->import(':DEFAULT') unless $import_done++;
168 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
175 if ($] < 5.00322) { # parsewords had a bug until recently
178 eval { @line = Text::ParseWords::shellwords($_) };
179 warn($@), next if $@;
181 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
182 my $command = shift @line;
183 eval { CPAN::Shell->$command(@line) };
185 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
186 $CPAN::Frontend->myprint("\n");
192 CPAN::Queue->nullify_queue;
193 if ($try_detect_readline) {
194 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
196 $CPAN::META->has_inst("Term::ReadLine::Perl")
198 delete $INC{"Term/ReadLine.pm"};
200 local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef);
201 require Term::ReadLine;
202 $CPAN::Frontend->myprint("\n$redef subroutines in ".
203 "Term::ReadLine redefined\n");
210 package CPAN::CacheMgr;
211 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
214 package CPAN::Config;
215 import ExtUtils::MakeMaker 'neatvalue';
216 use vars qw(%can $dot_cpan);
219 'commit' => "Commit changes to disk",
220 'defaults' => "Reload defaults from disk",
221 'init' => "Interactive setting of all options",
225 use vars qw($Ua $Thesite $Themethod);
226 @CPAN::FTP::ISA = qw(CPAN::Debug);
228 package CPAN::Complete;
229 @CPAN::Complete::ISA = qw(CPAN::Debug);
232 use vars qw($last_time $date_of_03);
233 @CPAN::Index::ISA = qw(CPAN::Debug);
237 package CPAN::InfoObj;
238 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
240 package CPAN::Author;
241 @CPAN::Author::ISA = qw(CPAN::InfoObj);
243 package CPAN::Distribution;
244 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
246 package CPAN::Bundle;
247 @CPAN::Bundle::ISA = qw(CPAN::Module);
249 package CPAN::Module;
250 @CPAN::Module::ISA = qw(CPAN::InfoObj);
253 use vars qw($AUTOLOAD $redef @ISA);
254 @CPAN::Shell::ISA = qw(CPAN::Debug);
256 #-> sub CPAN::Shell::AUTOLOAD ;
258 my($autoload) = $AUTOLOAD;
259 my $class = shift(@_);
260 # warn "autoload[$autoload] class[$class]";
261 $autoload =~ s/.*:://;
262 if ($autoload =~ /^w/) {
263 if ($CPAN::META->has_inst('CPAN::WAIT')) {
264 CPAN::WAIT->$autoload(@_);
266 $CPAN::Frontend->mywarn(qq{
267 Commands starting with "w" require CPAN::WAIT to be installed.
268 Please consider installing CPAN::WAIT to use the fulltext index.
269 For this you just need to type
274 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
278 # $CPAN::Frontend->mywarn("Could not autoload $autoload");
280 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
286 #-> CPAN::Shell::try_dot_al
288 my($class,$autoload) = @_;
289 return unless $CPAN::Try_autoload;
290 # I don't see how to re-use that from the AutoLoader...
292 # Braces used to preserve $1 et al.
294 my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
296 if (defined($name=$INC{"$pkg.pm"}))
298 $name =~ s|^(.*)$pkg\.pm(?!\n)\Z|$1auto/$pkg/$func.al|s;
299 $name = undef unless (-r $name);
301 unless (defined $name)
303 $name = "auto/$autoload.al";
308 eval {local $SIG{__DIE__};require $name};
310 if (substr($autoload,-9) eq '::DESTROY') {
314 if ($name =~ s{(\w{12,})\.al(?!\n)\Z}{substr($1,0,11).".al"}e){
315 eval {local $SIG{__DIE__};require $name};
330 # my $lm = Carp::longmess();
331 # warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
335 #### autoloader is experimental
336 #### to try it we have to set $Try_autoload and uncomment
337 #### the use statement and uncomment the __END__ below
338 #### You also need AutoSplit 1.01 available. MakeMaker will
339 #### then build CPAN with all the AutoLoad stuff.
343 if ($CPAN::Try_autoload) {
346 CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
347 CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
348 CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
350 *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
354 package CPAN::Tarzip;
355 use vars qw($AUTOLOAD @ISA);
356 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
360 # One use of the queue is to determine if we should or shouldn't
361 # announce the availability of a new CPAN module
363 # Now we try to use it for dependency tracking. For that to happen
364 # we need to draw a dependency tree and do the leaves first. This can
365 # easily be reached by running CPAN.pm recursively, but we don't want
366 # to waste memory and run into deep recursion. So what we can do is
369 # CPAN::Queue is the package where the queue is maintained. Dependencies
370 # often have high priority and must be brought to the head of the queue,
371 # possibly by jumping the queue if they are already there. My first code
372 # attempt tried to be extremely correct. Whenever a module needed
373 # immediate treatment, I either unshifted it to the front of the queue,
374 # or, if it was already in the queue, I spliced and let it bypass the
375 # others. This became a too correct model that made it impossible to put
376 # an item more than once into the queue. Why would you need that? Well,
377 # you need temporary duplicates as the manager of the queue is a loop
380 # (1) looks at the first item in the queue without shifting it off
382 # (2) cares for the item
384 # (3) removes the item from the queue, *even if its agenda failed and
385 # even if the item isn't the first in the queue anymore* (that way
386 # protecting against never ending queues)
388 # So if an item has prerequisites, the installation fails now, but we
389 # want to retry later. That's easy if we have it twice in the queue.
391 # I also expect insane dependency situations where an item gets more
392 # than two lives in the queue. Simplest example is triggered by 'install
393 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
394 # get in the way. I wanted the queue manager to be a dumb servant, not
395 # one that knows everything.
397 # Who would I tell in this model that the user wants to be asked before
398 # processing? I can't attach that information to the module object,
399 # because not modules are installed but distributions. So I'd have to
400 # tell the distribution object that it should ask the user before
401 # processing. Where would the question be triggered then? Most probably
402 # in CPAN::Distribution::rematein.
403 # Hope that makes sense, my head is a bit off:-) -- AK
408 my($class,$mod) = @_;
409 my $self = bless {mod => $mod}, $class;
411 # my @all = map { $_->{mod} } @All;
412 # warn "Adding Queue object for mod[$mod] all[@all]";
422 my($class,$what) = @_;
424 for my $i (0..$#All) {
425 if ( $All[$i]->{mod} eq $what ) {
436 WHAT: for my $what (reverse @what) {
438 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
439 if ($All[$i]->{mod} eq $what){
441 if ($jumped > 100) { # one's OK if e.g. just processing now;
442 # more are OK if user typed it several
444 $CPAN::Frontend->mywarn(
445 qq{Object [$what] queued more than 100 times, ignoring}
451 my $obj = bless { mod => $what }, $class;
457 my($self,$what) = @_;
458 my @all = map { $_->{mod} } @All;
459 my $exists = grep { $_->{mod} eq $what } @All;
460 # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]";
466 @All = grep { $_->{mod} ne $mod } @All;
467 # my @all = map { $_->{mod} } @All;
468 # warn "Deleting Queue object for mod[$mod] all[@all]";
479 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
483 # __END__ # uncomment this and AutoSplit version 1.01 will split it
485 #-> sub CPAN::autobundle ;
487 #-> sub CPAN::bundle ;
489 #-> sub CPAN::expand ;
491 #-> sub CPAN::force ;
493 #-> sub CPAN::install ;
497 #-> sub CPAN::clean ;
504 my($mgr,$class) = @_;
505 CPAN::Config->load unless $CPAN::Config_loaded++;
506 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
508 values %{ $META->{$class} };
510 *all = \&all_objects;
512 # Called by shell, not in batch mode. Not clean XXX
513 #-> sub CPAN::checklock ;
516 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
517 if (-f $lockfile && -M _ > 0) {
518 my $fh = FileHandle->new($lockfile);
521 if (defined $other && $other) {
523 return if $$==$other; # should never happen
524 $CPAN::Frontend->mywarn(
526 There seems to be running another CPAN process ($other). Contacting...
528 if (kill 0, $other) {
529 $CPAN::Frontend->mydie(qq{Other job is running.
530 You may want to kill it and delete the lockfile, maybe. On UNIX try:
534 } elsif (-w $lockfile) {
536 ExtUtils::MakeMaker::prompt
537 (qq{Other job not responding. Shall I overwrite }.
538 qq{the lockfile? (Y/N)},"y");
539 $CPAN::Frontend->myexit("Ok, bye\n")
540 unless $ans =~ /^y/i;
543 qq{Lockfile $lockfile not writeable by you. }.
544 qq{Cannot proceed.\n}.
547 qq{ and then rerun us.\n}
552 my $dotcpan = $CPAN::Config->{cpan_home};
553 eval { File::Path::mkpath($dotcpan);};
555 # A special case at least for Jarkko.
560 $symlinkcpan = readlink $dotcpan;
561 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
562 eval { File::Path::mkpath($symlinkcpan); };
566 $CPAN::Frontend->mywarn(qq{
567 Working directory $symlinkcpan created.
571 unless (-d $dotcpan) {
573 Your configuration suggests "$dotcpan" as your
574 CPAN.pm working directory. I could not create this directory due
575 to this error: $firsterror\n};
577 As "$dotcpan" is a symlink to "$symlinkcpan",
578 I tried to create that, but I failed with this error: $seconderror
581 Please make sure the directory exists and is writable.
583 $CPAN::Frontend->mydie($diemess);
587 unless ($fh = FileHandle->new(">$lockfile")) {
588 if ($! =~ /Permission/) {
589 my $incc = $INC{'CPAN/Config.pm'};
590 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
591 $CPAN::Frontend->myprint(qq{
593 Your configuration suggests that CPAN.pm should use a working
595 $CPAN::Config->{cpan_home}
596 Unfortunately we could not create the lock file
598 due to permission problems.
600 Please make sure that the configuration variable
601 \$CPAN::Config->{cpan_home}
602 points to a directory where you can write a .lock file. You can set
603 this variable in either
610 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
612 $fh->print($$, "\n");
613 $self->{LOCK} = $lockfile;
617 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
622 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
623 print "Caught SIGINT\n";
627 # From: Larry Wall <larry@wall.org>
628 # Subject: Re: deprecating SIGDIE
629 # To: perl5-porters@perl.org
630 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
632 # The original intent of __DIE__ was only to allow you to substitute one
633 # kind of death for another on an application-wide basis without respect
634 # to whether you were in an eval or not. As a global backstop, it should
635 # not be used any more lightly (or any more heavily :-) than class
636 # UNIVERSAL. Any attempt to build a general exception model on it should
637 # be politely squashed. Any bug that causes every eval {} to have to be
638 # modified should be not so politely squashed.
640 # Those are my current opinions. It is also my optinion that polite
641 # arguments degenerate to personal arguments far too frequently, and that
642 # when they do, it's because both people wanted it to, or at least didn't
643 # sufficiently want it not to.
647 $SIG{'__DIE__'} = \&cleanup;
648 $self->debug("Signal handler set.") if $CPAN::DEBUG;
651 #-> sub CPAN::DESTROY ;
653 &cleanup; # need an eval?
657 sub cwd {Cwd::cwd();}
659 #-> sub CPAN::getcwd ;
660 sub getcwd {Cwd::getcwd();}
662 #-> sub CPAN::exists ;
664 my($mgr,$class,$id) = @_;
666 ### Carp::croak "exists called without class argument" unless $class;
668 exists $META->{$class}{$id};
671 #-> sub CPAN::delete ;
673 my($mgr,$class,$id) = @_;
674 delete $META->{$class}{$id};
677 #-> sub CPAN::has_usable
678 # has_inst is sometimes too optimistic, we should replace it with this
679 # has_usable whenever a case is given
681 my($self,$mod,$message) = @_;
682 return 1 if $HAS_USABLE->{$mod};
683 my $has_inst = $self->has_inst($mod,$message);
684 return unless $has_inst;
687 LWP => [ # we frequently had "Can't locate object
688 # method "new" via package
689 # "LWP::UserAgent" at (eval 69) line
692 sub {require LWP::UserAgent},
693 sub {require HTTP::Request},
694 sub {require URI::URL},
697 sub {require Net::FTP},
698 sub {require Net::Config},
701 if ($capabilities->{$mod}) {
702 for my $c (0..$#{$capabilities->{$mod}}) {
703 my $code = $capabilities->{$mod}[$c];
704 my $ret = eval { &$code() };
706 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
711 return $HAS_USABLE->{$mod} = 1;
714 #-> sub CPAN::has_inst
716 my($self,$mod,$message) = @_;
717 Carp::croak("CPAN->has_inst() called without an argument")
719 if (defined $message && $message eq "no"
721 exists $CPAN::META->{dontload_hash}{$mod}
723 exists $CPAN::Config->{dontload_hash}{$mod}
725 $CPAN::META->{dontload_hash}{$mod}||=1;
731 $file =~ s|/|\\|g if $^O eq 'MSWin32';
734 # checking %INC is wrong, because $INC{LWP} may be true
735 # although $INC{"URI/URL.pm"} may have failed. But as
736 # I really want to say "bla loaded OK", I have to somehow
738 ### warn "$file in %INC"; #debug
740 } elsif (eval { require $file }) {
741 # eval is good: if we haven't yet read the database it's
742 # perfect and if we have installed the module in the meantime,
743 # it tries again. The second require is only a NOOP returning
744 # 1 if we had success, otherwise it's retrying
746 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
747 if ($mod eq "CPAN::WAIT") {
748 push @CPAN::Shell::ISA, CPAN::WAIT;
751 } elsif ($mod eq "Net::FTP") {
753 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
755 install Bundle::libnet
759 } elsif ($mod eq "MD5"){
760 $CPAN::Frontend->myprint(qq{
761 CPAN: MD5 security checks disabled because MD5 not installed.
762 Please consider installing the MD5 module.
767 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
772 #-> sub CPAN::instance ;
774 my($mgr,$class,$id) = @_;
777 $META->{$class}{$id} ||= $class->new(ID => $id );
785 #-> sub CPAN::cleanup ;
787 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
788 local $SIG{__DIE__} = '';
793 0 && # disabled, try reload cpan with it
794 $] > 5.004_60 # thereabouts
799 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
801 $subroutine eq '(eval)';
804 return if $ineval && !$End;
805 return unless defined $META->{'LOCK'};
806 return unless -f $META->{'LOCK'};
807 unlink $META->{'LOCK'};
809 # Carp::cluck("DEBUGGING");
810 $CPAN::Frontend->mywarn("Lockfile removed.\n");
813 package CPAN::CacheMgr;
815 #-> sub CPAN::CacheMgr::as_string ;
817 eval { require Data::Dumper };
819 return shift->SUPER::as_string;
821 return Data::Dumper::Dumper(shift);
825 #-> sub CPAN::CacheMgr::cachesize ;
832 return unless -d $self->{ID};
833 while ($self->{DU} > $self->{'MAX'} ) {
834 my($toremove) = shift @{$self->{FIFO}};
835 $CPAN::Frontend->myprint(sprintf(
836 "Deleting from cache".
837 ": $toremove (%.1f>%.1f MB)\n",
838 $self->{DU}, $self->{'MAX'})
840 return if $CPAN::Signal;
841 $self->force_clean_cache($toremove);
842 return if $CPAN::Signal;
846 #-> sub CPAN::CacheMgr::dir ;
851 #-> sub CPAN::CacheMgr::entries ;
854 return unless defined $dir;
855 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
856 $dir ||= $self->{ID};
858 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
859 my($cwd) = CPAN->$getcwd();
860 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
861 my $dh = DirHandle->new(File::Spec->curdir)
862 or Carp::croak("Couldn't opendir $dir: $!");
865 next if $_ eq "." || $_ eq "..";
867 push @entries, MM->catfile($dir,$_);
869 push @entries, MM->catdir($dir,$_);
871 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
874 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
875 sort { -M $b <=> -M $a} @entries;
878 #-> sub CPAN::CacheMgr::disk_usage ;
881 return if exists $self->{SIZE}{$dir};
882 return if $CPAN::Signal;
886 $File::Find::prune++ if $CPAN::Signal;
888 if ($^O eq 'MacOS') {
890 my $cat = Mac::Files::FSpGetCatInfo($_);
891 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
898 return if $CPAN::Signal;
899 $self->{SIZE}{$dir} = $Du/1024/1024;
900 push @{$self->{FIFO}}, $dir;
901 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
902 $self->{DU} += $Du/1024/1024;
906 #-> sub CPAN::CacheMgr::force_clean_cache ;
907 sub force_clean_cache {
909 return unless -e $dir;
910 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
912 File::Path::rmtree($dir);
913 $self->{DU} -= $self->{SIZE}{$dir};
914 delete $self->{SIZE}{$dir};
917 #-> sub CPAN::CacheMgr::new ;
924 ID => $CPAN::Config->{'build_dir'},
925 MAX => $CPAN::Config->{'build_cache'},
926 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
929 File::Path::mkpath($self->{ID});
930 my $dh = DirHandle->new($self->{ID});
934 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
936 CPAN->debug($debug) if $CPAN::DEBUG;
940 #-> sub CPAN::CacheMgr::scan_cache ;
943 return if $self->{SCAN} eq 'never';
944 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
945 unless $self->{SCAN} eq 'atstart';
946 $CPAN::Frontend->myprint(
947 sprintf("Scanning cache %s for sizes\n",
950 for $e ($self->entries($self->{ID})) {
951 next if $e eq ".." || $e eq ".";
952 $self->disk_usage($e);
953 return if $CPAN::Signal;
960 #-> sub CPAN::Debug::debug ;
963 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
964 # Complete, caller(1)
966 ($caller) = caller(0);
968 $arg = "" unless defined $arg;
969 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
970 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
971 if ($arg and ref $arg) {
972 eval { require Data::Dumper };
974 $CPAN::Frontend->myprint($arg->as_string);
976 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
979 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
984 package CPAN::Config;
986 #-> sub CPAN::Config::edit ;
987 # returns true on successful action
989 my($class,@args) = @_;
991 CPAN->debug("class[$class]args[".join(" | ",@args)."]");
992 my($o,$str,$func,$args,$key_exists);
998 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1000 $func = shift @args;
1002 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1004 # Let's avoid eval, it's easier to comprehend without.
1005 if ($func eq "push") {
1006 push @{$CPAN::Config->{$o}}, @args;
1008 } elsif ($func eq "pop") {
1009 pop @{$CPAN::Config->{$o}};
1011 } elsif ($func eq "shift") {
1012 shift @{$CPAN::Config->{$o}};
1014 } elsif ($func eq "unshift") {
1015 unshift @{$CPAN::Config->{$o}}, @args;
1017 } elsif ($func eq "splice") {
1018 splice @{$CPAN::Config->{$o}}, @args;
1021 $CPAN::Config->{$o} = [@args];
1024 $CPAN::Frontend->myprint(
1027 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
1031 if ($o eq "urllist" && $changed) {
1032 # reset the cached values
1033 undef $CPAN::FTP::Thesite;
1034 undef $CPAN::FTP::Themethod;
1038 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1039 $CPAN::Frontend->myprint(" $o " .
1040 (defined $CPAN::Config->{$o} ?
1041 $CPAN::Config->{$o} : "UNDEFINED"));
1046 #-> sub CPAN::Config::commit ;
1048 my($self,$configpm) = @_;
1049 unless (defined $configpm){
1050 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1051 $configpm ||= $INC{"CPAN/Config.pm"};
1052 $configpm || Carp::confess(q{
1053 CPAN::Config::commit called without an argument.
1054 Please specify a filename where to save the configuration or try
1055 "o conf init" to have an interactive course through configing.
1060 $mode = (stat $configpm)[2];
1061 if ($mode && ! -w _) {
1062 Carp::confess("$configpm is not writable");
1067 $msg = <<EOF unless $configpm =~ /MyConfig/;
1069 # This is CPAN.pm's systemwide configuration file. This file provides
1070 # defaults for users, and the values can be changed in a per-user
1071 # configuration file. The user-config file is being looked for as
1072 # ~/.cpan/CPAN/MyConfig.pm.
1076 my($fh) = FileHandle->new;
1077 rename $configpm, "$configpm~" if -f $configpm;
1078 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
1079 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1080 foreach (sort keys %$CPAN::Config) {
1083 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1088 $fh->print("};\n1;\n__END__\n");
1091 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1092 #chmod $mode, $configpm;
1093 ###why was that so? $self->defaults;
1094 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1098 *default = \&defaults;
1099 #-> sub CPAN::Config::defaults ;
1109 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1118 #-> sub CPAN::Config::load ;
1123 eval {require CPAN::Config;}; # We eval because of some
1124 # MakeMaker problems
1125 unless ($dot_cpan++){
1126 unshift @INC, MM->catdir($ENV{HOME},".cpan");
1127 eval {require CPAN::MyConfig;}; # where you can override
1128 # system wide settings
1131 return unless @miss = $self->not_loaded;
1132 # XXX better check for arrayrefs too
1133 require CPAN::FirstTime;
1134 my($configpm,$fh,$redo,$theycalled);
1136 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1137 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1138 $configpm = $INC{"CPAN/Config.pm"};
1140 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1141 $configpm = $INC{"CPAN/MyConfig.pm"};
1144 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1145 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1146 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1147 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1148 if (-w $configpmtest) {
1149 $configpm = $configpmtest;
1150 } elsif (-w $configpmdir) {
1151 #_#_# following code dumped core on me with 5.003_11, a.k.
1152 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1153 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1154 my $fh = FileHandle->new;
1155 if ($fh->open(">$configpmtest")) {
1157 $configpm = $configpmtest;
1159 # Should never happen
1160 Carp::confess("Cannot open >$configpmtest");
1164 unless ($configpm) {
1165 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1166 File::Path::mkpath($configpmdir);
1167 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1168 if (-w $configpmtest) {
1169 $configpm = $configpmtest;
1170 } elsif (-w $configpmdir) {
1171 #_#_# following code dumped core on me with 5.003_11, a.k.
1172 my $fh = FileHandle->new;
1173 if ($fh->open(">$configpmtest")) {
1175 $configpm = $configpmtest;
1177 # Should never happen
1178 Carp::confess("Cannot open >$configpmtest");
1181 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1182 qq{create a configuration file.});
1187 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1188 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1192 $CPAN::Frontend->myprint(qq{
1193 $configpm initialized.
1196 CPAN::FirstTime::init($configpm);
1199 #-> sub CPAN::Config::not_loaded ;
1203 cpan_home keep_source_where build_dir build_cache scan_cache
1204 index_expire gzip tar unzip make pager makepl_arg make_arg
1205 make_install_arg urllist inhibit_startup_message
1206 ftp_proxy http_proxy no_proxy prerequisites_policy
1208 push @miss, $_ unless defined $CPAN::Config->{$_};
1213 #-> sub CPAN::Config::unload ;
1215 delete $INC{'CPAN/MyConfig.pm'};
1216 delete $INC{'CPAN/Config.pm'};
1219 #-> sub CPAN::Config::help ;
1221 $CPAN::Frontend->myprint(q[
1223 defaults reload default config values from disk
1224 commit commit session changes to disk
1225 init go through a dialog to set all parameters
1227 You may edit key values in the follow fashion (the "o" is a literal
1230 o conf build_cache 15
1232 o conf build_dir "/foo/bar"
1234 o conf urllist shift
1236 o conf urllist unshift ftp://ftp.foo.bar/
1239 undef; #don't reprint CPAN::Config
1242 #-> sub CPAN::Config::cpl ;
1244 my($word,$line,$pos) = @_;
1246 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1247 my(@words) = split " ", substr($line,0,$pos+1);
1252 $words[2] =~ /list$/ && @words == 3
1254 $words[2] =~ /list$/ && @words == 4 && length($word)
1257 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1258 } elsif (@words >= 4) {
1261 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1262 return grep /^\Q$word\E/, @o_conf;
1265 package CPAN::Shell;
1267 #-> sub CPAN::Shell::h ;
1269 my($class,$about) = @_;
1270 if (defined $about) {
1271 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1273 $CPAN::Frontend->myprint(q{
1276 b string display bundles
1277 d or info distributions
1278 m /regex/ about modules
1279 i or anything of above
1280 r none reinstall recommendations
1281 u uninstalled distributions
1283 Download, Test, Make, Install...
1285 make make (implies get)
1286 test modules, make test (implies make)
1287 install dists, bundles make install (implies test)
1289 look open subshell in these dists' directories
1290 readme display these dists' README files
1293 h,? display this menu ! perl-code eval a perl command
1294 o conf [opt] set and query options q quit the cpan shell
1295 reload cpan load CPAN.pm again reload index load newer indices
1296 autobundle Snapshot force cmd unconditionally do cmd});
1302 #-> sub CPAN::Shell::a ;
1304 my($self,@arg) = @_;
1305 # authors are always UPPERCASE
1309 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1311 #-> sub CPAN::Shell::b ;
1313 my($self,@which) = @_;
1314 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1315 my($incdir,$bdir,$dh);
1316 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1317 $bdir = MM->catdir($incdir,"Bundle");
1318 if ($dh = DirHandle->new($bdir)) { # may fail
1320 for $entry ($dh->read) {
1321 next if -d MM->catdir($bdir,$entry);
1322 next unless $entry =~ s/\.pm(?!\n)\Z//;
1323 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1327 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1329 #-> sub CPAN::Shell::d ;
1330 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1331 #-> sub CPAN::Shell::m ;
1332 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1333 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1336 #-> sub CPAN::Shell::i ;
1341 @type = qw/Author Bundle Distribution Module/;
1342 @args = '/./' unless @args;
1345 push @result, $self->expand($type,@args);
1347 my $result = @result == 1 ?
1348 $result[0]->as_string :
1349 join "", map {$_->as_glimpse} @result;
1350 $result ||= "No objects found of any type for argument @args\n";
1351 $CPAN::Frontend->myprint($result);
1354 #-> sub CPAN::Shell::o ;
1356 my($self,$o_type,@o_what) = @_;
1358 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1359 if ($o_type eq 'conf') {
1360 shift @o_what if @o_what && $o_what[0] eq 'help';
1363 $CPAN::Frontend->myprint("CPAN::Config options");
1364 if (exists $INC{'CPAN/Config.pm'}) {
1365 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1367 if (exists $INC{'CPAN/MyConfig.pm'}) {
1368 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1370 $CPAN::Frontend->myprint(":\n");
1371 for $k (sort keys %CPAN::Config::can) {
1372 $v = $CPAN::Config::can{$k};
1373 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1375 $CPAN::Frontend->myprint("\n");
1376 for $k (sort keys %$CPAN::Config) {
1377 $v = $CPAN::Config->{$k};
1379 my(@report) = ref $v eq "ARRAY" ? @$v : %$v;
1380 $CPAN::Frontend->myprint(
1387 map {"\t$_\n"} @report
1391 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1394 $CPAN::Frontend->myprint("\n");
1395 } elsif (!CPAN::Config->edit(@o_what)) {
1396 $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
1398 } elsif ($o_type eq 'debug') {
1400 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1403 my($what) = shift @o_what;
1404 if ( exists $CPAN::DEBUG{$what} ) {
1405 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1406 } elsif ($what =~ /^\d/) {
1407 $CPAN::DEBUG = $what;
1408 } elsif (lc $what eq 'all') {
1410 for (values %CPAN::DEBUG) {
1413 $CPAN::DEBUG = $max;
1416 for (keys %CPAN::DEBUG) {
1417 next unless lc($_) eq lc($what);
1418 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1421 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1426 my $raw = "Valid options for debug are ".
1427 join(", ",sort(keys %CPAN::DEBUG), 'all').
1428 qq{ or a number. Completion works on the options. }.
1429 qq{Case is ignored.};
1431 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1432 $CPAN::Frontend->myprint("\n\n");
1435 $CPAN::Frontend->myprint("Options set for debugging:\n");
1437 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1438 $v = $CPAN::DEBUG{$k};
1439 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1440 if $v & $CPAN::DEBUG;
1443 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1446 $CPAN::Frontend->myprint(qq{
1448 conf set or get configuration variables
1449 debug set or get debugging options
1454 sub dotdot_onreload {
1457 if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1461 # $CPAN::Frontend->myprint(".($subr)");
1462 $CPAN::Frontend->myprint(".");
1469 #-> sub CPAN::Shell::reload ;
1471 my($self,$command,@arg) = @_;
1473 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1474 if ($command =~ /cpan/i) {
1475 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1476 my $fh = FileHandle->new($INC{'CPAN.pm'});
1479 local($SIG{__WARN__}) = dotdot_onreload(\$redef);
1482 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1483 } elsif ($command =~ /index/) {
1484 CPAN::Index->force_reload;
1486 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1487 index re-reads the index files\n});
1491 #-> sub CPAN::Shell::_binary_extensions ;
1492 sub _binary_extensions {
1493 my($self) = shift @_;
1494 my(@result,$module,%seen,%need,$headerdone);
1495 for $module ($self->expand('Module','/./')) {
1496 my $file = $module->cpan_file;
1497 next if $file eq "N/A";
1498 next if $file =~ /^Contact Author/;
1499 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1500 next if $dist->isa_perl;
1501 next unless $module->xs_file;
1503 $CPAN::Frontend->myprint(".");
1504 push @result, $module;
1506 # print join " | ", @result;
1507 $CPAN::Frontend->myprint("\n");
1511 #-> sub CPAN::Shell::recompile ;
1513 my($self) = shift @_;
1514 my($module,@module,$cpan_file,%dist);
1515 @module = $self->_binary_extensions();
1516 for $module (@module){ # we force now and compile later, so we
1518 $cpan_file = $module->cpan_file;
1519 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1521 $dist{$cpan_file}++;
1523 for $cpan_file (sort keys %dist) {
1524 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1525 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1527 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1528 # stop a package from recompiling,
1529 # e.g. IO-1.12 when we have perl5.003_10
1533 #-> sub CPAN::Shell::_u_r_common ;
1535 my($self) = shift @_;
1536 my($what) = shift @_;
1537 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1538 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1539 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1541 @args = '/./' unless @args;
1542 my(@result,$module,%seen,%need,$headerdone,
1543 $version_undefs,$version_zeroes);
1544 $version_undefs = $version_zeroes = 0;
1545 my $sprintf = "%-25s %9s %9s %s\n";
1546 for $module ($self->expand('Module',@args)) {
1547 my $file = $module->cpan_file;
1548 next unless defined $file; # ??
1549 my($latest) = $module->cpan_version; # %vd
1550 my($inst_file) = $module->inst_file;
1552 return if $CPAN::Signal;
1555 $have = $module->inst_version; # %vd
1556 } elsif ($what eq "r") {
1557 $have = $module->inst_version; # %vd
1559 if ($have eq "undef"){
1561 } elsif ($have == 0){
1564 next if $have >= $latest;
1565 # to be pedantic we should probably say:
1566 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1567 # to catch the case where CPAN has a version 0 and we have a version undef
1568 } elsif ($what eq "u") {
1574 } elsif ($what eq "r") {
1576 } elsif ($what eq "u") {
1580 return if $CPAN::Signal; # this is sometimes lengthy
1583 push @result, sprintf "%s %s\n", $module->id, $have;
1584 } elsif ($what eq "r") {
1585 push @result, $module->id;
1586 next if $seen{$file}++;
1587 } elsif ($what eq "u") {
1588 push @result, $module->id;
1589 next if $seen{$file}++;
1590 next if $file =~ /^Contact/;
1592 unless ($headerdone++){
1593 $CPAN::Frontend->myprint("\n");
1594 $CPAN::Frontend->myprint(sprintf(
1596 "Package namespace",
1602 for ($have,$latest) {
1603 if ($] >= 5.006) { # people start using v-strings
1605 unless (/^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
1610 /^-$/ # not installed
1612 $_ = sprintf "%vd", $_;
1615 $_ = substr($_,0,8) if length($_) > 8;
1617 $CPAN::Frontend->myprint(sprintf $sprintf,
1622 $need{$module->id}++;
1626 $CPAN::Frontend->myprint("No modules found for @args\n");
1627 } elsif ($what eq "r") {
1628 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1632 if ($version_zeroes) {
1633 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1634 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1635 qq{a version number of 0\n});
1637 if ($version_undefs) {
1638 my $s_has = $version_undefs > 1 ? "s have" : " has";
1639 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1640 qq{parseable version number\n});
1646 #-> sub CPAN::Shell::r ;
1648 shift->_u_r_common("r",@_);
1651 #-> sub CPAN::Shell::u ;
1653 shift->_u_r_common("u",@_);
1656 #-> sub CPAN::Shell::autobundle ;
1659 CPAN::Config->load unless $CPAN::Config_loaded++;
1660 my(@bundle) = $self->_u_r_common("a",@_);
1661 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1662 File::Path::mkpath($todir);
1663 unless (-d $todir) {
1664 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1667 my($y,$m,$d) = (localtime)[5,4,3];
1671 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1672 my($to) = MM->catfile($todir,"$me.pm");
1674 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1675 $to = MM->catfile($todir,"$me.pm");
1677 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1679 "package Bundle::$me;\n\n",
1680 "\$VERSION = '0.01';\n\n",
1684 "Bundle::$me - Snapshot of installation on ",
1685 $Config::Config{'myhostname'},
1688 "\n\n=head1 SYNOPSIS\n\n",
1689 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1690 "=head1 CONTENTS\n\n",
1691 join("\n", @bundle),
1692 "\n\n=head1 CONFIGURATION\n\n",
1694 "\n\n=head1 AUTHOR\n\n",
1695 "This Bundle has been generated automatically ",
1696 "by the autobundle routine in CPAN.pm.\n",
1699 $CPAN::Frontend->myprint("\nWrote bundle file
1703 #-> sub CPAN::Shell::expand ;
1706 my($type,@args) = @_;
1710 if ($arg =~ m|^/(.*)/$|) {
1713 my $class = "CPAN::$type";
1715 if (defined $regex) {
1719 $CPAN::META->all_objects($class)
1722 # BUG, we got an empty object somewhere
1723 CPAN->debug(sprintf(
1724 "Empty id on obj[%s]%%[%s]",
1731 if $obj->id =~ /$regex/i
1735 $] < 5.00303 ### provide sort of
1736 ### compatibility with 5.003
1741 $obj->name =~ /$regex/i
1746 if ( $type eq 'Bundle' ) {
1747 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1749 if ($CPAN::META->exists($class,$xarg)) {
1750 $obj = $CPAN::META->instance($class,$xarg);
1751 } elsif ($CPAN::META->exists($class,$arg)) {
1752 $obj = $CPAN::META->instance($class,$arg);
1759 return wantarray ? @m : $m[0];
1762 #-> sub CPAN::Shell::format_result ;
1765 my($type,@args) = @_;
1766 @args = '/./' unless @args;
1767 my(@result) = $self->expand($type,@args);
1768 my $result = @result == 1 ?
1769 $result[0]->as_string :
1770 join "", map {$_->as_glimpse} @result;
1771 $result ||= "No objects of type $type found for argument @args\n";
1775 # The only reason for this method is currently to have a reliable
1776 # debugging utility that reveals which output is going through which
1777 # channel. No, I don't like the colors ;-)
1778 sub print_ornamented {
1779 my($self,$what,$ornament) = @_;
1781 my $ornamenting = 0; # turn the colors on
1784 unless (defined &color) {
1785 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1786 import Term::ANSIColor "color";
1788 *color = sub { return "" };
1792 for $line (split /\n/, $what) {
1793 $longest = length($line) if length($line) > $longest;
1795 my $sprintf = "%-" . $longest . "s";
1797 $what =~ s/(.*\n?)//m;
1800 my($nl) = chomp $line ? "\n" : "";
1801 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1802 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1810 my($self,$what) = @_;
1811 $self->print_ornamented($what, 'bold blue on_yellow');
1815 my($self,$what) = @_;
1816 $self->myprint($what);
1821 my($self,$what) = @_;
1822 $self->print_ornamented($what, 'bold red on_yellow');
1826 my($self,$what) = @_;
1827 $self->print_ornamented($what, 'bold red on_white');
1828 Carp::confess "died";
1832 my($self,$what) = @_;
1833 $self->print_ornamented($what, 'bold red on_white');
1838 return if -t STDOUT;
1839 my $odef = select STDERR;
1846 #-> sub CPAN::Shell::rematein ;
1847 # RE-adme||MA-ke||TE-st||IN-stall
1850 my($meth,@some) = @_;
1852 if ($meth eq 'force') {
1854 $meth = shift @some;
1857 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1859 foreach $s (@some) {
1860 CPAN::Queue->new($s);
1862 while ($s = CPAN::Queue->first) {
1866 } elsif ($s =~ m|/|) { # looks like a file
1867 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1868 } elsif ($s =~ m|^Bundle::|) {
1869 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1871 $obj = $CPAN::META->instance('CPAN::Module',$s)
1872 if $CPAN::META->exists('CPAN::Module',$s);
1876 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1884 ($] < 5.00303 || $obj->can($pragma)); ###
1888 if ($]>=5.00303 && $obj->can('called_for')) {
1889 $obj->called_for($s);
1891 CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1894 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1895 $obj = $CPAN::META->instance('CPAN::Author',$s);
1896 $CPAN::Frontend->myprint(
1898 "Don't be silly, you can't $meth ",
1904 ->myprint(qq{Warning: Cannot $meth $s, }.
1905 qq{don\'t know what it is.
1910 to find objects with similar identifiers.
1913 CPAN::Queue->delete_first($s);
1917 #-> sub CPAN::Shell::force ;
1918 sub force { shift->rematein('force',@_); }
1919 #-> sub CPAN::Shell::get ;
1920 sub get { shift->rematein('get',@_); }
1921 #-> sub CPAN::Shell::readme ;
1922 sub readme { shift->rematein('readme',@_); }
1923 #-> sub CPAN::Shell::make ;
1924 sub make { shift->rematein('make',@_); }
1925 #-> sub CPAN::Shell::test ;
1926 sub test { shift->rematein('test',@_); }
1927 #-> sub CPAN::Shell::install ;
1928 sub install { shift->rematein('install',@_); }
1929 #-> sub CPAN::Shell::clean ;
1930 sub clean { shift->rematein('clean',@_); }
1931 #-> sub CPAN::Shell::look ;
1932 sub look { shift->rematein('look',@_); }
1933 #-> sub CPAN::Shell::cvs_import ;
1934 sub cvs_import { shift->rematein('cvs_import',@_); }
1938 #-> sub CPAN::FTP::ftp_get ;
1940 my($class,$host,$dir,$file,$target) = @_;
1942 qq[Going to fetch file [$file] from dir [$dir]
1943 on host [$host] as local [$target]\n]
1945 my $ftp = Net::FTP->new($host);
1946 return 0 unless defined $ftp;
1947 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1948 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1949 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1950 warn "Couldn't login on $host";
1953 unless ( $ftp->cwd($dir) ){
1954 warn "Couldn't cwd $dir";
1958 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1959 unless ( $ftp->get($file,$target) ){
1960 warn "Couldn't fetch $file from $host\n";
1963 $ftp->quit; # it's ok if this fails
1967 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1969 # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
1970 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997
1971 # leach,> ***************
1972 # leach,> *** 1562,1567 ****
1973 # leach,> --- 1562,1580 ----
1974 # leach,> return 1 if substr($url,0,4) eq "file";
1975 # leach,> return 1 unless $url =~ m|://([^/]+)|;
1976 # leach,> my $host = $1;
1977 # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1978 # leach,> + if ($proxy) {
1979 # leach,> + $proxy =~ m|://([^/:]+)|;
1980 # leach,> + $proxy = $1;
1981 # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1982 # leach,> + if ($noproxy) {
1983 # leach,> + if ($host !~ /$noproxy$/) {
1984 # leach,> + $host = $proxy;
1986 # leach,> + } else {
1987 # leach,> + $host = $proxy;
1990 # leach,> require Net::Ping;
1991 # leach,> return 1 unless $Net::Ping::VERSION >= 2;
1995 # this is quite optimistic and returns one on several occasions where
1996 # inappropriate. But this does no harm. It would do harm if we were
1997 # too pessimistic (as I was before the http_proxy
1999 my($self,$url) = @_;
2000 return 1; # we can't simply roll our own, firewalls may break ping
2001 return 0 unless $url;
2002 return 1 if substr($url,0,4) eq "file";
2003 return 1 unless $url =~ m|^(\w+)://([^/]+)|;
2004 my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
2006 return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
2008 return 1 unless $Net::Ping::VERSION >= 2;
2010 # 1.3101 had it different: only if the first eval raised an
2011 # exception we tried it with TCP. Now we are happy if icmp wins
2012 # the order and return, we don't even check for $@. Thanks to
2013 # thayer@uis.edu for the suggestion.
2014 eval {$p = Net::Ping->new("icmp");};
2015 return 1 if $p && ref($p) && $p->ping($host, 10);
2016 eval {$p = Net::Ping->new("tcp");};
2017 $CPAN::Frontend->mydie($@) if $@;
2018 return $p->ping($host, 10);
2021 #-> sub CPAN::FTP::localize ;
2022 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
2025 my($self,$file,$aslocal,$force) = @_;
2027 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2028 unless defined $aslocal;
2029 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2032 if ($^O eq 'MacOS') {
2033 my($name, $path) = File::Basename::fileparse($aslocal, '');
2034 if (length($name) > 31) {
2035 $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
2037 my $size = 31 - length($suf);
2038 while (length($name) > $size) {
2042 $aslocal = File::Spec->catfile($path, $name);
2046 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2049 rename $aslocal, "$aslocal.bak";
2053 my($aslocal_dir) = File::Basename::dirname($aslocal);
2054 File::Path::mkpath($aslocal_dir);
2055 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2056 qq{directory "$aslocal_dir".
2057 I\'ll continue, but if you encounter problems, they may be due
2058 to insufficient permissions.\n}) unless -w $aslocal_dir;
2060 # Inheritance is not easier to manage than a few if/else branches
2061 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2063 $Ua = LWP::UserAgent->new;
2065 $Ua->proxy('ftp', $var)
2066 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
2067 $Ua->proxy('http', $var)
2068 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2070 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2074 # Try the list of urls for each single object. We keep a record
2075 # where we did get a file from
2076 my(@reordered,$last);
2077 $CPAN::Config->{urllist} ||= [];
2078 $last = $#{$CPAN::Config->{urllist}};
2079 if ($force & 2) { # local cpans probably out of date, don't reorder
2080 @reordered = (0..$last);
2084 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2086 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2097 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2099 @levels = qw/easy hard hardest/;
2101 @levels = qw/easy/ if $^O eq 'MacOS';
2102 for $level (@levels) {
2103 my $method = "host$level";
2104 my @host_seq = $level eq "easy" ?
2105 @reordered : 0..$last; # reordered has CDROM up front
2106 @host_seq = (0) unless @host_seq;
2107 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2109 $Themethod = $level;
2111 # utime $now, $now, $aslocal; # too bad, if we do that, we
2112 # might alter a local mirror
2113 $self->debug("level[$level]") if $CPAN::DEBUG;
2121 qq{Please check, if the URLs I found in your configuration file \(}.
2122 join(", ", @{$CPAN::Config->{urllist}}).
2123 qq{\) are valid. The urllist can be edited.},
2124 qq{E.g. with ``o conf urllist push ftp://myurl/''};
2125 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2127 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
2129 rename "$aslocal.bak", $aslocal;
2130 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2131 $self->ls($aslocal));
2138 my($self,$host_seq,$file,$aslocal) = @_;
2140 HOSTEASY: for $i (@$host_seq) {
2141 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2142 unless ($self->is_reachable($url)) {
2143 $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
2147 $url .= "/" unless substr($url,-1) eq "/";
2149 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2150 if ($url =~ /^file:/) {
2152 if ($CPAN::META->has_inst('URI::URL')) {
2153 my $u = URI::URL->new($url);
2155 } else { # works only on Unix, is poorly constructed, but
2156 # hopefully better than nothing.
2157 # RFC 1738 says fileurl BNF is
2158 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2159 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2161 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2162 $l =~ s|^file:||; # assume they
2165 $l =~ s|^/||s unless -f $l; # e.g. /P:
2167 if ( -f $l && -r _) {
2171 # Maybe mirror has compressed it?
2173 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2174 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2181 if ($CPAN::META->has_usable('LWP')) {
2182 $CPAN::Frontend->myprint("Fetching with LWP:
2186 require LWP::UserAgent;
2187 $Ua = LWP::UserAgent->new;
2189 my $res = $Ua->mirror($url, $aslocal);
2190 if ($res->is_success) {
2193 utime $now, $now, $aslocal; # download time is more
2194 # important than upload time
2196 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2197 my $gzurl = "$url.gz";
2198 $CPAN::Frontend->myprint("Fetching with LWP:
2201 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2202 if ($res->is_success &&
2203 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2211 # Alan Burlison informed me that in firewall envs Net::FTP
2212 # can still succeed where LWP fails. So we do not skip
2213 # Net::FTP anymore when LWP is available.
2217 $self->debug("LWP not installed") if $CPAN::DEBUG;
2219 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2220 # that's the nice and easy way thanks to Graham
2221 my($host,$dir,$getfile) = ($1,$2,$3);
2222 if ($CPAN::META->has_usable('Net::FTP')) {
2224 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2227 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2228 "aslocal[$aslocal]") if $CPAN::DEBUG;
2229 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2233 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2234 my $gz = "$aslocal.gz";
2235 $CPAN::Frontend->myprint("Fetching with Net::FTP
2238 if (CPAN::FTP->ftp_get($host,
2242 CPAN::Tarzip->gunzip($gz,$aslocal)
2255 my($self,$host_seq,$file,$aslocal) = @_;
2257 # Came back if Net::FTP couldn't establish connection (or
2258 # failed otherwise) Maybe they are behind a firewall, but they
2259 # gave us a socksified (or other) ftp program...
2262 my($devnull) = $CPAN::Config->{devnull} || "";
2264 my($aslocal_dir) = File::Basename::dirname($aslocal);
2265 File::Path::mkpath($aslocal_dir);
2266 HOSTHARD: for $i (@$host_seq) {
2267 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2268 unless ($self->is_reachable($url)) {
2269 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2272 $url .= "/" unless substr($url,-1) eq "/";
2274 my($proto,$host,$dir,$getfile);
2276 # Courtesy Mark Conty mark_conty@cargill.com change from
2277 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2279 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2280 # proto not yet used
2281 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2283 next HOSTHARD; # who said, we could ftp anything except ftp?
2286 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2288 for $f ('lynx','ncftpget','ncftp') {
2289 next unless exists $CPAN::Config->{$f};
2290 $funkyftp = $CPAN::Config->{$f};
2291 next unless defined $funkyftp;
2292 next if $funkyftp =~ /^\s*$/;
2293 my($asl_ungz, $asl_gz);
2294 ($asl_ungz = $aslocal) =~ s/\.gz//;
2295 $asl_gz = "$asl_ungz.gz";
2296 my($src_switch) = "";
2298 $src_switch = " -source";
2299 } elsif ($f eq "ncftp"){
2300 $src_switch = " -c";
2303 my($stdout_redir) = " > $asl_ungz";
2304 if ($f eq "ncftpget"){
2305 $chdir = "cd $aslocal_dir && ";
2308 $CPAN::Frontend->myprint(
2310 Trying with "$funkyftp$src_switch" to get
2314 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2315 $self->debug("system[$system]") if $CPAN::DEBUG;
2317 if (($wstatus = system($system)) == 0
2320 -s $asl_ungz # lynx returns 0 on my
2321 # system even if it fails
2327 } elsif ($asl_ungz ne $aslocal) {
2328 # test gzip integrity
2330 CPAN::Tarzip->gtest($asl_ungz)
2332 rename $asl_ungz, $aslocal;
2334 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2339 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2341 -f $asl_ungz && -s _ == 0;
2342 my $gz = "$aslocal.gz";
2343 my $gzurl = "$url.gz";
2344 $CPAN::Frontend->myprint(
2346 Trying with "$funkyftp$src_switch" to get
2349 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2350 $self->debug("system[$system]") if $CPAN::DEBUG;
2352 if (($wstatus = system($system)) == 0
2356 # test gzip integrity
2357 if (CPAN::Tarzip->gtest($asl_gz)) {
2358 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2360 rename $asl_ungz, $aslocal;
2365 unlink $asl_gz if -f $asl_gz;
2368 my $estatus = $wstatus >> 8;
2369 my $size = -f $aslocal ?
2370 ", left\n$aslocal with size ".-s _ :
2371 "\nWarning: expected file [$aslocal] doesn't exist";
2372 $CPAN::Frontend->myprint(qq{
2373 System call "$system"
2374 returned status $estatus (wstat $wstatus)$size
2382 my($self,$host_seq,$file,$aslocal) = @_;
2385 my($aslocal_dir) = File::Basename::dirname($aslocal);
2386 File::Path::mkpath($aslocal_dir);
2387 HOSTHARDEST: for $i (@$host_seq) {
2388 unless (length $CPAN::Config->{'ftp'}) {
2389 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2392 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2393 unless ($self->is_reachable($url)) {
2394 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2397 $url .= "/" unless substr($url,-1) eq "/";
2399 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2400 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2403 my($host,$dir,$getfile) = ($1,$2,$3);
2405 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2406 $ctime,$blksize,$blocks) = stat($aslocal);
2407 $timestamp = $mtime ||= 0;
2408 my($netrc) = CPAN::FTP::netrc->new;
2409 my($netrcfile) = $netrc->netrc;
2410 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2411 my $targetfile = File::Basename::basename($aslocal);
2417 map("cd $_", split "/", $dir), # RFC 1738
2419 "get $getfile $targetfile",
2423 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2424 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2425 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2427 $netrc->contains($host))) if $CPAN::DEBUG;
2428 if ($netrc->protected) {
2429 $CPAN::Frontend->myprint(qq{
2430 Trying with external ftp to get
2432 As this requires some features that are not thoroughly tested, we\'re
2433 not sure, that we get it right....
2437 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2439 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2440 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2442 if ($mtime > $timestamp) {
2443 $CPAN::Frontend->myprint("GOT $aslocal\n");
2447 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2450 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2451 qq{correctly protected.\n});
2454 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2455 nor does it have a default entry\n");
2458 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2459 # then and login manually to host, using e-mail as
2461 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2465 "user anonymous $Config::Config{'cf_email'}"
2467 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2468 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2469 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2471 if ($mtime > $timestamp) {
2472 $CPAN::Frontend->myprint("GOT $aslocal\n");
2476 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2478 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2484 my($self,$command,@dialog) = @_;
2485 my $fh = FileHandle->new;
2486 $fh->open("|$command") or die "Couldn't open ftp: $!";
2487 foreach (@dialog) { $fh->print("$_\n") }
2488 $fh->close; # Wait for process to complete
2490 my $estatus = $wstatus >> 8;
2491 $CPAN::Frontend->myprint(qq{
2492 Subprocess "|$command"
2493 returned status $estatus (wstat $wstatus)
2497 # find2perl needs modularization, too, all the following is stolen
2501 my($self,$name) = @_;
2502 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2503 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2505 my($perms,%user,%group);
2509 $blocks = int(($blocks + 1) / 2);
2512 $blocks = int(($sizemm + 1023) / 1024);
2515 if (-f _) { $perms = '-'; }
2516 elsif (-d _) { $perms = 'd'; }
2517 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2518 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2519 elsif (-p _) { $perms = 'p'; }
2520 elsif (-S _) { $perms = 's'; }
2521 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2523 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2524 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2525 my $tmpmode = $mode;
2526 my $tmp = $rwx[$tmpmode & 7];
2528 $tmp = $rwx[$tmpmode & 7] . $tmp;
2530 $tmp = $rwx[$tmpmode & 7] . $tmp;
2531 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2532 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2533 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2536 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2537 my $group = $group{$gid} || $gid;
2539 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2541 my($moname) = $moname[$mon];
2542 if (-M _ > 365.25 / 2) {
2543 $timeyear = $year + 1900;
2546 $timeyear = sprintf("%02d:%02d", $hour, $min);
2549 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2563 package CPAN::FTP::netrc;
2567 my $file = MM->catfile($ENV{HOME},".netrc");
2569 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2570 $atime,$mtime,$ctime,$blksize,$blocks)
2575 my($fh,@machines,$hasdefault);
2577 $fh = FileHandle->new or die "Could not create a filehandle";
2579 if($fh->open($file)){
2580 $protected = ($mode & 077) == 0;
2582 NETRC: while (<$fh>) {
2583 my(@tokens) = split " ", $_;
2584 TOKEN: while (@tokens) {
2585 my($t) = shift @tokens;
2586 if ($t eq "default"){
2590 last TOKEN if $t eq "macdef";
2591 if ($t eq "machine") {
2592 push @machines, shift @tokens;
2597 $file = $hasdefault = $protected = "";
2601 'mach' => [@machines],
2603 'hasdefault' => $hasdefault,
2604 'protected' => $protected,
2608 sub hasdefault { shift->{'hasdefault'} }
2609 sub netrc { shift->{'netrc'} }
2610 sub protected { shift->{'protected'} }
2612 my($self,$mach) = @_;
2613 for ( @{$self->{'mach'}} ) {
2614 return 1 if $_ eq $mach;
2619 package CPAN::Complete;
2622 my($text, $line, $start, $end) = @_;
2623 my(@perlret) = cpl($text, $line, $start);
2624 # find longest common match. Can anybody show me how to peruse
2625 # T::R::Gnu to have this done automatically? Seems expensive.
2626 return () unless @perlret;
2627 my($newtext) = $text;
2628 for (my $i = length($text)+1;;$i++) {
2629 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2630 my $try = substr($perlret[0],0,$i);
2631 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2632 # warn "try[$try]tries[@tries]";
2633 if (@tries == @perlret) {
2639 ($newtext,@perlret);
2642 #-> sub CPAN::Complete::cpl ;
2644 my($word,$line,$pos) = @_;
2648 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2650 if ($line =~ s/^(force\s*)//) {
2658 ! a b d h i m o q r u autobundle clean
2659 make test install force reload look cvs_import
2662 } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
2664 } elsif ($line =~ /^a\s/) {
2665 @return = cplx('CPAN::Author',$word);
2666 } elsif ($line =~ /^b\s/) {
2667 @return = cplx('CPAN::Bundle',$word);
2668 } elsif ($line =~ /^d\s/) {
2669 @return = cplx('CPAN::Distribution',$word);
2670 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) {
2671 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2672 } elsif ($line =~ /^i\s/) {
2673 @return = cpl_any($word);
2674 } elsif ($line =~ /^reload\s/) {
2675 @return = cpl_reload($word,$line,$pos);
2676 } elsif ($line =~ /^o\s/) {
2677 @return = cpl_option($word,$line,$pos);
2684 #-> sub CPAN::Complete::cplx ;
2686 my($class, $word) = @_;
2687 # I believed for many years that this was sorted, today I
2688 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2689 # make it sorted again. Maybe sort was dropped when GNU-readline
2690 # support came in? The RCS file is difficult to read on that:-(
2691 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2694 #-> sub CPAN::Complete::cpl_any ;
2698 cplx('CPAN::Author',$word),
2699 cplx('CPAN::Bundle',$word),
2700 cplx('CPAN::Distribution',$word),
2701 cplx('CPAN::Module',$word),
2705 #-> sub CPAN::Complete::cpl_reload ;
2707 my($word,$line,$pos) = @_;
2709 my(@words) = split " ", $line;
2710 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2711 my(@ok) = qw(cpan index);
2712 return @ok if @words == 1;
2713 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2716 #-> sub CPAN::Complete::cpl_option ;
2718 my($word,$line,$pos) = @_;
2720 my(@words) = split " ", $line;
2721 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2722 my(@ok) = qw(conf debug);
2723 return @ok if @words == 1;
2724 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2726 } elsif ($words[1] eq 'index') {
2728 } elsif ($words[1] eq 'conf') {
2729 return CPAN::Config::cpl(@_);
2730 } elsif ($words[1] eq 'debug') {
2731 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2735 package CPAN::Index;
2737 #-> sub CPAN::Index::force_reload ;
2740 $CPAN::Index::last_time = 0;
2744 #-> sub CPAN::Index::reload ;
2746 my($cl,$force) = @_;
2749 # XXX check if a newer one is available. (We currently read it
2750 # from time to time)
2751 for ($CPAN::Config->{index_expire}) {
2752 $_ = 0.001 unless $_ && $_ > 0.001;
2754 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2756 ## IFF we are developing, it helps to wipe out the memory between
2757 ## reloads, otherwise it is not what a user expects.
2759 ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2760 ## $CPAN::META = CPAN->new;
2764 my $needshort = $^O eq "dos";
2766 $cl->rd_authindex($cl
2768 "authors/01mailrc.txt.gz",
2770 File::Spec->catfile('authors', '01mailrc.gz') :
2771 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2774 $debug = "timing reading 01[".($t2 - $time)."]";
2776 return if $CPAN::Signal; # this is sometimes lengthy
2777 $cl->rd_modpacks($cl
2779 "modules/02packages.details.txt.gz",
2781 File::Spec->catfile('modules', '02packag.gz') :
2782 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2785 $debug .= "02[".($t2 - $time)."]";
2787 return if $CPAN::Signal; # this is sometimes lengthy
2790 "modules/03modlist.data.gz",
2792 File::Spec->catfile('modules', '03mlist.gz') :
2793 File::Spec->catfile('modules', '03modlist.data.gz'),
2796 $debug .= "03[".($t2 - $time)."]";
2798 CPAN->debug($debug) if $CPAN::DEBUG;
2801 #-> sub CPAN::Index::reload_x ;
2803 my($cl,$wanted,$localname,$force) = @_;
2804 $force |= 2; # means we're dealing with an index here
2805 CPAN::Config->load; # we should guarantee loading wherever we rely
2807 $localname ||= $wanted;
2808 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2812 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2815 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2816 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2817 qq{day$s. I\'ll use that.});
2820 $force |= 1; # means we're quite serious about it.
2822 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2825 #-> sub CPAN::Index::rd_authindex ;
2827 my($cl, $index_target) = @_;
2829 return unless defined $index_target;
2830 $CPAN::Frontend->myprint("Going to read $index_target\n");
2831 # my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2832 # while ($_ = $fh->READLINE) {
2835 tie *FH, CPAN::Tarzip, $index_target;
2837 push @lines, split /\012/ while <FH>;
2839 my($userid,$fullname,$email) =
2840 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2841 next unless $userid && $fullname && $email;
2843 # instantiate an author object
2844 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2845 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2846 return if $CPAN::Signal;
2851 my($self,$dist) = @_;
2852 $dist = $self->{'id'} unless defined $dist;
2853 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2857 #-> sub CPAN::Index::rd_modpacks ;
2859 my($self, $index_target) = @_;
2861 return unless defined $index_target;
2862 $CPAN::Frontend->myprint("Going to read $index_target\n");
2863 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2865 while ($_ = $fh->READLINE) {
2867 my @ls = map {"$_\n"} split /\n/, $_;
2868 unshift @ls, "\n" x length($1) if /^(\n+)/;
2874 my $shift = shift(@lines);
2875 $shift =~ /^Line-Count:\s+(\d+)/;
2876 $line_count = $1 if $1;
2877 last if $shift =~ /^\s*$/;
2879 if (not defined $line_count) {
2881 warn qq{Warning: Your $index_target does not contain a Line-Count header.
2882 Please check the validity of the index file by comparing it to more
2883 than one CPAN mirror. I'll continue but problems seem likely to
2888 } elsif ($line_count != scalar @lines) {
2890 warn sprintf qq{Warning: Your %s
2891 contains a Line-Count header of %d but I see %d lines there. Please
2892 check the validity of the index file by comparing it to more than one
2893 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
2894 $index_target, $line_count, scalar(@lines);
2899 # before 1.56 we split into 3 and discarded the rest. From
2900 # 1.57 we assign remaining text to $comment thus allowing to
2901 # influence isa_perl
2902 my($mod,$version,$dist,$comment) = split " ", $_, 4;
2903 ### $version =~ s/^\+//;
2905 # if it is a bundle, instantiate a bundle object
2906 my($bundle,$id,$userid);
2908 if ($mod eq 'CPAN' &&
2910 CPAN::Queue->exists('Bundle::CPAN') ||
2911 CPAN::Queue->exists('CPAN')
2915 if ($version > $CPAN::VERSION){
2916 $CPAN::Frontend->myprint(qq{
2917 There\'s a new CPAN.pm version (v$version) available!
2918 [Current version is v$CPAN::VERSION]
2919 You might want to try
2920 install Bundle::CPAN
2922 without quitting the current session. It should be a seamless upgrade
2923 while we are running...
2926 $CPAN::Frontend->myprint(qq{\n});
2928 last if $CPAN::Signal;
2929 } elsif ($mod =~ /^Bundle::(.*)/) {
2934 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2935 # warn "made mod[$mod]a bundle";
2936 # Let's make it a module too, because bundles have so much
2937 # in common with modules
2938 $CPAN::META->instance('CPAN::Module',$mod);
2939 # warn "made mod[$mod]a module";
2941 # This "next" makes us faster but if the job is running long, we ignore
2942 # rereads which is bad. So we have to be a bit slower again.
2943 # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2948 # instantiate a module object
2949 $id = $CPAN::META->instance('CPAN::Module',$mod);
2952 if ($id->cpan_file ne $dist){
2953 $userid = $self->userid($dist);
2955 'CPAN_USERID' => $userid,
2956 'CPAN_VERSION' => $version, # %vd
2957 'CPAN_FILE' => $dist,
2958 'CPAN_COMMENT' => $comment,
2962 # instantiate a distribution object
2963 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2964 # we do not need CONTAINSMODS unless we do something with
2965 # this dist, so we better produce it on demand.
2967 ## my $obj = $CPAN::META->instance(
2968 ## 'CPAN::Distribution' => $dist
2970 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
2972 $CPAN::META->instance(
2973 'CPAN::Distribution' => $dist
2975 'CPAN_USERID' => $userid
2979 return if $CPAN::Signal;
2984 #-> sub CPAN::Index::rd_modlist ;
2986 my($cl,$index_target) = @_;
2987 return unless defined $index_target;
2988 $CPAN::Frontend->myprint("Going to read $index_target\n");
2989 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2992 while ($_ = $fh->READLINE) {
2994 my @ls = map {"$_\n"} split /\n/, $_;
2995 unshift @ls, "\n" x length($1) if /^(\n+)/;
2999 my $shift = shift(@eval);
3000 if ($shift =~ /^Date:\s+(.*)/){
3001 return if $date_of_03 eq $1;
3004 last if $shift =~ /^\s*$/;
3007 push @eval, q{CPAN::Modulelist->data;};
3009 my($comp) = Safe->new("CPAN::Safe1");
3010 my($eval) = join("", @eval);
3011 my $ret = $comp->reval($eval);
3012 Carp::confess($@) if $@;
3013 return if $CPAN::Signal;
3015 my $obj = $CPAN::META->instance(CPAN::Module,$_);
3016 $obj->set(%{$ret->{$_}});
3017 return if $CPAN::Signal;
3021 package CPAN::InfoObj;
3023 #-> sub CPAN::InfoObj::new ;
3024 sub new { my $this = bless {}, shift; %$this = @_; $this }
3026 #-> sub CPAN::InfoObj::set ;
3028 my($self,%att) = @_;
3029 my(%oldatt) = %$self;
3030 %$self = (%oldatt, %att);
3033 #-> sub CPAN::InfoObj::id ;
3034 sub id { shift->{'ID'} }
3036 #-> sub CPAN::InfoObj::as_glimpse ;
3040 my $class = ref($self);
3041 $class =~ s/^CPAN:://;
3042 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3046 #-> sub CPAN::InfoObj::as_string ;
3050 my $class = ref($self);
3051 $class =~ s/^CPAN:://;
3052 push @m, $class, " id = $self->{ID}\n";
3053 for (sort keys %$self) {
3056 if ($_ eq "CPAN_USERID") {
3057 $extra .= " (".$self->author;
3058 my $email; # old perls!
3059 if ($email = $CPAN::META->instance(CPAN::Author,
3062 $extra .= " <$email>";
3064 $extra .= " <no email>";
3068 if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
3069 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
3070 } elsif (ref($self->{$_}) eq "HASH") {
3074 join(" ",keys %{$self->{$_}}),
3077 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
3083 #-> sub CPAN::InfoObj::author ;
3086 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
3091 require Data::Dumper;
3092 Data::Dumper::Dumper($self);
3095 package CPAN::Author;
3097 #-> sub CPAN::Author::as_glimpse ;
3101 my $class = ref($self);
3102 $class =~ s/^CPAN:://;
3103 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3107 # Dead code, I would have liked to have,,, but it was never reached,,,
3110 # return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
3113 #-> sub CPAN::Author::fullname ;
3114 sub fullname { shift->{'FULLNAME'} }
3117 #-> sub CPAN::Author::email ;
3118 sub email { shift->{'EMAIL'} }
3120 package CPAN::Distribution;
3122 #-> sub CPAN::Distribution::as_string ;
3125 $self->containsmods;
3126 $self->SUPER::as_string(@_);
3129 #-> sub CPAN::Distribution::containsmods ;
3132 return if exists $self->{CONTAINSMODS};
3133 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3134 my $mod_file = $mod->{CPAN_FILE} or next;
3135 my $dist_id = $self->{ID} or next;
3136 my $mod_id = $mod->{ID} or next;
3137 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3141 #-> sub CPAN::Distribution::called_for ;
3144 $self->{'CALLED_FOR'} = $id if defined $id;
3145 return $self->{'CALLED_FOR'};
3148 #-> sub CPAN::Distribution::get ;
3153 exists $self->{'build_dir'} and push @e,
3154 "Unwrapped into directory $self->{'build_dir'}";
3155 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3160 $CPAN::Config->{keep_source_where},
3163 split("/",$self->{ID})
3166 $self->debug("Doing localize") if $CPAN::DEBUG;
3168 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3169 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
3170 $self->{localfile} = $local_file;
3171 my $builddir = $CPAN::META->{cachemgr}->dir;
3172 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3173 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3176 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3177 if ($CPAN::META->has_inst('MD5')) {
3178 $self->debug("MD5 is installed, verifying");
3181 $self->debug("MD5 is NOT installed");
3183 $self->debug("Removing tmp") if $CPAN::DEBUG;
3184 File::Path::rmtree("tmp");
3185 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3186 chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
3187 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
3188 if (! $local_file) {
3189 Carp::croak "bad download, can't do anything :-(\n";
3190 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3191 $self->untar_me($local_file);
3192 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3193 $self->unzip_me($local_file);
3194 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3195 $self->pm2dir_me($local_file);
3197 $self->{archived} = "NO";
3199 my $cwd = File::Spec->updir;
3200 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
3201 if ($self->{archived} ne 'NO') {
3202 $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
3203 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3204 # Let's check if the package has its own directory.
3205 my $dh = DirHandle->new(File::Spec->curdir)
3206 or Carp::croak("Couldn't opendir .: $!");
3207 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3209 my ($distdir,$packagedir);
3210 if (@readdir == 1 && -d $readdir[0]) {
3211 $distdir = $readdir[0];
3212 $packagedir = MM->catdir($builddir,$distdir);
3213 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
3214 File::Path::rmtree($packagedir);
3215 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3217 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
3218 $pragmatic_dir =~ s/\W_//g;
3219 $pragmatic_dir++ while -d "../$pragmatic_dir";
3220 $packagedir = MM->catdir($builddir,$pragmatic_dir);
3221 File::Path::mkpath($packagedir);
3223 for $f (@readdir) { # is already without "." and ".."
3224 my $to = MM->catdir($packagedir,$f);
3225 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3228 $self->{'build_dir'} = $packagedir;
3229 $cwd = File::Spec->updir;
3230 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3232 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
3234 File::Path::rmtree("tmp");
3235 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
3236 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
3237 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3239 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
3240 unless (-f $makefilepl) {
3241 my($configure) = MM->catfile($packagedir,"Configure");
3242 if (-f $configure) {
3243 # do we have anything to do?
3244 $self->{'configure'} = $configure;
3245 } elsif (-f MM->catfile($packagedir,"Makefile")) {
3246 $CPAN::Frontend->myprint(qq{
3247 Package comes with a Makefile and without a Makefile.PL.
3248 We\'ll try to build it with that Makefile then.
3250 $self->{writemakefile} = "YES";
3253 my $fh = FileHandle->new(">$makefilepl")
3254 or Carp::croak("Could not open >$makefilepl");
3255 my $cf = $self->called_for || "unknown";
3257 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3258 # because there was no Makefile.PL supplied.
3259 # Autogenerated on: }.scalar localtime().qq{
3261 use ExtUtils::MakeMaker;
3262 WriteMakefile(NAME => q[$cf]);
3265 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
3266 Writing one on our own (calling it $cf)\n});
3274 my($self,$local_file) = @_;
3275 $self->{archived} = "tar";
3276 if (CPAN::Tarzip->untar($local_file)) {
3277 $self->{unwrapped} = "YES";
3279 $self->{unwrapped} = "NO";
3284 my($self,$local_file) = @_;
3285 $self->{archived} = "zip";
3286 if ($CPAN::META->has_inst("Archive::Zip")) {
3287 if (CPAN::Tarzip->unzip($local_file)) {
3288 $self->{unwrapped} = "YES";
3290 $self->{unwrapped} = "NO";
3294 my $unzip = $CPAN::Config->{unzip} or
3295 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
3296 my @system = ($unzip, $local_file);
3297 if (system(@system) == 0) {
3298 $self->{unwrapped} = "YES";
3300 $self->{unwrapped} = "NO";
3305 my($self,$local_file) = @_;
3306 $self->{archived} = "pm";
3307 my $to = File::Basename::basename($local_file);
3308 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3309 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3310 $self->{unwrapped} = "YES";
3312 $self->{unwrapped} = "NO";
3316 #-> sub CPAN::Distribution::new ;
3318 my($class,%att) = @_;
3320 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3322 my $this = { %att };
3323 return bless $this, $class;
3326 #-> sub CPAN::Distribution::look ;
3330 if ($^O eq 'MacOS') {
3331 $self->ExtUtils::MM_MacOS::look;
3335 if ( $CPAN::Config->{'shell'} ) {
3336 $CPAN::Frontend->myprint(qq{
3337 Trying to open a subshell in the build directory...
3340 $CPAN::Frontend->myprint(qq{
3341 Your configuration does not define a value for subshells.
3342 Please define it with "o conf shell <your shell>"
3346 my $dist = $self->id;
3347 my $dir = $self->dir or $self->get;
3350 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3351 my $pwd = CPAN->$getcwd();
3352 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3353 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3354 system($CPAN::Config->{'shell'}) == 0
3355 or $CPAN::Frontend->mydie("Subprocess shell error");
3356 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3362 my $dir = $self->dir;
3364 my $package = $self->called_for;
3365 my $module = $CPAN::META->instance('CPAN::Module', $package);
3366 my $version = $module->cpan_version; # %vd
3368 my $userid = $self->{CPAN_USERID};
3370 my $cvs_dir = (split '/', $dir)[-1];
3371 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
3373 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3375 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3376 if ($cvs_site_perl) {
3377 $cvs_dir = "$cvs_site_perl/$cvs_dir";
3379 my $cvs_log = qq{"imported $package $version sources"};
3380 $version =~ s/\./_/g;
3381 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3382 "$cvs_dir", $userid, "v$version");
3385 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3386 my $pwd = CPAN->$getcwd();
3387 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3389 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3391 $CPAN::Frontend->myprint(qq{@cmd\n});
3392 system(@cmd) == 0 or
3393 $CPAN::Frontend->mydie("cvs import failed");
3394 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3397 #-> sub CPAN::Distribution::readme ;
3400 my($dist) = $self->id;
3401 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3402 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3406 $CPAN::Config->{keep_source_where},
3409 split("/","$sans.readme"),
3411 $self->debug("Doing localize") if $CPAN::DEBUG;
3412 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3414 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3416 if ($^O eq 'MacOS') {
3417 ExtUtils::MM_MacOS::launch_file($local_file);
3421 my $fh_pager = FileHandle->new;
3422 local($SIG{PIPE}) = "IGNORE";
3423 $fh_pager->open("|$CPAN::Config->{'pager'}")
3424 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3425 my $fh_readme = FileHandle->new;
3426 $fh_readme->open($local_file)
3427 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3428 $CPAN::Frontend->myprint(qq{
3431 with pager "$CPAN::Config->{'pager'}"
3434 $fh_pager->print(<$fh_readme>);
3437 #-> sub CPAN::Distribution::verifyMD5 ;
3442 $self->{MD5_STATUS} ||= "";
3443 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3444 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3446 my($lc_want,$lc_file,@local,$basename);
3447 @local = split("/",$self->{ID});
3449 push @local, "CHECKSUMS";
3451 MM->catfile($CPAN::Config->{keep_source_where},
3452 "authors", "id", @local);
3457 $self->MD5_check_file($lc_want)
3459 return $self->{MD5_STATUS} = "OK";
3461 $lc_file = CPAN::FTP->localize("authors/id/@local",
3464 $local[-1] .= ".gz";
3465 $lc_file = CPAN::FTP->localize("authors/id/@local",
3468 $lc_file =~ s/\.gz(?!\n)\Z//;
3469 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3474 $self->MD5_check_file($lc_file);
3477 #-> sub CPAN::Distribution::MD5_check_file ;
3478 sub MD5_check_file {
3479 my($self,$chk_file) = @_;
3480 my($cksum,$file,$basename);
3481 $file = $self->{localfile};
3482 $basename = File::Basename::basename($file);
3483 my $fh = FileHandle->new;
3484 if (open $fh, $chk_file){
3487 $eval =~ s/\015?\012/\n/g;
3489 my($comp) = Safe->new();
3490 $cksum = $comp->reval($eval);
3492 rename $chk_file, "$chk_file.bad";
3493 Carp::confess($@) if $@;
3496 Carp::carp "Could not open $chk_file for reading";
3499 if (exists $cksum->{$basename}{md5}) {
3500 $self->debug("Found checksum for $basename:" .
3501 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3505 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3507 $fh = CPAN::Tarzip->TIEHANDLE($file);
3510 # had to inline it, when I tied it, the tiedness got lost on
3511 # the call to eq_MD5. (Jan 1998)
3515 while ($fh->READ($ref, 4096) > 0){
3518 my $hexdigest = $md5->hexdigest;
3519 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3523 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3524 return $self->{MD5_STATUS} = "OK";
3526 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
3527 qq{distribution file. }.
3528 qq{Please investigate.\n\n}.
3530 $CPAN::META->instance(
3532 $self->{CPAN_USERID}
3535 my $wrap = qq{I\'d recommend removing $file. Its MD5
3536 checksum is incorrect. Maybe you have configured your \`urllist\' with
3537 a bad URL. Please check this array with \`o conf urllist\', and
3540 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3541 $CPAN::Frontend->myprint("\n\n");
3545 # close $fh if fileno($fh);
3547 $self->{MD5_STATUS} ||= "";
3548 if ($self->{MD5_STATUS} eq "NIL") {
3549 $CPAN::Frontend->myprint(qq{
3550 No md5 checksum for $basename in local $chk_file.
3553 unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
3556 $self->{MD5_STATUS} = "NIL";
3561 #-> sub CPAN::Distribution::eq_MD5 ;
3563 my($self,$fh,$expectMD5) = @_;
3566 while (read($fh, $data, 4096)){
3569 # $md5->addfile($fh);
3570 my $hexdigest = $md5->hexdigest;
3571 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3572 $hexdigest eq $expectMD5;
3575 #-> sub CPAN::Distribution::force ;
3578 $self->{'force_update'}++;
3580 MD5_STATUS archived build_dir localfile make install unwrapped
3583 delete $self->{$att};
3587 #-> sub CPAN::Distribution::isa_perl ;
3590 my $file = File::Basename::basename($self->id);
3591 if ($file =~ m{ ^ perl
3604 } elsif ($self->{'CPAN_COMMENT'} && $self->{'CPAN_COMMENT'} =~ /isa_perl\(.+?\)/){
3609 #-> sub CPAN::Distribution::perl ;
3612 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3613 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3614 my $pwd = CPAN->$getcwd();
3615 my $candidate = MM->catfile($pwd,$^X);
3616 $perl ||= $candidate if MM->maybe_command($candidate);
3618 my ($component,$perl_name);
3619 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3620 PATH_COMPONENT: foreach $component (MM->path(),
3621 $Config::Config{'binexp'}) {
3622 next unless defined($component) && $component;
3623 my($abs) = MM->catfile($component,$perl_name);
3624 if (MM->maybe_command($abs)) {
3634 #-> sub CPAN::Distribution::make ;
3637 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3638 # Emergency brake if they said install Pippi and get newest perl
3639 if ($self->isa_perl) {
3641 $self->called_for ne $self->id && ! $self->{'force_update'}
3643 # if we die here, we break bundles
3644 $CPAN::Frontend->mywarn(sprintf qq{
3645 The most recent version "%s" of the module "%s"
3646 comes with the current version of perl (%s).
3647 I\'ll build that only if you ask for something like
3652 $CPAN::META->instance(
3655 )->cpan_version, # %vd
3666 $self->{archived} eq "NO" and push @e,
3667 "Is neither a tar nor a zip archive.";
3669 $self->{unwrapped} eq "NO" and push @e,
3670 "had problems unarchiving. Please build manually";
3672 exists $self->{writemakefile} &&
3673 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3674 $1 || "Had some problem writing Makefile";
3676 defined $self->{'make'} and push @e,
3677 "Has already been processed within this session";
3679 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3681 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
3682 my $builddir = $self->dir;
3683 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3684 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3686 if ($^O eq 'MacOS') {
3687 ExtUtils::MM_MacOS::make($self);
3692 if ($self->{'configure'}) {
3693 $system = $self->{'configure'};
3695 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3697 # This needs a handler that can be turned on or off:
3698 # $switch = "-MExtUtils::MakeMaker ".
3699 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3701 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3703 unless (exists $self->{writemakefile}) {
3704 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3707 if ($CPAN::Config->{inactivity_timeout}) {
3709 alarm $CPAN::Config->{inactivity_timeout};
3710 local $SIG{CHLD}; # = sub { wait };
3711 if (defined($pid = fork)) {
3716 # note, this exec isn't necessary if
3717 # inactivity_timeout is 0. On the Mac I'd
3718 # suggest, we set it always to 0.
3722 $CPAN::Frontend->myprint("Cannot fork: $!");
3730 $CPAN::Frontend->myprint($@);
3731 $self->{writemakefile} = "NO $@";
3736 $ret = system($system);
3738 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
3742 if (-f "Makefile") {
3743 $self->{writemakefile} = "YES";
3745 $self->{writemakefile} =
3746 qq{NO Makefile.PL refused to write a Makefile.};
3747 # It's probably worth to record the reason, so let's retry
3749 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
3750 # $self->{writemakefile} .= <$fh>;
3753 return if $CPAN::Signal;
3754 if (my @prereq = $self->needs_prereq){
3756 $CPAN::Frontend->myprint("---- Dependencies detected ".
3757 "during [$id] -----\n");
3759 for my $p (@prereq) {
3760 $CPAN::Frontend->myprint(" $p\n");
3763 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3765 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3766 require ExtUtils::MakeMaker;
3767 my $answer = ExtUtils::MakeMaker::prompt(
3768 "Shall I follow them and prepend them to the queue
3769 of modules we are processing right now?", "yes");
3770 $follow = $answer =~ /^\s*y/i;
3774 myprint(" Ignoring dependencies on modules @prereq\n");
3777 CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3781 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3782 if (system($system) == 0) {
3783 $CPAN::Frontend->myprint(" $system -- OK\n");
3784 $self->{'make'} = "YES";
3786 $self->{writemakefile} ||= "YES";
3787 $self->{'make'} = "NO";
3788 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3792 #-> sub CPAN::Distribution::needs_prereq ;
3795 return unless -f "Makefile"; # we cannot say much
3796 my $fh = FileHandle->new("<Makefile") or
3797 $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3800 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
3804 last if /MakeMaker post_initialize section/;
3806 \s+PREREQ_PM\s+=>\s+(.+)
3809 # warn "Found prereq expr[$p]";
3811 # Regexp modified by A.Speer to remember actual version of file
3812 # PREREQ_PM hash key wants, then add to
3813 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
3814 # In case a prereq is mentioned twice, complain.
3815 if ( defined $p{$1} ) {
3816 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
3822 NEED: while (my($module, $need_version) = each %p) {
3823 my $mo = $CPAN::META->instance("CPAN::Module",$module);
3824 # we were too demanding:
3825 # next if $mo->uptodate;
3827 # We only want to install prereqs if either they're not installed
3828 # or if the installed version is too old. We cannot omit this
3829 # check, because if 'force' is in effect, nobody else will check.
3832 if (defined $mo->inst_file &&
3833 $mo->inst_version >= $need_version){ # %vd
3834 CPAN->debug(sprintf "inst_file[%s]inst_version[%s]need_version[%s]",
3835 $mo->inst_file, $mo->inst_version, $need_version
3841 if ($self->{have_sponsored}{$module}++){
3842 # We have already sponsored it and for some reason it's still
3843 # not available. So we do nothing. Or what should we do?
3844 # if we push it again, we have a potential infinite loop
3847 push @need, $module;
3852 #-> sub CPAN::Distribution::test ;
3856 return if $CPAN::Signal;
3857 $CPAN::Frontend->myprint("Running make test\n");
3860 exists $self->{'make'} or push @e,
3861 "Make had some problems, maybe interrupted? Won't test";
3863 exists $self->{'make'} and
3864 $self->{'make'} eq 'NO' and
3865 push @e, "Oops, make had returned bad status";
3867 exists $self->{'build_dir'} or push @e, "Has no own directory";
3868 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3870 chdir $self->{'build_dir'} or
3871 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3872 $self->debug("Changed directory to $self->{'build_dir'}")
3875 if ($^O eq 'MacOS') {
3876 ExtUtils::MM_MacOS::make_test($self);
3880 my $system = join " ", $CPAN::Config->{'make'}, "test";
3881 if (system($system) == 0) {
3882 $CPAN::Frontend->myprint(" $system -- OK\n");
3883 $self->{'make_test'} = "YES";
3885 $self->{'make_test'} = "NO";
3886 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3890 #-> sub CPAN::Distribution::clean ;
3893 $CPAN::Frontend->myprint("Running make clean\n");
3896 exists $self->{'build_dir'} or push @e, "Has no own directory";
3897 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3899 chdir $self->{'build_dir'} or
3900 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3901 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3903 if ($^O eq 'MacOS') {
3904 ExtUtils::MM_MacOS::make_clean($self);
3908 my $system = join " ", $CPAN::Config->{'make'}, "clean";
3909 if (system($system) == 0) {
3910 $CPAN::Frontend->myprint(" $system -- OK\n");
3913 # Hmmm, what to do if make clean failed?
3917 #-> sub CPAN::Distribution::install ;
3921 return if $CPAN::Signal;
3922 $CPAN::Frontend->myprint("Running make install\n");
3925 exists $self->{'build_dir'} or push @e, "Has no own directory";
3927 exists $self->{'make'} or push @e,
3928 "Make had some problems, maybe interrupted? Won't install";
3930 exists $self->{'make'} and
3931 $self->{'make'} eq 'NO' and
3932 push @e, "Oops, make had returned bad status";
3934 push @e, "make test had returned bad status, ".
3935 "won't install without force"
3936 if exists $self->{'make_test'} and
3937 $self->{'make_test'} eq 'NO' and
3938 ! $self->{'force_update'};
3940 exists $self->{'install'} and push @e,
3941 $self->{'install'} eq "YES" ?
3942 "Already done" : "Already tried without success";
3944 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3946 chdir $self->{'build_dir'} or
3947 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3948 $self->debug("Changed directory to $self->{'build_dir'}")
3951 if ($^O eq 'MacOS') {
3952 ExtUtils::MM_MacOS::make_install($self);
3956 my $system = join(" ", $CPAN::Config->{'make'},
3957 "install", $CPAN::Config->{make_install_arg});
3958 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
3959 my($pipe) = FileHandle->new("$system $stderr |");
3962 $CPAN::Frontend->myprint($_);
3967 $CPAN::Frontend->myprint(" $system -- OK\n");
3968 return $self->{'install'} = "YES";
3970 $self->{'install'} = "NO";
3971 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3972 if ($makeout =~ /permission/s && $> > 0) {
3973 $CPAN::Frontend->myprint(qq{ You may have to su }.
3974 qq{to root to install the package\n});
3979 #-> sub CPAN::Distribution::dir ;
3981 shift->{'build_dir'};
3984 package CPAN::Bundle;
3986 #-> sub CPAN::Bundle::as_string ;
3990 $self->{INST_VERSION} ||= $self->inst_version; # %vd
3991 return $self->SUPER::as_string;
3994 #-> sub CPAN::Bundle::contains ;
3997 my($parsefile) = $self->inst_file;
3998 my($id) = $self->id;
3999 $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
4000 unless ($parsefile) {
4001 # Try to get at it in the cpan directory
4002 $self->debug("no parsefile") if $CPAN::DEBUG;
4003 Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
4004 my $dist = $CPAN::META->instance('CPAN::Distribution',
4005 $self->{CPAN_FILE});
4007 $self->debug($dist->as_string) if $CPAN::DEBUG;
4008 my($todir) = $CPAN::Config->{'cpan_home'};
4009 my(@me,$from,$to,$me);
4010 @me = split /::/, $self->id;
4012 $me = MM->catfile(@me);
4013 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4014 $to = MM->catfile($todir,$me);
4015 File::Path::mkpath(File::Basename::dirname($to));
4016 File::Copy::copy($from, $to)
4017 or Carp::confess("Couldn't copy $from to $to: $!");
4021 my $fh = FileHandle->new;
4023 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
4025 $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
4027 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4028 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4029 next unless $in_cont;
4034 push @result, (split " ", $_, 2)[0];
4037 delete $self->{STATUS};
4038 $self->{CONTAINS} = join ", ", @result;
4039 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4041 $CPAN::Frontend->mywarn(qq{
4042 The bundle file "$parsefile" may be a broken
4043 bundlefile. It seems not to contain any bundle definition.
4044 Please check the file and if it is bogus, please delete it.
4045 Sorry for the inconvenience.
4051 #-> sub CPAN::Bundle::find_bundle_file
4052 sub find_bundle_file {
4053 my($self,$where,$what) = @_;
4054 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4055 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4056 ### my $bu = MM->catfile($where,$what);
4057 ### return $bu if -f $bu;
4058 my $manifest = MM->catfile($where,"MANIFEST");
4059 unless (-f $manifest) {
4060 require ExtUtils::Manifest;
4061 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
4062 my $cwd = CPAN->$getcwd();
4063 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4064 ExtUtils::Manifest::mkmanifest();
4065 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4067 my $fh = FileHandle->new($manifest)
4068 or Carp::croak("Couldn't open $manifest: $!");
4071 if ($^O eq 'MacOS') {
4074 $what2 =~ s/:Bundle://;
4077 $what2 =~ s|Bundle[/\\]||;
4082 my($file) = /(\S+)/;
4083 if ($file =~ m|\Q$what\E$|) {
4085 # return MM->catfile($where,$bu); # bad
4088 # retry if she managed to
4089 # have no Bundle directory
4090 $bu = $file if $file =~ m|\Q$what2\E$|;
4092 $bu =~ tr|/|:| if $^O eq 'MacOS';
4093 return MM->catfile($where, $bu) if $bu;
4094 Carp::croak("Couldn't find a Bundle file in $where");
4097 #-> sub CPAN::Bundle::inst_file ;
4101 ($me = $self->id) =~ s/.*://;
4102 ## my(@me,$inst_file);
4103 ## @me = split /::/, $self->id;
4104 ## $me[-1] .= ".pm";
4105 $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
4106 "Bundle", "$me.pm");
4108 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4110 $self->SUPER::inst_file;
4111 # return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4112 # return $self->{'INST_FILE'}; # even if undefined?
4115 #-> sub CPAN::Bundle::rematein ;
4117 my($self,$meth) = @_;
4118 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4119 my($id) = $self->id;
4120 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4121 unless $self->inst_file || $self->{CPAN_FILE};
4123 for $s ($self->contains) {
4124 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4125 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4126 if ($type eq 'CPAN::Distribution') {
4127 $CPAN::Frontend->mywarn(qq{
4128 The Bundle }.$self->id.qq{ contains
4129 explicitly a file $s.
4133 # possibly noisy action:
4134 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4135 my $obj = $CPAN::META->instance($type,$s);
4137 if ($obj->isa(CPAN::Bundle)
4139 exists $obj->{install_failed}
4141 ref($obj->{install_failed}) eq "HASH"
4143 for (keys %{$obj->{install_failed}}) {
4144 $self->{install_failed}{$_} = undef; # propagate faiure up
4147 $fail{$s} = 1; # the bundle itself may have succeeded but
4152 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4153 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4155 delete $self->{install_failed}{$s};
4162 # recap with less noise
4163 if ( $meth eq "install" ) {
4166 my $raw = sprintf(qq{Bundle summary:
4167 The following items in bundle %s had installation problems:},
4170 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4171 $CPAN::Frontend->myprint("\n");
4174 for $s ($self->contains) {
4176 $paragraph .= "$s ";
4177 $self->{install_failed}{$s} = undef;
4178 $reported{$s} = undef;
4181 my $report_propagated;
4182 for $s (sort keys %{$self->{install_failed}}) {
4183 next if exists $reported{$s};
4184 $paragraph .= "and the following items had problems
4185 during recursive bundle calls: " unless $report_propagated++;
4186 $paragraph .= "$s ";
4188 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
4189 $CPAN::Frontend->myprint("\n");
4191 $self->{'install'} = 'YES';
4196 #sub CPAN::Bundle::xs_file
4198 # If a bundle contains another that contains an xs_file we have
4199 # here, we just don't bother I suppose
4203 #-> sub CPAN::Bundle::force ;
4204 sub force { shift->rematein('force',@_); }
4205 #-> sub CPAN::Bundle::get ;
4206 sub get { shift->rematein('get',@_); }
4207 #-> sub CPAN::Bundle::make ;
4208 sub make { shift->rematein('make',@_); }
4209 #-> sub CPAN::Bundle::test ;
4210 sub test { shift->rematein('test',@_); }
4211 #-> sub CPAN::Bundle::install ;
4214 $self->rematein('install',@_);
4216 #-> sub CPAN::Bundle::clean ;
4217 sub clean { shift->rematein('clean',@_); }
4219 #-> sub CPAN::Bundle::readme ;
4222 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
4223 No File found for bundle } . $self->id . qq{\n}), return;
4224 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
4225 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
4228 package CPAN::Module;
4230 #-> sub CPAN::Module::as_glimpse ;
4234 my $class = ref($self);
4235 $class =~ s/^CPAN:://;
4236 push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
4241 #-> sub CPAN::Module::as_string ;
4245 CPAN->debug($self) if $CPAN::DEBUG;
4246 my $class = ref($self);
4247 $class =~ s/^CPAN:://;
4249 push @m, $class, " id = $self->{ID}\n";
4250 my $sprintf = " %-12s %s\n";
4251 push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
4252 if $self->{description};
4253 my $sprintf2 = " %-12s %s (%s)\n";
4255 if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
4257 if ($author = CPAN::Shell->expand('Author',$userid)) {
4260 if ($m = $author->email) {
4267 $author->fullname . $email
4271 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) # %vd
4272 if $self->{CPAN_VERSION}; # %vd
4273 push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
4274 if $self->{CPAN_FILE};
4275 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
4276 my(%statd,%stats,%statl,%stati);
4277 @statd{qw,? i c a b R M S,} = qw,unknown idea
4278 pre-alpha alpha beta released mature standard,;
4279 @stats{qw,? m d u n,} = qw,unknown mailing-list
4280 developer comp.lang.perl.* none,;
4281 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
4282 @stati{qw,? f r O h,} = qw,unknown functions
4283 references+ties object-oriented hybrid,;
4284 $statd{' '} = 'unknown';
4285 $stats{' '} = 'unknown';
4286 $statl{' '} = 'unknown';
4287 $stati{' '} = 'unknown';
4295 $statd{$self->{statd}},
4296 $stats{$self->{stats}},
4297 $statl{$self->{statl}},
4298 $stati{$self->{stati}}
4299 ) if $self->{statd};
4300 my $local_file = $self->inst_file;
4302 $self->{MANPAGE} ||= $self->manpage_headline($local_file);
4305 for $item (qw/MANPAGE CONTAINS/) {
4306 push @m, sprintf($sprintf, $item, $self->{$item})
4307 if exists $self->{$item};
4309 push @m, sprintf($sprintf, 'INST_FILE',
4310 $local_file || "(not installed)");
4311 push @m, sprintf($sprintf, 'INST_VERSION',
4312 $self->inst_version) if $local_file; #%vd
4316 sub manpage_headline {
4317 my($self,$local_file) = @_;
4318 my(@local_file) = $local_file;
4319 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
4320 push @local_file, $local_file;
4322 for $locf (@local_file) {
4323 next unless -f $locf;
4324 my $fh = FileHandle->new($locf)
4325 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
4329 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
4330 m/^=head1\s+NAME/ ? 1 : $inpod;
4343 #-> sub CPAN::Module::cpan_file ;
4346 CPAN->debug($self->id) if $CPAN::DEBUG;
4347 unless (defined $self->{'CPAN_FILE'}) {
4348 CPAN::Index->reload;
4350 if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
4351 return $self->{'CPAN_FILE'};
4352 } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
4353 my $fullname = $CPAN::META->instance(CPAN::Author,
4354 $self->{'userid'})->fullname;
4355 my $email = $CPAN::META->instance(CPAN::Author,
4356 $self->{'userid'})->email;
4357 unless (defined $fullname && defined $email) {
4358 return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
4360 return "Contact Author $fullname <$email>";
4366 *name = \&cpan_file;
4368 #-> sub CPAN::Module::cpan_version ;
4371 $self->{'CPAN_VERSION'} = 'undef'
4372 unless defined $self->{'CPAN_VERSION'}; # I believe this is
4373 # always a bug in the
4374 # index and should be
4376 # but usually I find
4378 # and do not want to
4381 $self->{'CPAN_VERSION'}; # %vd
4384 #-> sub CPAN::Module::force ;
4387 $self->{'force_update'}++;
4390 #-> sub CPAN::Module::rematein ;
4392 my($self,$meth) = @_;
4393 $self->debug($self->id) if $CPAN::DEBUG;
4394 my $cpan_file = $self->cpan_file;
4395 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
4396 $CPAN::Frontend->mywarn(sprintf qq{
4397 The module %s isn\'t available on CPAN.
4399 Either the module has not yet been uploaded to CPAN, or it is
4400 temporary unavailable. Please contact the author to find out
4401 more about the status. Try ``i %s''.
4408 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
4409 $pack->called_for($self->id);
4410 $pack->force if exists $self->{'force_update'};
4412 delete $self->{'force_update'};
4415 #-> sub CPAN::Module::readme ;
4416 sub readme { shift->rematein('readme') }
4417 #-> sub CPAN::Module::look ;
4418 sub look { shift->rematein('look') }
4419 #-> sub CPAN::Module::cvs_import ;
4420 sub cvs_import { shift->rematein('cvs_import') }
4421 #-> sub CPAN::Module::get ;
4422 sub get { shift->rematein('get',@_); }
4423 #-> sub CPAN::Module::make ;
4424 sub make { shift->rematein('make') }
4425 #-> sub CPAN::Module::test ;
4426 sub test { shift->rematein('test') }
4427 #-> sub CPAN::Module::uptodate ;
4430 my($latest) = $self->cpan_version; # %vd
4432 my($inst_file) = $self->inst_file;
4434 if (defined $inst_file) {
4435 $have = $self->inst_version; # %vd?
4440 $have >= $latest # %vd
4446 #-> sub CPAN::Module::install ;
4452 not exists $self->{'force_update'}
4454 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
4458 $self->rematein('install') if $doit;
4460 #-> sub CPAN::Module::clean ;
4461 sub clean { shift->rematein('clean') }
4463 #-> sub CPAN::Module::inst_file ;
4467 @packpath = split /::/, $self->{ID};
4468 $packpath[-1] .= ".pm";
4469 foreach $dir (@INC) {
4470 my $pmfile = MM->catfile($dir,@packpath);
4478 #-> sub CPAN::Module::xs_file ;
4482 @packpath = split /::/, $self->{ID};
4483 push @packpath, $packpath[-1];
4484 $packpath[-1] .= "." . $Config::Config{'dlext'};
4485 foreach $dir (@INC) {
4486 my $xsfile = MM->catfile($dir,'auto',@packpath);
4494 #-> sub CPAN::Module::inst_version ;
4497 my $parsefile = $self->inst_file or return;
4498 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4501 # local($SIG{__WARN__}) = sub { warn "1. have[$have]"; };
4503 # there was a bug in 5.6.0 that let lots of unini warnings out of
4504 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
4505 # this workaround after 5.6.1 is out.
4506 local($SIG{__WARN__}) = sub { my $w = shift;
4507 return if $w =~ /uninitialized/i;
4510 $have = MM->parse_version($parsefile) || "undef";
4511 $have =~ s/^ //; # since the %vd hack these two lines here are needed
4512 $have =~ s/ $//; # trailing whitespace happens all the time
4514 # local($SIG{__WARN__}) = sub { warn "2. have[$have]"; };
4516 if ($] >= 5.006) { # people start using v-strings
4517 unless ($have =~ /^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
4524 $have = sprintf "%vd", $have;
4527 $have =~ s/\s*//g; # stringify to float around floating point issues
4528 # local($SIG{__WARN__}) = sub { warn "3. have[$have]"; };
4529 $have; # no stringify needed, \s* above matches always
4532 package CPAN::Tarzip;
4534 # CPAN::Tarzip::gzip
4536 my($class,$read,$write) = @_;
4537 if ($CPAN::META->has_inst("Compress::Zlib")) {
4539 $fhw = FileHandle->new($read)
4540 or $CPAN::Frontend->mydie("Could not open $read: $!");
4541 my $gz = Compress::Zlib::gzopen($write, "wb")
4542 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
4543 $gz->gzwrite($buffer)
4544 while read($fhw,$buffer,4096) > 0 ;
4549 system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
4554 # CPAN::Tarzip::gunzip
4556 my($class,$read,$write) = @_;
4557 if ($CPAN::META->has_inst("Compress::Zlib")) {
4559 $fhw = FileHandle->new(">$write")
4560 or $CPAN::Frontend->mydie("Could not open >$write: $!");
4561 my $gz = Compress::Zlib::gzopen($read, "rb")
4562 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
4563 $fhw->print($buffer)
4564 while $gz->gzread($buffer) > 0 ;
4565 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4566 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4571 system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
4576 # CPAN::Tarzip::gtest
4578 my($class,$read) = @_;
4579 if ($CPAN::META->has_inst("Compress::Zlib")) {
4581 my $gz = Compress::Zlib::gzopen($read, "rb")
4582 or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
4583 1 while $gz->gzread($buffer) > 0 ;
4584 my $err = $gz->gzerror;
4585 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
4587 $class->debug("err[$err]success[$success]") if $CPAN::DEBUG;
4590 return system("$CPAN::Config->{'gzip'} -dt $read")==0;
4595 # CPAN::Tarzip::TIEHANDLE
4597 my($class,$file) = @_;
4599 $class->debug("file[$file]");
4600 if ($CPAN::META->has_inst("Compress::Zlib")) {
4601 my $gz = Compress::Zlib::gzopen($file,"rb") or
4602 die "Could not gzopen $file";
4603 $ret = bless {GZ => $gz}, $class;
4605 my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
4606 my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
4608 $ret = bless {FH => $fh}, $class;
4614 # CPAN::Tarzip::READLINE
4617 if (exists $self->{GZ}) {
4618 my $gz = $self->{GZ};
4619 my($line,$bytesread);
4620 $bytesread = $gz->gzreadline($line);
4621 return undef if $bytesread <= 0;
4624 my $fh = $self->{FH};
4625 return scalar <$fh>;
4630 # CPAN::Tarzip::READ
4632 my($self,$ref,$length,$offset) = @_;
4633 die "read with offset not implemented" if defined $offset;
4634 if (exists $self->{GZ}) {
4635 my $gz = $self->{GZ};
4636 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
4639 my $fh = $self->{FH};
4640 return read($fh,$$ref,$length);
4645 # CPAN::Tarzip::DESTROY
4648 if (exists $self->{GZ}) {
4649 my $gz = $self->{GZ};
4652 my $fh = $self->{FH};
4653 $fh->close if defined $fh;
4659 # CPAN::Tarzip::untar
4661 my($class,$file) = @_;
4662 # had to disable, because version 0.07 seems to be buggy
4663 if (MM->maybe_command($CPAN::Config->{'gzip'})
4665 MM->maybe_command($CPAN::Config->{'tar'})) {
4666 my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
4667 "< $file | $CPAN::Config->{tar} xvf -";
4668 if (system($system) != 0) {
4669 # people find the most curious tar binaries that cannot handle
4671 my $system = "$CPAN::Config->{'gzip'} --decompress $file";
4672 if (system($system)==0) {
4673 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
4675 $CPAN::Frontend->mydie(
4676 qq{Couldn\'t uncompress $file\n}
4679 $file =~ s/\.gz(?!\n)\Z//;
4680 $system = "$CPAN::Config->{tar} xvf $file";
4681 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
4682 if (system($system)==0) {
4683 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
4685 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
4691 } elsif ($CPAN::META->has_inst("Archive::Tar")
4693 $CPAN::META->has_inst("Compress::Zlib") ) {
4694 my $tar = Archive::Tar->new($file,1);
4695 $tar->extract($tar->list_files); # I'm pretty sure we have nothing
4696 # that isn't compressed
4698 ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
4699 if ($^O eq 'MacOS');
4703 $CPAN::Frontend->mydie(qq{
4704 CPAN.pm needs either both external programs tar and gzip installed or
4705 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
4706 is available. Can\'t continue.
4712 my($class,$file) = @_;
4713 return unless $CPAN::META->has_inst("Archive::Zip");
4714 # blueprint of the code from Archive::Zip::Tree::extractTree();
4715 my $zip = Archive::Zip->new();
4717 $status = $zip->read($file);
4718 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
4719 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
4720 my @members = $zip->members();
4721 for my $member ( @members ) {
4722 my $f = $member->fileName();
4723 my $status = $member->extractToFileNamed( $f );
4724 $CPAN::META->debug("f[$f]status[$status]") if $CPAN::DEBUG;
4725 die "Extracting of file[$f] from zipfile[$file] failed\n" if
4726 $status != Archive::Zip::AZ_OK();
4739 CPAN - query, download and build perl modules from CPAN sites
4745 perl -MCPAN -e shell;
4751 autobundle, clean, install, make, recompile, test
4755 The CPAN module is designed to automate the make and install of perl
4756 modules and extensions. It includes some searching capabilities and
4757 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
4758 to fetch the raw data from the net.
4760 Modules are fetched from one or more of the mirrored CPAN
4761 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
4764 The CPAN module also supports the concept of named and versioned
4765 I<bundles> of modules. Bundles simplify the handling of sets of
4766 related modules. See Bundles below.
4768 The package contains a session manager and a cache manager. There is
4769 no status retained between sessions. The session manager keeps track
4770 of what has been fetched, built and installed in the current
4771 session. The cache manager keeps track of the disk space occupied by
4772 the make processes and deletes excess space according to a simple FIFO
4775 For extended searching capabilities there's a plugin for CPAN available,
4776 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
4777 all documents available in CPAN authors directories. If C<CPAN::WAIT>
4778 is installed on your system, the interactive shell of <CPAN.pm> will
4779 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
4780 queries to the WAIT server that has been configured for your
4783 All other methods provided are accessible in a programmer style and in an
4784 interactive shell style.
4786 =head2 Interactive Mode
4788 The interactive mode is entered by running
4790 perl -MCPAN -e shell
4792 which puts you into a readline interface. You will have the most fun if
4793 you install Term::ReadKey and Term::ReadLine to enjoy both history and
4796 Once you are on the command line, type 'h' and the rest should be
4799 The most common uses of the interactive modes are
4803 =item Searching for authors, bundles, distribution files and modules
4805 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
4806 for each of the four categories and another, C<i> for any of the
4807 mentioned four. Each of the four entities is implemented as a class
4808 with slightly differing methods for displaying an object.
4810 Arguments you pass to these commands are either strings exactly matching
4811 the identification string of an object or regular expressions that are
4812 then matched case-insensitively against various attributes of the
4813 objects. The parser recognizes a regular expression only if you
4814 enclose it between two slashes.
4816 The principle is that the number of found objects influences how an
4817 item is displayed. If the search finds one item, the result is
4818 displayed with the rather verbose method C<as_string>, but if we find
4819 more than one, we display each object with the terse method
4822 =item make, test, install, clean modules or distributions
4824 These commands take any number of arguments and investigate what is
4825 necessary to perform the action. If the argument is a distribution
4826 file name (recognized by embedded slashes), it is processed. If it is
4827 a module, CPAN determines the distribution file in which this module
4828 is included and processes that, following any dependencies named in
4829 the module's Makefile.PL (this behavior is controlled by
4830 I<prerequisites_policy>.)
4832 Any C<make> or C<test> are run unconditionally. An
4834 install <distribution_file>
4836 also is run unconditionally. But for
4840 CPAN checks if an install is actually needed for it and prints
4841 I<module up to date> in the case that the distribution file containing
4842 the module doesn't need to be updated.
4844 CPAN also keeps track of what it has done within the current session
4845 and doesn't try to build a package a second time regardless if it
4846 succeeded or not. The C<force> command takes as a first argument the
4847 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
4848 command from scratch.
4852 cpan> install OpenGL
4853 OpenGL is up to date.
4854 cpan> force install OpenGL
4857 OpenGL-0.4/COPYRIGHT
4860 A C<clean> command results in a
4864 being executed within the distribution file's working directory.
4866 =item get, readme, look module or distribution
4868 C<get> downloads a distribution file without further action. C<readme>
4869 displays the README file of the associated distribution. C<Look> gets
4870 and untars (if not yet done) the distribution file, changes to the
4871 appropriate directory and opens a subshell process in that directory.
4875 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4876 in the cpan-shell it is intended that you can press C<^C> anytime and
4877 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4878 to clean up and leave the shell loop. You can emulate the effect of a
4879 SIGTERM by sending two consecutive SIGINTs, which usually means by
4880 pressing C<^C> twice.
4882 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4883 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4889 The commands that are available in the shell interface are methods in
4890 the package CPAN::Shell. If you enter the shell command, all your
4891 input is split by the Text::ParseWords::shellwords() routine which
4892 acts like most shells do. The first word is being interpreted as the
4893 method to be called and the rest of the words are treated as arguments
4894 to this method. Continuation lines are supported if a line ends with a
4899 C<autobundle> writes a bundle file into the
4900 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4901 a list of all modules that are both available from CPAN and currently
4902 installed within @INC. The name of the bundle file is based on the
4903 current date and a counter.
4907 recompile() is a very special command in that it takes no argument and
4908 runs the make/test/install cycle with brute force over all installed
4909 dynamically loadable extensions (aka XS modules) with 'force' in
4910 effect. The primary purpose of this command is to finish a network
4911 installation. Imagine, you have a common source tree for two different
4912 architectures. You decide to do a completely independent fresh
4913 installation. You start on one architecture with the help of a Bundle
4914 file produced earlier. CPAN installs the whole Bundle for you, but
4915 when you try to repeat the job on the second architecture, CPAN
4916 responds with a C<"Foo up to date"> message for all modules. So you
4917 invoke CPAN's recompile on the second architecture and you're done.
4919 Another popular use for C<recompile> is to act as a rescue in case your
4920 perl breaks binary compatibility. If one of the modules that CPAN uses
4921 is in turn depending on binary compatibility (so you cannot run CPAN
4922 commands), then you should try the CPAN::Nox module for recovery.
4924 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
4926 Although it may be considered internal, the class hierarchy does matter
4927 for both users and programmer. CPAN.pm deals with above mentioned four
4928 classes, and all those classes share a set of methods. A classical
4929 single polymorphism is in effect. A metaclass object registers all
4930 objects of all kinds and indexes them with a string. The strings
4931 referencing objects have a separated namespace (well, not completely
4936 words containing a "/" (slash) Distribution
4937 words starting with Bundle:: Bundle
4938 everything else Module or Author
4940 Modules know their associated Distribution objects. They always refer
4941 to the most recent official release. Developers may mark their releases
4942 as unstable development versions (by inserting an underbar into the
4943 visible version number), so the really hottest and newest distribution
4944 file is not always the default. If a module Foo circulates on CPAN in
4945 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
4946 install version 1.23 by saying
4950 This would install the complete distribution file (say
4951 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
4952 like to install version 1.23_90, you need to know where the
4953 distribution file resides on CPAN relative to the authors/id/
4954 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
4955 so you would have to say
4957 install BAR/Foo-1.23_90.tar.gz
4959 The first example will be driven by an object of the class
4960 CPAN::Module, the second by an object of class CPAN::Distribution.
4962 =head2 Programmer's interface
4964 If you do not enter the shell, the available shell commands are both
4965 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
4966 functions in the calling package (C<install(...)>).
4968 There's currently only one class that has a stable interface -
4969 CPAN::Shell. All commands that are available in the CPAN shell are
4970 methods of the class CPAN::Shell. Each of the commands that produce
4971 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
4972 the IDs of all modules within the list.
4976 =item expand($type,@things)
4978 The IDs of all objects available within a program are strings that can
4979 be expanded to the corresponding real objects with the
4980 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
4981 list of CPAN::Module objects according to the C<@things> arguments
4982 given. In scalar context it only returns the first element of the
4985 =item Programming Examples
4987 This enables the programmer to do operations that combine
4988 functionalities that are available in the shell.
4990 # install everything that is outdated on my disk:
4991 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
4993 # install my favorite programs if necessary:
4994 for $mod (qw(Net::FTP MD5 Data::Dumper)){
4995 my $obj = CPAN::Shell->expand('Module',$mod);
4999 # list all modules on my disk that have no VERSION number
5000 for $mod (CPAN::Shell->expand("Module","/./")){
5001 next unless $mod->inst_file;
5002 # MakeMaker convention for undefined $VERSION:
5003 next unless $mod->inst_version eq "undef";
5004 print "No VERSION in ", $mod->id, "\n";
5007 # find out which distribution on CPAN contains a module:
5008 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
5010 Or if you want to write a cronjob to watch The CPAN, you could list
5011 all modules that need updating. First a quick and dirty way:
5013 perl -e 'use CPAN; CPAN::Shell->r;'
5015 If you don't want to get any output if all modules are up to date, you
5016 can parse the output of above command for the regular expression
5017 //modules are up to date// and decide to mail the output only if it
5020 If you prefer to do it more in a programmer style in one single
5021 process, maybe something like this suites you better:
5023 # list all modules on my disk that have newer versions on CPAN
5024 for $mod (CPAN::Shell->expand("Module","/./")){
5025 next unless $mod->inst_file;
5026 next if $mod->uptodate;
5027 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
5028 $mod->id, $mod->inst_version, $mod->cpan_version;
5031 If that gives you too much output every day, you maybe only want to
5032 watch for three modules. You can write
5034 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
5036 as the first line instead. Or you can combine some of the above
5039 # watch only for a new mod_perl module
5040 $mod = CPAN::Shell->expand("Module","mod_perl");
5041 exit if $mod->uptodate;
5042 # new mod_perl arrived, let me know all update recommendations
5047 =head2 Methods in the four Classes
5049 =head2 Cache Manager
5051 Currently the cache manager only keeps track of the build directory
5052 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
5053 deletes complete directories below C<build_dir> as soon as the size of
5054 all directories there gets bigger than $CPAN::Config->{build_cache}
5055 (in MB). The contents of this cache may be used for later
5056 re-installations that you intend to do manually, but will never be
5057 trusted by CPAN itself. This is due to the fact that the user might
5058 use these directories for building modules on different architectures.
5060 There is another directory ($CPAN::Config->{keep_source_where}) where
5061 the original distribution files are kept. This directory is not
5062 covered by the cache manager and must be controlled by the user. If
5063 you choose to have the same directory as build_dir and as
5064 keep_source_where directory, then your sources will be deleted with
5065 the same fifo mechanism.
5069 A bundle is just a perl module in the namespace Bundle:: that does not
5070 define any functions or methods. It usually only contains documentation.
5072 It starts like a perl module with a package declaration and a $VERSION
5073 variable. After that the pod section looks like any other pod with the
5074 only difference being that I<one special pod section> exists starting with
5079 In this pod section each line obeys the format
5081 Module_Name [Version_String] [- optional text]
5083 The only required part is the first field, the name of a module
5084 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
5085 of the line is optional. The comment part is delimited by a dash just
5086 as in the man page header.
5088 The distribution of a bundle should follow the same convention as
5089 other distributions.
5091 Bundles are treated specially in the CPAN package. If you say 'install
5092 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
5093 the modules in the CONTENTS section of the pod. You can install your
5094 own Bundles locally by placing a conformant Bundle file somewhere into
5095 your @INC path. The autobundle() command which is available in the
5096 shell interface does that for you by including all currently installed
5097 modules in a snapshot bundle file.
5099 =head2 Prerequisites
5101 If you have a local mirror of CPAN and can access all files with
5102 "file:" URLs, then you only need a perl better than perl5.003 to run
5103 this module. Otherwise Net::FTP is strongly recommended. LWP may be
5104 required for non-UNIX systems or if your nearest CPAN site is
5105 associated with an URL that is not C<ftp:>.
5107 If you have neither Net::FTP nor LWP, there is a fallback mechanism
5108 implemented for an external ftp command or for an external lynx
5111 =head2 Finding packages and VERSION
5113 This module presumes that all packages on CPAN
5119 declare their $VERSION variable in an easy to parse manner. This
5120 prerequisite can hardly be relaxed because it consumes far too much
5121 memory to load all packages into the running program just to determine
5122 the $VERSION variable. Currently all programs that are dealing with
5123 version use something like this
5125 perl -MExtUtils::MakeMaker -le \
5126 'print MM->parse_version(shift)' filename
5128 If you are author of a package and wonder if your $VERSION can be
5129 parsed, please try the above method.
5133 come as compressed or gzipped tarfiles or as zip files and contain a
5134 Makefile.PL (well, we try to handle a bit more, but without much
5141 The debugging of this module is pretty difficult, because we have
5142 interferences of the software producing the indices on CPAN, of the
5143 mirroring process on CPAN, of packaging, of configuration, of
5144 synchronicity, and of bugs within CPAN.pm.
5146 In interactive mode you can try "o debug" which will list options for
5147 debugging the various parts of the package. The output may not be very
5148 useful for you as it's just a by-product of my own testing, but if you
5149 have an idea which part of the package may have a bug, it's sometimes
5150 worth to give it a try and send me more specific output. You should
5151 know that "o debug" has built-in completion support.
5153 =head2 Floppy, Zip, Offline Mode
5155 CPAN.pm works nicely without network too. If you maintain machines
5156 that are not networked at all, you should consider working with file:
5157 URLs. Of course, you have to collect your modules somewhere first. So
5158 you might use CPAN.pm to put together all you need on a networked
5159 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
5160 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
5161 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
5162 with this floppy. See also below the paragraph about CD-ROM support.
5164 =head1 CONFIGURATION
5166 When the CPAN module is installed, a site wide configuration file is
5167 created as CPAN/Config.pm. The default values defined there can be
5168 overridden in another configuration file: CPAN/MyConfig.pm. You can
5169 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
5170 $HOME/.cpan is added to the search path of the CPAN module before the
5171 use() or require() statements.
5173 Currently the following keys in the hash reference $CPAN::Config are
5176 build_cache size of cache for directories to build modules
5177 build_dir locally accessible directory to build modules
5178 index_expire after this many days refetch index files
5179 cpan_home local directory reserved for this package
5180 dontload_hash anonymous hash: modules in the keys will not be
5181 loaded by the CPAN::has_inst() routine
5182 gzip location of external program gzip
5183 inactivity_timeout breaks interactive Makefile.PLs after this
5184 many seconds inactivity. Set to 0 to never break.
5185 inhibit_startup_message
5186 if true, does not print the startup message
5187 keep_source_where directory in which to keep the source (if we do)
5188 make location of external make program
5189 make_arg arguments that should always be passed to 'make'
5190 make_install_arg same as make_arg for 'make install'
5191 makepl_arg arguments passed to 'perl Makefile.PL'
5192 pager location of external program more (or any pager)
5193 prerequisites_policy
5194 what to do if you are missing module prerequisites
5195 ('follow' automatically, 'ask' me, or 'ignore')
5196 scan_cache controls scanning of cache ('atstart' or 'never')
5197 tar location of external program tar
5198 unzip location of external program unzip
5199 urllist arrayref to nearby CPAN sites (or equivalent locations)
5200 wait_list arrayref to a wait server to try (See CPAN::WAIT)
5201 ftp_proxy, } the three usual variables for configuring
5202 http_proxy, } proxy requests. Both as CPAN::Config variables
5203 no_proxy } and as environment variables configurable.
5205 You can set and query each of these options interactively in the cpan
5206 shell with the command set defined within the C<o conf> command:
5210 =item C<o conf E<lt>scalar optionE<gt>>
5212 prints the current value of the I<scalar option>
5214 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
5216 Sets the value of the I<scalar option> to I<value>
5218 =item C<o conf E<lt>list optionE<gt>>
5220 prints the current value of the I<list option> in MakeMaker's
5223 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
5225 shifts or pops the array in the I<list option> variable
5227 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
5229 works like the corresponding perl commands.
5233 =head2 Note on urllist parameter's format
5235 urllist parameters are URLs according to RFC 1738. We do a little
5236 guessing if your URL is not compliant, but if you have problems with
5237 file URLs, please try the correct format. Either:
5239 file://localhost/whatever/ftp/pub/CPAN/
5243 file:///home/ftp/pub/CPAN/
5245 =head2 urllist parameter has CD-ROM support
5247 The C<urllist> parameter of the configuration table contains a list of
5248 URLs that are to be used for downloading. If the list contains any
5249 C<file> URLs, CPAN always tries to get files from there first. This
5250 feature is disabled for index files. So the recommendation for the
5251 owner of a CD-ROM with CPAN contents is: include your local, possibly
5252 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
5254 o conf urllist push file://localhost/CDROM/CPAN
5256 CPAN.pm will then fetch the index files from one of the CPAN sites
5257 that come at the beginning of urllist. It will later check for each
5258 module if there is a local copy of the most recent version.
5260 Another peculiarity of urllist is that the site that we could
5261 successfully fetch the last file from automatically gets a preference
5262 token and is tried as the first site for the next request. So if you
5263 add a new site at runtime it may happen that the previously preferred
5264 site will be tried another time. This means that if you want to disallow
5265 a site for the next transfer, it must be explicitly removed from
5270 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
5271 install foreign, unmasked, unsigned code on your machine. We compare
5272 to a checksum that comes from the net just as the distribution file
5273 itself. If somebody has managed to tamper with the distribution file,
5274 they may have as well tampered with the CHECKSUMS file. Future
5275 development will go towards strong authentication.
5279 Most functions in package CPAN are exported per default. The reason
5280 for this is that the primary use is intended for the cpan shell or for
5283 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
5285 To populate a freshly installed perl with my favorite modules is pretty
5286 easiest by maintaining a private bundle definition file. To get a useful
5287 blueprint of a bundle definition file, the command autobundle can be used
5288 on the CPAN shell command line. This command writes a bundle definition
5289 file for all modules that are installed for the currently running perl
5290 interpreter. It's recommended to run this command only once and from then
5291 on maintain the file manually under a private name, say
5292 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
5294 cpan> install Bundle::my_bundle
5296 then answer a few questions and then go out for a coffee.
5298 Maintaining a bundle definition file means to keep track of two
5299 things: dependencies and interactivity. CPAN.pm sometimes fails on
5300 calculating dependencies because not all modules define all MakeMaker
5301 attributes correctly, so a bundle definition file should specify
5302 prerequisites as early as possible. On the other hand, it's a bit
5303 annoying that many distributions need some interactive configuring. So
5304 what I try to accomplish in my private bundle file is to have the
5305 packages that need to be configured early in the file and the gentle
5306 ones later, so I can go out after a few minutes and leave CPAN.pm
5309 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
5311 Thanks to Graham Barr for contributing the following paragraphs about
5312 the interaction between perl, and various firewall configurations. For
5313 further informations on firewalls, it is recommended to consult the
5314 documentation that comes with the ncftp program. If you are unable to
5315 go through the firewall with a simple Perl setup, it is very likely
5316 that you can configure ncftp so that it works for your firewall.
5318 =head2 Three basic types of firewalls
5320 Firewalls can be categorized into three basic types.
5326 This is where the firewall machine runs a web server and to access the
5327 outside world you must do it via the web server. If you set environment
5328 variables like http_proxy or ftp_proxy to a values beginning with http://
5329 or in your web browser you have to set proxy information then you know
5330 you are running a http firewall.
5332 To access servers outside these types of firewalls with perl (even for
5333 ftp) you will need to use LWP.
5337 This where the firewall machine runs a ftp server. This kind of
5338 firewall will only let you access ftp servers outside the firewall.
5339 This is usually done by connecting to the firewall with ftp, then
5340 entering a username like "user@outside.host.com"
5342 To access servers outside these type of firewalls with perl you
5343 will need to use Net::FTP.
5345 =item One way visibility
5347 I say one way visibility as these firewalls try to make themselve look
5348 invisible to the users inside the firewall. An FTP data connection is
5349 normally created by sending the remote server your IP address and then
5350 listening for the connection. But the remote server will not be able to
5351 connect to you because of the firewall. So for these types of firewall
5352 FTP connections need to be done in a passive mode.
5354 There are two that I can think off.
5360 If you are using a SOCKS firewall you will need to compile perl and link
5361 it with the SOCKS library, this is what is normally called a ``socksified''
5362 perl. With this executable you will be able to connect to servers outside
5363 the firewall as if it is not there.
5367 This is the firewall implemented in the Linux kernel, it allows you to
5368 hide a complete network behind one IP address. With this firewall no
5369 special compiling is need as you can access hosts directly.
5375 =head2 Configuring lynx or ncftp for going throught the firewall
5377 If you can go through your firewall with e.g. lynx, presumably with a
5380 /usr/local/bin/lynx -pscott:tiger
5382 then you would configure CPAN.pm with the command
5384 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
5386 That's all. Similarly for ncftp or ftp, you would configure something
5389 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
5391 Your milage may vary...
5397 =item I installed a new version of module X but CPAN keeps saying, I
5398 have the old version installed
5400 Most probably you B<do> have the old version installed. This can
5401 happen if a module installs itself into a different directory in the
5402 @INC path than it was previously installed. This is not really a
5403 CPAN.pm problem, you would have the same problem when installing the
5404 module manually. The easiest way to prevent this behaviour is to add
5405 the argument C<UNINST=1> to the C<make install> call, and that is why
5406 many people add this argument permanently by configuring
5408 o conf make_install_arg UNINST=1
5410 =item So why is UNINST=1 not the default?
5412 Because there are people who have their precise expectations about who
5413 may install where in the @INC path and who uses which @INC array. In
5414 fine tuned environments C<UNINST=1> can cause damage.
5416 =item When I install bundles or multiple modules with one command
5417 there is too much output to keep track of
5419 You may want to configure something like
5421 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
5422 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
5424 so that STDOUT is captured in a file for later inspection.
5430 We should give coverage for B<all> of the CPAN and not just the PAUSE
5431 part, right? In this discussion CPAN and PAUSE have become equal --
5432 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
5433 the clpa/, doc/, misc/, ports/, src/, scripts/.
5435 Future development should be directed towards a better integration of
5438 If a Makefile.PL requires special customization of libraries, prompts
5439 the user for special input, etc. then you may find CPAN is not able to
5440 build the distribution. In that case, you should attempt the
5441 traditional method of building a Perl module package from a shell.
5445 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
5449 perl(1), CPAN::Nox(3)