2 use vars qw{$Try_autoload
4 $META $Signal $Cwd $End
5 $Suppress_readline %Dontload
11 # $Id: CPAN.pm,v 1.260 1999/03/06 19:31:02 k Exp $
13 # only used during development:
15 # $Revision = "[".substr(q$Revision: 1.260 $, 10)."]";
22 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
23 use File::Basename ();
29 use Text::ParseWords ();
33 END { $End++; &cleanup; }
54 $CPAN::Frontend ||= "CPAN::Shell";
55 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
58 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term);
61 @CPAN::ISA = qw(CPAN::Debug Exporter);
64 autobundle bundle expand force get
65 install make readme recompile shell test clean
68 #-> sub CPAN::AUTOLOAD ;
73 @EXPORT{@EXPORT} = '';
74 CPAN::Config->load unless $CPAN::Config_loaded++;
75 if (exists $EXPORT{$l}){
78 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
82 # $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
84 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
93 $Suppress_readline ||= ! -t STDIN;
94 CPAN::Config->load unless $CPAN::Config_loaded++;
96 my $prompt = "cpan> ";
98 unless ($Suppress_readline) {
99 require Term::ReadLine;
100 # import Term::ReadLine;
101 $term = Term::ReadLine->new('CPAN Monitor');
102 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
103 my $attribs = $term->Attribs;
104 # $attribs->{completion_entry_function} =
105 # $attribs->{'list_completion_function'};
106 $attribs->{attempted_completion_function} = sub {
107 &CPAN::Complete::gnu_cpl;
109 # $attribs->{completion_word} =
110 # [qw(help me somebody to find out how
111 # to use completion with GNU)];
113 $readline::rl_completion_function =
114 $readline::rl_completion_function = 'CPAN::Complete::cpl';
121 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
122 my $cwd = CPAN->$getcwd();
123 my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub";
124 my $rl_avail = $Suppress_readline ? "suppressed" :
125 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
126 "available (try ``install Bundle::CPAN'')";
128 $CPAN::Frontend->myprint(
130 cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
131 ReadLine support $rl_avail
133 }) unless $CPAN::Config->{'inhibit_startup_message'} ;
134 my($continuation) = "";
136 if ($Suppress_readline) {
138 last unless defined ($_ = <> );
141 last unless defined ($_ = $term->readline($prompt));
143 $_ = "$continuation$_" if $continuation;
146 $_ = 'h' if /^\s*\?/;
147 if (/^(?:q(?:uit)?|bye|exit)$/i) {
157 use vars qw($import_done);
158 CPAN->import(':DEFAULT') unless $import_done++;
159 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
166 if ($] < 5.00322) { # parsewords had a bug until recently
169 eval { @line = Text::ParseWords::shellwords($_) };
170 warn($@), next if $@;
172 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
173 my $command = shift @line;
174 eval { CPAN::Shell->$command(@line) };
177 $CPAN::Frontend->myprint("\n");
183 CPAN::Queue->nullify_queue;
184 if ($try_detect_readline) {
185 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
187 $CPAN::META->has_inst("Term::ReadLine::Perl")
189 delete $INC{"Term/ReadLine.pm"};
191 local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef);
192 require Term::ReadLine;
193 $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n");
200 package CPAN::CacheMgr;
201 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
204 package CPAN::Config;
205 import ExtUtils::MakeMaker 'neatvalue';
206 use vars qw(%can $dot_cpan);
209 'commit' => "Commit changes to disk",
210 'defaults' => "Reload defaults from disk",
211 'init' => "Interactive setting of all options",
215 use vars qw($Ua $Thesite $Themethod);
216 @CPAN::FTP::ISA = qw(CPAN::Debug);
218 package CPAN::Complete;
219 @CPAN::Complete::ISA = qw(CPAN::Debug);
222 use vars qw($last_time $date_of_03);
223 @CPAN::Index::ISA = qw(CPAN::Debug);
227 package CPAN::InfoObj;
228 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
230 package CPAN::Author;
231 @CPAN::Author::ISA = qw(CPAN::InfoObj);
233 package CPAN::Distribution;
234 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
236 package CPAN::Bundle;
237 @CPAN::Bundle::ISA = qw(CPAN::Module);
239 package CPAN::Module;
240 @CPAN::Module::ISA = qw(CPAN::InfoObj);
243 use vars qw($AUTOLOAD $redef @ISA);
244 @CPAN::Shell::ISA = qw(CPAN::Debug);
246 #-> sub CPAN::Shell::AUTOLOAD ;
248 my($autoload) = $AUTOLOAD;
249 my $class = shift(@_);
250 # warn "autoload[$autoload] class[$class]";
251 $autoload =~ s/.*:://;
252 if ($autoload =~ /^w/) {
253 if ($CPAN::META->has_inst('CPAN::WAIT')) {
254 CPAN::WAIT->$autoload(@_);
256 $CPAN::Frontend->mywarn(qq{
257 Commands starting with "w" require CPAN::WAIT to be installed.
258 Please consider installing CPAN::WAIT to use the fulltext index.
259 For this you just need to type
264 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
268 # $CPAN::Frontend->mywarn("Could not autoload $autoload");
270 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
276 #-> CPAN::Shell::try_dot_al
278 my($class,$autoload) = @_;
279 return unless $CPAN::Try_autoload;
280 # I don't see how to re-use that from the AutoLoader...
282 # Braces used to preserve $1 et al.
284 my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
286 if (defined($name=$INC{"$pkg.pm"}))
288 $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|;
289 $name = undef unless (-r $name);
291 unless (defined $name)
293 $name = "auto/$autoload.al";
298 eval {local $SIG{__DIE__};require $name};
300 if (substr($autoload,-9) eq '::DESTROY') {
304 if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
305 eval {local $SIG{__DIE__};require $name};
320 # my $lm = Carp::longmess();
321 # warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
325 #### autoloader is experimental
326 #### to try it we have to set $Try_autoload and uncomment
327 #### the use statement and uncomment the __END__ below
328 #### You also need AutoSplit 1.01 available. MakeMaker will
329 #### then build CPAN with all the AutoLoad stuff.
333 if ($CPAN::Try_autoload) {
336 CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
337 CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
338 CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
340 *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
344 package CPAN::Tarzip;
345 use vars qw($AUTOLOAD @ISA);
346 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
350 # One use of the queue is to determine if we should or shouldn't
351 # announce the availability of a new CPAN module
353 # Now we try to use it for dependency tracking. For that to happen
354 # we need to draw a dependency tree and do the leaves first. This can
355 # easily be reached by running CPAN.pm recursively, but we don't want
356 # to waste memory and run into deep recursion. So what we can do is
359 # CPAN::Queue is the package where the queue is maintained. Dependencies
360 # often have high priority and must be brought to the head of the queue,
361 # possibly by jumping the queue if they are already there. My first code
362 # attempt tried to be extremely correct. Whenever a module needed
363 # immediate treatment, I either unshifted it to the front of the queue,
364 # or, if it was already in the queue, I spliced and let it bypass the
365 # others. This became a too correct model that made it impossible to put
366 # an item more than once into the queue. Why would you need that? Well,
367 # you need temporary duplicates as the manager of the queue is a loop
370 # (1) looks at the first item in the queue without shifting it off
372 # (2) cares for the item
374 # (3) removes the item from the queue, *even if its agenda failed and
375 # even if the item isn't the first in the queue anymore* (that way
376 # protecting against never ending queues)
378 # So if an item has prerequisites, the installation fails now, but we
379 # want to retry later. That's easy if we have it twice in the queue.
381 # I also expect insane dependency situations where an item gets more
382 # than two lives in the queue. Simplest example is triggered by 'install
383 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
384 # get in the way. I wanted the queue manager to be a dumb servant, not
385 # one that knows everything.
387 # Who would I tell in this model that the user wants to be asked before
388 # processing? I can't attach that information to the module object,
389 # because not modules are installed but distributions. So I'd have to
390 # tell the distribution object that it should ask the user before
391 # processing. Where would the question be triggered then? Most probably
392 # in CPAN::Distribution::rematein.
393 # Hope that makes sense, my head is a bit off:-) -- AK
398 my($class,$mod) = @_;
399 my $self = bless {mod => $mod}, $class;
401 # my @all = map { $_->{mod} } @All;
402 # warn "Adding Queue object for mod[$mod] all[@all]";
412 my($class,$what) = @_;
414 for my $i (0..$#All) {
415 if ( $All[$i]->{mod} eq $what ) {
426 WHAT: for my $what (reverse @what) {
428 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
429 if ($All[$i]->{mod} eq $what){
431 if ($jumped > 100) { # one's OK if e.g. just processing now;
432 # more are OK if user typed it several
434 $CPAN::Frontend->mywarn(
435 qq{Object [$what] queued more than 100 times, ignoring}
441 my $obj = bless { mod => $what }, $class;
447 my($self,$what) = @_;
448 my @all = map { $_->{mod} } @All;
449 my $exists = grep { $_->{mod} eq $what } @All;
450 # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]";
456 @All = grep { $_->{mod} ne $mod } @All;
457 # my @all = map { $_->{mod} } @All;
458 # warn "Deleting Queue object for mod[$mod] all[@all]";
469 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
473 # __END__ # uncomment this and AutoSplit version 1.01 will split it
475 #-> sub CPAN::autobundle ;
477 #-> sub CPAN::bundle ;
479 #-> sub CPAN::expand ;
481 #-> sub CPAN::force ;
483 #-> sub CPAN::install ;
487 #-> sub CPAN::clean ;
494 my($mgr,$class) = @_;
495 CPAN::Config->load unless $CPAN::Config_loaded++;
496 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
498 values %{ $META->{$class} };
500 *all = \&all_objects;
502 # Called by shell, not in batch mode. Not clean XXX
503 #-> sub CPAN::checklock ;
506 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
507 if (-f $lockfile && -M _ > 0) {
508 my $fh = FileHandle->new($lockfile);
511 if (defined $other && $other) {
513 return if $$==$other; # should never happen
514 $CPAN::Frontend->mywarn(
516 There seems to be running another CPAN process ($other). Contacting...
518 if (kill 0, $other) {
519 $CPAN::Frontend->mydie(qq{Other job is running.
520 You may want to kill it and delete the lockfile, maybe. On UNIX try:
524 } elsif (-w $lockfile) {
526 ExtUtils::MakeMaker::prompt
527 (qq{Other job not responding. Shall I overwrite }.
528 qq{the lockfile? (Y/N)},"y");
529 $CPAN::Frontend->myexit("Ok, bye\n")
530 unless $ans =~ /^y/i;
533 qq{Lockfile $lockfile not writeable by you. }.
534 qq{Cannot proceed.\n}.
537 qq{ and then rerun us.\n}
542 File::Path::mkpath($CPAN::Config->{cpan_home});
544 unless ($fh = FileHandle->new(">$lockfile")) {
545 if ($! =~ /Permission/) {
546 my $incc = $INC{'CPAN/Config.pm'};
547 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
548 $CPAN::Frontend->myprint(qq{
550 Your configuration suggests that CPAN.pm should use a working
552 $CPAN::Config->{cpan_home}
553 Unfortunately we could not create the lock file
555 due to permission problems.
557 Please make sure that the configuration variable
558 \$CPAN::Config->{cpan_home}
559 points to a directory where you can write a .lock file. You can set
560 this variable in either
567 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
569 $fh->print($$, "\n");
570 $self->{LOCK} = $lockfile;
574 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
579 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
580 print "Caught SIGINT\n";
583 $SIG{'__DIE__'} = \&cleanup;
584 $self->debug("Signal handler set.") if $CPAN::DEBUG;
587 #-> sub CPAN::DESTROY ;
589 &cleanup; # need an eval?
593 sub cwd {Cwd::cwd();}
595 #-> sub CPAN::getcwd ;
596 sub getcwd {Cwd::getcwd();}
598 #-> sub CPAN::exists ;
600 my($mgr,$class,$id) = @_;
602 ### Carp::croak "exists called without class argument" unless $class;
604 exists $META->{$class}{$id};
607 #-> sub CPAN::delete ;
609 my($mgr,$class,$id) = @_;
610 delete $META->{$class}{$id};
613 #-> sub CPAN::has_inst
615 my($self,$mod,$message) = @_;
616 Carp::croak("CPAN->has_inst() called without an argument")
618 if (defined $message && $message eq "no") {
621 } elsif (exists $Dontload{$mod}) {
627 $file =~ s|/|\\|g if $^O eq 'MSWin32';
630 # checking %INC is wrong, because $INC{LWP} may be true
631 # although $INC{"URI/URL.pm"} may have failed. But as
632 # I really want to say "bla loaded OK", I have to somehow
634 ### warn "$file in %INC"; #debug
636 } elsif (eval { require $file }) {
637 # eval is good: if we haven't yet read the database it's
638 # perfect and if we have installed the module in the meantime,
639 # it tries again. The second require is only a NOOP returning
640 # 1 if we had success, otherwise it's retrying
642 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
643 if ($mod eq "CPAN::WAIT") {
644 push @CPAN::Shell::ISA, CPAN::WAIT;
647 } elsif ($mod eq "Net::FTP") {
649 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
651 install Bundle::libnet
655 } elsif ($mod eq "MD5"){
656 $CPAN::Frontend->myprint(qq{
657 CPAN: MD5 security checks disabled because MD5 not installed.
658 Please consider installing the MD5 module.
663 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
668 #-> sub CPAN::instance ;
670 my($mgr,$class,$id) = @_;
673 $META->{$class}{$id} ||= $class->new(ID => $id );
681 #-> sub CPAN::cleanup ;
683 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
684 local $SIG{__DIE__} = '';
689 0 && # disabled, try reload cpan with it
690 $] > 5.004_60 # thereabouts
695 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
697 $subroutine eq '(eval)';
700 return if $ineval && !$End;
701 return unless defined $META->{'LOCK'};
702 return unless -f $META->{'LOCK'};
703 unlink $META->{'LOCK'};
705 # Carp::cluck("DEBUGGING");
706 $CPAN::Frontend->mywarn("Lockfile removed.\n");
709 package CPAN::CacheMgr;
711 #-> sub CPAN::CacheMgr::as_string ;
713 eval { require Data::Dumper };
715 return shift->SUPER::as_string;
717 return Data::Dumper::Dumper(shift);
721 #-> sub CPAN::CacheMgr::cachesize ;
728 return unless -d $self->{ID};
729 while ($self->{DU} > $self->{'MAX'} ) {
730 my($toremove) = shift @{$self->{FIFO}};
731 $CPAN::Frontend->myprint(sprintf(
732 "Deleting from cache".
733 ": $toremove (%.1f>%.1f MB)\n",
734 $self->{DU}, $self->{'MAX'})
736 return if $CPAN::Signal;
737 $self->force_clean_cache($toremove);
738 return if $CPAN::Signal;
742 #-> sub CPAN::CacheMgr::dir ;
747 #-> sub CPAN::CacheMgr::entries ;
750 return unless defined $dir;
751 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
752 $dir ||= $self->{ID};
754 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
755 my($cwd) = CPAN->$getcwd();
756 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
757 my $dh = DirHandle->new(File::Spec->curdir)
758 or Carp::croak("Couldn't opendir $dir: $!");
761 next if $_ eq "." || $_ eq "..";
763 push @entries, MM->catfile($dir,$_);
765 push @entries, MM->catdir($dir,$_);
767 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
770 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
771 sort { -M $b <=> -M $a} @entries;
774 #-> sub CPAN::CacheMgr::disk_usage ;
777 return if exists $self->{SIZE}{$dir};
778 return if $CPAN::Signal;
782 $File::Find::prune++ if $CPAN::Signal;
784 if ($^O eq 'MacOS') {
786 my $cat = Mac::Files::FSpGetCatInfo($_);
787 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen();
794 return if $CPAN::Signal;
795 $self->{SIZE}{$dir} = $Du/1024/1024;
796 push @{$self->{FIFO}}, $dir;
797 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
798 $self->{DU} += $Du/1024/1024;
802 #-> sub CPAN::CacheMgr::force_clean_cache ;
803 sub force_clean_cache {
805 return unless -e $dir;
806 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
808 File::Path::rmtree($dir);
809 $self->{DU} -= $self->{SIZE}{$dir};
810 delete $self->{SIZE}{$dir};
813 #-> sub CPAN::CacheMgr::new ;
820 ID => $CPAN::Config->{'build_dir'},
821 MAX => $CPAN::Config->{'build_cache'},
822 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
825 File::Path::mkpath($self->{ID});
826 my $dh = DirHandle->new($self->{ID});
830 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
832 CPAN->debug($debug) if $CPAN::DEBUG;
836 #-> sub CPAN::CacheMgr::scan_cache ;
839 return if $self->{SCAN} eq 'never';
840 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
841 unless $self->{SCAN} eq 'atstart';
842 $CPAN::Frontend->myprint(
843 sprintf("Scanning cache %s for sizes\n",
846 for $e ($self->entries($self->{ID})) {
847 next if $e eq ".." || $e eq ".";
848 $self->disk_usage($e);
849 return if $CPAN::Signal;
856 #-> sub CPAN::Debug::debug ;
859 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
860 # Complete, caller(1)
862 ($caller) = caller(0);
864 $arg = "" unless defined $arg;
865 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
866 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
867 if ($arg and ref $arg) {
868 eval { require Data::Dumper };
870 $CPAN::Frontend->myprint($arg->as_string);
872 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
875 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
880 package CPAN::Config;
882 #-> sub CPAN::Config::edit ;
884 my($class,@args) = @_;
886 CPAN->debug("class[$class]args[".join(" | ",@args)."]");
887 my($o,$str,$func,$args,$key_exists);
893 if (ref($CPAN::Config->{$o}) eq ARRAY) {
896 # Let's avoid eval, it's easier to comprehend without.
897 if ($func eq "push") {
898 push @{$CPAN::Config->{$o}}, @args;
899 } elsif ($func eq "pop") {
900 pop @{$CPAN::Config->{$o}};
901 } elsif ($func eq "shift") {
902 shift @{$CPAN::Config->{$o}};
903 } elsif ($func eq "unshift") {
904 unshift @{$CPAN::Config->{$o}}, @args;
905 } elsif ($func eq "splice") {
906 splice @{$CPAN::Config->{$o}}, @args;
908 $CPAN::Config->{$o} = [@args];
910 $CPAN::Frontend->myprint(
913 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
918 $CPAN::Config->{$o} = $args[0] if defined $args[0];
919 $CPAN::Frontend->myprint(" $o " .
920 (defined $CPAN::Config->{$o} ?
921 $CPAN::Config->{$o} : "UNDEFINED"));
926 #-> sub CPAN::Config::commit ;
928 my($self,$configpm) = @_;
929 unless (defined $configpm){
930 $configpm ||= $INC{"CPAN/MyConfig.pm"};
931 $configpm ||= $INC{"CPAN/Config.pm"};
932 $configpm || Carp::confess(q{
933 CPAN::Config::commit called without an argument.
934 Please specify a filename where to save the configuration or try
935 "o conf init" to have an interactive course through configing.
940 $mode = (stat $configpm)[2];
941 if ($mode && ! -w _) {
942 Carp::confess("$configpm is not writable");
946 my $msg = <<EOF unless $configpm =~ /MyConfig/;
948 # This is CPAN.pm's systemwide configuration file. This file provides
949 # defaults for users, and the values can be changed in a per-user
950 # configuration file. The user-config file is being looked for as
951 # ~/.cpan/CPAN/MyConfig.pm.
955 my($fh) = FileHandle->new;
956 rename $configpm, "$configpm~" if -f $configpm;
957 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
958 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
959 foreach (sort keys %$CPAN::Config) {
962 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
967 $fh->print("};\n1;\n__END__\n");
970 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
971 #chmod $mode, $configpm;
972 ###why was that so? $self->defaults;
973 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
977 *default = \&defaults;
978 #-> sub CPAN::Config::defaults ;
988 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
997 #-> sub CPAN::Config::load ;
1002 eval {require CPAN::Config;}; # We eval because of some
1003 # MakeMaker problems
1004 unless ($dot_cpan++){
1005 unshift @INC, MM->catdir($ENV{HOME},".cpan");
1006 eval {require CPAN::MyConfig;}; # where you can override
1007 # system wide settings
1010 return unless @miss = $self->not_loaded;
1011 # XXX better check for arrayrefs too
1012 require CPAN::FirstTime;
1013 my($configpm,$fh,$redo,$theycalled);
1015 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1016 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1017 $configpm = $INC{"CPAN/Config.pm"};
1019 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1020 $configpm = $INC{"CPAN/MyConfig.pm"};
1023 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1024 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1025 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1026 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1027 if (-w $configpmtest) {
1028 $configpm = $configpmtest;
1029 } elsif (-w $configpmdir) {
1030 #_#_# following code dumped core on me with 5.003_11, a.k.
1031 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1032 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1033 my $fh = FileHandle->new;
1034 if ($fh->open(">$configpmtest")) {
1036 $configpm = $configpmtest;
1038 # Should never happen
1039 Carp::confess("Cannot open >$configpmtest");
1043 unless ($configpm) {
1044 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1045 File::Path::mkpath($configpmdir);
1046 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1047 if (-w $configpmtest) {
1048 $configpm = $configpmtest;
1049 } elsif (-w $configpmdir) {
1050 #_#_# following code dumped core on me with 5.003_11, a.k.
1051 my $fh = FileHandle->new;
1052 if ($fh->open(">$configpmtest")) {
1054 $configpm = $configpmtest;
1056 # Should never happen
1057 Carp::confess("Cannot open >$configpmtest");
1060 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1061 qq{create a configuration file.});
1066 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1067 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1071 $CPAN::Frontend->myprint(qq{
1072 $configpm initialized.
1075 CPAN::FirstTime::init($configpm);
1078 #-> sub CPAN::Config::not_loaded ;
1082 cpan_home keep_source_where build_dir build_cache scan_cache
1083 index_expire gzip tar unzip make pager makepl_arg make_arg
1084 make_install_arg urllist inhibit_startup_message
1085 ftp_proxy http_proxy no_proxy prerequisites_policy
1087 push @miss, $_ unless defined $CPAN::Config->{$_};
1092 #-> sub CPAN::Config::unload ;
1094 delete $INC{'CPAN/MyConfig.pm'};
1095 delete $INC{'CPAN/Config.pm'};
1098 #-> sub CPAN::Config::help ;
1100 $CPAN::Frontend->myprint(q[
1102 defaults reload default config values from disk
1103 commit commit session changes to disk
1104 init go through a dialog to set all parameters
1106 You may edit key values in the follow fashion:
1108 o conf build_cache 15
1110 o conf build_dir "/foo/bar"
1112 o conf urllist shift
1114 o conf urllist unshift ftp://ftp.foo.bar/
1117 undef; #don't reprint CPAN::Config
1120 #-> sub CPAN::Config::cpl ;
1122 my($word,$line,$pos) = @_;
1124 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1125 my(@words) = split " ", substr($line,0,$pos+1);
1130 $words[2] =~ /list$/ && @words == 3
1132 $words[2] =~ /list$/ && @words == 4 && length($word)
1135 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1136 } elsif (@words >= 4) {
1139 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1140 return grep /^\Q$word\E/, @o_conf;
1143 package CPAN::Shell;
1145 #-> sub CPAN::Shell::h ;
1147 my($class,$about) = @_;
1148 if (defined $about) {
1149 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1151 $CPAN::Frontend->myprint(q{
1152 command arguments description
1154 b or display bundles
1155 d /regex/ info distributions
1157 i none anything of above
1159 r as reinstall recommendations
1160 u above uninstalled distributions
1161 See manpage for autobundle, recompile, force, look, etc.
1164 test modules, make test (implies make)
1165 install dists, bundles, make install (implies test)
1166 clean "r" or "u" make clean
1167 readme display the README file
1169 reload index|cpan load most recent indices/CPAN.pm
1170 h or ? display this menu
1171 o various set and query options
1172 ! perl-code eval a perl command
1173 q quit the shell subroutine
1180 #-> sub CPAN::Shell::a ;
1181 sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));}
1182 #-> sub CPAN::Shell::b ;
1184 my($self,@which) = @_;
1185 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1186 my($incdir,$bdir,$dh);
1187 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1188 $bdir = MM->catdir($incdir,"Bundle");
1189 if ($dh = DirHandle->new($bdir)) { # may fail
1191 for $entry ($dh->read) {
1192 next if -d MM->catdir($bdir,$entry);
1193 next unless $entry =~ s/\.pm$//;
1194 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1198 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1200 #-> sub CPAN::Shell::d ;
1201 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1202 #-> sub CPAN::Shell::m ;
1203 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1204 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1207 #-> sub CPAN::Shell::i ;
1212 @type = qw/Author Bundle Distribution Module/;
1213 @args = '/./' unless @args;
1216 push @result, $self->expand($type,@args);
1218 my $result = @result == 1 ?
1219 $result[0]->as_string :
1220 join "", map {$_->as_glimpse} @result;
1221 $result ||= "No objects found of any type for argument @args\n";
1222 $CPAN::Frontend->myprint($result);
1225 #-> sub CPAN::Shell::o ;
1227 my($self,$o_type,@o_what) = @_;
1229 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1230 if ($o_type eq 'conf') {
1231 shift @o_what if @o_what && $o_what[0] eq 'help';
1234 $CPAN::Frontend->myprint("CPAN::Config options");
1235 if (exists $INC{'CPAN/Config.pm'}) {
1236 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1238 if (exists $INC{'CPAN/MyConfig.pm'}) {
1239 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1241 $CPAN::Frontend->myprint(":\n");
1242 for $k (sort keys %CPAN::Config::can) {
1243 $v = $CPAN::Config::can{$k};
1244 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1246 $CPAN::Frontend->myprint("\n");
1247 for $k (sort keys %$CPAN::Config) {
1248 $v = $CPAN::Config->{$k};
1250 $CPAN::Frontend->myprint(
1257 map {"\t$_\n"} @{$v}
1261 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1264 $CPAN::Frontend->myprint("\n");
1265 } elsif (!CPAN::Config->edit(@o_what)) {
1266 $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
1268 } elsif ($o_type eq 'debug') {
1270 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1273 my($what) = shift @o_what;
1274 if ( exists $CPAN::DEBUG{$what} ) {
1275 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1276 } elsif ($what =~ /^\d/) {
1277 $CPAN::DEBUG = $what;
1278 } elsif (lc $what eq 'all') {
1280 for (values %CPAN::DEBUG) {
1283 $CPAN::DEBUG = $max;
1286 for (keys %CPAN::DEBUG) {
1287 next unless lc($_) eq lc($what);
1288 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1291 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1296 $CPAN::Frontend->myprint("Valid options for debug are ".
1297 join(", ",sort(keys %CPAN::DEBUG), 'all').
1298 qq{ or a number. Completion works on the options. }.
1299 qq{Case is ignored.\n\n});
1302 $CPAN::Frontend->myprint("Options set for debugging:\n");
1304 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1305 $v = $CPAN::DEBUG{$k};
1306 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
1309 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1312 $CPAN::Frontend->myprint(qq{
1314 conf set or get configuration variables
1315 debug set or get debugging options
1320 sub dotdot_onreload {
1323 if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1327 # $CPAN::Frontend->myprint(".($subr)");
1328 $CPAN::Frontend->myprint(".");
1335 #-> sub CPAN::Shell::reload ;
1337 my($self,$command,@arg) = @_;
1339 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1340 if ($command =~ /cpan/i) {
1341 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1342 my $fh = FileHandle->new($INC{'CPAN.pm'});
1345 local($SIG{__WARN__}) = dotdot_onreload(\$redef);
1348 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1349 } elsif ($command =~ /index/) {
1350 CPAN::Index->force_reload;
1352 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1353 index re-reads the index files\n});
1357 #-> sub CPAN::Shell::_binary_extensions ;
1358 sub _binary_extensions {
1359 my($self) = shift @_;
1360 my(@result,$module,%seen,%need,$headerdone);
1361 my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$};
1362 for $module ($self->expand('Module','/./')) {
1363 my $file = $module->cpan_file;
1364 next if $file eq "N/A";
1365 next if $file =~ /^Contact Author/;
1366 next if $file =~ / $isaperl /xo;
1367 next unless $module->xs_file;
1369 $CPAN::Frontend->myprint(".");
1370 push @result, $module;
1372 # print join " | ", @result;
1373 $CPAN::Frontend->myprint("\n");
1377 #-> sub CPAN::Shell::recompile ;
1379 my($self) = shift @_;
1380 my($module,@module,$cpan_file,%dist);
1381 @module = $self->_binary_extensions();
1382 for $module (@module){ # we force now and compile later, so we
1384 $cpan_file = $module->cpan_file;
1385 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1387 $dist{$cpan_file}++;
1389 for $cpan_file (sort keys %dist) {
1390 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1391 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1393 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1394 # stop a package from recompiling,
1395 # e.g. IO-1.12 when we have perl5.003_10
1399 #-> sub CPAN::Shell::_u_r_common ;
1401 my($self) = shift @_;
1402 my($what) = shift @_;
1403 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1404 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1405 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1407 @args = '/./' unless @args;
1408 my(@result,$module,%seen,%need,$headerdone,
1409 $version_undefs,$version_zeroes);
1410 $version_undefs = $version_zeroes = 0;
1411 my $sprintf = "%-25s %9s %9s %s\n";
1412 for $module ($self->expand('Module',@args)) {
1413 my $file = $module->cpan_file;
1414 next unless defined $file; # ??
1415 my($latest) = $module->cpan_version;
1416 my($inst_file) = $module->inst_file;
1418 return if $CPAN::Signal;
1421 $have = $module->inst_version;
1422 } elsif ($what eq "r") {
1423 $have = $module->inst_version;
1425 if ($have eq "undef"){
1427 } elsif ($have == 0){
1430 next if $have >= $latest;
1431 # to be pedantic we should probably say:
1432 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1433 # to catch the case where CPAN has a version 0 and we have a version undef
1434 } elsif ($what eq "u") {
1440 } elsif ($what eq "r") {
1442 } elsif ($what eq "u") {
1446 return if $CPAN::Signal; # this is sometimes lengthy
1449 push @result, sprintf "%s %s\n", $module->id, $have;
1450 } elsif ($what eq "r") {
1451 push @result, $module->id;
1452 next if $seen{$file}++;
1453 } elsif ($what eq "u") {
1454 push @result, $module->id;
1455 next if $seen{$file}++;
1456 next if $file =~ /^Contact/;
1458 unless ($headerdone++){
1459 $CPAN::Frontend->myprint("\n");
1460 $CPAN::Frontend->myprint(sprintf(
1462 "Package namespace",
1468 $latest = substr($latest,0,8) if length($latest) > 8;
1469 $have = substr($have,0,8) if length($have) > 8;
1470 $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
1471 $need{$module->id}++;
1475 $CPAN::Frontend->myprint("No modules found for @args\n");
1476 } elsif ($what eq "r") {
1477 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1481 if ($version_zeroes) {
1482 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1483 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1484 qq{a version number of 0\n});
1486 if ($version_undefs) {
1487 my $s_has = $version_undefs > 1 ? "s have" : " has";
1488 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1489 qq{parseable version number\n});
1495 #-> sub CPAN::Shell::r ;
1497 shift->_u_r_common("r",@_);
1500 #-> sub CPAN::Shell::u ;
1502 shift->_u_r_common("u",@_);
1505 #-> sub CPAN::Shell::autobundle ;
1508 CPAN::Config->load unless $CPAN::Config_loaded++;
1509 my(@bundle) = $self->_u_r_common("a",@_);
1510 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1511 File::Path::mkpath($todir);
1512 unless (-d $todir) {
1513 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1516 my($y,$m,$d) = (localtime)[5,4,3];
1520 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1521 my($to) = MM->catfile($todir,"$me.pm");
1523 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1524 $to = MM->catfile($todir,"$me.pm");
1526 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1528 "package Bundle::$me;\n\n",
1529 "\$VERSION = '0.01';\n\n",
1533 "Bundle::$me - Snapshot of installation on ",
1534 $Config::Config{'myhostname'},
1537 "\n\n=head1 SYNOPSIS\n\n",
1538 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1539 "=head1 CONTENTS\n\n",
1540 join("\n", @bundle),
1541 "\n\n=head1 CONFIGURATION\n\n",
1543 "\n\n=head1 AUTHOR\n\n",
1544 "This Bundle has been generated automatically ",
1545 "by the autobundle routine in CPAN.pm.\n",
1548 $CPAN::Frontend->myprint("\nWrote bundle file
1552 #-> sub CPAN::Shell::expand ;
1555 my($type,@args) = @_;
1559 if ($arg =~ m|^/(.*)/$|) {
1562 my $class = "CPAN::$type";
1564 if (defined $regex) {
1565 for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) {
1568 $obj->id =~ /$regex/i
1572 $] < 5.00303 ### provide sort of compatibility with 5.003
1577 $obj->name =~ /$regex/i
1582 if ( $type eq 'Bundle' ) {
1583 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1585 if ($CPAN::META->exists($class,$xarg)) {
1586 $obj = $CPAN::META->instance($class,$xarg);
1587 } elsif ($CPAN::META->exists($class,$arg)) {
1588 $obj = $CPAN::META->instance($class,$arg);
1595 return wantarray ? @m : $m[0];
1598 #-> sub CPAN::Shell::format_result ;
1601 my($type,@args) = @_;
1602 @args = '/./' unless @args;
1603 my(@result) = $self->expand($type,@args);
1604 my $result = @result == 1 ?
1605 $result[0]->as_string :
1606 join "", map {$_->as_glimpse} @result;
1607 $result ||= "No objects of type $type found for argument @args\n";
1611 # The only reason for this method is currently to have a reliable
1612 # debugging utility that reveals which output is going through which
1613 # channel. No, I don't like the colors ;-)
1614 sub print_ornamented {
1615 my($self,$what,$ornament) = @_;
1617 my $ornamenting = 0; # turn the colors on
1620 unless (defined &color) {
1621 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1622 import Term::ANSIColor "color";
1624 *color = sub { return "" };
1628 for $line (split /\n/, $what) {
1629 $longest = length($line) if length($line) > $longest;
1631 my $sprintf = "%-" . $longest . "s";
1633 $what =~ s/(.*\n?)//m;
1636 my($nl) = chomp $line ? "\n" : "";
1637 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1638 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1646 my($self,$what) = @_;
1647 $self->print_ornamented($what, 'bold blue on_yellow');
1651 my($self,$what) = @_;
1652 $self->myprint($what);
1657 my($self,$what) = @_;
1658 $self->print_ornamented($what, 'bold red on_yellow');
1662 my($self,$what) = @_;
1663 $self->print_ornamented($what, 'bold red on_white');
1664 Carp::confess "died";
1668 my($self,$what) = @_;
1669 $self->print_ornamented($what, 'bold red on_white');
1673 #-> sub CPAN::Shell::rematein ;
1674 # RE-adme||MA-ke||TE-st||IN-stall
1677 my($meth,@some) = @_;
1679 if ($meth eq 'force') {
1681 $meth = shift @some;
1683 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1685 foreach $s (@some) {
1686 CPAN::Queue->new($s);
1688 while ($s = CPAN::Queue->first) {
1692 } elsif ($s =~ m|/|) { # looks like a file
1693 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1694 } elsif ($s =~ m|^Bundle::|) {
1695 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1697 $obj = $CPAN::META->instance('CPAN::Module',$s)
1698 if $CPAN::META->exists('CPAN::Module',$s);
1702 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1710 ($] < 5.00303 || $obj->can($pragma)); ###
1714 if ($]>=5.00303 && $obj->can('called_for')) {
1715 $obj->called_for($s);
1717 CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1720 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1721 $obj = $CPAN::META->instance('CPAN::Author',$s);
1722 $CPAN::Frontend->myprint(
1724 "Don't be silly, you can't $meth ",
1730 ->myprint(qq{Warning: Cannot $meth $s, }.
1731 qq{don\'t know what it is.
1736 to find objects with similar identifiers.
1739 CPAN::Queue->delete_first($s);
1743 #-> sub CPAN::Shell::force ;
1744 sub force { shift->rematein('force',@_); }
1745 #-> sub CPAN::Shell::get ;
1746 sub get { shift->rematein('get',@_); }
1747 #-> sub CPAN::Shell::readme ;
1748 sub readme { shift->rematein('readme',@_); }
1749 #-> sub CPAN::Shell::make ;
1750 sub make { shift->rematein('make',@_); }
1751 #-> sub CPAN::Shell::test ;
1752 sub test { shift->rematein('test',@_); }
1753 #-> sub CPAN::Shell::install ;
1754 sub install { shift->rematein('install',@_); }
1755 #-> sub CPAN::Shell::clean ;
1756 sub clean { shift->rematein('clean',@_); }
1757 #-> sub CPAN::Shell::look ;
1758 sub look { shift->rematein('look',@_); }
1762 #-> sub CPAN::FTP::ftp_get ;
1764 my($class,$host,$dir,$file,$target) = @_;
1766 qq[Going to fetch file [$file] from dir [$dir]
1767 on host [$host] as local [$target]\n]
1769 my $ftp = Net::FTP->new($host);
1770 return 0 unless defined $ftp;
1771 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1772 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1773 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1774 warn "Couldn't login on $host";
1777 unless ( $ftp->cwd($dir) ){
1778 warn "Couldn't cwd $dir";
1782 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1783 unless ( $ftp->get($file,$target) ){
1784 warn "Couldn't fetch $file from $host\n";
1787 $ftp->quit; # it's ok if this fails
1791 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1793 # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
1794 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997
1795 # leach,> ***************
1796 # leach,> *** 1562,1567 ****
1797 # leach,> --- 1562,1580 ----
1798 # leach,> return 1 if substr($url,0,4) eq "file";
1799 # leach,> return 1 unless $url =~ m|://([^/]+)|;
1800 # leach,> my $host = $1;
1801 # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1802 # leach,> + if ($proxy) {
1803 # leach,> + $proxy =~ m|://([^/:]+)|;
1804 # leach,> + $proxy = $1;
1805 # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1806 # leach,> + if ($noproxy) {
1807 # leach,> + if ($host !~ /$noproxy$/) {
1808 # leach,> + $host = $proxy;
1810 # leach,> + } else {
1811 # leach,> + $host = $proxy;
1814 # leach,> require Net::Ping;
1815 # leach,> return 1 unless $Net::Ping::VERSION >= 2;
1819 # this is quite optimistic and returns one on several occasions where
1820 # inappropriate. But this does no harm. It would do harm if we were
1821 # too pessimistic (as I was before the http_proxy
1823 my($self,$url) = @_;
1824 return 1; # we can't simply roll our own, firewalls may break ping
1825 return 0 unless $url;
1826 return 1 if substr($url,0,4) eq "file";
1827 return 1 unless $url =~ m|^(\w+)://([^/]+)|;
1828 my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
1830 return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
1832 return 1 unless $Net::Ping::VERSION >= 2;
1834 # 1.3101 had it different: only if the first eval raised an
1835 # exception we tried it with TCP. Now we are happy if icmp wins
1836 # the order and return, we don't even check for $@. Thanks to
1837 # thayer@uis.edu for the suggestion.
1838 eval {$p = Net::Ping->new("icmp");};
1839 return 1 if $p && ref($p) && $p->ping($host, 10);
1840 eval {$p = Net::Ping->new("tcp");};
1841 $CPAN::Frontend->mydie($@) if $@;
1842 return $p->ping($host, 10);
1845 #-> sub CPAN::FTP::localize ;
1846 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
1849 my($self,$file,$aslocal,$force) = @_;
1851 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
1852 unless defined $aslocal;
1853 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
1856 if ($^O eq 'MacOS') {
1857 my($name, $path) = File::Basename::fileparse($aslocal, '');
1858 if (length($name) > 31) {
1859 $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
1861 my $size = 31 - length($suf);
1862 while (length($name) > $size) {
1866 $aslocal = File::Spec->catfile($path, $name);
1870 return $aslocal if -f $aslocal && -r _ && !($force & 1);
1873 rename $aslocal, "$aslocal.bak";
1877 my($aslocal_dir) = File::Basename::dirname($aslocal);
1878 File::Path::mkpath($aslocal_dir);
1879 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
1880 qq{directory "$aslocal_dir".
1881 I\'ll continue, but if you encounter problems, they may be due
1882 to insufficient permissions.\n}) unless -w $aslocal_dir;
1884 # Inheritance is not easier to manage than a few if/else branches
1885 if ($CPAN::META->has_inst('LWP::UserAgent')) {
1886 require LWP::UserAgent;
1888 $Ua = LWP::UserAgent->new;
1890 $Ua->proxy('ftp', $var)
1891 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
1892 $Ua->proxy('http', $var)
1893 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1895 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1899 # Try the list of urls for each single object. We keep a record
1900 # where we did get a file from
1901 my(@reordered,$last);
1902 $CPAN::Config->{urllist} ||= [];
1903 $last = $#{$CPAN::Config->{urllist}};
1904 if ($force & 2) { # local cpans probably out of date, don't reorder
1905 @reordered = (0..$last);
1909 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
1911 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
1922 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
1924 @levels = qw/easy hard hardest/;
1926 @levels = qw/easy/ if $^O eq 'MacOS';
1927 for $level (@levels) {
1928 my $method = "host$level";
1929 my @host_seq = $level eq "easy" ?
1930 @reordered : 0..$last; # reordered has CDROM up front
1931 @host_seq = (0) unless @host_seq;
1932 my $ret = $self->$method(\@host_seq,$file,$aslocal);
1934 $Themethod = $level;
1935 $self->debug("level[$level]") if $CPAN::DEBUG;
1943 qq{Please check, if the URLs I found in your configuration file \(}.
1944 join(", ", @{$CPAN::Config->{urllist}}).
1945 qq{\) are valid. The urllist can be edited.},
1946 qq{E.g. with ``o conf urllist push ftp://myurl/''};
1947 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
1949 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
1951 rename "$aslocal.bak", $aslocal;
1952 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
1953 $self->ls($aslocal));
1960 my($self,$host_seq,$file,$aslocal) = @_;
1962 HOSTEASY: for $i (@$host_seq) {
1963 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
1964 unless ($self->is_reachable($url)) {
1965 $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
1969 $url .= "/" unless substr($url,-1) eq "/";
1971 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
1972 if ($url =~ /^file:/) {
1974 if ($CPAN::META->has_inst('LWP')) {
1976 my $u = URI::URL->new($url);
1978 } else { # works only on Unix, is poorly constructed, but
1979 # hopefully better than nothing.
1980 # RFC 1738 says fileurl BNF is
1981 # fileurl = "file://" [ host | "localhost" ] "/" fpath
1982 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
1984 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
1985 $l =~ s|^file:||; # assume they
1988 $l =~ s|^/|| unless -f $l; # e.g. /P:
1990 if ( -f $l && -r _) {
1994 # Maybe mirror has compressed it?
1996 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
1997 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2004 if ($CPAN::META->has_inst('LWP')) {
2005 $CPAN::Frontend->myprint("Fetching with LWP:
2009 require LWP::UserAgent;
2010 $Ua = LWP::UserAgent->new;
2012 my $res = $Ua->mirror($url, $aslocal);
2013 if ($res->is_success) {
2016 } elsif ($url !~ /\.gz$/) {
2017 my $gzurl = "$url.gz";
2018 $CPAN::Frontend->myprint("Fetching with LWP:
2021 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2022 if ($res->is_success &&
2023 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2031 # Alan Burlison informed me that in firewall envs Net::FTP
2032 # can still succeed where LWP fails. So we do not skip
2033 # Net::FTP anymore when LWP is available.
2037 $self->debug("LWP not installed") if $CPAN::DEBUG;
2039 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2040 # that's the nice and easy way thanks to Graham
2041 my($host,$dir,$getfile) = ($1,$2,$3);
2042 if ($CPAN::META->has_inst('Net::FTP')) {
2044 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2047 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2048 "aslocal[$aslocal]") if $CPAN::DEBUG;
2049 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2053 if ($aslocal !~ /\.gz$/) {
2054 my $gz = "$aslocal.gz";
2055 $CPAN::Frontend->myprint("Fetching with Net::FTP
2058 if (CPAN::FTP->ftp_get($host,
2062 CPAN::Tarzip->gunzip($gz,$aslocal)
2075 my($self,$host_seq,$file,$aslocal) = @_;
2077 # Came back if Net::FTP couldn't establish connection (or
2078 # failed otherwise) Maybe they are behind a firewall, but they
2079 # gave us a socksified (or other) ftp program...
2082 my($devnull) = $CPAN::Config->{devnull} || "";
2084 my($aslocal_dir) = File::Basename::dirname($aslocal);
2085 File::Path::mkpath($aslocal_dir);
2086 HOSTHARD: for $i (@$host_seq) {
2087 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2088 unless ($self->is_reachable($url)) {
2089 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2092 $url .= "/" unless substr($url,-1) eq "/";
2094 my($proto,$host,$dir,$getfile);
2096 # Courtesy Mark Conty mark_conty@cargill.com change from
2097 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2099 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2100 # proto not yet used
2101 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2103 next HOSTHARD; # who said, we could ftp anything except ftp?
2105 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2107 for $f ('lynx','ncftpget','ncftp') {
2108 next unless exists $CPAN::Config->{$f};
2109 $funkyftp = $CPAN::Config->{$f};
2110 next unless defined $funkyftp;
2111 next if $funkyftp =~ /^\s*$/;
2112 my($want_compressed);
2113 my $aslocal_uncompressed;
2114 ($aslocal_uncompressed = $aslocal) =~ s/\.gz//;
2115 my($source_switch) = "";
2116 $source_switch = " -source" if $funkyftp =~ /\blynx$/;
2117 $source_switch = " -c" if $funkyftp =~ /\bncftp$/;
2118 $CPAN::Frontend->myprint(
2120 Trying with "$funkyftp$source_switch" to get
2123 my($system) = "$funkyftp$source_switch '$url' $devnull > ".
2124 "$aslocal_uncompressed";
2125 $self->debug("system[$system]") if $CPAN::DEBUG;
2127 if (($wstatus = system($system)) == 0
2129 -s $aslocal_uncompressed # lynx returns 0 on my
2130 # system even if it fails
2132 if ($aslocal_uncompressed ne $aslocal) {
2133 # test gzip integrity
2135 CPAN::Tarzip->gtest($aslocal_uncompressed)
2137 rename $aslocal_uncompressed, $aslocal;
2139 CPAN::Tarzip->gzip($aslocal_uncompressed,
2140 "$aslocal_uncompressed.gz");
2145 } elsif ($url !~ /\.gz$/) {
2146 unlink $aslocal_uncompressed if
2147 -f $aslocal_uncompressed && -s _ == 0;
2148 my $gz = "$aslocal.gz";
2149 my $gzurl = "$url.gz";
2150 $CPAN::Frontend->myprint(
2152 Trying with "$funkyftp$source_switch" to get
2155 my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ".
2156 "$aslocal_uncompressed.gz";
2157 $self->debug("system[$system]") if $CPAN::DEBUG;
2159 if (($wstatus = system($system)) == 0
2161 -s "$aslocal_uncompressed.gz"
2163 # test gzip integrity
2164 if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) {
2165 CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz",
2168 rename $aslocal_uncompressed, $aslocal;
2173 unlink "$aslocal_uncompressed.gz" if
2174 -f "$aslocal_uncompressed.gz";
2177 my $estatus = $wstatus >> 8;
2178 my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : "";
2179 $CPAN::Frontend->myprint(qq{
2180 System call "$system"
2181 returned status $estatus (wstat $wstatus)$size
2189 my($self,$host_seq,$file,$aslocal) = @_;
2192 my($aslocal_dir) = File::Basename::dirname($aslocal);
2193 File::Path::mkpath($aslocal_dir);
2194 HOSTHARDEST: for $i (@$host_seq) {
2195 unless (length $CPAN::Config->{'ftp'}) {
2196 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2199 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2200 unless ($self->is_reachable($url)) {
2201 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2204 $url .= "/" unless substr($url,-1) eq "/";
2206 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2207 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2210 my($host,$dir,$getfile) = ($1,$2,$3);
2213 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2214 $ctime,$blksize,$blocks) = stat($aslocal);
2215 $timestamp = $mtime ||= 0;
2216 my($netrc) = CPAN::FTP::netrc->new;
2217 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2218 my $targetfile = File::Basename::basename($aslocal);
2224 map("cd $_", split "/", $dir), # RFC 1738
2226 "get $getfile $targetfile",
2229 if (! $netrc->netrc) {
2230 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2231 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2232 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2234 $netrc->contains($host))) if $CPAN::DEBUG;
2235 if ($netrc->protected) {
2236 $CPAN::Frontend->myprint(qq{
2237 Trying with external ftp to get
2239 As this requires some features that are not thoroughly tested, we\'re
2240 not sure, that we get it right....
2244 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2246 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2247 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2249 if ($mtime > $timestamp) {
2250 $CPAN::Frontend->myprint("GOT $aslocal\n");
2254 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2257 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2258 qq{correctly protected.\n});
2261 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2262 nor does it have a default entry\n");
2265 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2266 # then and login manually to host, using e-mail as
2268 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2272 "user anonymous $Config::Config{'cf_email'}"
2274 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2275 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2276 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2278 if ($mtime > $timestamp) {
2279 $CPAN::Frontend->myprint("GOT $aslocal\n");
2283 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2285 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2291 my($self,$command,@dialog) = @_;
2292 my $fh = FileHandle->new;
2293 $fh->open("|$command") or die "Couldn't open ftp: $!";
2294 foreach (@dialog) { $fh->print("$_\n") }
2295 $fh->close; # Wait for process to complete
2297 my $estatus = $wstatus >> 8;
2298 $CPAN::Frontend->myprint(qq{
2299 Subprocess "|$command"
2300 returned status $estatus (wstat $wstatus)
2304 # find2perl needs modularization, too, all the following is stolen
2308 my($self,$name) = @_;
2309 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2310 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2312 my($perms,%user,%group);
2316 $blocks = int(($blocks + 1) / 2);
2319 $blocks = int(($sizemm + 1023) / 1024);
2322 if (-f _) { $perms = '-'; }
2323 elsif (-d _) { $perms = 'd'; }
2324 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2325 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2326 elsif (-p _) { $perms = 'p'; }
2327 elsif (-S _) { $perms = 's'; }
2328 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2330 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2331 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2332 my $tmpmode = $mode;
2333 my $tmp = $rwx[$tmpmode & 7];
2335 $tmp = $rwx[$tmpmode & 7] . $tmp;
2337 $tmp = $rwx[$tmpmode & 7] . $tmp;
2338 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2339 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2340 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2343 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2344 my $group = $group{$gid} || $gid;
2346 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2348 my($moname) = $moname[$mon];
2349 if (-M _ > 365.25 / 2) {
2350 $timeyear = $year + 1900;
2353 $timeyear = sprintf("%02d:%02d", $hour, $min);
2356 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2370 package CPAN::FTP::netrc;
2374 my $file = MM->catfile($ENV{HOME},".netrc");
2376 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2377 $atime,$mtime,$ctime,$blksize,$blocks)
2382 my($fh,@machines,$hasdefault);
2384 $fh = FileHandle->new or die "Could not create a filehandle";
2386 if($fh->open($file)){
2387 $protected = ($mode & 077) == 0;
2389 NETRC: while (<$fh>) {
2390 my(@tokens) = split " ", $_;
2391 TOKEN: while (@tokens) {
2392 my($t) = shift @tokens;
2393 if ($t eq "default"){
2397 last TOKEN if $t eq "macdef";
2398 if ($t eq "machine") {
2399 push @machines, shift @tokens;
2404 $file = $hasdefault = $protected = "";
2408 'mach' => [@machines],
2410 'hasdefault' => $hasdefault,
2411 'protected' => $protected,
2415 sub hasdefault { shift->{'hasdefault'} }
2416 sub netrc { shift->{'netrc'} }
2417 sub protected { shift->{'protected'} }
2419 my($self,$mach) = @_;
2420 for ( @{$self->{'mach'}} ) {
2421 return 1 if $_ eq $mach;
2426 package CPAN::Complete;
2429 my($text, $line, $start, $end) = @_;
2430 my(@perlret) = cpl($text, $line, $start);
2431 # find longest common match. Can anybody show me how to peruse
2432 # T::R::Gnu to have this done automatically? Seems expensive.
2433 return () unless @perlret;
2434 my($newtext) = $text;
2435 for (my $i = length($text)+1;;$i++) {
2436 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2437 my $try = substr($perlret[0],0,$i);
2438 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2439 # warn "try[$try]tries[@tries]";
2440 if (@tries == @perlret) {
2446 ($newtext,@perlret);
2449 #-> sub CPAN::Complete::cpl ;
2451 my($word,$line,$pos) = @_;
2455 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2457 if ($line =~ s/^(force\s*)//) {
2465 ! a b d h i m o q r u autobundle clean
2466 make test install force reload look
2469 } elsif ( $line !~ /^[\!abdhimorutl]/ ) {
2471 } elsif ($line =~ /^a\s/) {
2472 @return = cplx('CPAN::Author',$word);
2473 } elsif ($line =~ /^b\s/) {
2474 @return = cplx('CPAN::Bundle',$word);
2475 } elsif ($line =~ /^d\s/) {
2476 @return = cplx('CPAN::Distribution',$word);
2477 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) {
2478 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2479 } elsif ($line =~ /^i\s/) {
2480 @return = cpl_any($word);
2481 } elsif ($line =~ /^reload\s/) {
2482 @return = cpl_reload($word,$line,$pos);
2483 } elsif ($line =~ /^o\s/) {
2484 @return = cpl_option($word,$line,$pos);
2491 #-> sub CPAN::Complete::cplx ;
2493 my($class, $word) = @_;
2494 grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2497 #-> sub CPAN::Complete::cpl_any ;
2501 cplx('CPAN::Author',$word),
2502 cplx('CPAN::Bundle',$word),
2503 cplx('CPAN::Distribution',$word),
2504 cplx('CPAN::Module',$word),
2508 #-> sub CPAN::Complete::cpl_reload ;
2510 my($word,$line,$pos) = @_;
2512 my(@words) = split " ", $line;
2513 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2514 my(@ok) = qw(cpan index);
2515 return @ok if @words == 1;
2516 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2519 #-> sub CPAN::Complete::cpl_option ;
2521 my($word,$line,$pos) = @_;
2523 my(@words) = split " ", $line;
2524 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2525 my(@ok) = qw(conf debug);
2526 return @ok if @words == 1;
2527 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2529 } elsif ($words[1] eq 'index') {
2531 } elsif ($words[1] eq 'conf') {
2532 return CPAN::Config::cpl(@_);
2533 } elsif ($words[1] eq 'debug') {
2534 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2538 package CPAN::Index;
2540 #-> sub CPAN::Index::force_reload ;
2543 $CPAN::Index::last_time = 0;
2547 #-> sub CPAN::Index::reload ;
2549 my($cl,$force) = @_;
2552 # XXX check if a newer one is available. (We currently read it
2553 # from time to time)
2554 for ($CPAN::Config->{index_expire}) {
2555 $_ = 0.001 unless $_ > 0.001;
2557 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2562 my $needshort = $^O eq "dos";
2564 $cl->rd_authindex($cl
2566 "authors/01mailrc.txt.gz",
2568 File::Spec->catfile('authors', '01mailrc.gz') :
2569 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2572 $debug = "timing reading 01[".($t2 - $time)."]";
2574 return if $CPAN::Signal; # this is sometimes lengthy
2575 $cl->rd_modpacks($cl
2577 "modules/02packages.details.txt.gz",
2579 File::Spec->catfile('modules', '02packag.gz') :
2580 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2583 $debug .= "02[".($t2 - $time)."]";
2585 return if $CPAN::Signal; # this is sometimes lengthy
2588 "modules/03modlist.data.gz",
2590 File::Spec->catfile('modules', '03mlist.gz') :
2591 File::Spec->catfile('modules', '03modlist.data.gz'),
2594 $debug .= "03[".($t2 - $time)."]";
2596 CPAN->debug($debug) if $CPAN::DEBUG;
2599 #-> sub CPAN::Index::reload_x ;
2601 my($cl,$wanted,$localname,$force) = @_;
2602 $force |= 2; # means we're dealing with an index here
2603 CPAN::Config->load; # we should guarantee loading wherever we rely
2605 $localname ||= $wanted;
2606 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2610 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2613 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2614 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2615 qq{day$s. I\'ll use that.});
2618 $force |= 1; # means we're quite serious about it.
2620 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2623 #-> sub CPAN::Index::rd_authindex ;
2625 my($cl, $index_target) = @_;
2627 return unless defined $index_target;
2628 $CPAN::Frontend->myprint("Going to read $index_target\n");
2629 # my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2630 # while ($_ = $fh->READLINE) {
2633 tie *FH, CPAN::Tarzip, $index_target;
2635 push @lines, split /\012/ while <FH>;
2637 my($userid,$fullname,$email) =
2638 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2639 next unless $userid && $fullname && $email;
2641 # instantiate an author object
2642 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2643 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2644 return if $CPAN::Signal;
2649 my($self,$dist) = @_;
2650 $dist = $self->{'id'} unless defined $dist;
2651 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2655 #-> sub CPAN::Index::rd_modpacks ;
2657 my($cl, $index_target) = @_;
2659 return unless defined $index_target;
2660 $CPAN::Frontend->myprint("Going to read $index_target\n");
2661 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2663 while ($_ = $fh->READLINE) {
2665 my @ls = map {"$_\n"} split /\n/, $_;
2666 unshift @ls, "\n" x length($1) if /^(\n+)/;
2670 my $shift = shift(@lines);
2671 last if $shift =~ /^\s*$/;
2675 my($mod,$version,$dist) = split;
2676 ### $version =~ s/^\+//;
2678 # if it is a bundle, instatiate a bundle object
2679 my($bundle,$id,$userid);
2681 if ($mod eq 'CPAN' &&
2683 CPAN::Queue->exists('Bundle::CPAN') ||
2684 CPAN::Queue->exists('CPAN')
2688 if ($version > $CPAN::VERSION){
2689 $CPAN::Frontend->myprint(qq{
2690 There\'s a new CPAN.pm version (v$version) available!
2691 You might want to try
2692 install Bundle::CPAN
2694 without quitting the current session. It should be a seamless upgrade
2695 while we are running...
2698 $CPAN::Frontend->myprint(qq{\n});
2700 last if $CPAN::Signal;
2701 } elsif ($mod =~ /^Bundle::(.*)/) {
2706 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2707 # warn "made mod[$mod]a bundle";
2708 # Let's make it a module too, because bundles have so much
2709 # in common with modules
2710 $CPAN::META->instance('CPAN::Module',$mod);
2711 # warn "made mod[$mod]a module";
2713 # This "next" makes us faster but if the job is running long, we ignore
2714 # rereads which is bad. So we have to be a bit slower again.
2715 # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2720 # instantiate a module object
2721 $id = $CPAN::META->instance('CPAN::Module',$mod);
2724 if ($id->cpan_file ne $dist){
2725 $userid = $cl->userid($dist);
2727 'CPAN_USERID' => $userid,
2728 'CPAN_VERSION' => $version,
2729 'CPAN_FILE' => $dist
2733 # instantiate a distribution object
2734 unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2735 $CPAN::META->instance(
2736 'CPAN::Distribution' => $dist
2738 'CPAN_USERID' => $userid
2742 return if $CPAN::Signal;
2747 #-> sub CPAN::Index::rd_modlist ;
2749 my($cl,$index_target) = @_;
2750 return unless defined $index_target;
2751 $CPAN::Frontend->myprint("Going to read $index_target\n");
2752 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2755 while ($_ = $fh->READLINE) {
2757 my @ls = map {"$_\n"} split /\n/, $_;
2758 unshift @ls, "\n" x length($1) if /^(\n+)/;
2762 my $shift = shift(@eval);
2763 if ($shift =~ /^Date:\s+(.*)/){
2764 return if $date_of_03 eq $1;
2767 last if $shift =~ /^\s*$/;
2770 push @eval, q{CPAN::Modulelist->data;};
2772 my($comp) = Safe->new("CPAN::Safe1");
2773 my($eval) = join("", @eval);
2774 my $ret = $comp->reval($eval);
2775 Carp::confess($@) if $@;
2776 return if $CPAN::Signal;
2778 my $obj = $CPAN::META->instance(CPAN::Module,$_);
2779 $obj->set(%{$ret->{$_}});
2780 return if $CPAN::Signal;
2784 package CPAN::InfoObj;
2786 #-> sub CPAN::InfoObj::new ;
2787 sub new { my $this = bless {}, shift; %$this = @_; $this }
2789 #-> sub CPAN::InfoObj::set ;
2791 my($self,%att) = @_;
2792 my(%oldatt) = %$self;
2793 %$self = (%oldatt, %att);
2796 #-> sub CPAN::InfoObj::id ;
2797 sub id { shift->{'ID'} }
2799 #-> sub CPAN::InfoObj::as_glimpse ;
2803 my $class = ref($self);
2804 $class =~ s/^CPAN:://;
2805 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
2809 #-> sub CPAN::InfoObj::as_string ;
2813 my $class = ref($self);
2814 $class =~ s/^CPAN:://;
2815 push @m, $class, " id = $self->{ID}\n";
2816 for (sort keys %$self) {
2819 if ($_ eq "CPAN_USERID") {
2820 $extra .= " (".$self->author;
2821 my $email; # old perls!
2822 if ($email = $CPAN::META->instance(CPAN::Author,
2825 $extra .= " <$email>";
2827 $extra .= " <no email>";
2831 if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
2832 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
2834 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
2840 #-> sub CPAN::InfoObj::author ;
2843 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
2846 package CPAN::Author;
2848 #-> sub CPAN::Author::as_glimpse ;
2852 my $class = ref($self);
2853 $class =~ s/^CPAN:://;
2854 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
2858 # Dead code, I would have liked to have,,, but it was never reached,,,
2861 # return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
2864 #-> sub CPAN::Author::fullname ;
2865 sub fullname { shift->{'FULLNAME'} }
2868 #-> sub CPAN::Author::email ;
2869 sub email { shift->{'EMAIL'} }
2871 package CPAN::Distribution;
2873 #-> sub CPAN::Distribution::called_for ;
2876 $self->{'CALLED_FOR'} = $id if defined $id;
2877 return $self->{'CALLED_FOR'};
2880 #-> sub CPAN::Distribution::get ;
2885 exists $self->{'build_dir'} and push @e,
2886 "Unwrapped into directory $self->{'build_dir'}";
2887 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
2892 $CPAN::Config->{keep_source_where},
2895 split("/",$self->{ID})
2898 $self->debug("Doing localize") if $CPAN::DEBUG;
2900 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
2901 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
2902 $self->{localfile} = $local_file;
2903 my $builddir = $CPAN::META->{cachemgr}->dir;
2904 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
2905 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2908 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
2909 if ($CPAN::META->has_inst('MD5')) {
2910 $self->debug("MD5 is installed, verifying");
2913 $self->debug("MD5 is NOT installed");
2915 $self->debug("Removing tmp") if $CPAN::DEBUG;
2916 File::Path::rmtree("tmp");
2917 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
2919 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
2920 if (! $local_file) {
2921 Carp::croak "bad download, can't do anything :-(\n";
2922 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
2923 $self->untar_me($local_file);
2924 } elsif ( $local_file =~ /\.zip$/i ) {
2925 $self->unzip_me($local_file);
2926 } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
2927 $self->pm2dir_me($local_file);
2929 $self->{archived} = "NO";
2931 chdir File::Spec->updir;
2932 if ($self->{archived} ne 'NO') {
2933 chdir File::Spec->catdir(File::Spec->curdir, "tmp");
2934 # Let's check if the package has its own directory.
2935 my $dh = DirHandle->new(File::Spec->curdir)
2936 or Carp::croak("Couldn't opendir .: $!");
2937 my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
2939 my ($distdir,$packagedir);
2940 if (@readdir == 1 && -d $readdir[0]) {
2941 $distdir = $readdir[0];
2942 $packagedir = MM->catdir($builddir,$distdir);
2943 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
2944 File::Path::rmtree($packagedir);
2945 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
2947 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
2948 $pragmatic_dir =~ s/\W_//g;
2949 $pragmatic_dir++ while -d "../$pragmatic_dir";
2950 $packagedir = MM->catdir($builddir,$pragmatic_dir);
2951 File::Path::mkpath($packagedir);
2953 for $f (@readdir) { # is already without "." and ".."
2954 my $to = MM->catdir($packagedir,$f);
2955 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
2958 $self->{'build_dir'} = $packagedir;
2959 chdir File::Spec->updir;
2961 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
2963 File::Path::rmtree("tmp");
2964 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
2965 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
2966 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
2968 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
2969 unless (-f $makefilepl) {
2970 my($configure) = MM->catfile($packagedir,"Configure");
2971 if (-f $configure) {
2972 # do we have anything to do?
2973 $self->{'configure'} = $configure;
2974 } elsif (-f MM->catfile($packagedir,"Makefile")) {
2975 $CPAN::Frontend->myprint(qq{
2976 Package comes with a Makefile and without a Makefile.PL.
2977 We\'ll try to build it with that Makefile then.
2979 $self->{writemakefile} = "YES";
2982 my $fh = FileHandle->new(">$makefilepl")
2983 or Carp::croak("Could not open >$makefilepl");
2984 my $cf = $self->called_for || "unknown";
2986 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
2987 # because there was no Makefile.PL supplied.
2988 # Autogenerated on: }.scalar localtime().qq{
2990 use ExtUtils::MakeMaker;
2991 WriteMakefile(NAME => q[$cf]);
2994 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
2995 Writing one on our own (calling it $cf)\n});
3003 my($self,$local_file) = @_;
3004 $self->{archived} = "tar";
3005 if (CPAN::Tarzip->untar($local_file)) {
3006 $self->{unwrapped} = "YES";
3008 $self->{unwrapped} = "NO";
3013 my($self,$local_file) = @_;
3014 $self->{archived} = "zip";
3015 my $system = "$CPAN::Config->{unzip} $local_file";
3016 if (system($system) == 0) {
3017 $self->{unwrapped} = "YES";
3019 $self->{unwrapped} = "NO";
3024 my($self,$local_file) = @_;
3025 $self->{archived} = "pm";
3026 my $to = File::Basename::basename($local_file);
3027 $to =~ s/\.(gz|Z)$//;
3028 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3029 $self->{unwrapped} = "YES";
3031 $self->{unwrapped} = "NO";
3035 #-> sub CPAN::Distribution::new ;
3037 my($class,%att) = @_;
3039 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3041 my $this = { %att };
3042 return bless $this, $class;
3045 #-> sub CPAN::Distribution::look ;
3049 if ($^O eq 'MacOS') {
3050 $self->ExtUtils::MM_MacOS::look;
3054 if ( $CPAN::Config->{'shell'} ) {
3055 $CPAN::Frontend->myprint(qq{
3056 Trying to open a subshell in the build directory...
3059 $CPAN::Frontend->myprint(qq{
3060 Your configuration does not define a value for subshells.
3061 Please define it with "o conf shell <your shell>"
3065 my $dist = $self->id;
3066 my $dir = $self->dir or $self->get;
3069 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3070 my $pwd = CPAN->$getcwd();
3072 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3073 system($CPAN::Config->{'shell'}) == 0
3074 or $CPAN::Frontend->mydie("Subprocess shell error");
3078 #-> sub CPAN::Distribution::readme ;
3081 my($dist) = $self->id;
3082 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3083 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3087 $CPAN::Config->{keep_source_where},
3090 split("/","$sans.readme"),
3092 $self->debug("Doing localize") if $CPAN::DEBUG;
3093 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3095 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3097 if ($^O eq 'MacOS') {
3098 ExtUtils::MM_MacOS::launch_file($local_file);
3102 my $fh_pager = FileHandle->new;
3103 local($SIG{PIPE}) = "IGNORE";
3104 $fh_pager->open("|$CPAN::Config->{'pager'}")
3105 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3106 my $fh_readme = FileHandle->new;
3107 $fh_readme->open($local_file)
3108 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3109 $CPAN::Frontend->myprint(qq{
3112 with pager "$CPAN::Config->{'pager'}"
3115 $fh_pager->print(<$fh_readme>);
3118 #-> sub CPAN::Distribution::verifyMD5 ;
3123 $self->{MD5_STATUS} ||= "";
3124 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3125 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3127 my($lc_want,$lc_file,@local,$basename);
3128 @local = split("/",$self->{ID});
3130 push @local, "CHECKSUMS";
3132 MM->catfile($CPAN::Config->{keep_source_where},
3133 "authors", "id", @local);
3138 $self->MD5_check_file($lc_want)
3140 return $self->{MD5_STATUS} = "OK";
3142 $lc_file = CPAN::FTP->localize("authors/id/@local",
3145 $local[-1] .= ".gz";
3146 $lc_file = CPAN::FTP->localize("authors/id/@local",
3149 $lc_file =~ s/\.gz$//;
3150 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3155 $self->MD5_check_file($lc_file);
3158 #-> sub CPAN::Distribution::MD5_check_file ;
3159 sub MD5_check_file {
3160 my($self,$chk_file) = @_;
3161 my($cksum,$file,$basename);
3162 $file = $self->{localfile};
3163 $basename = File::Basename::basename($file);
3164 my $fh = FileHandle->new;
3165 if (open $fh, $chk_file){
3168 $eval =~ s/\015?\012/\n/g;
3170 my($comp) = Safe->new();
3171 $cksum = $comp->reval($eval);
3173 rename $chk_file, "$chk_file.bad";
3174 Carp::confess($@) if $@;
3177 Carp::carp "Could not open $chk_file for reading";
3180 if (exists $cksum->{$basename}{md5}) {
3181 $self->debug("Found checksum for $basename:" .
3182 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3186 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3188 $fh = CPAN::Tarzip->TIEHANDLE($file);
3191 # had to inline it, when I tied it, the tiedness got lost on
3192 # the call to eq_MD5. (Jan 1998)
3196 while ($fh->READ($ref, 4096)){
3199 my $hexdigest = $md5->hexdigest;
3200 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3204 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3205 return $self->{MD5_STATUS} = "OK";
3207 $CPAN::Frontend->myprint(qq{Checksum mismatch for }.
3208 qq{distribution file. }.
3209 qq{Please investigate.\n\n}.
3211 $CPAN::META->instance(
3213 $self->{CPAN_USERID}
3215 my $wrap = qq{I\'d recommend removing $file. It seems to
3216 be a bogus file. Maybe you have configured your \`urllist\' with a
3217 bad URL. Please check this array with \`o conf urllist\', and
3219 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3220 $CPAN::Frontend->myprint("\n\n");
3224 # close $fh if fileno($fh);
3226 $self->{MD5_STATUS} ||= "";
3227 if ($self->{MD5_STATUS} eq "NIL") {
3228 $CPAN::Frontend->myprint(qq{
3229 No md5 checksum for $basename in local $chk_file.
3232 unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
3235 $self->{MD5_STATUS} = "NIL";
3240 #-> sub CPAN::Distribution::eq_MD5 ;
3242 my($self,$fh,$expectMD5) = @_;
3245 while (read($fh, $data, 4096)){
3248 # $md5->addfile($fh);
3249 my $hexdigest = $md5->hexdigest;
3250 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3251 $hexdigest eq $expectMD5;
3254 #-> sub CPAN::Distribution::force ;
3257 $self->{'force_update'}++;
3259 MD5_STATUS archived build_dir localfile make install unwrapped
3260 writemakefile have_sponsored
3262 delete $self->{$att};
3268 my $file = File::Basename::basename($self->id);
3269 return unless $file =~ m{ ^ perl
3272 (\d{3}(_[0-4][0-9])?)
3279 #-> sub CPAN::Distribution::perl ;
3282 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3283 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3284 my $pwd = CPAN->$getcwd();
3285 my $candidate = MM->catfile($pwd,$^X);
3286 $perl ||= $candidate if MM->maybe_command($candidate);
3288 my ($component,$perl_name);
3289 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3290 PATH_COMPONENT: foreach $component (MM->path(),
3291 $Config::Config{'binexp'}) {
3292 next unless defined($component) && $component;
3293 my($abs) = MM->catfile($component,$perl_name);
3294 if (MM->maybe_command($abs)) {
3304 #-> sub CPAN::Distribution::make ;
3307 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3308 # Emergency brake if they said install Pippi and get newest perl
3309 if ($self->isa_perl) {
3311 $self->called_for ne $self->id && ! $self->{'force_update'}
3313 $CPAN::Frontend->mydie(sprintf qq{
3314 The most recent version "%s" of the module "%s"
3315 comes with the current version of perl (%s).
3316 I\'ll build that only if you ask for something like
3321 $CPAN::META->instance(
3334 $self->{archived} eq "NO" and push @e,
3335 "Is neither a tar nor a zip archive.";
3337 $self->{unwrapped} eq "NO" and push @e,
3338 "had problems unarchiving. Please build manually";
3340 exists $self->{writemakefile} &&
3341 $self->{writemakefile} eq "NO" and push @e,
3342 "Had some problem writing Makefile";
3344 defined $self->{'make'} and push @e,
3345 "Has already been processed within this session";
3347 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3349 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
3350 my $builddir = $self->dir;
3351 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3352 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3354 if ($^O eq 'MacOS') {
3355 ExtUtils::MM_MacOS::make($self);
3360 if ($self->{'configure'}) {
3361 $system = $self->{'configure'};
3363 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3365 # This needs a handler that can be turned on or off:
3366 # $switch = "-MExtUtils::MakeMaker ".
3367 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3369 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3371 unless (exists $self->{writemakefile}) {
3372 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3375 if ($CPAN::Config->{inactivity_timeout}) {
3377 alarm $CPAN::Config->{inactivity_timeout};
3378 local $SIG{CHLD}; # = sub { wait };
3379 if (defined($pid = fork)) {
3384 # note, this exec isn't necessary if
3385 # inactivity_timeout is 0. On the Mac I'd
3386 # suggest, we set it always to 0.
3390 $CPAN::Frontend->myprint("Cannot fork: $!");
3398 $CPAN::Frontend->myprint($@);
3399 $self->{writemakefile} = "NO - $@";
3404 $ret = system($system);
3406 $self->{writemakefile} = "NO";
3410 $self->{writemakefile} = "YES";
3412 return if $CPAN::Signal;
3413 if (my @prereq = $self->needs_prereq){
3415 $CPAN::Frontend->myprint("---- Dependencies detected ".
3416 "during [$id] -----\n");
3418 for my $p (@prereq) {
3419 $CPAN::Frontend->myprint(" $p\n");
3422 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3424 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3425 require ExtUtils::MakeMaker;
3426 my $answer = ExtUtils::MakeMaker::prompt(
3427 "Shall I follow them and prepend them to the queue
3428 of modules we are processing right now?", "yes");
3429 $follow = $answer =~ /^\s*y/i;
3432 $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n");
3435 CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3439 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3440 if (system($system) == 0) {
3441 $CPAN::Frontend->myprint(" $system -- OK\n");
3442 $self->{'make'} = "YES";
3444 $self->{writemakefile} = "YES";
3445 $self->{'make'} = "NO";
3446 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3450 #-> sub CPAN::Distribution::needs_prereq ;
3453 return unless -f "Makefile"; # we cannot say much
3454 my $fh = FileHandle->new("<Makefile") or
3455 $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3460 last if /MakeMaker post_initialize section/;
3462 \s+PREREQ_PM\s+=>\s+(.+)
3465 # warn "Found prereq expr[$p]";
3467 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){
3473 my $mo = $CPAN::META->instance("CPAN::Module",$p);
3474 next if $mo->uptodate;
3475 # it's not needed, so don't push it. We cannot omit this step, because
3476 # if 'force' is in effect, nobody else will check.
3477 if ($self->{'have_sponsored'}{$p}++){
3478 # We have already sponsored it and for some reason it's still
3479 # not available. So we do nothing. Or what should we do?
3480 # if we push it again, we have a potential infinite loop
3488 #-> sub CPAN::Distribution::test ;
3492 return if $CPAN::Signal;
3493 $CPAN::Frontend->myprint("Running make test\n");
3496 exists $self->{'make'} or push @e,
3497 "Make had some problems, maybe interrupted? Won't test";
3499 exists $self->{'make'} and
3500 $self->{'make'} eq 'NO' and
3501 push @e, "Oops, make had returned bad status";
3503 exists $self->{'build_dir'} or push @e, "Has no own directory";
3504 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3506 chdir $self->{'build_dir'} or
3507 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3508 $self->debug("Changed directory to $self->{'build_dir'}")
3511 if ($^O eq 'MacOS') {
3512 ExtUtils::MM_MacOS::make_test($self);
3516 my $system = join " ", $CPAN::Config->{'make'}, "test";
3517 if (system($system) == 0) {
3518 $CPAN::Frontend->myprint(" $system -- OK\n");
3519 $self->{'make_test'} = "YES";
3521 $self->{'make_test'} = "NO";
3522 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3526 #-> sub CPAN::Distribution::clean ;
3529 $CPAN::Frontend->myprint("Running make clean\n");
3532 exists $self->{'build_dir'} or push @e, "Has no own directory";
3533 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3535 chdir $self->{'build_dir'} or
3536 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3537 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3539 if ($^O eq 'MacOS') {
3540 ExtUtils::MM_MacOS::make_clean($self);
3544 my $system = join " ", $CPAN::Config->{'make'}, "clean";
3545 if (system($system) == 0) {
3546 $CPAN::Frontend->myprint(" $system -- OK\n");
3549 # Hmmm, what to do if make clean failed?
3553 #-> sub CPAN::Distribution::install ;
3557 return if $CPAN::Signal;
3558 $CPAN::Frontend->myprint("Running make install\n");
3561 exists $self->{'build_dir'} or push @e, "Has no own directory";
3563 exists $self->{'make'} or push @e,
3564 "Make had some problems, maybe interrupted? Won't install";
3566 exists $self->{'make'} and
3567 $self->{'make'} eq 'NO' and
3568 push @e, "Oops, make had returned bad status";
3570 push @e, "make test had returned bad status, ".
3571 "won't install without force"
3572 if exists $self->{'make_test'} and
3573 $self->{'make_test'} eq 'NO' and
3574 ! $self->{'force_update'};
3576 exists $self->{'install'} and push @e,
3577 $self->{'install'} eq "YES" ?
3578 "Already done" : "Already tried without success";
3580 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3582 chdir $self->{'build_dir'} or
3583 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3584 $self->debug("Changed directory to $self->{'build_dir'}")
3587 if ($^O eq 'MacOS') {
3588 ExtUtils::MM_MacOS::make_install($self);
3592 my $system = join(" ", $CPAN::Config->{'make'},
3593 "install", $CPAN::Config->{make_install_arg});
3594 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
3595 my($pipe) = FileHandle->new("$system $stderr |");
3598 $CPAN::Frontend->myprint($_);
3603 $CPAN::Frontend->myprint(" $system -- OK\n");
3604 return $self->{'install'} = "YES";
3606 $self->{'install'} = "NO";
3607 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3608 if ($makeout =~ /permission/s && $> > 0) {
3609 $CPAN::Frontend->myprint(qq{ You may have to su }.
3610 qq{to root to install the package\n});
3615 #-> sub CPAN::Distribution::dir ;
3617 shift->{'build_dir'};
3620 package CPAN::Bundle;
3622 #-> sub CPAN::Bundle::as_string ;
3626 $self->{INST_VERSION} = $self->inst_version;
3627 return $self->SUPER::as_string;
3630 #-> sub CPAN::Bundle::contains ;
3633 my($parsefile) = $self->inst_file;
3634 my($id) = $self->id;
3635 $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
3636 unless ($parsefile) {
3637 # Try to get at it in the cpan directory
3638 $self->debug("no parsefile") if $CPAN::DEBUG;
3639 Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
3640 my $dist = $CPAN::META->instance('CPAN::Distribution',
3641 $self->{CPAN_FILE});
3643 $self->debug($dist->as_string) if $CPAN::DEBUG;
3644 my($todir) = $CPAN::Config->{'cpan_home'};
3645 my(@me,$from,$to,$me);
3646 @me = split /::/, $self->id;
3648 $me = MM->catfile(@me);
3649 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
3650 $to = MM->catfile($todir,$me);
3651 File::Path::mkpath(File::Basename::dirname($to));
3652 File::Copy::copy($from, $to)
3653 or Carp::confess("Couldn't copy $from to $to: $!");
3657 my $fh = FileHandle->new;
3659 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
3661 $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
3663 $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 :
3664 m/^=head1\s+CONTENTS/ ? 1 : $inpod;
3669 push @result, (split " ", $_, 2)[0];
3672 delete $self->{STATUS};
3673 $self->{CONTAINS} = join ", ", @result;
3674 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
3676 $CPAN::Frontend->mywarn(qq{
3677 The bundle file "$parsefile" may be a broken
3678 bundlefile. It seems not to contain any bundle definition.
3679 Please check the file and if it is bogus, please delete it.
3680 Sorry for the inconvenience.
3686 #-> sub CPAN::Bundle::find_bundle_file
3687 sub find_bundle_file {
3688 my($self,$where,$what) = @_;
3689 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
3690 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
3691 ### my $bu = MM->catfile($where,$what);
3692 ### return $bu if -f $bu;
3693 my $manifest = MM->catfile($where,"MANIFEST");
3694 unless (-f $manifest) {
3695 require ExtUtils::Manifest;
3696 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3697 my $cwd = CPAN->$getcwd();
3699 ExtUtils::Manifest::mkmanifest();
3702 my $fh = FileHandle->new($manifest)
3703 or Carp::croak("Couldn't open $manifest: $!");
3706 if ($^O eq 'MacOS') {
3709 $what2 =~ s/:Bundle://;
3712 $what2 =~ s|Bundle/||;
3717 my($file) = /(\S+)/;
3718 if ($file =~ m|\Q$what\E$|) {
3720 # return MM->catfile($where,$bu); # bad
3723 # retry if she managed to
3724 # have no Bundle directory
3725 $bu = $file if $file =~ m|\Q$what2\E$|;
3727 $bu =~ tr|/|:| if $^O eq 'MacOS';
3728 return MM->catfile($where, $bu) if $bu;
3729 Carp::croak("Couldn't find a Bundle file in $where");
3732 #-> sub CPAN::Bundle::inst_file ;
3736 ($me = $self->id) =~ s/.*://;
3737 ## my(@me,$inst_file);
3738 ## @me = split /::/, $self->id;
3739 ## $me[-1] .= ".pm";
3740 $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
3741 "Bundle", "$me.pm");
3743 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3745 $self->SUPER::inst_file;
3746 # return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3747 # return $self->{'INST_FILE'}; # even if undefined?
3750 #-> sub CPAN::Bundle::rematein ;
3752 my($self,$meth) = @_;
3753 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
3754 my($id) = $self->id;
3755 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
3756 unless $self->inst_file || $self->{CPAN_FILE};
3758 for $s ($self->contains) {
3759 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
3760 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
3761 if ($type eq 'CPAN::Distribution') {
3762 $CPAN::Frontend->mywarn(qq{
3763 The Bundle }.$self->id.qq{ contains
3764 explicitly a file $s.
3768 # possibly noisy action:
3769 my $obj = $CPAN::META->instance($type,$s);
3771 my $success = $obj->can("uptodate") ? $obj->uptodate : 0;
3772 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
3773 $fail{$s} = 1 unless $success;
3775 # recap with less noise
3776 if ( $meth eq "install") {
3778 $CPAN::Frontend->myprint(qq{\nBundle summary: }.
3779 qq{The following items seem to }.
3780 qq{have had installation problems:\n});
3781 for $s ($self->contains) {
3782 $CPAN::Frontend->myprint( "$s " ) if $fail{$s};
3784 $CPAN::Frontend->myprint(qq{\n});
3786 $self->{'install'} = 'YES';
3791 #sub CPAN::Bundle::xs_file
3793 # If a bundle contains another that contains an xs_file we have
3794 # here, we just don't bother I suppose
3798 #-> sub CPAN::Bundle::force ;
3799 sub force { shift->rematein('force',@_); }
3800 #-> sub CPAN::Bundle::get ;
3801 sub get { shift->rematein('get',@_); }
3802 #-> sub CPAN::Bundle::make ;
3803 sub make { shift->rematein('make',@_); }
3804 #-> sub CPAN::Bundle::test ;
3805 sub test { shift->rematein('test',@_); }
3806 #-> sub CPAN::Bundle::install ;
3809 $self->rematein('install',@_);
3811 #-> sub CPAN::Bundle::clean ;
3812 sub clean { shift->rematein('clean',@_); }
3814 #-> sub CPAN::Bundle::readme ;
3817 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
3818 No File found for bundle } . $self->id . qq{\n}), return;
3819 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
3820 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
3823 package CPAN::Module;
3825 #-> sub CPAN::Module::as_glimpse ;
3829 my $class = ref($self);
3830 $class =~ s/^CPAN:://;
3831 push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
3836 #-> sub CPAN::Module::as_string ;
3840 CPAN->debug($self) if $CPAN::DEBUG;
3841 my $class = ref($self);
3842 $class =~ s/^CPAN:://;
3844 push @m, $class, " id = $self->{ID}\n";
3845 my $sprintf = " %-12s %s\n";
3846 push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
3847 if $self->{description};
3848 my $sprintf2 = " %-12s %s (%s)\n";
3850 if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
3852 if ($author = CPAN::Shell->expand('Author',$userid)) {
3855 if ($m = $author->email) {
3862 $author->fullname . $email
3866 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
3867 if $self->{CPAN_VERSION};
3868 push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
3869 if $self->{CPAN_FILE};
3870 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
3871 my(%statd,%stats,%statl,%stati);
3872 @statd{qw,? i c a b R M S,} = qw,unknown idea
3873 pre-alpha alpha beta released mature standard,;
3874 @stats{qw,? m d u n,} = qw,unknown mailing-list
3875 developer comp.lang.perl.* none,;
3876 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
3877 @stati{qw,? f r O h,} = qw,unknown functions
3878 references+ties object-oriented hybrid,;
3879 $statd{' '} = 'unknown';
3880 $stats{' '} = 'unknown';
3881 $statl{' '} = 'unknown';
3882 $stati{' '} = 'unknown';
3890 $statd{$self->{statd}},
3891 $stats{$self->{stats}},
3892 $statl{$self->{statl}},
3893 $stati{$self->{stati}}
3894 ) if $self->{statd};
3895 my $local_file = $self->inst_file;
3897 $self->{MANPAGE} ||= $self->manpage_headline($local_file);
3900 for $item (qw/MANPAGE CONTAINS/) {
3901 push @m, sprintf($sprintf, $item, $self->{$item})
3902 if exists $self->{$item};
3904 push @m, sprintf($sprintf, 'INST_FILE',
3905 $local_file || "(not installed)");
3906 push @m, sprintf($sprintf, 'INST_VERSION',
3907 $self->inst_version) if $local_file;
3911 sub manpage_headline {
3912 my($self,$local_file) = @_;
3913 my(@local_file) = $local_file;
3914 $local_file =~ s/\.pm$/.pod/;
3915 push @local_file, $local_file;
3917 for $locf (@local_file) {
3918 next unless -f $locf;
3919 my $fh = FileHandle->new($locf)
3920 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
3924 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
3925 m/^=head1\s+NAME/ ? 1 : $inpod;
3938 #-> sub CPAN::Module::cpan_file ;
3941 CPAN->debug($self->id) if $CPAN::DEBUG;
3942 unless (defined $self->{'CPAN_FILE'}) {
3943 CPAN::Index->reload;
3945 if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
3946 return $self->{'CPAN_FILE'};
3947 } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
3948 my $fullname = $CPAN::META->instance(CPAN::Author,
3949 $self->{'userid'})->fullname;
3950 my $email = $CPAN::META->instance(CPAN::Author,
3951 $self->{'userid'})->email;
3952 unless (defined $fullname && defined $email) {
3953 return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
3955 return "Contact Author $fullname <$email>";
3961 *name = \&cpan_file;
3963 #-> sub CPAN::Module::cpan_version ;
3966 $self->{'CPAN_VERSION'} = 'undef'
3967 unless defined $self->{'CPAN_VERSION'}; # I believe this is
3968 # always a bug in the
3969 # index and should be
3971 # but usually I find
3973 # and do not want to
3976 $self->{'CPAN_VERSION'};
3979 #-> sub CPAN::Module::force ;
3982 $self->{'force_update'}++;
3985 #-> sub CPAN::Module::rematein ;
3987 my($self,$meth) = @_;
3988 $self->debug($self->id) if $CPAN::DEBUG;
3989 my $cpan_file = $self->cpan_file;
3990 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
3991 $CPAN::Frontend->mywarn(sprintf qq{
3992 The module %s isn\'t available on CPAN.
3994 Either the module has not yet been uploaded to CPAN, or it is
3995 temporary unavailable. Please contact the author to find out
3996 more about the status. Try ``i %s''.
4003 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
4004 $pack->called_for($self->id);
4005 $pack->force if exists $self->{'force_update'};
4007 delete $self->{'force_update'};
4010 #-> sub CPAN::Module::readme ;
4011 sub readme { shift->rematein('readme') }
4012 #-> sub CPAN::Module::look ;
4013 sub look { shift->rematein('look') }
4014 #-> sub CPAN::Module::get ;
4015 sub get { shift->rematein('get',@_); }
4016 #-> sub CPAN::Module::make ;
4017 sub make { shift->rematein('make') }
4018 #-> sub CPAN::Module::test ;
4019 sub test { shift->rematein('test') }
4020 #-> sub CPAN::Module::uptodate ;
4023 my($latest) = $self->cpan_version;
4025 my($inst_file) = $self->inst_file;
4027 if (defined $inst_file) {
4028 $have = $self->inst_version;
4039 #-> sub CPAN::Module::install ;
4045 not exists $self->{'force_update'}
4047 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
4051 $self->rematein('install') if $doit;
4053 #-> sub CPAN::Module::clean ;
4054 sub clean { shift->rematein('clean') }
4056 #-> sub CPAN::Module::inst_file ;
4060 @packpath = split /::/, $self->{ID};
4061 $packpath[-1] .= ".pm";
4062 foreach $dir (@INC) {
4063 my $pmfile = MM->catfile($dir,@packpath);
4071 #-> sub CPAN::Module::xs_file ;
4075 @packpath = split /::/, $self->{ID};
4076 push @packpath, $packpath[-1];
4077 $packpath[-1] .= "." . $Config::Config{'dlext'};
4078 foreach $dir (@INC) {
4079 my $xsfile = MM->catfile($dir,'auto',@packpath);
4087 #-> sub CPAN::Module::inst_version ;
4090 my $parsefile = $self->inst_file or return;
4091 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4093 my $have = MM->parse_version($parsefile) || "undef";
4098 package CPAN::Tarzip;
4101 my($class,$read,$write) = @_;
4102 if ($CPAN::META->has_inst("Compress::Zlib")) {
4104 $fhw = FileHandle->new($read)
4105 or $CPAN::Frontend->mydie("Could not open $read: $!");
4106 my $gz = Compress::Zlib::gzopen($write, "wb")
4107 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
4108 $gz->gzwrite($buffer)
4109 while read($fhw,$buffer,4096) > 0 ;
4114 system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
4119 my($class,$read,$write) = @_;
4120 if ($CPAN::META->has_inst("Compress::Zlib")) {
4122 $fhw = FileHandle->new(">$write")
4123 or $CPAN::Frontend->mydie("Could not open >$write: $!");
4124 my $gz = Compress::Zlib::gzopen($read, "rb")
4125 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
4126 $fhw->print($buffer)
4127 while $gz->gzread($buffer) > 0 ;
4128 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4129 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4134 system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
4139 my($class,$read) = @_;
4140 if ($CPAN::META->has_inst("Compress::Zlib")) {
4142 my $gz = Compress::Zlib::gzopen($read, "rb")
4143 or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
4144 1 while $gz->gzread($buffer) > 0 ;
4145 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4146 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4150 return system("$CPAN::Config->{'gzip'} -dt $read")==0;
4155 my($class,$file) = @_;
4157 $class->debug("file[$file]");
4158 if ($CPAN::META->has_inst("Compress::Zlib")) {
4159 my $gz = Compress::Zlib::gzopen($file,"rb") or
4160 die "Could not gzopen $file";
4161 $ret = bless {GZ => $gz}, $class;
4163 my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
4164 my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
4166 $ret = bless {FH => $fh}, $class;
4173 if (exists $self->{GZ}) {
4174 my $gz = $self->{GZ};
4175 my($line,$bytesread);
4176 $bytesread = $gz->gzreadline($line);
4177 return undef if $bytesread == 0;
4180 my $fh = $self->{FH};
4181 return scalar <$fh>;
4186 my($self,$ref,$length,$offset) = @_;
4187 die "read with offset not implemented" if defined $offset;
4188 if (exists $self->{GZ}) {
4189 my $gz = $self->{GZ};
4190 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
4193 my $fh = $self->{FH};
4194 return read($fh,$$ref,$length);
4200 if (exists $self->{GZ}) {
4201 my $gz = $self->{GZ};
4204 my $fh = $self->{FH};
4211 my($class,$file) = @_;
4212 # had to disable, because version 0.07 seems to be buggy
4213 if (MM->maybe_command($CPAN::Config->{'gzip'})
4215 MM->maybe_command($CPAN::Config->{'tar'})) {
4216 if ($^O =~ /win/i) { # irgggh
4217 # people find the most curious tar binaries that cannot handle
4219 my $system = "$CPAN::Config->{'gzip'} --decompress $file";
4220 if (system($system)==0) {
4221 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
4223 $CPAN::Frontend->mydie(
4224 qq{Couldn\'t uncompress $file\n}
4228 $system = "$CPAN::Config->{tar} xvf $file";
4229 if (system($system)==0) {
4230 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
4232 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
4236 my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
4237 "< $file | $CPAN::Config->{tar} xvf -";
4238 return system($system) == 0;
4240 } elsif ($CPAN::META->has_inst("Archive::Tar")
4242 $CPAN::META->has_inst("Compress::Zlib") ) {
4243 my $tar = Archive::Tar->new($file,1);
4244 $tar->extract($tar->list_files); # I'm pretty sure we have nothing
4245 # that isn't compressed
4247 ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
4248 if ($^O eq 'MacOS');
4252 $CPAN::Frontend->mydie(qq{
4253 CPAN.pm needs either both external programs tar and gzip installed or
4254 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
4255 is available. Can\'t continue.
4268 CPAN - query, download and build perl modules from CPAN sites
4274 perl -MCPAN -e shell;
4280 autobundle, clean, install, make, recompile, test
4284 The CPAN module is designed to automate the make and install of perl
4285 modules and extensions. It includes some searching capabilities and
4286 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
4287 to fetch the raw data from the net.
4289 Modules are fetched from one or more of the mirrored CPAN
4290 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
4293 The CPAN module also supports the concept of named and versioned
4294 'bundles' of modules. Bundles simplify the handling of sets of
4295 related modules. See BUNDLES below.
4297 The package contains a session manager and a cache manager. There is
4298 no status retained between sessions. The session manager keeps track
4299 of what has been fetched, built and installed in the current
4300 session. The cache manager keeps track of the disk space occupied by
4301 the make processes and deletes excess space according to a simple FIFO
4304 For extended searching capabilities there's a plugin for CPAN available,
4305 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
4306 all documents available in CPAN authors directories. If C<CPAN::WAIT>
4307 is installed on your system, the interactive shell of <CPAN.pm> will
4308 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
4309 queries to the WAIT server that has been configured for your
4312 All other methods provided are accessible in a programmer style and in an
4313 interactive shell style.
4315 =head2 Interactive Mode
4317 The interactive mode is entered by running
4319 perl -MCPAN -e shell
4321 which puts you into a readline interface. You will have the most fun if
4322 you install Term::ReadKey and Term::ReadLine to enjoy both history and
4325 Once you are on the command line, type 'h' and the rest should be
4328 The most common uses of the interactive modes are
4332 =item Searching for authors, bundles, distribution files and modules
4334 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
4335 for each of the four categories and another, C<i> for any of the
4336 mentioned four. Each of the four entities is implemented as a class
4337 with slightly differing methods for displaying an object.
4339 Arguments you pass to these commands are either strings exactly matching
4340 the identification string of an object or regular expressions that are
4341 then matched case-insensitively against various attributes of the
4342 objects. The parser recognizes a regular expression only if you
4343 enclose it between two slashes.
4345 The principle is that the number of found objects influences how an
4346 item is displayed. If the search finds one item, the result is displayed
4347 as object-E<gt>as_string, but if we find more than one, we display
4348 each as object-E<gt>as_glimpse. E.g.
4352 EMAIL a.koenig@franz.ww.TU-Berlin.DE
4353 FULLNAME Andreas König
4358 EMAIL a.koenig@franz.ww.TU-Berlin.DE
4359 FULLNAME Andreas König
4363 Author ANDYD (Andy Dougherty)
4364 Author MERLYN (Randal L. Schwartz)
4366 =item make, test, install, clean modules or distributions
4368 These commands take any number of arguments and investigates what is
4369 necessary to perform the action. If the argument is a distribution
4370 file name (recognized by embedded slashes), it is processed. If it is
4371 a module, CPAN determines the distribution file in which this module
4372 is included and processes that, following any dependencies named in
4373 the module's Makefile.PL (this behavior is controlled by
4374 I<prerequisites_policy>.)
4376 Any C<make> or C<test> are run unconditionally. An
4378 install <distribution_file>
4380 also is run unconditionally. But for
4384 CPAN checks if an install is actually needed for it and prints
4385 I<module up to date> in the case that the distribution file containing
4386 the module doesnE<39>t need to be updated.
4388 CPAN also keeps track of what it has done within the current session
4389 and doesnE<39>t try to build a package a second time regardless if it
4390 succeeded or not. The C<force> command takes as a first argument the
4391 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
4392 command from scratch.
4396 cpan> install OpenGL
4397 OpenGL is up to date.
4398 cpan> force install OpenGL
4401 OpenGL-0.4/COPYRIGHT
4404 A C<clean> command results in a
4408 being executed within the distribution file's working directory.
4410 =item readme, look module or distribution
4412 These two commands take only one argument, be it a module or a
4413 distribution file. C<readme> unconditionally runs, displaying the
4414 README of the associated distribution file. C<Look> gets and
4415 untars (if not yet done) the distribution file, changes to the
4416 appropriate directory and opens a subshell process in that directory.
4420 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
4421 in the cpan-shell it is intended that you can press C<^C> anytime and
4422 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
4423 to clean up and leave the shell loop. You can emulate the effect of a
4424 SIGTERM by sending two consecutive SIGINTs, which usually means by
4425 pressing C<^C> twice.
4427 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
4428 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
4434 The commands that are available in the shell interface are methods in
4435 the package CPAN::Shell. If you enter the shell command, all your
4436 input is split by the Text::ParseWords::shellwords() routine which
4437 acts like most shells do. The first word is being interpreted as the
4438 method to be called and the rest of the words are treated as arguments
4439 to this method. Continuation lines are supported if a line ends with a
4444 C<autobundle> writes a bundle file into the
4445 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
4446 a list of all modules that are both available from CPAN and currently
4447 installed within @INC. The name of the bundle file is based on the
4448 current date and a counter.
4452 recompile() is a very special command in that it takes no argument and
4453 runs the make/test/install cycle with brute force over all installed
4454 dynamically loadable extensions (aka XS modules) with 'force' in
4455 effect. The primary purpose of this command is to finish a network
4456 installation. Imagine, you have a common source tree for two different
4457 architectures. You decide to do a completely independent fresh
4458 installation. You start on one architecture with the help of a Bundle
4459 file produced earlier. CPAN installs the whole Bundle for you, but
4460 when you try to repeat the job on the second architecture, CPAN
4461 responds with a C<"Foo up to date"> message for all modules. So you
4462 invoke CPAN's recompile on the second architecture and youE<39>re done.
4464 Another popular use for C<recompile> is to act as a rescue in case your
4465 perl breaks binary compatibility. If one of the modules that CPAN uses
4466 is in turn depending on binary compatibility (so you cannot run CPAN
4467 commands), then you should try the CPAN::Nox module for recovery.
4469 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
4471 Although it may be considered internal, the class hierarchy does matter
4472 for both users and programmer. CPAN.pm deals with above mentioned four
4473 classes, and all those classes share a set of methods. A classical
4474 single polymorphism is in effect. A metaclass object registers all
4475 objects of all kinds and indexes them with a string. The strings
4476 referencing objects have a separated namespace (well, not completely
4481 words containing a "/" (slash) Distribution
4482 words starting with Bundle:: Bundle
4483 everything else Module or Author
4485 Modules know their associated Distribution objects. They always refer
4486 to the most recent official release. Developers may mark their releases
4487 as unstable development versions (by inserting an underbar into the
4488 visible version number), so the really hottest and newest distribution
4489 file is not always the default. If a module Foo circulates on CPAN in
4490 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
4491 install version 1.23 by saying
4495 This would install the complete distribution file (say
4496 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
4497 like to install version 1.23_90, you need to know where the
4498 distribution file resides on CPAN relative to the authors/id/
4499 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
4500 so you would have to say
4502 install BAR/Foo-1.23_90.tar.gz
4504 The first example will be driven by an object of the class
4505 CPAN::Module, the second by an object of class CPAN::Distribution.
4507 =head2 ProgrammerE<39>s interface
4509 If you do not enter the shell, the available shell commands are both
4510 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
4511 functions in the calling package (C<install(...)>).
4513 There's currently only one class that has a stable interface -
4514 CPAN::Shell. All commands that are available in the CPAN shell are
4515 methods of the class CPAN::Shell. Each of the commands that produce
4516 listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the
4517 IDs of all modules within the list.
4521 =item expand($type,@things)
4523 The IDs of all objects available within a program are strings that can
4524 be expanded to the corresponding real objects with the
4525 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
4526 list of CPAN::Module objects according to the C<@things> arguments
4527 given. In scalar context it only returns the first element of the
4530 =item Programming Examples
4532 This enables the programmer to do operations that combine
4533 functionalities that are available in the shell.
4535 # install everything that is outdated on my disk:
4536 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
4538 # install my favorite programs if necessary:
4539 for $mod (qw(Net::FTP MD5 Data::Dumper)){
4540 my $obj = CPAN::Shell->expand('Module',$mod);
4544 # list all modules on my disk that have no VERSION number
4545 for $mod (CPAN::Shell->expand("Module","/./")){
4546 next unless $mod->inst_file;
4547 # MakeMaker convention for undefined $VERSION:
4548 next unless $mod->inst_version eq "undef";
4549 print "No VERSION in ", $mod->id, "\n";
4554 =head2 Methods in the four Classes
4556 =head2 Cache Manager
4558 Currently the cache manager only keeps track of the build directory
4559 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
4560 deletes complete directories below C<build_dir> as soon as the size of
4561 all directories there gets bigger than $CPAN::Config->{build_cache}
4562 (in MB). The contents of this cache may be used for later
4563 re-installations that you intend to do manually, but will never be
4564 trusted by CPAN itself. This is due to the fact that the user might
4565 use these directories for building modules on different architectures.
4567 There is another directory ($CPAN::Config->{keep_source_where}) where
4568 the original distribution files are kept. This directory is not
4569 covered by the cache manager and must be controlled by the user. If
4570 you choose to have the same directory as build_dir and as
4571 keep_source_where directory, then your sources will be deleted with
4572 the same fifo mechanism.
4576 A bundle is just a perl module in the namespace Bundle:: that does not
4577 define any functions or methods. It usually only contains documentation.
4579 It starts like a perl module with a package declaration and a $VERSION
4580 variable. After that the pod section looks like any other pod with the
4581 only difference being that I<one special pod section> exists starting with
4586 In this pod section each line obeys the format
4588 Module_Name [Version_String] [- optional text]
4590 The only required part is the first field, the name of a module
4591 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
4592 of the line is optional. The comment part is delimited by a dash just
4593 as in the man page header.
4595 The distribution of a bundle should follow the same convention as
4596 other distributions.
4598 Bundles are treated specially in the CPAN package. If you say 'install
4599 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
4600 the modules in the CONTENTS section of the pod. You can install your
4601 own Bundles locally by placing a conformant Bundle file somewhere into
4602 your @INC path. The autobundle() command which is available in the
4603 shell interface does that for you by including all currently installed
4604 modules in a snapshot bundle file.
4606 =head2 Prerequisites
4608 If you have a local mirror of CPAN and can access all files with
4609 "file:" URLs, then you only need a perl better than perl5.003 to run
4610 this module. Otherwise Net::FTP is strongly recommended. LWP may be
4611 required for non-UNIX systems or if your nearest CPAN site is
4612 associated with an URL that is not C<ftp:>.
4614 If you have neither Net::FTP nor LWP, there is a fallback mechanism
4615 implemented for an external ftp command or for an external lynx
4618 =head2 Finding packages and VERSION
4620 This module presumes that all packages on CPAN
4626 declare their $VERSION variable in an easy to parse manner. This
4627 prerequisite can hardly be relaxed because it consumes far too much
4628 memory to load all packages into the running program just to determine
4629 the $VERSION variable. Currently all programs that are dealing with
4630 version use something like this
4632 perl -MExtUtils::MakeMaker -le \
4633 'print MM->parse_version(shift)' filename
4635 If you are author of a package and wonder if your $VERSION can be
4636 parsed, please try the above method.
4640 come as compressed or gzipped tarfiles or as zip files and contain a
4641 Makefile.PL (well, we try to handle a bit more, but without much
4648 The debugging of this module is pretty difficult, because we have
4649 interferences of the software producing the indices on CPAN, of the
4650 mirroring process on CPAN, of packaging, of configuration, of
4651 synchronicity, and of bugs within CPAN.pm.
4653 In interactive mode you can try "o debug" which will list options for
4654 debugging the various parts of the package. The output may not be very
4655 useful for you as it's just a by-product of my own testing, but if you
4656 have an idea which part of the package may have a bug, it's sometimes
4657 worth to give it a try and send me more specific output. You should
4658 know that "o debug" has built-in completion support.
4660 =head2 Floppy, Zip, Offline Mode
4662 CPAN.pm works nicely without network too. If you maintain machines
4663 that are not networked at all, you should consider working with file:
4664 URLs. Of course, you have to collect your modules somewhere first. So
4665 you might use CPAN.pm to put together all you need on a networked
4666 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
4667 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
4668 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
4671 =head1 CONFIGURATION
4673 When the CPAN module is installed, a site wide configuration file is
4674 created as CPAN/Config.pm. The default values defined there can be
4675 overridden in another configuration file: CPAN/MyConfig.pm. You can
4676 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
4677 $HOME/.cpan is added to the search path of the CPAN module before the
4678 use() or require() statements.
4680 Currently the following keys in the hash reference $CPAN::Config are
4683 build_cache size of cache for directories to build modules
4684 build_dir locally accessible directory to build modules
4685 index_expire after this many days refetch index files
4686 cpan_home local directory reserved for this package
4687 gzip location of external program gzip
4688 inactivity_timeout breaks interactive Makefile.PLs after this
4689 many seconds inactivity. Set to 0 to never break.
4690 inhibit_startup_message
4691 if true, does not print the startup message
4692 keep_source keep the source in a local directory?
4693 keep_source_where directory in which to keep the source (if we do)
4694 make location of external make program
4695 make_arg arguments that should always be passed to 'make'
4696 make_install_arg same as make_arg for 'make install'
4697 makepl_arg arguments passed to 'perl Makefile.PL'
4698 pager location of external program more (or any pager)
4699 prerequisites_policy
4700 what to do if you are missing module prerequisites
4701 ('follow' automatically, 'ask' me, or 'ignore')
4702 scan_cache controls scanning of cache ('atstart' or 'never')
4703 tar location of external program tar
4704 unzip location of external program unzip
4705 urllist arrayref to nearby CPAN sites (or equivalent locations)
4706 wait_list arrayref to a wait server to try (See CPAN::WAIT)
4707 ftp_proxy, } the three usual variables for configuring
4708 http_proxy, } proxy requests. Both as CPAN::Config variables
4709 no_proxy } and as environment variables configurable.
4711 You can set and query each of these options interactively in the cpan
4712 shell with the command set defined within the C<o conf> command:
4716 =item o conf E<lt>scalar optionE<gt>
4718 prints the current value of the I<scalar option>
4720 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
4722 Sets the value of the I<scalar option> to I<value>
4724 =item o conf E<lt>list optionE<gt>
4726 prints the current value of the I<list option> in MakeMaker's
4729 =item o conf E<lt>list optionE<gt> [shift|pop]
4731 shifts or pops the array in the I<list option> variable
4733 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
4735 works like the corresponding perl commands.
4739 =head2 urllist parameter has CD-ROM support
4741 The C<urllist> parameter of the configuration table contains a list of
4742 URLs that are to be used for downloading. If the list contains any
4743 C<file> URLs, CPAN always tries to get files from there first. This
4744 feature is disabled for index files. So the recommendation for the
4745 owner of a CD-ROM with CPAN contents is: include your local, possibly
4746 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
4748 o conf urllist push file://localhost/CDROM/CPAN
4750 CPAN.pm will then fetch the index files from one of the CPAN sites
4751 that come at the beginning of urllist. It will later check for each
4752 module if there is a local copy of the most recent version.
4754 Another peculiarity of urllist is that the site that we could
4755 successfully fetch the last file from automatically gets a preference
4756 token and is tried as the first site for the next request. So if you
4757 add a new site at runtime it may happen that the previously preferred
4758 site will be tried another time. This means that if you want to disallow
4759 a site for the next transfer, it must be explicitly removed from
4764 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
4765 install foreign, unmasked, unsigned code on your machine. We compare
4766 to a checksum that comes from the net just as the distribution file
4767 itself. If somebody has managed to tamper with the distribution file,
4768 they may have as well tampered with the CHECKSUMS file. Future
4769 development will go towards strong authentication.
4773 Most functions in package CPAN are exported per default. The reason
4774 for this is that the primary use is intended for the cpan shell or for
4777 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
4779 To populate a freshly installed perl with my favorite modules is pretty
4780 easiest by maintaining a private bundle definition file. To get a useful
4781 blueprint of a bundle definition file, the command autobundle can be used
4782 on the CPAN shell command line. This command writes a bundle definition
4783 file for all modules that re installed for the currently running perl
4784 interpreter. It's recommended to run this command only once and from then
4785 on maintain the file manually under a private name, say
4786 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
4788 cpan> install Bundle::my_bundle
4790 then answer a few questions and then go out.
4792 Maintaining a bundle definition file means to keep track of two things:
4793 dependencies and interactivity. CPAN.pm (currently) does not take into
4794 account dependencies between distributions, so a bundle definition file
4795 should specify distributions that depend on others B<after> the others.
4796 On the other hand, it's a bit annoying that many distributions need some
4797 interactive configuring. So what I try to accomplish in my private bundle
4798 file is to have the packages that need to be configured early in the file
4799 and the gentle ones later, so I can go out after a few minutes and leave
4802 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
4804 Thanks to Graham Barr for contributing the firewall following howto.
4806 Firewalls can be categorized into three basic types.
4812 This is where the firewall machine runs a web server and to access the
4813 outside world you must do it via the web server. If you set environment
4814 variables like http_proxy or ftp_proxy to a values beginning with http://
4815 or in your web browser you have to set proxy information then you know
4816 you are running a http firewall.
4818 To access servers outside these types of firewalls with perl (even for
4819 ftp) you will need to use LWP.
4823 This where the firewall machine runs a ftp server. This kind of firewall will
4824 only let you access ftp serves outside the firewall. This is usually done by
4825 connecting to the firewall with ftp, then entering a username like
4826 "user@outside.host.com"
4828 To access servers outside these type of firewalls with perl you
4829 will need to use Net::FTP.
4831 =item One way visibility
4833 I say one way visibility as these firewalls try to make themselve look
4834 invisible to the users inside the firewall. An FTP data connection is
4835 normally created by sending the remote server your IP address and then
4836 listening for the connection. But the remote server will not be able to
4837 connect to you because of the firewall. So for these types of firewall
4838 FTP connections need to be done in a passive mode.
4840 There are two that I can think off.
4846 If you are using a SOCKS firewall you will need to compile perl and link
4847 it with the SOCKS library, this is what is normally called a ``socksified''
4848 perl. With this executable you will be able to connect to servers outside
4849 the firewall as if it is not there.
4853 This is the firewall implemented in the Linux kernel, it allows you to
4854 hide a complete network behind one IP address. With this firewall no
4855 special compiling is need as you can access hosts directly.
4863 We should give coverage for _all_ of the CPAN and not just the PAUSE
4864 part, right? In this discussion CPAN and PAUSE have become equal --
4865 but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
4866 the clpa/, doc/, misc/, ports/, src/, scripts/.
4868 Future development should be directed towards a better integration of
4871 If a Makefile.PL requires special customization of libraries, prompts
4872 the user for special input, etc. then you may find CPAN is not able to
4873 build the distribution. In that case, you should attempt the
4874 traditional method of building a Perl module package from a shell.
4878 Andreas König E<lt>a.koenig@kulturbox.deE<gt>
4882 perl(1), CPAN::Nox(3)