2 use vars qw{$Try_autoload $Revision
3 $META $Signal $Cwd $End
4 $Suppress_readline %Dontload
10 # $Id: CPAN.pm,v 1.256 1999/01/25 13:06:22 k Exp $
12 # only used during development:
14 # $Revision = "[".substr(q$Revision: 1.256 $, 10)."]";
21 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
22 use File::Basename ();
28 use Text::ParseWords ();
32 END { $End++; &cleanup; }
53 $CPAN::Frontend ||= "CPAN::Shell";
54 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
57 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term);
60 @CPAN::ISA = qw(CPAN::Debug Exporter);
63 autobundle bundle expand force get
64 install make readme recompile shell test clean
67 #-> sub CPAN::AUTOLOAD ;
72 @EXPORT{@EXPORT} = '';
73 if (exists $EXPORT{$l}){
76 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
80 # $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
82 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
90 $Suppress_readline ||= ! -t STDIN;
92 my $prompt = "cpan> ";
94 unless ($Suppress_readline) {
95 require Term::ReadLine;
96 # import Term::ReadLine;
97 $term = Term::ReadLine->new('CPAN Monitor');
98 $readline::rl_completion_function =
99 $readline::rl_completion_function = 'CPAN::Complete::cpl';
105 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
106 my $cwd = CPAN->$getcwd();
107 my $rl_avail = $Suppress_readline ? "suppressed" :
108 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
109 "available (try ``install Bundle::CPAN'')";
111 $CPAN::Frontend->myprint(
113 cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
114 ReadLine support $rl_avail
116 }) unless $CPAN::Config->{'inhibit_startup_message'} ;
117 my($continuation) = "";
119 if ($Suppress_readline) {
121 last unless defined ($_ = <> );
124 last unless defined ($_ = $term->readline($prompt));
126 $_ = "$continuation$_" if $continuation;
129 $_ = 'h' if /^\s*\?/;
130 if (/^(?:q(?:uit)?|bye|exit)$/i) {
140 use vars qw($import_done);
141 CPAN->import(':DEFAULT') unless $import_done++;
142 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
149 if ($] < 5.00322) { # parsewords had a bug until recently
152 eval { @line = Text::ParseWords::shellwords($_) };
153 warn($@), next if $@;
155 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
156 my $command = shift @line;
157 eval { CPAN::Shell->$command(@line) };
160 $CPAN::Frontend->myprint("\n");
169 package CPAN::CacheMgr;
170 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
173 package CPAN::Config;
174 import ExtUtils::MakeMaker 'neatvalue';
175 use vars qw(%can $dot_cpan);
178 'commit' => "Commit changes to disk",
179 'defaults' => "Reload defaults from disk",
180 'init' => "Interactive setting of all options",
184 use vars qw($Ua $Thesite $Themethod);
185 @CPAN::FTP::ISA = qw(CPAN::Debug);
187 package CPAN::Complete;
188 @CPAN::Complete::ISA = qw(CPAN::Debug);
191 use vars qw($last_time $date_of_03);
192 @CPAN::Index::ISA = qw(CPAN::Debug);
196 package CPAN::InfoObj;
197 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
199 package CPAN::Author;
200 @CPAN::Author::ISA = qw(CPAN::InfoObj);
202 package CPAN::Distribution;
203 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
205 package CPAN::Bundle;
206 @CPAN::Bundle::ISA = qw(CPAN::Module);
208 package CPAN::Module;
209 @CPAN::Module::ISA = qw(CPAN::InfoObj);
212 use vars qw($AUTOLOAD $redef @ISA);
213 @CPAN::Shell::ISA = qw(CPAN::Debug);
215 #-> sub CPAN::Shell::AUTOLOAD ;
217 my($autoload) = $AUTOLOAD;
218 my $class = shift(@_);
219 # warn "autoload[$autoload] class[$class]";
220 $autoload =~ s/.*:://;
221 if ($autoload =~ /^w/) {
222 if ($CPAN::META->has_inst('CPAN::WAIT')) {
223 CPAN::WAIT->$autoload(@_);
225 $CPAN::Frontend->mywarn(qq{
226 Commands starting with "w" require CPAN::WAIT to be installed.
227 Please consider installing CPAN::WAIT to use the fulltext index.
228 For this you just need to type
233 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
237 # $CPAN::Frontend->mywarn("Could not autoload $autoload");
239 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
245 #-> CPAN::Shell::try_dot_al
247 my($class,$autoload) = @_;
248 return unless $CPAN::Try_autoload;
249 # I don't see how to re-use that from the AutoLoader...
251 # Braces used to preserve $1 et al.
253 my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
255 if (defined($name=$INC{"$pkg.pm"}))
257 $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|;
258 $name = undef unless (-r $name);
260 unless (defined $name)
262 $name = "auto/$autoload.al";
267 eval {local $SIG{__DIE__};require $name};
269 if (substr($autoload,-9) eq '::DESTROY') {
273 if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
274 eval {local $SIG{__DIE__};require $name};
289 # my $lm = Carp::longmess();
290 # warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
294 #### autoloader is experimental
295 #### to try it we have to set $Try_autoload and uncomment
296 #### the use statement and uncomment the __END__ below
297 #### You also need AutoSplit 1.01 available. MakeMaker will
298 #### then build CPAN with all the AutoLoad stuff.
302 if ($CPAN::Try_autoload) {
305 CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
306 CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
307 CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
309 *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
313 package CPAN::Tarzip;
314 use vars qw($AUTOLOAD @ISA);
315 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
319 # One use of the queue is to determine if we should or shouldn't
320 # announce the availability of a new CPAN module
322 # Now we try to use it for dependency tracking. For that to happen
323 # we need to draw a dependency tree and do the leaves first. This can
324 # easily be reached by running CPAN.pm recursively, but we don't want
325 # to waste memory and run into deep recursion. So what we can do is
328 # CPAN::Queue is the package where the queue is maintained. Dependencies
329 # often have high priority and must be brought to the head of the queue,
330 # possibly by jumping the queue if they are already there. My first code
331 # attempt tried to be extremely correct. Whenever a module needed
332 # immediate treatment, I either unshifted it to the front of the queue,
333 # or, if it was already in the queue, I spliced and let it bypass the
334 # others. This became a too correct model that made it impossible to put
335 # an item more than once into the queue. Why would you need that? Well,
336 # you need temporary duplicates as the manager of the queue is a loop
339 # (1) looks at the first item in the queue without shifting it off
341 # (2) cares for the item
343 # (3) removes the item from the queue, *even if its agenda failed and
344 # even if the item isn't the first in the queue anymore* (that way
345 # protecting against never ending queues)
347 # So if an item has prerequisites, the installation fails now, but we
348 # want to retry later. That's easy if we have it twice in the queue.
350 # I also expect insane dependency situations where an item gets more
351 # than two lives in the queue. Simplest example is triggered by 'install
352 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
353 # get in the way. I wanted the queue manager to be a dumb servant, not
354 # one that knows everything.
356 # Who would I tell in this model that the user wants to be asked before
357 # processing? I can't attach that information to the module object,
358 # because not modules are installed but distributions. So I'd have to
359 # tell the distribution object that it should ask the user before
360 # processing. Where would the question be triggered then? Most probably
361 # in CPAN::Distribution::rematein.
362 # Hope that makes sense, my head is a bit off:-) -- AK
367 my($class,$mod) = @_;
368 my $self = bless {mod => $mod}, $class;
370 # my @all = map { $_->{mod} } @All;
371 # warn "Adding Queue object for mod[$mod] all[@all]";
381 my($class,$what) = @_;
383 for my $i (0..$#All) {
384 if ( $All[$i]->{mod} eq $what ) {
395 WHAT: for my $what (reverse @what) {
397 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
398 if ($All[$i]->{mod} eq $what){
400 if ($jumped > 100) { # one's OK if e.g. just processing now;
401 # more are OK if user typed it several
403 $CPAN::Frontend->mywarn(
404 qq{Object [$what] queued more than 100 times, ignoring}
410 my $obj = bless { mod => $what }, $class;
416 my($self,$what) = @_;
417 my @all = map { $_->{mod} } @All;
418 my $exists = grep { $_->{mod} eq $what } @All;
419 # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]";
425 @All = grep { $_->{mod} ne $mod } @All;
426 # my @all = map { $_->{mod} } @All;
427 # warn "Deleting Queue object for mod[$mod] all[@all]";
432 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
434 # Do this after you have set up the whole inheritance
435 CPAN::Config->load unless defined $CPAN::No_Config_is_ok;
439 # __END__ # uncomment this and AutoSplit version 1.01 will split it
441 #-> sub CPAN::autobundle ;
443 #-> sub CPAN::bundle ;
445 #-> sub CPAN::expand ;
447 #-> sub CPAN::force ;
449 #-> sub CPAN::install ;
453 #-> sub CPAN::clean ;
460 my($mgr,$class) = @_;
461 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
463 values %{ $META->{$class} };
466 # Called by shell, not in batch mode. Not clean XXX
467 #-> sub CPAN::checklock ;
470 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
471 if (-f $lockfile && -M _ > 0) {
472 my $fh = FileHandle->new($lockfile);
475 if (defined $other && $other) {
477 return if $$==$other; # should never happen
478 $CPAN::Frontend->mywarn(
480 There seems to be running another CPAN process ($other). Contacting...
482 if (kill 0, $other) {
483 $CPAN::Frontend->mydie(qq{Other job is running.
484 You may want to kill it and delete the lockfile, maybe. On UNIX try:
488 } elsif (-w $lockfile) {
490 ExtUtils::MakeMaker::prompt
491 (qq{Other job not responding. Shall I overwrite }.
492 qq{the lockfile? (Y/N)},"y");
493 $CPAN::Frontend->myexit("Ok, bye\n")
494 unless $ans =~ /^y/i;
497 qq{Lockfile $lockfile not writeable by you. }.
498 qq{Cannot proceed.\n}.
501 qq{ and then rerun us.\n}
506 File::Path::mkpath($CPAN::Config->{cpan_home});
508 unless ($fh = FileHandle->new(">$lockfile")) {
509 if ($! =~ /Permission/) {
510 my $incc = $INC{'CPAN/Config.pm'};
511 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
512 $CPAN::Frontend->myprint(qq{
514 Your configuration suggests that CPAN.pm should use a working
516 $CPAN::Config->{cpan_home}
517 Unfortunately we could not create the lock file
519 due to permission problems.
521 Please make sure that the configuration variable
522 \$CPAN::Config->{cpan_home}
523 points to a directory where you can write a .lock file. You can set
524 this variable in either
531 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
533 $fh->print($$, "\n");
534 $self->{LOCK} = $lockfile;
538 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
543 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
544 print "Caught SIGINT\n";
547 $SIG{'__DIE__'} = \&cleanup;
548 $self->debug("Signal handler set.") if $CPAN::DEBUG;
551 #-> sub CPAN::DESTROY ;
553 &cleanup; # need an eval?
557 sub cwd {Cwd::cwd();}
559 #-> sub CPAN::getcwd ;
560 sub getcwd {Cwd::getcwd();}
562 #-> sub CPAN::exists ;
564 my($mgr,$class,$id) = @_;
566 ### Carp::croak "exists called without class argument" unless $class;
568 exists $META->{$class}{$id};
571 #-> sub CPAN::delete ;
573 my($mgr,$class,$id) = @_;
574 delete $META->{$class}{$id};
577 #-> sub CPAN::has_inst
579 my($self,$mod,$message) = @_;
580 Carp::croak("CPAN->has_inst() called without an argument")
582 if (defined $message && $message eq "no") {
585 } elsif (exists $Dontload{$mod}) {
591 $file =~ s|/|\\|g if $^O eq 'MSWin32';
594 # checking %INC is wrong, because $INC{LWP} may be true
595 # although $INC{"URI/URL.pm"} may have failed. But as
596 # I really want to say "bla loaded OK", I have to somehow
598 ### warn "$file in %INC"; #debug
600 } elsif (eval { require $file }) {
601 # eval is good: if we haven't yet read the database it's
602 # perfect and if we have installed the module in the meantime,
603 # it tries again. The second require is only a NOOP returning
604 # 1 if we had success, otherwise it's retrying
606 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
607 if ($mod eq "CPAN::WAIT") {
608 push @CPAN::Shell::ISA, CPAN::WAIT;
611 } elsif ($mod eq "Net::FTP") {
613 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
615 install Bundle::libnet
619 } elsif ($mod eq "MD5"){
620 $CPAN::Frontend->myprint(qq{
621 CPAN: MD5 security checks disabled because MD5 not installed.
622 Please consider installing the MD5 module.
627 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
632 #-> sub CPAN::instance ;
634 my($mgr,$class,$id) = @_;
637 $META->{$class}{$id} ||= $class->new(ID => $id );
645 #-> sub CPAN::cleanup ;
647 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
648 local $SIG{__DIE__} = '';
653 0 && # disabled, try reload cpan with it
654 $] > 5.004_60 # thereabouts
659 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
661 $subroutine eq '(eval)';
664 return if $ineval && !$End;
665 return unless defined $META->{'LOCK'};
666 return unless -f $META->{'LOCK'};
667 unlink $META->{'LOCK'};
669 # Carp::cluck("DEBUGGING");
670 $CPAN::Frontend->mywarn("Lockfile removed.\n");
673 package CPAN::CacheMgr;
675 #-> sub CPAN::CacheMgr::as_string ;
677 eval { require Data::Dumper };
679 return shift->SUPER::as_string;
681 return Data::Dumper::Dumper(shift);
685 #-> sub CPAN::CacheMgr::cachesize ;
692 return unless -d $self->{ID};
693 while ($self->{DU} > $self->{'MAX'} ) {
694 my($toremove) = shift @{$self->{FIFO}};
695 $CPAN::Frontend->myprint(sprintf(
696 "Deleting from cache".
697 ": $toremove (%.1f>%.1f MB)\n",
698 $self->{DU}, $self->{'MAX'})
700 return if $CPAN::Signal;
701 $self->force_clean_cache($toremove);
702 return if $CPAN::Signal;
706 #-> sub CPAN::CacheMgr::dir ;
711 #-> sub CPAN::CacheMgr::entries ;
714 return unless defined $dir;
715 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
716 $dir ||= $self->{ID};
718 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
719 my($cwd) = CPAN->$getcwd();
720 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
721 my $dh = DirHandle->new(File::Spec->curdir)
722 or Carp::croak("Couldn't opendir $dir: $!");
725 next if $_ eq "." || $_ eq "..";
727 push @entries, MM->catfile($dir,$_);
729 push @entries, MM->catdir($dir,$_);
731 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
734 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
735 sort { -M $b <=> -M $a} @entries;
738 #-> sub CPAN::CacheMgr::disk_usage ;
741 return if exists $self->{SIZE}{$dir};
742 return if $CPAN::Signal;
746 $File::Find::prune++ if $CPAN::Signal;
748 if ($^O eq 'MacOS') {
750 my $cat = Mac::Files::FSpGetCatInfo($_);
751 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen();
758 return if $CPAN::Signal;
759 $self->{SIZE}{$dir} = $Du/1024/1024;
760 push @{$self->{FIFO}}, $dir;
761 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
762 $self->{DU} += $Du/1024/1024;
766 #-> sub CPAN::CacheMgr::force_clean_cache ;
767 sub force_clean_cache {
769 return unless -e $dir;
770 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
772 File::Path::rmtree($dir);
773 $self->{DU} -= $self->{SIZE}{$dir};
774 delete $self->{SIZE}{$dir};
777 #-> sub CPAN::CacheMgr::new ;
784 ID => $CPAN::Config->{'build_dir'},
785 MAX => $CPAN::Config->{'build_cache'},
786 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
789 File::Path::mkpath($self->{ID});
790 my $dh = DirHandle->new($self->{ID});
794 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
796 CPAN->debug($debug) if $CPAN::DEBUG;
800 #-> sub CPAN::CacheMgr::scan_cache ;
803 return if $self->{SCAN} eq 'never';
804 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
805 unless $self->{SCAN} eq 'atstart';
806 $CPAN::Frontend->myprint(
807 sprintf("Scanning cache %s for sizes\n",
810 for $e ($self->entries($self->{ID})) {
811 next if $e eq ".." || $e eq ".";
812 $self->disk_usage($e);
813 return if $CPAN::Signal;
820 #-> sub CPAN::Debug::debug ;
823 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
824 # Complete, caller(1)
826 ($caller) = caller(0);
828 $arg = "" unless defined $arg;
829 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
830 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
831 if ($arg and ref $arg) {
832 eval { require Data::Dumper };
834 $CPAN::Frontend->myprint($arg->as_string);
836 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
839 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
844 package CPAN::Config;
846 #-> sub CPAN::Config::edit ;
848 my($class,@args) = @_;
850 CPAN->debug("class[$class]args[".join(" | ",@args)."]");
851 my($o,$str,$func,$args,$key_exists);
857 if (ref($CPAN::Config->{$o}) eq ARRAY) {
860 # Let's avoid eval, it's easier to comprehend without.
861 if ($func eq "push") {
862 push @{$CPAN::Config->{$o}}, @args;
863 } elsif ($func eq "pop") {
864 pop @{$CPAN::Config->{$o}};
865 } elsif ($func eq "shift") {
866 shift @{$CPAN::Config->{$o}};
867 } elsif ($func eq "unshift") {
868 unshift @{$CPAN::Config->{$o}}, @args;
869 } elsif ($func eq "splice") {
870 splice @{$CPAN::Config->{$o}}, @args;
872 $CPAN::Config->{$o} = [@args];
874 $CPAN::Frontend->myprint(
877 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
882 $CPAN::Config->{$o} = $args[0] if defined $args[0];
883 $CPAN::Frontend->myprint(" $o " .
884 (defined $CPAN::Config->{$o} ?
885 $CPAN::Config->{$o} : "UNDEFINED"));
890 #-> sub CPAN::Config::commit ;
892 my($self,$configpm) = @_;
893 unless (defined $configpm){
894 $configpm ||= $INC{"CPAN/MyConfig.pm"};
895 $configpm ||= $INC{"CPAN/Config.pm"};
896 $configpm || Carp::confess(q{
897 CPAN::Config::commit called without an argument.
898 Please specify a filename where to save the configuration or try
899 "o conf init" to have an interactive course through configing.
904 $mode = (stat $configpm)[2];
905 if ($mode && ! -w _) {
906 Carp::confess("$configpm is not writable");
910 my $msg = <<EOF unless $configpm =~ /MyConfig/;
912 # This is CPAN.pm's systemwide configuration file. This file provides
913 # defaults for users, and the values can be changed in a per-user
914 # configuration file. The user-config file is being looked for as
915 # ~/.cpan/CPAN/MyConfig.pm.
919 my($fh) = FileHandle->new;
920 rename $configpm, "$configpm~" if -f $configpm;
921 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
922 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
923 foreach (sort keys %$CPAN::Config) {
926 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
931 $fh->print("};\n1;\n__END__\n");
934 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
935 #chmod $mode, $configpm;
936 ###why was that so? $self->defaults;
937 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
941 *default = \&defaults;
942 #-> sub CPAN::Config::defaults ;
952 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
961 #-> sub CPAN::Config::load ;
966 eval {require CPAN::Config;}; # We eval because of some
968 unless ($dot_cpan++){
969 unshift @INC, MM->catdir($ENV{HOME},".cpan");
970 eval {require CPAN::MyConfig;}; # where you can override
971 # system wide settings
974 return unless @miss = $self->not_loaded;
975 # XXX better check for arrayrefs too
976 require CPAN::FirstTime;
977 my($configpm,$fh,$redo,$theycalled);
979 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
980 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
981 $configpm = $INC{"CPAN/Config.pm"};
983 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
984 $configpm = $INC{"CPAN/MyConfig.pm"};
987 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
988 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
989 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
990 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
991 if (-w $configpmtest) {
992 $configpm = $configpmtest;
993 } elsif (-w $configpmdir) {
994 #_#_# following code dumped core on me with 5.003_11, a.k.
995 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
996 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
997 my $fh = FileHandle->new;
998 if ($fh->open(">$configpmtest")) {
1000 $configpm = $configpmtest;
1002 # Should never happen
1003 Carp::confess("Cannot open >$configpmtest");
1007 unless ($configpm) {
1008 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1009 File::Path::mkpath($configpmdir);
1010 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1011 if (-w $configpmtest) {
1012 $configpm = $configpmtest;
1013 } elsif (-w $configpmdir) {
1014 #_#_# following code dumped core on me with 5.003_11, a.k.
1015 my $fh = FileHandle->new;
1016 if ($fh->open(">$configpmtest")) {
1018 $configpm = $configpmtest;
1020 # Should never happen
1021 Carp::confess("Cannot open >$configpmtest");
1024 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1025 qq{create a configuration file.});
1030 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1031 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1035 $CPAN::Frontend->myprint(qq{
1036 $configpm initialized.
1039 CPAN::FirstTime::init($configpm);
1042 #-> sub CPAN::Config::not_loaded ;
1046 cpan_home keep_source_where build_dir build_cache scan_cache
1047 index_expire gzip tar unzip make pager makepl_arg make_arg
1048 make_install_arg urllist inhibit_startup_message
1049 ftp_proxy http_proxy no_proxy prerequisites_policy
1051 push @miss, $_ unless defined $CPAN::Config->{$_};
1056 #-> sub CPAN::Config::unload ;
1058 delete $INC{'CPAN/MyConfig.pm'};
1059 delete $INC{'CPAN/Config.pm'};
1062 #-> sub CPAN::Config::help ;
1064 $CPAN::Frontend->myprint(q[
1066 defaults reload default config values from disk
1067 commit commit session changes to disk
1068 init go through a dialog to set all parameters
1070 You may edit key values in the follow fashion:
1072 o conf build_cache 15
1074 o conf build_dir "/foo/bar"
1076 o conf urllist shift
1078 o conf urllist unshift ftp://ftp.foo.bar/
1081 undef; #don't reprint CPAN::Config
1084 #-> sub CPAN::Config::cpl ;
1086 my($word,$line,$pos) = @_;
1088 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1089 my(@words) = split " ", substr($line,0,$pos+1);
1094 $words[2] =~ /list$/ && @words == 3
1096 $words[2] =~ /list$/ && @words == 4 && length($word)
1099 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1100 } elsif (@words >= 4) {
1103 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1104 return grep /^\Q$word\E/, @o_conf;
1107 package CPAN::Shell;
1109 #-> sub CPAN::Shell::h ;
1111 my($class,$about) = @_;
1112 if (defined $about) {
1113 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1115 $CPAN::Frontend->myprint(q{
1116 command arguments description
1118 b or display bundles
1119 d /regex/ info distributions
1121 i none anything of above
1123 r as reinstall recommendations
1124 u above uninstalled distributions
1125 See manpage for autobundle, recompile, force, look, etc.
1128 test modules, make test (implies make)
1129 install dists, bundles, make install (implies test)
1130 clean "r" or "u" make clean
1131 readme display the README file
1133 reload index|cpan load most recent indices/CPAN.pm
1134 h or ? display this menu
1135 o various set and query options
1136 ! perl-code eval a perl command
1137 q quit the shell subroutine
1144 #-> sub CPAN::Shell::a ;
1145 sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));}
1146 #-> sub CPAN::Shell::b ;
1148 my($self,@which) = @_;
1149 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1150 my($incdir,$bdir,$dh);
1151 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1152 $bdir = MM->catdir($incdir,"Bundle");
1153 if ($dh = DirHandle->new($bdir)) { # may fail
1155 for $entry ($dh->read) {
1156 next if -d MM->catdir($bdir,$entry);
1157 next unless $entry =~ s/\.pm$//;
1158 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1162 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1164 #-> sub CPAN::Shell::d ;
1165 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1166 #-> sub CPAN::Shell::m ;
1167 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1168 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1171 #-> sub CPAN::Shell::i ;
1176 @type = qw/Author Bundle Distribution Module/;
1177 @args = '/./' unless @args;
1180 push @result, $self->expand($type,@args);
1182 my $result = @result == 1 ?
1183 $result[0]->as_string :
1184 join "", map {$_->as_glimpse} @result;
1185 $result ||= "No objects found of any type for argument @args\n";
1186 $CPAN::Frontend->myprint($result);
1189 #-> sub CPAN::Shell::o ;
1191 my($self,$o_type,@o_what) = @_;
1193 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1194 if ($o_type eq 'conf') {
1195 shift @o_what if @o_what && $o_what[0] eq 'help';
1198 $CPAN::Frontend->myprint("CPAN::Config options");
1199 if (exists $INC{'CPAN/Config.pm'}) {
1200 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1202 if (exists $INC{'CPAN/MyConfig.pm'}) {
1203 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1205 $CPAN::Frontend->myprint(":\n");
1206 for $k (sort keys %CPAN::Config::can) {
1207 $v = $CPAN::Config::can{$k};
1208 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1210 $CPAN::Frontend->myprint("\n");
1211 for $k (sort keys %$CPAN::Config) {
1212 $v = $CPAN::Config->{$k};
1214 $CPAN::Frontend->myprint(
1221 map {"\t$_\n"} @{$v}
1225 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1228 $CPAN::Frontend->myprint("\n");
1229 } elsif (!CPAN::Config->edit(@o_what)) {
1230 $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
1232 } elsif ($o_type eq 'debug') {
1234 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1237 my($what) = shift @o_what;
1238 if ( exists $CPAN::DEBUG{$what} ) {
1239 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1240 } elsif ($what =~ /^\d/) {
1241 $CPAN::DEBUG = $what;
1242 } elsif (lc $what eq 'all') {
1244 for (values %CPAN::DEBUG) {
1247 $CPAN::DEBUG = $max;
1250 for (keys %CPAN::DEBUG) {
1251 next unless lc($_) eq lc($what);
1252 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1255 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1260 $CPAN::Frontend->myprint("Valid options for debug are ".
1261 join(", ",sort(keys %CPAN::DEBUG), 'all').
1262 qq{ or a number. Completion works on the options. }.
1263 qq{Case is ignored.\n\n});
1266 $CPAN::Frontend->myprint("Options set for debugging:\n");
1268 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1269 $v = $CPAN::DEBUG{$k};
1270 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
1273 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1276 $CPAN::Frontend->myprint(qq{
1278 conf set or get configuration variables
1279 debug set or get debugging options
1284 #-> sub CPAN::Shell::reload ;
1286 my($self,$command,@arg) = @_;
1288 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1289 if ($command =~ /cpan/i) {
1290 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1291 my $fh = FileHandle->new($INC{'CPAN.pm'});
1294 local($SIG{__WARN__})
1296 if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1300 # $CPAN::Frontend->myprint(".($subr)");
1301 $CPAN::Frontend->myprint(".");
1308 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1309 } elsif ($command =~ /index/) {
1310 CPAN::Index->force_reload;
1312 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1313 index re-reads the index files\n});
1317 #-> sub CPAN::Shell::_binary_extensions ;
1318 sub _binary_extensions {
1319 my($self) = shift @_;
1320 my(@result,$module,%seen,%need,$headerdone);
1321 my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$};
1322 for $module ($self->expand('Module','/./')) {
1323 my $file = $module->cpan_file;
1324 next if $file eq "N/A";
1325 next if $file =~ /^Contact Author/;
1326 next if $file =~ / $isaperl /xo;
1327 next unless $module->xs_file;
1329 $CPAN::Frontend->myprint(".");
1330 push @result, $module;
1332 # print join " | ", @result;
1333 $CPAN::Frontend->myprint("\n");
1337 #-> sub CPAN::Shell::recompile ;
1339 my($self) = shift @_;
1340 my($module,@module,$cpan_file,%dist);
1341 @module = $self->_binary_extensions();
1342 for $module (@module){ # we force now and compile later, so we
1344 $cpan_file = $module->cpan_file;
1345 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1347 $dist{$cpan_file}++;
1349 for $cpan_file (sort keys %dist) {
1350 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1351 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1353 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1354 # stop a package from recompiling,
1355 # e.g. IO-1.12 when we have perl5.003_10
1359 #-> sub CPAN::Shell::_u_r_common ;
1361 my($self) = shift @_;
1362 my($what) = shift @_;
1363 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1364 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1365 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1367 @args = '/./' unless @args;
1368 my(@result,$module,%seen,%need,$headerdone,
1369 $version_undefs,$version_zeroes);
1370 $version_undefs = $version_zeroes = 0;
1371 my $sprintf = "%-25s %9s %9s %s\n";
1372 for $module ($self->expand('Module',@args)) {
1373 my $file = $module->cpan_file;
1374 next unless defined $file; # ??
1375 my($latest) = $module->cpan_version;
1376 my($inst_file) = $module->inst_file;
1378 return if $CPAN::Signal;
1381 $have = $module->inst_version;
1382 } elsif ($what eq "r") {
1383 $have = $module->inst_version;
1385 if ($have eq "undef"){
1387 } elsif ($have == 0){
1390 next if $have >= $latest;
1391 # to be pedantic we should probably say:
1392 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1393 # to catch the case where CPAN has a version 0 and we have a version undef
1394 } elsif ($what eq "u") {
1400 } elsif ($what eq "r") {
1402 } elsif ($what eq "u") {
1406 return if $CPAN::Signal; # this is sometimes lengthy
1409 push @result, sprintf "%s %s\n", $module->id, $have;
1410 } elsif ($what eq "r") {
1411 push @result, $module->id;
1412 next if $seen{$file}++;
1413 } elsif ($what eq "u") {
1414 push @result, $module->id;
1415 next if $seen{$file}++;
1416 next if $file =~ /^Contact/;
1418 unless ($headerdone++){
1419 $CPAN::Frontend->myprint("\n");
1420 $CPAN::Frontend->myprint(sprintf(
1422 "Package namespace",
1428 $latest = substr($latest,0,8) if length($latest) > 8;
1429 $have = substr($have,0,8) if length($have) > 8;
1430 $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
1431 $need{$module->id}++;
1435 $CPAN::Frontend->myprint("No modules found for @args\n");
1436 } elsif ($what eq "r") {
1437 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1441 if ($version_zeroes) {
1442 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1443 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1444 qq{a version number of 0\n});
1446 if ($version_undefs) {
1447 my $s_has = $version_undefs > 1 ? "s have" : " has";
1448 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1449 qq{parseable version number\n});
1455 #-> sub CPAN::Shell::r ;
1457 shift->_u_r_common("r",@_);
1460 #-> sub CPAN::Shell::u ;
1462 shift->_u_r_common("u",@_);
1465 #-> sub CPAN::Shell::autobundle ;
1468 my(@bundle) = $self->_u_r_common("a",@_);
1469 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1470 File::Path::mkpath($todir);
1471 unless (-d $todir) {
1472 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1475 my($y,$m,$d) = (localtime)[5,4,3];
1479 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1480 my($to) = MM->catfile($todir,"$me.pm");
1482 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1483 $to = MM->catfile($todir,"$me.pm");
1485 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1487 "package Bundle::$me;\n\n",
1488 "\$VERSION = '0.01';\n\n",
1492 "Bundle::$me - Snapshot of installation on ",
1493 $Config::Config{'myhostname'},
1496 "\n\n=head1 SYNOPSIS\n\n",
1497 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1498 "=head1 CONTENTS\n\n",
1499 join("\n", @bundle),
1500 "\n\n=head1 CONFIGURATION\n\n",
1502 "\n\n=head1 AUTHOR\n\n",
1503 "This Bundle has been generated automatically ",
1504 "by the autobundle routine in CPAN.pm.\n",
1507 $CPAN::Frontend->myprint("\nWrote bundle file
1511 #-> sub CPAN::Shell::expand ;
1514 my($type,@args) = @_;
1518 if ($arg =~ m|^/(.*)/$|) {
1521 my $class = "CPAN::$type";
1523 if (defined $regex) {
1524 for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
1527 $obj->id =~ /$regex/i
1531 $] < 5.00303 ### provide sort of compatibility with 5.003
1536 $obj->name =~ /$regex/i
1541 if ( $type eq 'Bundle' ) {
1542 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1544 if ($CPAN::META->exists($class,$xarg)) {
1545 $obj = $CPAN::META->instance($class,$xarg);
1546 } elsif ($CPAN::META->exists($class,$arg)) {
1547 $obj = $CPAN::META->instance($class,$arg);
1554 return wantarray ? @m : $m[0];
1557 #-> sub CPAN::Shell::format_result ;
1560 my($type,@args) = @_;
1561 @args = '/./' unless @args;
1562 my(@result) = $self->expand($type,@args);
1563 my $result = @result == 1 ?
1564 $result[0]->as_string :
1565 join "", map {$_->as_glimpse} @result;
1566 $result ||= "No objects of type $type found for argument @args\n";
1570 # The only reason for this method is currently to have a reliable
1571 # debugging utility that reveals which output is going through which
1572 # channel. No, I don't like the colors ;-)
1573 sub print_ornamented {
1574 my($self,$what,$ornament) = @_;
1576 my $ornamenting = 0; # turn the colors on
1579 unless (defined &color) {
1580 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1581 import Term::ANSIColor "color";
1583 *color = sub { return "" };
1587 for $line (split /\n/, $what) {
1588 $longest = length($line) if length($line) > $longest;
1590 my $sprintf = "%-" . $longest . "s";
1592 $what =~ s/(.*\n?)//m;
1595 my($nl) = chomp $line ? "\n" : "";
1596 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1597 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1605 my($self,$what) = @_;
1606 $self->print_ornamented($what, 'bold blue on_yellow');
1610 my($self,$what) = @_;
1611 $self->myprint($what);
1616 my($self,$what) = @_;
1617 $self->print_ornamented($what, 'bold red on_yellow');
1621 my($self,$what) = @_;
1622 $self->print_ornamented($what, 'bold red on_white');
1623 Carp::confess "died";
1627 my($self,$what) = @_;
1628 $self->print_ornamented($what, 'bold red on_white');
1632 #-> sub CPAN::Shell::rematein ;
1633 # RE-adme||MA-ke||TE-st||IN-stall
1636 my($meth,@some) = @_;
1638 if ($meth eq 'force') {
1640 $meth = shift @some;
1642 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1644 foreach $s (@some) {
1645 CPAN::Queue->new($s);
1647 while ($s = CPAN::Queue->first) {
1651 } elsif ($s =~ m|/|) { # looks like a file
1652 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1653 } elsif ($s =~ m|^Bundle::|) {
1654 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1656 $obj = $CPAN::META->instance('CPAN::Module',$s)
1657 if $CPAN::META->exists('CPAN::Module',$s);
1661 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1669 ($] < 5.00303 || $obj->can($pragma)); ###
1673 if ($]>=5.00303 && $obj->can('called_for')) {
1674 $obj->called_for($s);
1676 CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1679 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1680 $obj = $CPAN::META->instance('CPAN::Author',$s);
1681 $CPAN::Frontend->myprint(
1683 "Don't be silly, you can't $meth ",
1689 ->myprint(qq{Warning: Cannot $meth $s, }.
1690 qq{don\'t know what it is.
1695 to find objects with similar identifiers.
1698 CPAN::Queue->delete_first($s);
1702 #-> sub CPAN::Shell::force ;
1703 sub force { shift->rematein('force',@_); }
1704 #-> sub CPAN::Shell::get ;
1705 sub get { shift->rematein('get',@_); }
1706 #-> sub CPAN::Shell::readme ;
1707 sub readme { shift->rematein('readme',@_); }
1708 #-> sub CPAN::Shell::make ;
1709 sub make { shift->rematein('make',@_); }
1710 #-> sub CPAN::Shell::test ;
1711 sub test { shift->rematein('test',@_); }
1712 #-> sub CPAN::Shell::install ;
1713 sub install { shift->rematein('install',@_); }
1714 #-> sub CPAN::Shell::clean ;
1715 sub clean { shift->rematein('clean',@_); }
1716 #-> sub CPAN::Shell::look ;
1717 sub look { shift->rematein('look',@_); }
1721 #-> sub CPAN::FTP::ftp_get ;
1723 my($class,$host,$dir,$file,$target) = @_;
1725 qq[Going to fetch file [$file] from dir [$dir]
1726 on host [$host] as local [$target]\n]
1728 my $ftp = Net::FTP->new($host);
1729 return 0 unless defined $ftp;
1730 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1731 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1732 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1733 warn "Couldn't login on $host";
1736 unless ( $ftp->cwd($dir) ){
1737 warn "Couldn't cwd $dir";
1741 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1742 unless ( $ftp->get($file,$target) ){
1743 warn "Couldn't fetch $file from $host\n";
1746 $ftp->quit; # it's ok if this fails
1750 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1752 # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
1753 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997
1754 # leach,> ***************
1755 # leach,> *** 1562,1567 ****
1756 # leach,> --- 1562,1580 ----
1757 # leach,> return 1 if substr($url,0,4) eq "file";
1758 # leach,> return 1 unless $url =~ m|://([^/]+)|;
1759 # leach,> my $host = $1;
1760 # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1761 # leach,> + if ($proxy) {
1762 # leach,> + $proxy =~ m|://([^/:]+)|;
1763 # leach,> + $proxy = $1;
1764 # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1765 # leach,> + if ($noproxy) {
1766 # leach,> + if ($host !~ /$noproxy$/) {
1767 # leach,> + $host = $proxy;
1769 # leach,> + } else {
1770 # leach,> + $host = $proxy;
1773 # leach,> require Net::Ping;
1774 # leach,> return 1 unless $Net::Ping::VERSION >= 2;
1778 # this is quite optimistic and returns one on several occasions where
1779 # inappropriate. But this does no harm. It would do harm if we were
1780 # too pessimistic (as I was before the http_proxy
1782 my($self,$url) = @_;
1783 return 1; # we can't simply roll our own, firewalls may break ping
1784 return 0 unless $url;
1785 return 1 if substr($url,0,4) eq "file";
1786 return 1 unless $url =~ m|^(\w+)://([^/]+)|;
1787 my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
1789 return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
1791 return 1 unless $Net::Ping::VERSION >= 2;
1793 # 1.3101 had it different: only if the first eval raised an
1794 # exception we tried it with TCP. Now we are happy if icmp wins
1795 # the order and return, we don't even check for $@. Thanks to
1796 # thayer@uis.edu for the suggestion.
1797 eval {$p = Net::Ping->new("icmp");};
1798 return 1 if $p && ref($p) && $p->ping($host, 10);
1799 eval {$p = Net::Ping->new("tcp");};
1800 $CPAN::Frontend->mydie($@) if $@;
1801 return $p->ping($host, 10);
1804 #-> sub CPAN::FTP::localize ;
1805 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
1808 my($self,$file,$aslocal,$force) = @_;
1810 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
1811 unless defined $aslocal;
1812 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
1815 if ($^O eq 'MacOS') {
1816 my($name, $path) = File::Basename::fileparse($aslocal, '');
1817 if (length($name) > 31) {
1818 $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
1820 my $size = 31 - length($suf);
1821 while (length($name) > $size) {
1825 $aslocal = File::Spec->catfile($path, $name);
1829 return $aslocal if -f $aslocal && -r _ && !($force & 1);
1832 rename $aslocal, "$aslocal.bak";
1836 my($aslocal_dir) = File::Basename::dirname($aslocal);
1837 File::Path::mkpath($aslocal_dir);
1838 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
1839 qq{directory "$aslocal_dir".
1840 I\'ll continue, but if you encounter problems, they may be due
1841 to insufficient permissions.\n}) unless -w $aslocal_dir;
1843 # Inheritance is not easier to manage than a few if/else branches
1844 if ($CPAN::META->has_inst('LWP')) {
1845 require LWP::UserAgent;
1847 $Ua = LWP::UserAgent->new;
1849 $Ua->proxy('ftp', $var)
1850 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
1851 $Ua->proxy('http', $var)
1852 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1854 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1858 # Try the list of urls for each single object. We keep a record
1859 # where we did get a file from
1860 my(@reordered,$last);
1861 $CPAN::Config->{urllist} ||= [];
1862 $last = $#{$CPAN::Config->{urllist}};
1863 if ($force & 2) { # local cpans probably out of date, don't reorder
1864 @reordered = (0..$last);
1868 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
1870 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
1881 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
1883 @levels = qw/easy hard hardest/;
1885 @levels = qw/easy/ if $^O eq 'MacOS';
1886 for $level (@levels) {
1887 my $method = "host$level";
1888 my @host_seq = $level eq "easy" ?
1889 @reordered : 0..$last; # reordered has CDROM up front
1890 @host_seq = (0) unless @host_seq;
1891 my $ret = $self->$method(\@host_seq,$file,$aslocal);
1893 $Themethod = $level;
1894 $self->debug("level[$level]") if $CPAN::DEBUG;
1902 qq{Please check, if the URLs I found in your configuration file \(}.
1903 join(", ", @{$CPAN::Config->{urllist}}).
1904 qq{\) are valid. The urllist can be edited.},
1905 qq{E.g. with ``o conf urllist push ftp://myurl/''};
1906 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
1908 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
1910 rename "$aslocal.bak", $aslocal;
1911 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
1912 $self->ls($aslocal));
1919 my($self,$host_seq,$file,$aslocal) = @_;
1921 HOSTEASY: for $i (@$host_seq) {
1922 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
1923 unless ($self->is_reachable($url)) {
1924 $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
1928 $url .= "/" unless substr($url,-1) eq "/";
1930 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
1931 if ($url =~ /^file:/) {
1933 if ($CPAN::META->has_inst('LWP')) {
1935 my $u = URI::URL->new($url);
1937 } else { # works only on Unix, is poorly constructed, but
1938 # hopefully better than nothing.
1939 # RFC 1738 says fileurl BNF is
1940 # fileurl = "file://" [ host | "localhost" ] "/" fpath
1941 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
1943 ($l = $url) =~ s,^file://[^/]+,,; # discard the host part
1944 $l =~ s/^file://; # assume they meant file://localhost
1946 if ( -f $l && -r _) {
1950 # Maybe mirror has compressed it?
1952 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
1953 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
1960 if ($CPAN::META->has_inst('LWP')) {
1961 $CPAN::Frontend->myprint("Fetching with LWP:
1965 require LWP::UserAgent;
1966 $Ua = LWP::UserAgent->new;
1968 my $res = $Ua->mirror($url, $aslocal);
1969 if ($res->is_success) {
1972 } elsif ($url !~ /\.gz$/) {
1973 my $gzurl = "$url.gz";
1974 $CPAN::Frontend->myprint("Fetching with LWP:
1977 $res = $Ua->mirror($gzurl, "$aslocal.gz");
1978 if ($res->is_success &&
1979 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
1987 # Alan Burlison informed me that in firewall envs Net::FTP
1988 # can still succeed where LWP fails. So we do not skip
1989 # Net::FTP anymore when LWP is available.
1993 $self->debug("LWP not installed") if $CPAN::DEBUG;
1995 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
1996 # that's the nice and easy way thanks to Graham
1997 my($host,$dir,$getfile) = ($1,$2,$3);
1998 if ($CPAN::META->has_inst('Net::FTP')) {
2000 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2003 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2004 "aslocal[$aslocal]") if $CPAN::DEBUG;
2005 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2009 if ($aslocal !~ /\.gz$/) {
2010 my $gz = "$aslocal.gz";
2011 $CPAN::Frontend->myprint("Fetching with Net::FTP
2014 if (CPAN::FTP->ftp_get($host,
2018 CPAN::Tarzip->gunzip($gz,$aslocal)
2031 my($self,$host_seq,$file,$aslocal) = @_;
2033 # Came back if Net::FTP couldn't establish connection (or
2034 # failed otherwise) Maybe they are behind a firewall, but they
2035 # gave us a socksified (or other) ftp program...
2038 my($devnull) = $CPAN::Config->{devnull} || "";
2040 my($aslocal_dir) = File::Basename::dirname($aslocal);
2041 File::Path::mkpath($aslocal_dir);
2042 HOSTHARD: for $i (@$host_seq) {
2043 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2044 unless ($self->is_reachable($url)) {
2045 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2048 $url .= "/" unless substr($url,-1) eq "/";
2050 my($proto,$host,$dir,$getfile);
2052 # Courtesy Mark Conty mark_conty@cargill.com change from
2053 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2055 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2056 # proto not yet used
2057 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2059 next HOSTHARD; # who said, we could ftp anything except ftp?
2061 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2063 for $f ('lynx','ncftpget','ncftp') {
2064 next unless exists $CPAN::Config->{$f};
2065 $funkyftp = $CPAN::Config->{$f};
2066 next unless defined $funkyftp;
2067 next if $funkyftp =~ /^\s*$/;
2068 my($want_compressed);
2069 my $aslocal_uncompressed;
2070 ($aslocal_uncompressed = $aslocal) =~ s/\.gz//;
2071 my($source_switch) = "";
2072 $source_switch = " -source" if $funkyftp =~ /\blynx$/;
2073 $source_switch = " -c" if $funkyftp =~ /\bncftp$/;
2074 $CPAN::Frontend->myprint(
2076 Trying with "$funkyftp$source_switch" to get
2079 my($system) = "$funkyftp$source_switch '$url' $devnull > ".
2080 "$aslocal_uncompressed";
2081 $self->debug("system[$system]") if $CPAN::DEBUG;
2083 if (($wstatus = system($system)) == 0
2085 -s $aslocal_uncompressed # lynx returns 0 on my
2086 # system even if it fails
2088 if ($aslocal_uncompressed ne $aslocal) {
2089 # test gzip integrity
2091 CPAN::Tarzip->gtest($aslocal_uncompressed)
2093 rename $aslocal_uncompressed, $aslocal;
2095 CPAN::Tarzip->gzip($aslocal_uncompressed,
2096 "$aslocal_uncompressed.gz");
2101 } elsif ($url !~ /\.gz$/) {
2102 unlink $aslocal_uncompressed if
2103 -f $aslocal_uncompressed && -s _ == 0;
2104 my $gz = "$aslocal.gz";
2105 my $gzurl = "$url.gz";
2106 $CPAN::Frontend->myprint(
2108 Trying with "$funkyftp$source_switch" to get
2111 my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ".
2112 "$aslocal_uncompressed.gz";
2113 $self->debug("system[$system]") if $CPAN::DEBUG;
2115 if (($wstatus = system($system)) == 0
2117 -s "$aslocal_uncompressed.gz"
2119 # test gzip integrity
2120 if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) {
2121 CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz",
2124 rename $aslocal_uncompressed, $aslocal;
2129 unlink "$aslocal_uncompressed.gz" if
2130 -f "$aslocal_uncompressed.gz";
2133 my $estatus = $wstatus >> 8;
2134 my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : "";
2135 $CPAN::Frontend->myprint(qq{
2136 System call "$system"
2137 returned status $estatus (wstat $wstatus)$size
2145 my($self,$host_seq,$file,$aslocal) = @_;
2148 my($aslocal_dir) = File::Basename::dirname($aslocal);
2149 File::Path::mkpath($aslocal_dir);
2150 HOSTHARDEST: for $i (@$host_seq) {
2151 unless (length $CPAN::Config->{'ftp'}) {
2152 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2155 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2156 unless ($self->is_reachable($url)) {
2157 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2160 $url .= "/" unless substr($url,-1) eq "/";
2162 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2163 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2166 my($host,$dir,$getfile) = ($1,$2,$3);
2169 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2170 $ctime,$blksize,$blocks) = stat($aslocal);
2171 $timestamp = $mtime ||= 0;
2172 my($netrc) = CPAN::FTP::netrc->new;
2173 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2174 my $targetfile = File::Basename::basename($aslocal);
2180 map("cd $_", split "/", $dir), # RFC 1738
2182 "get $getfile $targetfile",
2185 if (! $netrc->netrc) {
2186 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2187 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2188 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2190 $netrc->contains($host))) if $CPAN::DEBUG;
2191 if ($netrc->protected) {
2192 $CPAN::Frontend->myprint(qq{
2193 Trying with external ftp to get
2195 As this requires some features that are not thoroughly tested, we\'re
2196 not sure, that we get it right....
2200 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2202 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2203 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2205 if ($mtime > $timestamp) {
2206 $CPAN::Frontend->myprint("GOT $aslocal\n");
2210 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2213 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2214 qq{correctly protected.\n});
2217 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2218 nor does it have a default entry\n");
2221 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2222 # then and login manually to host, using e-mail as
2224 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2228 "user anonymous $Config::Config{'cf_email'}"
2230 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2231 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2232 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2234 if ($mtime > $timestamp) {
2235 $CPAN::Frontend->myprint("GOT $aslocal\n");
2239 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2241 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2247 my($self,$command,@dialog) = @_;
2248 my $fh = FileHandle->new;
2249 $fh->open("|$command") or die "Couldn't open ftp: $!";
2250 foreach (@dialog) { $fh->print("$_\n") }
2251 $fh->close; # Wait for process to complete
2253 my $estatus = $wstatus >> 8;
2254 $CPAN::Frontend->myprint(qq{
2255 Subprocess "|$command"
2256 returned status $estatus (wstat $wstatus)
2260 # find2perl needs modularization, too, all the following is stolen
2264 my($self,$name) = @_;
2265 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2266 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2268 my($perms,%user,%group);
2272 $blocks = int(($blocks + 1) / 2);
2275 $blocks = int(($sizemm + 1023) / 1024);
2278 if (-f _) { $perms = '-'; }
2279 elsif (-d _) { $perms = 'd'; }
2280 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2281 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2282 elsif (-p _) { $perms = 'p'; }
2283 elsif (-S _) { $perms = 's'; }
2284 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2286 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2287 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2288 my $tmpmode = $mode;
2289 my $tmp = $rwx[$tmpmode & 7];
2291 $tmp = $rwx[$tmpmode & 7] . $tmp;
2293 $tmp = $rwx[$tmpmode & 7] . $tmp;
2294 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2295 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2296 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2299 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2300 my $group = $group{$gid} || $gid;
2302 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2304 my($moname) = $moname[$mon];
2305 if (-M _ > 365.25 / 2) {
2306 $timeyear = $year + 1900;
2309 $timeyear = sprintf("%02d:%02d", $hour, $min);
2312 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2326 package CPAN::FTP::netrc;
2330 my $file = MM->catfile($ENV{HOME},".netrc");
2332 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2333 $atime,$mtime,$ctime,$blksize,$blocks)
2338 my($fh,@machines,$hasdefault);
2340 $fh = FileHandle->new or die "Could not create a filehandle";
2342 if($fh->open($file)){
2343 $protected = ($mode & 077) == 0;
2345 NETRC: while (<$fh>) {
2346 my(@tokens) = split " ", $_;
2347 TOKEN: while (@tokens) {
2348 my($t) = shift @tokens;
2349 if ($t eq "default"){
2353 last TOKEN if $t eq "macdef";
2354 if ($t eq "machine") {
2355 push @machines, shift @tokens;
2360 $file = $hasdefault = $protected = "";
2364 'mach' => [@machines],
2366 'hasdefault' => $hasdefault,
2367 'protected' => $protected,
2371 sub hasdefault { shift->{'hasdefault'} }
2372 sub netrc { shift->{'netrc'} }
2373 sub protected { shift->{'protected'} }
2375 my($self,$mach) = @_;
2376 for ( @{$self->{'mach'}} ) {
2377 return 1 if $_ eq $mach;
2382 package CPAN::Complete;
2384 #-> sub CPAN::Complete::cpl ;
2386 my($word,$line,$pos) = @_;
2390 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2392 if ($line =~ s/^(force\s*)//) {
2400 ! a b d h i m o q r u autobundle clean
2401 make test install force reload look
2404 } elsif ( $line !~ /^[\!abdhimorutl]/ ) {
2406 } elsif ($line =~ /^a\s/) {
2407 @return = cplx('CPAN::Author',$word);
2408 } elsif ($line =~ /^b\s/) {
2409 @return = cplx('CPAN::Bundle',$word);
2410 } elsif ($line =~ /^d\s/) {
2411 @return = cplx('CPAN::Distribution',$word);
2412 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) {
2413 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2414 } elsif ($line =~ /^i\s/) {
2415 @return = cpl_any($word);
2416 } elsif ($line =~ /^reload\s/) {
2417 @return = cpl_reload($word,$line,$pos);
2418 } elsif ($line =~ /^o\s/) {
2419 @return = cpl_option($word,$line,$pos);
2426 #-> sub CPAN::Complete::cplx ;
2428 my($class, $word) = @_;
2429 grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
2432 #-> sub CPAN::Complete::cpl_any ;
2436 cplx('CPAN::Author',$word),
2437 cplx('CPAN::Bundle',$word),
2438 cplx('CPAN::Distribution',$word),
2439 cplx('CPAN::Module',$word),
2443 #-> sub CPAN::Complete::cpl_reload ;
2445 my($word,$line,$pos) = @_;
2447 my(@words) = split " ", $line;
2448 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2449 my(@ok) = qw(cpan index);
2450 return @ok if @words == 1;
2451 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2454 #-> sub CPAN::Complete::cpl_option ;
2456 my($word,$line,$pos) = @_;
2458 my(@words) = split " ", $line;
2459 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2460 my(@ok) = qw(conf debug);
2461 return @ok if @words == 1;
2462 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2464 } elsif ($words[1] eq 'index') {
2466 } elsif ($words[1] eq 'conf') {
2467 return CPAN::Config::cpl(@_);
2468 } elsif ($words[1] eq 'debug') {
2469 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2473 package CPAN::Index;
2475 #-> sub CPAN::Index::force_reload ;
2478 $CPAN::Index::last_time = 0;
2482 #-> sub CPAN::Index::reload ;
2484 my($cl,$force) = @_;
2487 # XXX check if a newer one is available. (We currently read it
2488 # from time to time)
2489 for ($CPAN::Config->{index_expire}) {
2490 $_ = 0.001 unless $_ > 0.001;
2492 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2497 my $needshort = $^O eq "dos";
2499 $cl->rd_authindex($cl
2501 "authors/01mailrc.txt.gz",
2503 File::Spec->catfile('authors', '01mailrc.gz') :
2504 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2507 $debug = "timing reading 01[".($t2 - $time)."]";
2509 return if $CPAN::Signal; # this is sometimes lengthy
2510 $cl->rd_modpacks($cl
2512 "modules/02packages.details.txt.gz",
2514 File::Spec->catfile('modules', '02packag.gz') :
2515 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2518 $debug .= "02[".($t2 - $time)."]";
2520 return if $CPAN::Signal; # this is sometimes lengthy
2523 "modules/03modlist.data.gz",
2525 File::Spec->catfile('modules', '03mlist.gz') :
2526 File::Spec->catfile('modules', '03modlist.data.gz'),
2529 $debug .= "03[".($t2 - $time)."]";
2531 CPAN->debug($debug) if $CPAN::DEBUG;
2534 #-> sub CPAN::Index::reload_x ;
2536 my($cl,$wanted,$localname,$force) = @_;
2537 $force |= 2; # means we're dealing with an index here
2538 CPAN::Config->load; # we should guarantee loading wherever we rely
2540 $localname ||= $wanted;
2541 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2545 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2548 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2549 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2550 qq{day$s. I\'ll use that.});
2553 $force |= 1; # means we're quite serious about it.
2555 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2558 #-> sub CPAN::Index::rd_authindex ;
2560 my($cl, $index_target) = @_;
2562 return unless defined $index_target;
2563 $CPAN::Frontend->myprint("Going to read $index_target\n");
2564 # my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2565 # while ($_ = $fh->READLINE) {
2568 tie *FH, CPAN::Tarzip, $index_target;
2570 push @lines, split /\012/ while <FH>;
2572 my($userid,$fullname,$email) =
2573 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2574 next unless $userid && $fullname && $email;
2576 # instantiate an author object
2577 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2578 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2579 return if $CPAN::Signal;
2584 my($self,$dist) = @_;
2585 $dist = $self->{'id'} unless defined $dist;
2586 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2590 #-> sub CPAN::Index::rd_modpacks ;
2592 my($cl, $index_target) = @_;
2594 return unless defined $index_target;
2595 $CPAN::Frontend->myprint("Going to read $index_target\n");
2596 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2598 while ($_ = $fh->READLINE) {
2600 my @ls = map {"$_\n"} split /\n/, $_;
2601 unshift @ls, "\n" x length($1) if /^(\n+)/;
2605 my $shift = shift(@lines);
2606 last if $shift =~ /^\s*$/;
2610 my($mod,$version,$dist) = split;
2611 ### $version =~ s/^\+//;
2613 # if it is a bundle, instatiate a bundle object
2614 my($bundle,$id,$userid);
2616 if ($mod eq 'CPAN' &&
2618 CPAN::Queue->exists('Bundle::CPAN') ||
2619 CPAN::Queue->exists('CPAN')
2623 if ($version > $CPAN::VERSION){
2624 $CPAN::Frontend->myprint(qq{
2625 There\'s a new CPAN.pm version (v$version) available!
2626 You might want to try
2627 install Bundle::CPAN
2629 without quitting the current session. It should be a seamless upgrade
2630 while we are running...
2633 $CPAN::Frontend->myprint(qq{\n});
2635 last if $CPAN::Signal;
2636 } elsif ($mod =~ /^Bundle::(.*)/) {
2641 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2642 # warn "made mod[$mod]a bundle";
2643 # Let's make it a module too, because bundles have so much
2644 # in common with modules
2645 $CPAN::META->instance('CPAN::Module',$mod);
2646 # warn "made mod[$mod]a module";
2648 # This "next" makes us faster but if the job is running long, we ignore
2649 # rereads which is bad. So we have to be a bit slower again.
2650 # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2655 # instantiate a module object
2656 $id = $CPAN::META->instance('CPAN::Module',$mod);
2659 if ($id->cpan_file ne $dist){
2660 $userid = $cl->userid($dist);
2662 'CPAN_USERID' => $userid,
2663 'CPAN_VERSION' => $version,
2664 'CPAN_FILE' => $dist
2668 # instantiate a distribution object
2669 unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2670 $CPAN::META->instance(
2671 'CPAN::Distribution' => $dist
2673 'CPAN_USERID' => $userid
2677 return if $CPAN::Signal;
2682 #-> sub CPAN::Index::rd_modlist ;
2684 my($cl,$index_target) = @_;
2685 return unless defined $index_target;
2686 $CPAN::Frontend->myprint("Going to read $index_target\n");
2687 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2690 while ($_ = $fh->READLINE) {
2692 my @ls = map {"$_\n"} split /\n/, $_;
2693 unshift @ls, "\n" x length($1) if /^(\n+)/;
2697 my $shift = shift(@eval);
2698 if ($shift =~ /^Date:\s+(.*)/){
2699 return if $date_of_03 eq $1;
2702 last if $shift =~ /^\s*$/;
2705 push @eval, q{CPAN::Modulelist->data;};
2707 my($comp) = Safe->new("CPAN::Safe1");
2708 my($eval) = join("", @eval);
2709 my $ret = $comp->reval($eval);
2710 Carp::confess($@) if $@;
2711 return if $CPAN::Signal;
2713 my $obj = $CPAN::META->instance(CPAN::Module,$_);
2714 $obj->set(%{$ret->{$_}});
2715 return if $CPAN::Signal;
2719 package CPAN::InfoObj;
2721 #-> sub CPAN::InfoObj::new ;
2722 sub new { my $this = bless {}, shift; %$this = @_; $this }
2724 #-> sub CPAN::InfoObj::set ;
2726 my($self,%att) = @_;
2727 my(%oldatt) = %$self;
2728 %$self = (%oldatt, %att);
2731 #-> sub CPAN::InfoObj::id ;
2732 sub id { shift->{'ID'} }
2734 #-> sub CPAN::InfoObj::as_glimpse ;
2738 my $class = ref($self);
2739 $class =~ s/^CPAN:://;
2740 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
2744 #-> sub CPAN::InfoObj::as_string ;
2748 my $class = ref($self);
2749 $class =~ s/^CPAN:://;
2750 push @m, $class, " id = $self->{ID}\n";
2751 for (sort keys %$self) {
2754 if ($_ eq "CPAN_USERID") {
2755 $extra .= " (".$self->author;
2756 my $email; # old perls!
2757 if ($email = $CPAN::META->instance(CPAN::Author,
2760 $extra .= " <$email>";
2762 $extra .= " <no email>";
2766 if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
2767 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
2769 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
2775 #-> sub CPAN::InfoObj::author ;
2778 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
2781 package CPAN::Author;
2783 #-> sub CPAN::Author::as_glimpse ;
2787 my $class = ref($self);
2788 $class =~ s/^CPAN:://;
2789 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
2793 # Dead code, I would have liked to have,,, but it was never reached,,,
2796 # return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
2799 #-> sub CPAN::Author::fullname ;
2800 sub fullname { shift->{'FULLNAME'} }
2802 #-> sub CPAN::Author::email ;
2803 sub email { shift->{'EMAIL'} }
2805 package CPAN::Distribution;
2807 #-> sub CPAN::Distribution::called_for ;
2810 $self->{'CALLED_FOR'} = $id if defined $id;
2811 return $self->{'CALLED_FOR'};
2814 #-> sub CPAN::Distribution::get ;
2819 exists $self->{'build_dir'} and push @e,
2820 "Unwrapped into directory $self->{'build_dir'}";
2821 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
2826 $CPAN::Config->{keep_source_where},
2829 split("/",$self->{ID})
2832 $self->debug("Doing localize") if $CPAN::DEBUG;
2834 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
2835 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
2836 $self->{localfile} = $local_file;
2837 my $builddir = $CPAN::META->{cachemgr}->dir;
2838 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
2839 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2842 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
2843 if ($CPAN::META->has_inst('MD5')) {
2844 $self->debug("MD5 is installed, verifying");
2847 $self->debug("MD5 is NOT installed");
2849 $self->debug("Removing tmp") if $CPAN::DEBUG;
2850 File::Path::rmtree("tmp");
2851 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
2853 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
2854 if (! $local_file) {
2855 Carp::croak "bad download, can't do anything :-(\n";
2856 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
2857 $self->untar_me($local_file);
2858 } elsif ( $local_file =~ /\.zip$/i ) {
2859 $self->unzip_me($local_file);
2860 } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
2861 $self->pm2dir_me($local_file);
2863 $self->{archived} = "NO";
2865 chdir File::Spec->updir;
2866 if ($self->{archived} ne 'NO') {
2867 chdir File::Spec->catdir(File::Spec->curdir, "tmp");
2868 # Let's check if the package has its own directory.
2869 my $dh = DirHandle->new(File::Spec->curdir)
2870 or Carp::croak("Couldn't opendir .: $!");
2871 my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
2873 my ($distdir,$packagedir);
2874 if (@readdir == 1 && -d $readdir[0]) {
2875 $distdir = $readdir[0];
2876 $packagedir = MM->catdir($builddir,$distdir);
2877 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
2878 File::Path::rmtree($packagedir);
2879 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
2881 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
2882 $pragmatic_dir =~ s/\W_//g;
2883 $pragmatic_dir++ while -d "../$pragmatic_dir";
2884 $packagedir = MM->catdir($builddir,$pragmatic_dir);
2885 File::Path::mkpath($packagedir);
2887 for $f (@readdir) { # is already without "." and ".."
2888 my $to = MM->catdir($packagedir,$f);
2889 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
2892 $self->{'build_dir'} = $packagedir;
2893 chdir File::Spec->updir;
2895 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
2897 File::Path::rmtree("tmp");
2898 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
2899 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
2900 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
2902 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
2903 unless (-f $makefilepl) {
2904 my($configure) = MM->catfile($packagedir,"Configure");
2905 if (-f $configure) {
2906 # do we have anything to do?
2907 $self->{'configure'} = $configure;
2908 } elsif (-f MM->catfile($packagedir,"Makefile")) {
2909 $CPAN::Frontend->myprint(qq{
2910 Package comes with a Makefile and without a Makefile.PL.
2911 We\'ll try to build it with that Makefile then.
2913 $self->{writemakefile} = "YES";
2916 my $fh = FileHandle->new(">$makefilepl")
2917 or Carp::croak("Could not open >$makefilepl");
2918 my $cf = $self->called_for || "unknown";
2920 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
2921 # because there was no Makefile.PL supplied.
2922 # Autogenerated on: }.scalar localtime().qq{
2924 use ExtUtils::MakeMaker;
2925 WriteMakefile(NAME => q[$cf]);
2928 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
2929 Writing one on our own (calling it $cf)\n});
2937 my($self,$local_file) = @_;
2938 $self->{archived} = "tar";
2939 if (CPAN::Tarzip->untar($local_file)) {
2940 $self->{unwrapped} = "YES";
2942 $self->{unwrapped} = "NO";
2947 my($self,$local_file) = @_;
2948 $self->{archived} = "zip";
2949 my $system = "$CPAN::Config->{unzip} $local_file";
2950 if (system($system) == 0) {
2951 $self->{unwrapped} = "YES";
2953 $self->{unwrapped} = "NO";
2958 my($self,$local_file) = @_;
2959 $self->{archived} = "pm";
2960 my $to = File::Basename::basename($local_file);
2961 $to =~ s/\.(gz|Z)$//;
2962 if (CPAN::Tarzip->gunzip($local_file,$to)) {
2963 $self->{unwrapped} = "YES";
2965 $self->{unwrapped} = "NO";
2969 #-> sub CPAN::Distribution::new ;
2971 my($class,%att) = @_;
2973 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
2975 my $this = { %att };
2976 return bless $this, $class;
2979 #-> sub CPAN::Distribution::look ;
2982 if ( $CPAN::Config->{'shell'} ) {
2983 $CPAN::Frontend->myprint(qq{
2984 Trying to open a subshell in the build directory...
2987 $CPAN::Frontend->myprint(qq{
2988 Your configuration does not define a value for subshells.
2989 Please define it with "o conf shell <your shell>"
2993 my $dist = $self->id;
2994 my $dir = $self->dir or $self->get;
2997 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2998 my $pwd = CPAN->$getcwd();
3000 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3001 system($CPAN::Config->{'shell'}) == 0
3002 or $CPAN::Frontend->mydie("Subprocess shell error");
3006 #-> sub CPAN::Distribution::readme ;
3009 my($dist) = $self->id;
3010 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3011 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3015 $CPAN::Config->{keep_source_where},
3018 split("/","$sans.readme"),
3020 $self->debug("Doing localize") if $CPAN::DEBUG;
3021 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3023 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3025 if ($^O eq 'MacOS') {
3026 ExtUtils::MM_MacOS::launch_file($local_file);
3030 my $fh_pager = FileHandle->new;
3031 local($SIG{PIPE}) = "IGNORE";
3032 $fh_pager->open("|$CPAN::Config->{'pager'}")
3033 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3034 my $fh_readme = FileHandle->new;
3035 $fh_readme->open($local_file)
3036 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3037 $CPAN::Frontend->myprint(qq{
3040 with pager "$CPAN::Config->{'pager'}"
3043 $fh_pager->print(<$fh_readme>);
3046 #-> sub CPAN::Distribution::verifyMD5 ;
3051 $self->{MD5_STATUS} ||= "";
3052 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3053 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3055 my($lc_want,$lc_file,@local,$basename);
3056 @local = split("/",$self->{ID});
3058 push @local, "CHECKSUMS";
3060 MM->catfile($CPAN::Config->{keep_source_where},
3061 "authors", "id", @local);
3066 $self->MD5_check_file($lc_want)
3068 return $self->{MD5_STATUS} = "OK";
3070 $lc_file = CPAN::FTP->localize("authors/id/@local",
3073 $local[-1] .= ".gz";
3074 $lc_file = CPAN::FTP->localize("authors/id/@local",
3077 $lc_file =~ s/\.gz$//;
3078 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3083 $self->MD5_check_file($lc_file);
3086 #-> sub CPAN::Distribution::MD5_check_file ;
3087 sub MD5_check_file {
3088 my($self,$chk_file) = @_;
3089 my($cksum,$file,$basename);
3090 $file = $self->{localfile};
3091 $basename = File::Basename::basename($file);
3092 my $fh = FileHandle->new;
3093 if (open $fh, $chk_file){
3096 $eval =~ s/\015?\012/\n/g;
3098 my($comp) = Safe->new();
3099 $cksum = $comp->reval($eval);
3101 rename $chk_file, "$chk_file.bad";
3102 Carp::confess($@) if $@;
3105 Carp::carp "Could not open $chk_file for reading";
3108 if (exists $cksum->{$basename}{md5}) {
3109 $self->debug("Found checksum for $basename:" .
3110 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3114 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3116 $fh = CPAN::Tarzip->TIEHANDLE($file);
3119 # had to inline it, when I tied it, the tiedness got lost on
3120 # the call to eq_MD5. (Jan 1998)
3124 while ($fh->READ($ref, 4096)){
3127 my $hexdigest = $md5->hexdigest;
3128 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3132 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3133 return $self->{MD5_STATUS} = "OK";
3135 $CPAN::Frontend->myprint(qq{Checksum mismatch for }.
3136 qq{distribution file. }.
3137 qq{Please investigate.\n\n}.
3139 $CPAN::META->instance(
3141 $self->{CPAN_USERID}
3143 my $wrap = qq{I\'d recommend removing $file. It seems to
3144 be a bogus file. Maybe you have configured your \`urllist\' with a
3145 bad URL. Please check this array with \`o conf urllist\', and
3147 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3148 $CPAN::Frontend->myprint("\n\n");
3152 # close $fh if fileno($fh);
3154 $self->{MD5_STATUS} ||= "";
3155 if ($self->{MD5_STATUS} eq "NIL") {
3156 $CPAN::Frontend->myprint(qq{
3157 No md5 checksum for $basename in local $chk_file.
3160 unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
3163 $self->{MD5_STATUS} = "NIL";
3168 #-> sub CPAN::Distribution::eq_MD5 ;
3170 my($self,$fh,$expectMD5) = @_;
3173 while (read($fh, $data, 4096)){
3176 # $md5->addfile($fh);
3177 my $hexdigest = $md5->hexdigest;
3178 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3179 $hexdigest eq $expectMD5;
3182 #-> sub CPAN::Distribution::force ;
3185 $self->{'force_update'}++;
3187 MD5_STATUS archived build_dir localfile make install unwrapped
3188 writemakefile have_sponsored
3190 delete $self->{$att};
3196 my $file = File::Basename::basename($self->id);
3197 return unless $file =~ m{ ^ perl
3200 (\d{3}(_[0-4][0-9])?)
3207 #-> sub CPAN::Distribution::perl ;
3210 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3211 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3212 my $pwd = CPAN->$getcwd();
3213 my $candidate = MM->catfile($pwd,$^X);
3214 $perl ||= $candidate if MM->maybe_command($candidate);
3216 my ($component,$perl_name);
3217 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3218 PATH_COMPONENT: foreach $component (MM->path(),
3219 $Config::Config{'binexp'}) {
3220 next unless defined($component) && $component;
3221 my($abs) = MM->catfile($component,$perl_name);
3222 if (MM->maybe_command($abs)) {
3232 #-> sub CPAN::Distribution::make ;
3235 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3236 # Emergency brake if they said install Pippi and get newest perl
3237 if ($self->isa_perl) {
3239 $self->called_for ne $self->id && ! $self->{'force_update'}
3241 $CPAN::Frontend->mydie(sprintf qq{
3242 The most recent version "%s" of the module "%s"
3243 comes with the current version of perl (%s).
3244 I\'ll build that only if you ask for something like
3249 $CPAN::META->instance(
3262 $self->{archived} eq "NO" and push @e,
3263 "Is neither a tar nor a zip archive.";
3265 $self->{unwrapped} eq "NO" and push @e,
3266 "had problems unarchiving. Please build manually";
3268 exists $self->{writemakefile} &&
3269 $self->{writemakefile} eq "NO" and push @e,
3270 "Had some problem writing Makefile";
3272 defined $self->{'make'} and push @e,
3273 "Has already been processed within this session";
3275 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3277 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
3278 my $builddir = $self->dir;
3279 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3280 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3282 if ($^O eq 'MacOS') {
3283 ExtUtils::MM_MacOS::make($self);
3288 if ($self->{'configure'}) {
3289 $system = $self->{'configure'};
3291 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3293 # This needs a handler that can be turned on or off:
3294 # $switch = "-MExtUtils::MakeMaker ".
3295 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3297 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3299 unless (exists $self->{writemakefile}) {
3300 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3303 if ($CPAN::Config->{inactivity_timeout}) {
3305 alarm $CPAN::Config->{inactivity_timeout};
3306 local $SIG{CHLD}; # = sub { wait };
3307 if (defined($pid = fork)) {
3312 # note, this exec isn't necessary if
3313 # inactivity_timeout is 0. On the Mac I'd
3314 # suggest, we set it always to 0.
3318 $CPAN::Frontend->myprint("Cannot fork: $!");
3326 $CPAN::Frontend->myprint($@);
3327 $self->{writemakefile} = "NO - $@";
3332 $ret = system($system);
3334 $self->{writemakefile} = "NO";
3338 $self->{writemakefile} = "YES";
3340 return if $CPAN::Signal;
3341 if (my @prereq = $self->needs_prereq){
3343 $CPAN::Frontend->myprint("---- Dependencies detected ".
3344 "during [$id] -----\n");
3346 for my $p (@prereq) {
3347 $CPAN::Frontend->myprint(" $p\n");
3350 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3352 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3353 require ExtUtils::MakeMaker;
3354 my $answer = ExtUtils::MakeMaker::prompt(
3355 "Shall I follow them and prepend them to the queue
3356 of modules we are processing right now?", "yes");
3357 $follow = $answer =~ /^\s*y/i;
3360 $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n");
3363 CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3367 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3368 if (system($system) == 0) {
3369 $CPAN::Frontend->myprint(" $system -- OK\n");
3370 $self->{'make'} = "YES";
3372 $self->{writemakefile} = "YES";
3373 $self->{'make'} = "NO";
3374 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3378 #-> sub CPAN::Distribution::needs_prereq ;
3381 return unless -f "Makefile"; # we cannot say much
3382 my $fh = FileHandle->new("<Makefile") or
3383 $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3388 last if /MakeMaker post_initialize section/;
3390 \s+PREREQ_PM\s+=>\s+(.+)
3393 # warn "Found prereq expr[$p]";
3395 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){
3401 my $mo = $CPAN::META->instance("CPAN::Module",$p);
3402 next if $mo->uptodate;
3403 # it's not needed, so don't push it. We cannot omit this step, because
3404 # if 'force' is in effect, nobody else will check.
3405 if ($self->{'have_sponsored'}{$p}++){
3406 # We have already sponsored it and for some reason it's still
3407 # not available. So we do nothing. Or what should we do?
3408 # if we push it again, we have a potential infinite loop
3416 #-> sub CPAN::Distribution::test ;
3420 return if $CPAN::Signal;
3421 $CPAN::Frontend->myprint("Running make test\n");
3424 exists $self->{'make'} or push @e,
3425 "Make had some problems, maybe interrupted? Won't test";
3427 exists $self->{'make'} and
3428 $self->{'make'} eq 'NO' and
3429 push @e, "Oops, make had returned bad status";
3431 exists $self->{'build_dir'} or push @e, "Has no own directory";
3432 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3434 chdir $self->{'build_dir'} or
3435 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3436 $self->debug("Changed directory to $self->{'build_dir'}")
3439 if ($^O eq 'MacOS') {
3440 ExtUtils::MM_MacOS::make_test($self);
3444 my $system = join " ", $CPAN::Config->{'make'}, "test";
3445 if (system($system) == 0) {
3446 $CPAN::Frontend->myprint(" $system -- OK\n");
3447 $self->{'make_test'} = "YES";
3449 $self->{'make_test'} = "NO";
3450 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3454 #-> sub CPAN::Distribution::clean ;
3457 $CPAN::Frontend->myprint("Running make clean\n");
3460 exists $self->{'build_dir'} or push @e, "Has no own directory";
3461 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3463 chdir $self->{'build_dir'} or
3464 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3465 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3467 if ($^O eq 'MacOS') {
3468 ExtUtils::MM_MacOS::make_clean($self);
3472 my $system = join " ", $CPAN::Config->{'make'}, "clean";
3473 if (system($system) == 0) {
3474 $CPAN::Frontend->myprint(" $system -- OK\n");
3477 # Hmmm, what to do if make clean failed?
3481 #-> sub CPAN::Distribution::install ;
3485 return if $CPAN::Signal;
3486 $CPAN::Frontend->myprint("Running make install\n");
3489 exists $self->{'build_dir'} or push @e, "Has no own directory";
3491 exists $self->{'make'} or push @e,
3492 "Make had some problems, maybe interrupted? Won't install";
3494 exists $self->{'make'} and
3495 $self->{'make'} eq 'NO' and
3496 push @e, "Oops, make had returned bad status";
3498 push @e, "make test had returned bad status, ".
3499 "won't install without force"
3500 if exists $self->{'make_test'} and
3501 $self->{'make_test'} eq 'NO' and
3502 ! $self->{'force_update'};
3504 exists $self->{'install'} and push @e,
3505 $self->{'install'} eq "YES" ?
3506 "Already done" : "Already tried without success";
3508 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3510 chdir $self->{'build_dir'} or
3511 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3512 $self->debug("Changed directory to $self->{'build_dir'}")
3515 if ($^O eq 'MacOS') {
3516 ExtUtils::MM_MacOS::make_install($self);
3520 my $system = join(" ", $CPAN::Config->{'make'},
3521 "install", $CPAN::Config->{make_install_arg});
3522 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
3523 my($pipe) = FileHandle->new("$system $stderr |");
3526 $CPAN::Frontend->myprint($_);
3531 $CPAN::Frontend->myprint(" $system -- OK\n");
3532 return $self->{'install'} = "YES";
3534 $self->{'install'} = "NO";
3535 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3536 if ($makeout =~ /permission/s && $> > 0) {
3537 $CPAN::Frontend->myprint(qq{ You may have to su }.
3538 qq{to root to install the package\n});
3543 #-> sub CPAN::Distribution::dir ;
3545 shift->{'build_dir'};
3548 package CPAN::Bundle;
3550 #-> sub CPAN::Bundle::as_string ;
3554 $self->{INST_VERSION} = $self->inst_version;
3555 return $self->SUPER::as_string;
3558 #-> sub CPAN::Bundle::contains ;
3561 my($parsefile) = $self->inst_file;
3562 my($id) = $self->id;
3563 $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
3564 unless ($parsefile) {
3565 # Try to get at it in the cpan directory
3566 $self->debug("no parsefile") if $CPAN::DEBUG;
3567 Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
3568 my $dist = $CPAN::META->instance('CPAN::Distribution',
3569 $self->{CPAN_FILE});
3571 $self->debug($dist->as_string) if $CPAN::DEBUG;
3572 my($todir) = $CPAN::Config->{'cpan_home'};
3573 my(@me,$from,$to,$me);
3574 @me = split /::/, $self->id;
3576 $me = MM->catfile(@me);
3577 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
3578 $to = MM->catfile($todir,$me);
3579 File::Path::mkpath(File::Basename::dirname($to));
3580 File::Copy::copy($from, $to)
3581 or Carp::confess("Couldn't copy $from to $to: $!");
3585 my $fh = FileHandle->new;
3587 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
3589 $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
3591 $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 :
3592 m/^=head1\s+CONTENTS/ ? 1 : $inpod;
3597 push @result, (split " ", $_, 2)[0];
3600 delete $self->{STATUS};
3601 $self->{CONTAINS} = join ", ", @result;
3602 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
3604 $CPAN::Frontend->mywarn(qq{
3605 The bundle file "$parsefile" may be a broken
3606 bundlefile. It seems not to contain any bundle definition.
3607 Please check the file and if it is bogus, please delete it.
3608 Sorry for the inconvenience.
3614 #-> sub CPAN::Bundle::find_bundle_file
3615 sub find_bundle_file {
3616 my($self,$where,$what) = @_;
3617 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
3618 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
3619 ### my $bu = MM->catfile($where,$what);
3620 ### return $bu if -f $bu;
3621 my $manifest = MM->catfile($where,"MANIFEST");
3622 unless (-f $manifest) {
3623 require ExtUtils::Manifest;
3624 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3625 my $cwd = CPAN->$getcwd();
3627 ExtUtils::Manifest::mkmanifest();
3630 my $fh = FileHandle->new($manifest)
3631 or Carp::croak("Couldn't open $manifest: $!");
3634 if ($^O eq 'MacOS') {
3637 $what2 =~ s/:Bundle://;
3640 $what2 =~ s|Bundle/||;
3645 my($file) = /(\S+)/;
3646 if ($file =~ m|\Q$what\E$|) {
3648 # return MM->catfile($where,$bu); # bad
3651 # retry if she managed to
3652 # have no Bundle directory
3653 $bu = $file if $file =~ m|\Q$what2\E$|;
3655 $bu =~ tr|/|:| if $^O eq 'MacOS';
3656 return MM->catfile($where, $bu) if $bu;
3657 Carp::croak("Couldn't find a Bundle file in $where");
3660 #-> sub CPAN::Bundle::inst_file ;
3664 ($me = $self->id) =~ s/.*://;
3665 ## my(@me,$inst_file);
3666 ## @me = split /::/, $self->id;
3667 ## $me[-1] .= ".pm";
3668 $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
3669 "Bundle", "$me.pm");
3671 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3673 $self->SUPER::inst_file;
3674 # return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3675 # return $self->{'INST_FILE'}; # even if undefined?
3678 #-> sub CPAN::Bundle::rematein ;
3680 my($self,$meth) = @_;
3681 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
3682 my($id) = $self->id;
3683 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
3684 unless $self->inst_file || $self->{CPAN_FILE};
3686 for $s ($self->contains) {
3687 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
3688 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
3689 if ($type eq 'CPAN::Distribution') {
3690 $CPAN::Frontend->mywarn(qq{
3691 The Bundle }.$self->id.qq{ contains
3692 explicitly a file $s.
3696 # possibly noisy action:
3697 my $obj = $CPAN::META->instance($type,$s);
3699 my $success = $obj->can("uptodate") ? $obj->uptodate : 0;
3700 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
3701 $fail{$s} = 1 unless $success;
3703 # recap with less noise
3704 if ( $meth eq "install") {
3706 $CPAN::Frontend->myprint(qq{\nBundle summary: }.
3707 qq{The following items seem to }.
3708 qq{have had installation problems:\n});
3709 for $s ($self->contains) {
3710 $CPAN::Frontend->myprint( "$s " ) if $fail{$s};
3712 $CPAN::Frontend->myprint(qq{\n});
3714 $self->{'install'} = 'YES';
3719 #sub CPAN::Bundle::xs_file
3721 # If a bundle contains another that contains an xs_file we have
3722 # here, we just don't bother I suppose
3726 #-> sub CPAN::Bundle::force ;
3727 sub force { shift->rematein('force',@_); }
3728 #-> sub CPAN::Bundle::get ;
3729 sub get { shift->rematein('get',@_); }
3730 #-> sub CPAN::Bundle::make ;
3731 sub make { shift->rematein('make',@_); }
3732 #-> sub CPAN::Bundle::test ;
3733 sub test { shift->rematein('test',@_); }
3734 #-> sub CPAN::Bundle::install ;
3737 $self->rematein('install',@_);
3739 #-> sub CPAN::Bundle::clean ;
3740 sub clean { shift->rematein('clean',@_); }
3742 #-> sub CPAN::Bundle::readme ;
3745 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
3746 No File found for bundle } . $self->id . qq{\n}), return;
3747 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
3748 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
3751 package CPAN::Module;
3753 #-> sub CPAN::Module::as_glimpse ;
3757 my $class = ref($self);
3758 $class =~ s/^CPAN:://;
3759 push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
3764 #-> sub CPAN::Module::as_string ;
3768 CPAN->debug($self) if $CPAN::DEBUG;
3769 my $class = ref($self);
3770 $class =~ s/^CPAN:://;
3772 push @m, $class, " id = $self->{ID}\n";
3773 my $sprintf = " %-12s %s\n";
3774 push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
3775 if $self->{description};
3776 my $sprintf2 = " %-12s %s (%s)\n";
3778 if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
3780 if ($author = CPAN::Shell->expand('Author',$userid)) {
3783 if ($m = $author->email) {
3790 $author->fullname . $email
3794 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
3795 if $self->{CPAN_VERSION};
3796 push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
3797 if $self->{CPAN_FILE};
3798 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
3799 my(%statd,%stats,%statl,%stati);
3800 @statd{qw,? i c a b R M S,} = qw,unknown idea
3801 pre-alpha alpha beta released mature standard,;
3802 @stats{qw,? m d u n,} = qw,unknown mailing-list
3803 developer comp.lang.perl.* none,;
3804 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
3805 @stati{qw,? f r O h,} = qw,unknown functions
3806 references+ties object-oriented hybrid,;
3807 $statd{' '} = 'unknown';
3808 $stats{' '} = 'unknown';
3809 $statl{' '} = 'unknown';
3810 $stati{' '} = 'unknown';
3818 $statd{$self->{statd}},
3819 $stats{$self->{stats}},
3820 $statl{$self->{statl}},
3821 $stati{$self->{stati}}
3822 ) if $self->{statd};
3823 my $local_file = $self->inst_file;
3825 $self->{MANPAGE} ||= $self->manpage_headline($local_file);
3828 for $item (qw/MANPAGE CONTAINS/) {
3829 push @m, sprintf($sprintf, $item, $self->{$item})
3830 if exists $self->{$item};
3832 push @m, sprintf($sprintf, 'INST_FILE',
3833 $local_file || "(not installed)");
3834 push @m, sprintf($sprintf, 'INST_VERSION',
3835 $self->inst_version) if $local_file;
3839 sub manpage_headline {
3840 my($self,$local_file) = @_;
3841 my(@local_file) = $local_file;
3842 $local_file =~ s/\.pm$/.pod/;
3843 push @local_file, $local_file;
3845 for $locf (@local_file) {
3846 next unless -f $locf;
3847 my $fh = FileHandle->new($locf)
3848 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
3852 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
3853 m/^=head1\s+NAME/ ? 1 : $inpod;
3866 #-> sub CPAN::Module::cpan_file ;
3869 CPAN->debug($self->id) if $CPAN::DEBUG;
3870 unless (defined $self->{'CPAN_FILE'}) {
3871 CPAN::Index->reload;
3873 if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
3874 return $self->{'CPAN_FILE'};
3875 } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
3876 my $fullname = $CPAN::META->instance(CPAN::Author,
3877 $self->{'userid'})->fullname;
3878 my $email = $CPAN::META->instance(CPAN::Author,
3879 $self->{'userid'})->email;
3880 unless (defined $fullname && defined $email) {
3881 return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
3883 return "Contact Author $fullname <$email>";
3889 *name = \&cpan_file;
3891 #-> sub CPAN::Module::cpan_version ;
3894 $self->{'CPAN_VERSION'} = 'undef'
3895 unless defined $self->{'CPAN_VERSION'}; # I believe this is
3896 # always a bug in the
3897 # index and should be
3899 # but usually I find
3901 # and do not want to
3904 $self->{'CPAN_VERSION'};
3907 #-> sub CPAN::Module::force ;
3910 $self->{'force_update'}++;
3913 #-> sub CPAN::Module::rematein ;
3915 my($self,$meth) = @_;
3916 $self->debug($self->id) if $CPAN::DEBUG;
3917 my $cpan_file = $self->cpan_file;
3918 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
3919 $CPAN::Frontend->mywarn(sprintf qq{
3920 The module %s isn\'t available on CPAN.
3922 Either the module has not yet been uploaded to CPAN, or it is
3923 temporary unavailable. Please contact the author to find out
3924 more about the status. Try ``i %s''.
3931 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
3932 $pack->called_for($self->id);
3933 $pack->force if exists $self->{'force_update'};
3935 delete $self->{'force_update'};
3938 #-> sub CPAN::Module::readme ;
3939 sub readme { shift->rematein('readme') }
3940 #-> sub CPAN::Module::look ;
3941 sub look { shift->rematein('look') }
3942 #-> sub CPAN::Module::get ;
3943 sub get { shift->rematein('get',@_); }
3944 #-> sub CPAN::Module::make ;
3945 sub make { shift->rematein('make') }
3946 #-> sub CPAN::Module::test ;
3947 sub test { shift->rematein('test') }
3948 #-> sub CPAN::Module::uptodate ;
3951 my($latest) = $self->cpan_version;
3953 my($inst_file) = $self->inst_file;
3955 if (defined $inst_file) {
3956 $have = $self->inst_version;
3967 #-> sub CPAN::Module::install ;
3973 not exists $self->{'force_update'}
3975 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
3979 $self->rematein('install') if $doit;
3981 #-> sub CPAN::Module::clean ;
3982 sub clean { shift->rematein('clean') }
3984 #-> sub CPAN::Module::inst_file ;
3988 @packpath = split /::/, $self->{ID};
3989 $packpath[-1] .= ".pm";
3990 foreach $dir (@INC) {
3991 my $pmfile = MM->catfile($dir,@packpath);
3999 #-> sub CPAN::Module::xs_file ;
4003 @packpath = split /::/, $self->{ID};
4004 push @packpath, $packpath[-1];
4005 $packpath[-1] .= "." . $Config::Config{'dlext'};
4006 foreach $dir (@INC) {
4007 my $xsfile = MM->catfile($dir,'auto',@packpath);
4015 #-> sub CPAN::Module::inst_version ;
4018 my $parsefile = $self->inst_file or return;
4019 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4021 my $have = MM->parse_version($parsefile) || "undef";
4026 package CPAN::Tarzip;
4029 my($class,$read,$write) = @_;
4030 if ($CPAN::META->has_inst("Compress::Zlib")) {
4032 $fhw = FileHandle->new($read)
4033 or $CPAN::Frontend->mydie("Could not open $read: $!");
4034 my $gz = Compress::Zlib::gzopen($write, "wb")
4035 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
4036 $gz->gzwrite($buffer)
4037 while read($fhw,$buffer,4096) > 0 ;
4042 system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
4047 my($class,$read,$write) = @_;
4048 if ($CPAN::META->has_inst("Compress::Zlib")) {
4050 $fhw = FileHandle->new(">$write")
4051 or $CPAN::Frontend->mydie("Could not open >$write: $!");
4052 my $gz = Compress::Zlib::gzopen($read, "rb")
4053 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
4054 $fhw->print($buffer)
4055 while $gz->gzread($buffer) > 0 ;
4056 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4057 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4062 system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
4067 my($class,$read) = @_;
4068 if ($CPAN::META->has_inst("Compress::Zlib")) {
4070 my $gz = Compress::Zlib::gzopen($read, "rb")
4071 or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
4072 1 while $gz->gzread($buffer) > 0 ;
4073 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4074 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4078 return system("$CPAN::Config->{'gzip'} -dt $read")==0;
4083 my($class,$file) = @_;
4085 $class->debug("file[$file]");
4086 if ($CPAN::META->has_inst("Compress::Zlib")) {
4087 my $gz = Compress::Zlib::gzopen($file,"rb") or
4088 die "Could not gzopen $file";
4089 $ret = bless {GZ => $gz}, $class;
4091 my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
4092 my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
4094 $ret = bless {FH => $fh}, $class;
4101 if (exists $self->{GZ}) {
4102 my $gz = $self->{GZ};
4103 my($line,$bytesread);
4104 $bytesread = $gz->gzreadline($line);
4105 return undef if $bytesread == 0;
4108 my $fh = $self->{FH};
4109 return scalar <$fh>;
4114 my($self,$ref,$length,$offset) = @_;
4115 die "read with offset not implemented" if defined $offset;
4116 if (exists $self->{GZ}) {
4117 my $gz = $self->{GZ};
4118 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
4121 my $fh = $self->{FH};
4122 return read($fh,$$ref,$length);
4128 if (exists $self->{GZ}) {
4129 my $gz = $self->{GZ};
4132 my $fh = $self->{FH};
4139 my($class,$file) = @_;
4140 # had to disable, because version 0.07 seems to be buggy
4141 if (MM->maybe_command($CPAN::Config->{'gzip'})
4143 MM->maybe_command($CPAN::Config->{'tar'})) {
4144 if ($^O =~ /win/i) { # irgggh
4145 # people find the most curious tar binaries that cannot handle
4147 my $system = "$CPAN::Config->{'gzip'} --decompress $file";
4148 if (system($system)==0) {
4149 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
4151 $CPAN::Frontend->mydie(
4152 qq{Couldn\'t uncompress $file\n}
4156 $system = "$CPAN::Config->{tar} xvf $file";
4157 if (system($system)==0) {
4158 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
4160 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
4164 my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
4165 "< $file | $CPAN::Config->{tar} xvf -";
4166 return system($system) == 0;
4168 } elsif ($CPAN::META->has_inst("Archive::Tar")
4170 $CPAN::META->has_inst("Compress::Zlib") ) {
4171 my $tar = Archive::Tar->new($file,1);
4172 $tar->extract($tar->list_files); # I'm pretty sure we have nothing
4173 # that isn't compressed
4175 ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
4176 if ($^O eq 'MacOS');
4180 $CPAN::Frontend->mydie(qq{
4181 CPAN.pm needs either both external programs tar and gzip installed or
4182 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
4183 is available. Can\'t continue.
4196 CPAN - query, download and build perl modules from CPAN sites
4202 perl -MCPAN -e shell;
4208 autobundle, clean, install, make, recompile, test
4212 The CPAN module is designed to automate the make and install of perl
4213 modules and extensions. It includes some searching capabilities and
4214 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
4215 to fetch the raw data from the net.
4217 Modules are fetched from one or more of the mirrored CPAN
4218 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
4221 The CPAN module also supports the concept of named and versioned
4222 'bundles' of modules. Bundles simplify the handling of sets of
4223 related modules. See BUNDLES below.
4225 The package contains a session manager and a cache manager. There is
4226 no status retained between sessions. The session manager keeps track
4227 of what has been fetched, built and installed in the current
4228 session. The cache manager keeps track of the disk space occupied by
4229 the make processes and deletes excess space according to a simple FIFO
4232 For extended searching capabilities there's a plugin for CPAN available,
4233 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
4234 all documents available in CPAN authors directories. If C<CPAN::WAIT>
4235 is installed on your system, the interactive shell of <CPAN.pm> will
4236 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
4237 queries to the WAIT server that has been configured for your
4240 All other methods provided are accessible in a programmer style and in an
4241 interactive shell style.
4243 =head2 Interactive Mode
4245 The interactive mode is entered by running
4247 perl -MCPAN -e shell
4249 which puts you into a readline interface. You will have the most fun if
4250 you install Term::ReadKey and Term::ReadLine to enjoy both history and
4253 Once you are on the command line, type 'h' and the rest should be
4256 The most common uses of the interactive modes are
4260 =item Searching for authors, bundles, distribution files and modules
4262 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
4263 for each of the four categories and another, C<i> for any of the
4264 mentioned four. Each of the four entities is implemented as a class
4265 with slightly differing methods for displaying an object.
4267 Arguments you pass to these commands are either strings exactly matching
4268 the identification string of an object or regular expressions that are
4269 then matched case-insensitively against various attributes of the
4270 objects. The parser recognizes a regular expression only if you
4271 enclose it between two slashes.
4273 The principle is that the number of found objects influences how an
4274 item is displayed. If the search finds one item, the result is displayed
4275 as object-E<gt>as_string, but if we find more than one, we display
4276 each as object-E<gt>as_glimpse. E.g.
4280 EMAIL a.koenig@franz.ww.TU-Berlin.DE
4281 FULLNAME Andreas König
4286 EMAIL a.koenig@franz.ww.TU-Berlin.DE
4287 FULLNAME Andreas König
4291 Author ANDYD (Andy Dougherty)
4292 Author MERLYN (Randal L. Schwartz)
4294 =item make, test, install, clean modules or distributions
4296 These commands take any number of arguments and investigates what is
4297 necessary to perform the action. If the argument is a distribution
4298 file name (recognized by embedded slashes), it is processed. If it is
4299 a module, CPAN determines the distribution file in which this module
4300 is included and processes that, following any dependencies named in
4301 the module's Makefile.PL (this behavior is controlled by
4302 I<prerequisites_policy>.)
4304 Any C<make> or C<test> are run unconditionally. An
4306 install <distribution_file>
4308 also is run unconditionally. But for
4312 CPAN checks if an install is actually needed for it and prints
4313 I<module up to date> in the case that the distribution file containing
4314 the module doesnE<39>t need to be updated.
4316 CPAN also keeps track of what it has done within the current session
4317 and doesnE<39>t try to build a package a second time regardless if it
4318 succeeded or not. The C<force> command takes as a first argument the
4319 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
4320 command from scratch.
4324 cpan> install OpenGL
4325 OpenGL is up to date.
4326 cpan> force install OpenGL
4329 OpenGL-0.4/COPYRIGHT
4332 A C<clean> command results in a
4336 being executed within the distribution file's working directory.
4338 =item readme, look module or distribution
4340 These two commands take only one argument, be it a module or a
4341 distribution file. C<readme> unconditionally runs, displaying the
4342 README of the associated distribution file. C<Look> gets and
4343 untars (if not yet done) the distribution file, changes to the
4344 appropriate directory and opens a subshell process in that directory.
4348 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4349 in the cpan-shell it is intended that you can press C<^C> anytime and
4350 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4351 to clean up and leave the shell loop. You can emulate the effect of a
4352 SIGTERM by sending two consecutive SIGINTs, which usually means by
4353 pressing C<^C> twice.
4355 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4356 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4362 The commands that are available in the shell interface are methods in
4363 the package CPAN::Shell. If you enter the shell command, all your
4364 input is split by the Text::ParseWords::shellwords() routine which
4365 acts like most shells do. The first word is being interpreted as the
4366 method to be called and the rest of the words are treated as arguments
4367 to this method. Continuation lines are supported if a line ends with a
4372 C<autobundle> writes a bundle file into the
4373 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4374 a list of all modules that are both available from CPAN and currently
4375 installed within @INC. The name of the bundle file is based on the
4376 current date and a counter.
4380 recompile() is a very special command in that it takes no argument and
4381 runs the make/test/install cycle with brute force over all installed
4382 dynamically loadable extensions (aka XS modules) with 'force' in
4383 effect. The primary purpose of this command is to finish a network
4384 installation. Imagine, you have a common source tree for two different
4385 architectures. You decide to do a completely independent fresh
4386 installation. You start on one architecture with the help of a Bundle
4387 file produced earlier. CPAN installs the whole Bundle for you, but
4388 when you try to repeat the job on the second architecture, CPAN
4389 responds with a C<"Foo up to date"> message for all modules. So you
4390 invoke CPAN's recompile on the second architecture and youE<39>re done.
4392 Another popular use for C<recompile> is to act as a rescue in case your
4393 perl breaks binary compatibility. If one of the modules that CPAN uses
4394 is in turn depending on binary compatibility (so you cannot run CPAN
4395 commands), then you should try the CPAN::Nox module for recovery.
4397 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
4399 Although it may be considered internal, the class hierarchy does matter
4400 for both users and programmer. CPAN.pm deals with above mentioned four
4401 classes, and all those classes share a set of methods. A classical
4402 single polymorphism is in effect. A metaclass object registers all
4403 objects of all kinds and indexes them with a string. The strings
4404 referencing objects have a separated namespace (well, not completely
4409 words containing a "/" (slash) Distribution
4410 words starting with Bundle:: Bundle
4411 everything else Module or Author
4413 Modules know their associated Distribution objects. They always refer
4414 to the most recent official release. Developers may mark their releases
4415 as unstable development versions (by inserting an underbar into the
4416 visible version number), so the really hottest and newest distribution
4417 file is not always the default. If a module Foo circulates on CPAN in
4418 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
4419 install version 1.23 by saying
4423 This would install the complete distribution file (say
4424 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
4425 like to install version 1.23_90, you need to know where the
4426 distribution file resides on CPAN relative to the authors/id/
4427 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
4428 so you would have to say
4430 install BAR/Foo-1.23_90.tar.gz
4432 The first example will be driven by an object of the class
4433 CPAN::Module, the second by an object of class CPAN::Distribution.
4435 =head2 ProgrammerE<39>s interface
4437 If you do not enter the shell, the available shell commands are both
4438 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
4439 functions in the calling package (C<install(...)>).
4441 There's currently only one class that has a stable interface -
4442 CPAN::Shell. All commands that are available in the CPAN shell are
4443 methods of the class CPAN::Shell. Each of the commands that produce
4444 listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the
4445 IDs of all modules within the list.
4449 =item expand($type,@things)
4451 The IDs of all objects available within a program are strings that can
4452 be expanded to the corresponding real objects with the
4453 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
4454 list of CPAN::Module objects according to the C<@things> arguments
4455 given. In scalar context it only returns the first element of the
4458 =item Programming Examples
4460 This enables the programmer to do operations that combine
4461 functionalities that are available in the shell.
4463 # install everything that is outdated on my disk:
4464 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
4466 # install my favorite programs if necessary:
4467 for $mod (qw(Net::FTP MD5 Data::Dumper)){
4468 my $obj = CPAN::Shell->expand('Module',$mod);
4472 # list all modules on my disk that have no VERSION number
4473 for $mod (CPAN::Shell->expand("Module","/./")){
4474 next unless $mod->inst_file;
4475 # MakeMaker convention for undefined $VERSION:
4476 next unless $mod->inst_version eq "undef";
4477 print "No VERSION in ", $mod->id, "\n";
4482 =head2 Methods in the four Classes
4484 =head2 Cache Manager
4486 Currently the cache manager only keeps track of the build directory
4487 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
4488 deletes complete directories below C<build_dir> as soon as the size of
4489 all directories there gets bigger than $CPAN::Config->{build_cache}
4490 (in MB). The contents of this cache may be used for later
4491 re-installations that you intend to do manually, but will never be
4492 trusted by CPAN itself. This is due to the fact that the user might
4493 use these directories for building modules on different architectures.
4495 There is another directory ($CPAN::Config->{keep_source_where}) where
4496 the original distribution files are kept. This directory is not
4497 covered by the cache manager and must be controlled by the user. If
4498 you choose to have the same directory as build_dir and as
4499 keep_source_where directory, then your sources will be deleted with
4500 the same fifo mechanism.
4504 A bundle is just a perl module in the namespace Bundle:: that does not
4505 define any functions or methods. It usually only contains documentation.
4507 It starts like a perl module with a package declaration and a $VERSION
4508 variable. After that the pod section looks like any other pod with the
4509 only difference being that I<one special pod section> exists starting with
4514 In this pod section each line obeys the format
4516 Module_Name [Version_String] [- optional text]
4518 The only required part is the first field, the name of a module
4519 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
4520 of the line is optional. The comment part is delimited by a dash just
4521 as in the man page header.
4523 The distribution of a bundle should follow the same convention as
4524 other distributions.
4526 Bundles are treated specially in the CPAN package. If you say 'install
4527 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
4528 the modules in the CONTENTS section of the pod. You can install your
4529 own Bundles locally by placing a conformant Bundle file somewhere into
4530 your @INC path. The autobundle() command which is available in the
4531 shell interface does that for you by including all currently installed
4532 modules in a snapshot bundle file.
4534 =head2 Prerequisites
4536 If you have a local mirror of CPAN and can access all files with
4537 "file:" URLs, then you only need a perl better than perl5.003 to run
4538 this module. Otherwise Net::FTP is strongly recommended. LWP may be
4539 required for non-UNIX systems or if your nearest CPAN site is
4540 associated with an URL that is not C<ftp:>.
4542 If you have neither Net::FTP nor LWP, there is a fallback mechanism
4543 implemented for an external ftp command or for an external lynx
4546 =head2 Finding packages and VERSION
4548 This module presumes that all packages on CPAN
4554 declare their $VERSION variable in an easy to parse manner. This
4555 prerequisite can hardly be relaxed because it consumes far too much
4556 memory to load all packages into the running program just to determine
4557 the $VERSION variable. Currently all programs that are dealing with
4558 version use something like this
4560 perl -MExtUtils::MakeMaker -le \
4561 'print MM->parse_version(shift)' filename
4563 If you are author of a package and wonder if your $VERSION can be
4564 parsed, please try the above method.
4568 come as compressed or gzipped tarfiles or as zip files and contain a
4569 Makefile.PL (well, we try to handle a bit more, but without much
4576 The debugging of this module is pretty difficult, because we have
4577 interferences of the software producing the indices on CPAN, of the
4578 mirroring process on CPAN, of packaging, of configuration, of
4579 synchronicity, and of bugs within CPAN.pm.
4581 In interactive mode you can try "o debug" which will list options for
4582 debugging the various parts of the package. The output may not be very
4583 useful for you as it's just a by-product of my own testing, but if you
4584 have an idea which part of the package may have a bug, it's sometimes
4585 worth to give it a try and send me more specific output. You should
4586 know that "o debug" has built-in completion support.
4588 =head2 Floppy, Zip, Offline Mode
4590 CPAN.pm works nicely without network too. If you maintain machines
4591 that are not networked at all, you should consider working with file:
4592 URLs. Of course, you have to collect your modules somewhere first. So
4593 you might use CPAN.pm to put together all you need on a networked
4594 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
4595 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
4596 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
4599 =head1 CONFIGURATION
4601 When the CPAN module is installed, a site wide configuration file is
4602 created as CPAN/Config.pm. The default values defined there can be
4603 overridden in another configuration file: CPAN/MyConfig.pm. You can
4604 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
4605 $HOME/.cpan is added to the search path of the CPAN module before the
4606 use() or require() statements.
4608 Currently the following keys in the hash reference $CPAN::Config are
4611 build_cache size of cache for directories to build modules
4612 build_dir locally accessible directory to build modules
4613 index_expire after this many days refetch index files
4614 cpan_home local directory reserved for this package
4615 gzip location of external program gzip
4616 inactivity_timeout breaks interactive Makefile.PLs after this
4617 many seconds inactivity. Set to 0 to never break.
4618 inhibit_startup_message
4619 if true, does not print the startup message
4620 keep_source keep the source in a local directory?
4621 keep_source_where directory in which to keep the source (if we do)
4622 make location of external make program
4623 make_arg arguments that should always be passed to 'make'
4624 make_install_arg same as make_arg for 'make install'
4625 makepl_arg arguments passed to 'perl Makefile.PL'
4626 pager location of external program more (or any pager)
4627 prerequisites_policy
4628 what to do if you are missing module prerequisites
4629 ('follow' automatically, 'ask' me, or 'ignore')
4630 scan_cache controls scanning of cache ('atstart' or 'never')
4631 tar location of external program tar
4632 unzip location of external program unzip
4633 urllist arrayref to nearby CPAN sites (or equivalent locations)
4634 wait_list arrayref to a wait server to try (See CPAN::WAIT)
4635 ftp_proxy, } the three usual variables for configuring
4636 http_proxy, } proxy requests. Both as CPAN::Config variables
4637 no_proxy } and as environment variables configurable.
4639 You can set and query each of these options interactively in the cpan
4640 shell with the command set defined within the C<o conf> command:
4644 =item o conf E<lt>scalar optionE<gt>
4646 prints the current value of the I<scalar option>
4648 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
4650 Sets the value of the I<scalar option> to I<value>
4652 =item o conf E<lt>list optionE<gt>
4654 prints the current value of the I<list option> in MakeMaker's
4657 =item o conf E<lt>list optionE<gt> [shift|pop]
4659 shifts or pops the array in the I<list option> variable
4661 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
4663 works like the corresponding perl commands.
4667 =head2 urllist parameter has CD-ROM support
4669 The C<urllist> parameter of the configuration table contains a list of
4670 URLs that are to be used for downloading. If the list contains any
4671 C<file> URLs, CPAN always tries to get files from there first. This
4672 feature is disabled for index files. So the recommendation for the
4673 owner of a CD-ROM with CPAN contents is: include your local, possibly
4674 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
4676 o conf urllist push file://localhost/CDROM/CPAN
4678 CPAN.pm will then fetch the index files from one of the CPAN sites
4679 that come at the beginning of urllist. It will later check for each
4680 module if there is a local copy of the most recent version.
4682 Another peculiarity of urllist is that the site that we could
4683 successfully fetch the last file from automatically gets a preference
4684 token and is tried as the first site for the next request. So if you
4685 add a new site at runtime it may happen that the previously preferred
4686 site will be tried another time. This means that if you want to disallow
4687 a site for the next transfer, it must be explicitly removed from
4692 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
4693 install foreign, unmasked, unsigned code on your machine. We compare
4694 to a checksum that comes from the net just as the distribution file
4695 itself. If somebody has managed to tamper with the distribution file,
4696 they may have as well tampered with the CHECKSUMS file. Future
4697 development will go towards strong authentication.
4701 Most functions in package CPAN are exported per default. The reason
4702 for this is that the primary use is intended for the cpan shell or for
4705 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
4707 To populate a freshly installed perl with my favorite modules is pretty
4708 easiest by maintaining a private bundle definition file. To get a useful
4709 blueprint of a bundle definition file, the command autobundle can be used
4710 on the CPAN shell command line. This command writes a bundle definition
4711 file for all modules that re installed for the currently running perl
4712 interpreter. It's recommended to run this command only once and from then
4713 on maintain the file manually under a private name, say
4714 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
4716 cpan> install Bundle::my_bundle
4718 then answer a few questions and then go out.
4720 Maintaining a bundle definition file means to keep track of two things:
4721 dependencies and interactivity. CPAN.pm (currently) does not take into
4722 account dependencies between distributions, so a bundle definition file
4723 should specify distributions that depend on others B<after> the others.
4724 On the other hand, it's a bit annoying that many distributions need some
4725 interactive configuring. So what I try to accomplish in my private bundle
4726 file is to have the packages that need to be configured early in the file
4727 and the gentle ones later, so I can go out after a few minutes and leave
4730 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
4732 Thanks to Graham Barr for contributing the firewall following howto.
4734 Firewalls can be categorized into three basic types.
4740 This is where the firewall machine runs a web server and to access the
4741 outside world you must do it via the web server. If you set environment
4742 variables like http_proxy or ftp_proxy to a values beginning with http://
4743 or in your web browser you have to set proxy information then you know
4744 you are running a http firewall.
4746 To access servers outside these types of firewalls with perl (even for
4747 ftp) you will need to use LWP.
4751 This where the firewall machine runs a ftp server. This kind of firewall will
4752 only let you access ftp serves outside the firewall. This is usually done by
4753 connecting to the firewall with ftp, then entering a username like
4754 "user@outside.host.com"
4756 To access servers outside these type of firewalls with perl you
4757 will need to use Net::FTP.
4759 =item One way visibility
4761 I say one way visibility as these firewalls try to make themselve look
4762 invisible to the users inside the firewall. An FTP data connection is
4763 normally created by sending the remote server your IP address and then
4764 listening for the connection. But the remote server will not be able to
4765 connect to you because of the firewall. So for these types of firewall
4766 FTP connections need to be done in a passive mode.
4768 There are two that I can think off.
4774 If you are using a SOCKS firewall you will need to compile perl and link
4775 it with the SOCKS library, this is what is normally called a ``socksified''
4776 perl. With this executable you will be able to connect to servers outside
4777 the firewall as if it is not there.
4781 This is the firewall implemented in the Linux kernel, it allows you to
4782 hide a complete network behind one IP address. With this firewall no
4783 special compiling is need as you can access hosts directly.
4791 We should give coverage for _all_ of the CPAN and not just the PAUSE
4792 part, right? In this discussion CPAN and PAUSE have become equal --
4793 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
4794 the clpa/, doc/, misc/, ports/, src/, scripts/.
4796 Future development should be directed towards a better integration of
4799 If a Makefile.PL requires special customization of libraries, prompts
4800 the user for special input, etc. then you may find CPAN is not able to
4801 build the distribution. In that case, you should attempt the
4802 traditional method of building a Perl module package from a shell.
4806 Andreas König E<lt>a.koenig@kulturbox.deE<gt>
4810 perl(1), CPAN::Nox(3)