2 use vars qw{$Try_autoload $Revision
3 $META $Signal $Cwd $End
4 $Suppress_readline %Dontload
10 # $Id: CPAN.pm,v 1.202 1997/09/23 18:30:36 k Exp k $
12 # only used during development:
14 # $Revision = "[".substr(q$Revision: 1.202 $, 10)."]";
21 use ExtUtils::MakeMaker ();
22 use File::Basename ();
28 use Text::ParseWords ();
31 END { $End++; &cleanup; }
51 $CPAN::Frontend ||= "CPAN::Shell";
54 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term);
57 @CPAN::ISA = qw(CPAN::Debug Exporter MM); # MM will go away
58 # soonish. Already version
59 # 1.29 doesn't rely on
60 # catfile and catdir being
62 # inheritance. Anything else
66 autobundle bundle expand force get
67 install make readme recompile shell test clean
70 #-> sub CPAN::AUTOLOAD ;
75 @EXPORT{@EXPORT} = '';
76 if (exists $EXPORT{$l}){
79 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
83 # $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
85 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
93 $Suppress_readline ||= ! -t STDIN;
95 my $prompt = "cpan> ";
97 unless ($Suppress_readline) {
98 require Term::ReadLine;
99 # import Term::ReadLine;
100 $term = Term::ReadLine->new('CPAN Monitor');
101 $readline::rl_completion_function =
102 $readline::rl_completion_function = 'CPAN::Complete::cpl';
108 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
109 my $cwd = CPAN->$getcwd();
110 my $rl_avail = $Suppress_readline ? "suppressed" :
111 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
112 "available (try ``install Bundle::CPAN'')";
114 $CPAN::Frontend->myprint(
116 cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
117 ReadLine support $rl_avail
119 }) unless $CPAN::Config->{'inhibit_startup_message'} ;
120 my($continuation) = "";
122 if ($Suppress_readline) {
124 last unless defined ($_ = <> );
127 last unless defined ($_ = $term->readline($prompt));
129 $_ = "$continuation$_" if $continuation;
132 $_ = 'h' if $_ eq '?';
133 if (/^q(?:uit)?$/i) {
143 use vars qw($import_done);
144 CPAN->import(':DEFAULT') unless $import_done++;
145 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
152 if ($] < 5.00322) { # parsewords had a bug until recently
155 eval { @line = Text::ParseWords::shellwords($_) };
156 warn($@), next if $@;
158 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
159 my $command = shift @line;
160 eval { CPAN::Shell->$command(@line) };
163 $CPAN::Frontend->myprint("\n");
168 &cleanup, $CPAN::Frontend->mydie("Goodbye\n") if $Signal;
172 package CPAN::CacheMgr;
174 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
177 package CPAN::Config;
178 import ExtUtils::MakeMaker 'neatvalue';
179 use vars qw(%can $dot_cpan);
182 'commit' => "Commit changes to disk",
183 'defaults' => "Reload defaults from disk",
184 'init' => "Interactive setting of all options",
188 use vars qw($Ua $Thesite $Themethod);
189 @CPAN::FTP::ISA = qw(CPAN::Debug);
191 package CPAN::Complete;
192 @CPAN::Complete::ISA = qw(CPAN::Debug);
195 use vars qw($last_time $date_of_03);
196 @CPAN::Index::ISA = qw(CPAN::Debug);
200 package CPAN::InfoObj;
201 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
203 package CPAN::Author;
204 @CPAN::Author::ISA = qw(CPAN::InfoObj);
206 package CPAN::Distribution;
207 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
209 package CPAN::Bundle;
210 @CPAN::Bundle::ISA = qw(CPAN::Module);
212 package CPAN::Module;
213 @CPAN::Module::ISA = qw(CPAN::InfoObj);
216 use vars qw($AUTOLOAD $redef @ISA);
217 @CPAN::Shell::ISA = qw(CPAN::Debug);
219 #-> sub CPAN::Shell::AUTOLOAD ;
221 my($autoload) = $AUTOLOAD;
222 my $class = shift(@_);
223 $autoload =~ s/.*:://;
224 if ($autoload =~ /^w/) {
225 if ($CPAN::META->has_inst('CPAN::WAIT')) {
226 CPAN::WAIT->$autoload(@_);
228 $CPAN::Frontend->mywarn(qq{
229 Commands starting with "w" require CPAN::WAIT to be installed.
230 Please consider installing CPAN::WAIT to use the fulltext index.
231 For this you just need to type
236 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
240 # $CPAN::Frontend->mywarn("Could not autoload $autoload");
242 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
248 #-> CPAN::Shell::try_dot_al
250 my($class,$autoload) = @_;
251 return unless $CPAN::Try_autoload;
252 # I don't see how to re-use that from the AutoLoader...
254 # Braces used to preserve $1 et al.
256 my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
258 if (defined($name=$INC{"$pkg.pm"}))
260 $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|;
261 $name = undef unless (-r $name);
263 unless (defined $name)
265 $name = "auto/$autoload.al";
270 eval {local $SIG{__DIE__};require $name};
272 if (substr($autoload,-9) eq '::DESTROY') {
276 if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
277 eval {local $SIG{__DIE__};require $name};
290 # my $lm = Carp::longmess();
291 # warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
295 #### autoloader is experimental
296 #### to try it we have to set $Try_autoload and uncomment
297 #### the use statement and uncomment the __END__ below
298 #### You also need AutoSplit 1.01 available. MakeMaker will
299 #### then build CPAN with all the AutoLoad stuff.
303 if ($CPAN::Try_autoload) {
306 CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
307 CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
308 CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
310 *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
317 $META ||= CPAN->new; # In case we reeval ourselves we
320 # Do this after you have set up the whole inheritance
321 CPAN::Config->load unless defined $CPAN::No_Config_is_ok;
325 # __END__ # uncomment this and AutoSplit version 1.01 will split it
327 #-> sub CPAN::autobundle ;
329 #-> sub CPAN::bundle ;
331 #-> sub CPAN::expand ;
333 #-> sub CPAN::force ;
335 #-> sub CPAN::install ;
339 #-> sub CPAN::clean ;
346 my($mgr,$class) = @_;
347 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
349 values %{ $META->{$class} };
352 # Called by shell, not in batch mode. Not clean XXX
353 #-> sub CPAN::checklock ;
356 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
357 if (-f $lockfile && -M _ > 0) {
358 my $fh = FileHandle->new($lockfile);
361 if (defined $other && $other) {
363 return if $$==$other; # should never happen
364 $CPAN::Frontend->mywarn(
366 There seems to be running another CPAN process ($other). Contacting...
368 if (kill 0, $other) {
369 $CPAN::Frontend->mydie(qq{Other job is running.
370 You may want to kill it and delete the lockfile, maybe. On UNIX try:
374 } elsif (-w $lockfile) {
376 ExtUtils::MakeMaker::prompt
377 (qq{Other job not responding. Shall I overwrite }.
378 qq{the lockfile? (Y/N)},"y");
379 $CPAN::Frontend->myexit("Ok, bye\n")
380 unless $ans =~ /^y/i;
383 qq{Lockfile $lockfile not writeable by you. }.
384 qq{Cannot proceed.\n}.
387 qq{ and then rerun us.\n}
392 File::Path::mkpath($CPAN::Config->{cpan_home});
394 unless ($fh = FileHandle->new(">$lockfile")) {
395 if ($! =~ /Permission/) {
396 my $incc = $INC{'CPAN/Config.pm'};
397 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
398 $CPAN::Frontend->myprint(qq{
400 Your configuration suggests that CPAN.pm should use a working
402 $CPAN::Config->{cpan_home}
403 Unfortunately we could not create the lock file
405 due to permission problems.
407 Please make sure that the configuration variable
408 \$CPAN::Config->{cpan_home}
409 points to a directory where you can write a .lock file. You can set
410 this variable in either
417 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
419 $fh->print($$, "\n");
420 $self->{LOCK} = $lockfile;
424 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
427 my $s = $Signal == 2 ? "a second" : "another";
428 &cleanup, $CPAN::Frontend->mydie("Got $s SIGINT") if $Signal;
431 $SIG{'__DIE__'} = \&cleanup;
432 $self->debug("Signal handler set.") if $CPAN::DEBUG;
435 #-> sub CPAN::DESTROY ;
437 &cleanup; # need an eval?
441 sub cwd {Cwd::cwd();}
443 #-> sub CPAN::getcwd ;
444 sub getcwd {Cwd::getcwd();}
446 #-> sub CPAN::exists ;
448 my($mgr,$class,$id) = @_;
450 ### Carp::croak "exists called without class argument" unless $class;
452 exists $META->{$class}{$id};
455 #-> sub CPAN::has_inst
457 my($self,$mod,$message) = @_;
458 Carp::croak("CPAN->has_inst() called without an argument")
460 if (defined $message && $message eq "no") {
463 } elsif (exists $Dontload{$mod}) {
469 $file =~ s|/|\\|g if $^O eq 'MSWin32';
472 # warn "$file in %INC"; #debug
474 } elsif (eval { require $file }) {
475 # eval is good: if we haven't yet read the database it's
476 # perfect and if we have installed the module in the meantime,
477 # it tries again. The second require is only a NOOP returning
478 # 1 if we had success, otherwise it's retrying
479 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
480 if ($mod eq "CPAN::WAIT") {
481 push @CPAN::Shell::ISA, CPAN::WAIT;
484 } elsif ($mod eq "Net::FTP") {
486 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
488 install Bundle::libnet
492 } elsif ($mod eq "MD5"){
493 $CPAN::Frontend->myprint(qq{
494 CPAN: MD5 security checks disabled because MD5 not installed.
495 Please consider installing the MD5 module.
503 #-> sub CPAN::instance ;
505 my($mgr,$class,$id) = @_;
508 $META->{$class}{$id} ||= $class->new(ID => $id );
516 #-> sub CPAN::cleanup ;
518 local $SIG{__DIE__} = '';
519 my $i = 0; my $ineval = 0; my $sub;
520 while ((undef,undef,undef,$sub) = caller(++$i)) {
521 $ineval = 1, last if $sub eq '(eval)';
523 return if $ineval && !$End;
524 return unless defined $META->{'LOCK'};
525 return unless -f $META->{'LOCK'};
526 unlink $META->{'LOCK'};
527 $CPAN::Frontend->mywarn("Lockfile removed.\n");
530 package CPAN::CacheMgr;
532 #-> sub CPAN::CacheMgr::as_string ;
534 eval { require Data::Dumper };
536 return shift->SUPER::as_string;
538 return Data::Dumper::Dumper(shift);
542 #-> sub CPAN::CacheMgr::cachesize ;
548 # my($self,@dirs) = @_;
549 # return unless -d $self->{ID};
551 # @dirs = $self->dirs unless @dirs;
553 # $self->disk_usage($dir);
557 #-> sub CPAN::CacheMgr::clean_cache ;
558 #=# sub clean_cache {
559 #=# my $self = shift;
561 #=# while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) {
562 #=# $self->force_clean_cache($dir);
564 #=# $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG;
567 #-> sub CPAN::CacheMgr::dir ;
572 #-> sub CPAN::CacheMgr::entries ;
575 return unless defined $dir;
576 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
577 $dir ||= $self->{ID};
579 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
580 my($cwd) = CPAN->$getcwd();
581 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
582 my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
585 next if $_ eq "." || $_ eq "..";
587 push @entries, MM->catfile($dir,$_);
589 push @entries, MM->catdir($dir,$_);
591 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
594 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
595 sort { -M $b <=> -M $a} @entries;
598 #-> sub CPAN::CacheMgr::disk_usage ;
601 # if (! defined $dir or $dir eq "") {
602 # $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG;
605 return if $self->{SIZE}{$dir};
614 $self->{SIZE}{$dir} = $Du/1024/1024;
615 push @{$self->{FIFO}}, $dir;
616 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
617 $self->{DU} += $Du/1024/1024;
618 if ($self->{DU} > $self->{'MAX'} ) {
619 my($toremove) = shift @{$self->{FIFO}};
620 $CPAN::Frontend->myprint(sprintf(
621 "...Hold on a sec... ".
622 "cleaning from cache ".
623 "(%.1f>%.1f MB): $toremove\n",
624 $self->{DU}, $self->{'MAX'})
626 $self->force_clean_cache($toremove);
631 #-> sub CPAN::CacheMgr::force_clean_cache ;
632 sub force_clean_cache {
634 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
636 File::Path::rmtree($dir);
637 $self->{DU} -= $self->{SIZE}{$dir};
638 delete $self->{SIZE}{$dir};
641 #-> sub CPAN::CacheMgr::new ;
648 ID => $CPAN::Config->{'build_dir'},
649 MAX => $CPAN::Config->{'build_cache'},
652 File::Path::mkpath($self->{ID});
653 my $dh = DirHandle->new($self->{ID});
655 $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG;
657 for $e ($self->entries) {
658 next if $e eq ".." || $e eq ".";
659 $self->disk_usage($e);
662 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
664 CPAN->debug($debug) if $CPAN::DEBUG;
670 #-> sub CPAN::Debug::debug ;
673 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
674 # Complete, caller(1)
676 ($caller) = caller(0);
678 $arg = "" unless defined $arg;
679 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
680 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
681 if ($arg and ref $arg) {
682 eval { require Data::Dumper };
684 $CPAN::Frontend->myprint($arg->as_string);
686 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
689 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
694 package CPAN::Config;
696 #-> sub CPAN::Config::edit ;
698 my($class,@args) = @_;
700 CPAN->debug("class[$class]args[".join(" | ",@args)."]");
701 my($o,$str,$func,$args,$key_exists);
707 if (ref($CPAN::Config->{$o}) eq ARRAY) {
710 # Let's avoid eval, it's easier to comprehend without.
711 if ($func eq "push") {
712 push @{$CPAN::Config->{$o}}, @args;
713 } elsif ($func eq "pop") {
714 pop @{$CPAN::Config->{$o}};
715 } elsif ($func eq "shift") {
716 shift @{$CPAN::Config->{$o}};
717 } elsif ($func eq "unshift") {
718 unshift @{$CPAN::Config->{$o}}, @args;
719 } elsif ($func eq "splice") {
720 splice @{$CPAN::Config->{$o}}, @args;
722 $CPAN::Config->{$o} = [@args];
724 $CPAN::Frontend->myprint(
727 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
732 $CPAN::Config->{$o} = $args[0] if defined $args[0];
733 $CPAN::Frontend->myprint(" $o " .
734 (defined $CPAN::Config->{$o} ?
735 $CPAN::Config->{$o} : "UNDEFINED"));
740 #-> sub CPAN::Config::commit ;
742 my($self,$configpm) = @_;
743 unless (defined $configpm){
744 $configpm ||= $INC{"CPAN/MyConfig.pm"};
745 $configpm ||= $INC{"CPAN/Config.pm"};
746 $configpm || Carp::confess(qq{
747 CPAN::Config::commit called without an argument.
748 Please specify a filename where to save the configuration or try
749 "o conf init" to have an interactive course through configing.
754 $mode = (stat $configpm)[2];
755 if ($mode && ! -w _) {
756 Carp::confess("$configpm is not writable");
760 my $msg = <<EOF unless $configpm =~ /MyConfig/;
762 # This is CPAN.pm's systemwide configuration file. This file provides
763 # defaults for users, and the values can be changed in a per-user
764 # configuration file. The user-config file is being looked for as
765 # ~/.cpan/CPAN/MyConfig.pm.
769 my($fh) = FileHandle->new;
770 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
771 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
772 foreach (sort keys %$CPAN::Config) {
775 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
780 $fh->print("};\n1;\n__END__\n");
783 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
784 #chmod $mode, $configpm;
785 ###why was that so? $self->defaults;
786 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
790 *default = \&defaults;
791 #-> sub CPAN::Config::defaults ;
801 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
810 #-> sub CPAN::Config::load ;
814 eval {require CPAN::Config;}; # We eval because of some
816 unshift @INC, MM->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
817 eval {require CPAN::MyConfig;}; # where you can override
818 # system wide settings
819 return unless @miss = $self->not_loaded;
820 # XXX better check for arrayrefs too
821 require CPAN::FirstTime;
822 my($configpm,$fh,$redo,$theycalled);
824 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
825 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
826 $configpm = $INC{"CPAN/Config.pm"};
828 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
829 $configpm = $INC{"CPAN/MyConfig.pm"};
832 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
833 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
834 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
835 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
836 if (-w $configpmtest) {
837 $configpm = $configpmtest;
838 } elsif (-w $configpmdir) {
839 #_#_# following code dumped core on me with 5.003_11, a.k.
840 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
841 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
842 my $fh = FileHandle->new;
843 if ($fh->open(">$configpmtest")) {
845 $configpm = $configpmtest;
847 # Should never happen
848 Carp::confess("Cannot open >$configpmtest");
853 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
854 File::Path::mkpath($configpmdir);
855 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
856 if (-w $configpmtest) {
857 $configpm = $configpmtest;
858 } elsif (-w $configpmdir) {
859 #_#_# following code dumped core on me with 5.003_11, a.k.
860 my $fh = FileHandle->new;
861 if ($fh->open(">$configpmtest")) {
863 $configpm = $configpmtest;
865 # Should never happen
866 Carp::confess("Cannot open >$configpmtest");
869 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
870 qq{create a configuration file.});
875 $CPAN::Frontend->myprint(qq{
876 We have to reconfigure CPAN.pm due to following uninitialized parameters:
879 }) if $redo && ! $theycalled;
880 $CPAN::Frontend->myprint(qq{
881 $configpm initialized.
884 CPAN::FirstTime::init($configpm);
887 #-> sub CPAN::Config::not_loaded ;
891 cpan_home keep_source_where build_dir build_cache index_expire
892 gzip tar unzip make pager makepl_arg make_arg make_install_arg
893 urllist inhibit_startup_message ftp_proxy http_proxy no_proxy
895 push @miss, $_ unless defined $CPAN::Config->{$_};
900 #-> sub CPAN::Config::unload ;
902 delete $INC{'CPAN/MyConfig.pm'};
903 delete $INC{'CPAN/Config.pm'};
907 #-> sub CPAN::Config::help ;
909 $CPAN::Frontend->myprint(qq{
911 defaults reload default config values from disk
912 commit commit session changes to disk
913 init go through a dialog to set all parameters
915 You may edit key values in the follow fashion:
917 o conf build_cache 15
919 o conf build_dir "/foo/bar"
923 o conf urllist unshift ftp://ftp.foo.bar/
926 undef; #don't reprint CPAN::Config
929 #-> sub CPAN::Config::cpl ;
931 my($word,$line,$pos) = @_;
933 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
934 my(@words) = split " ", substr($line,0,$pos+1);
936 $words[2] =~ /list$/ && @words == 3
938 $words[2] =~ /list$/ && @words == 4 && length($word)
940 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
941 } elsif (@words >= 4) {
944 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
945 return grep /^\Q$word\E/, @o_conf;
950 #-> sub CPAN::Shell::h ;
952 my($class,$about) = @_;
953 if (defined $about) {
954 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
956 $CPAN::Frontend->myprint(q{
957 command arguments description
960 d /regex/ info distributions
962 i none anything of above
964 r as reinstall recommendations
965 u above uninstalled distributions
966 See manpage for autobundle, recompile, force, look, etc.
969 test modules, make test (implies make)
970 install dists, bundles, make install (implies test)
971 clean "r" or "u" make clean
972 readme display the README file
974 reload index|cpan load most recent indices/CPAN.pm
975 h or ? display this menu
976 o various set and query options
977 ! perl-code eval a perl command
978 q quit the shell subroutine
983 #-> sub CPAN::Shell::a ;
984 sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));}
985 #-> sub CPAN::Shell::b ;
987 my($self,@which) = @_;
988 CPAN->debug("which[@which]") if $CPAN::DEBUG;
989 my($incdir,$bdir,$dh);
990 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
991 $bdir = MM->catdir($incdir,"Bundle");
992 if ($dh = DirHandle->new($bdir)) { # may fail
994 for $entry ($dh->read) {
995 next if -d MM->catdir($bdir,$entry);
996 next unless $entry =~ s/\.pm$//;
997 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1001 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1003 #-> sub CPAN::Shell::d ;
1004 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1005 #-> sub CPAN::Shell::m ;
1006 sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));}
1008 #-> sub CPAN::Shell::i ;
1013 @type = qw/Author Bundle Distribution Module/;
1014 @args = '/./' unless @args;
1017 push @result, $self->expand($type,@args);
1019 my $result = @result == 1 ?
1020 $result[0]->as_string :
1021 join "", map {$_->as_glimpse} @result;
1022 $result ||= "No objects found of any type for argument @args\n";
1023 $CPAN::Frontend->myprint($result);
1026 #-> sub CPAN::Shell::o ;
1028 my($self,$o_type,@o_what) = @_;
1030 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1031 if ($o_type eq 'conf') {
1032 shift @o_what if @o_what && $o_what[0] eq 'help';
1035 $CPAN::Frontend->myprint("CPAN::Config options:\n");
1036 for $k (sort keys %CPAN::Config::can) {
1037 $v = $CPAN::Config::can{$k};
1038 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1040 $CPAN::Frontend->myprint("\n");
1041 for $k (sort keys %$CPAN::Config) {
1042 $v = $CPAN::Config->{$k};
1044 $CPAN::Frontend->myprint(
1051 map {"\t$_\n"} @{$v}
1055 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1058 $CPAN::Frontend->myprint("\n");
1059 } elsif (!CPAN::Config->edit(@o_what)) {
1060 $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
1062 } elsif ($o_type eq 'debug') {
1064 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1067 my($what) = shift @o_what;
1068 if ( exists $CPAN::DEBUG{$what} ) {
1069 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1070 } elsif ($what =~ /^\d/) {
1071 $CPAN::DEBUG = $what;
1072 } elsif (lc $what eq 'all') {
1074 for (values %CPAN::DEBUG) {
1077 $CPAN::DEBUG = $max;
1080 for (keys %CPAN::DEBUG) {
1081 next unless lc($_) eq lc($what);
1082 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1085 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1090 $CPAN::Frontend->myprint("Valid options for debug are ".
1091 join(", ",sort(keys %CPAN::DEBUG), 'all').
1092 qq{ or a number. Completion works on the options. }.
1093 qq{Case is ignored.\n\n});
1096 $CPAN::Frontend->myprint("Options set for debugging:\n");
1098 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1099 $v = $CPAN::DEBUG{$k};
1100 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
1103 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1106 $CPAN::Frontend->myprint(qq{
1108 conf set or get configuration variables
1109 debug set or get debugging options
1114 #-> sub CPAN::Shell::reload ;
1116 my($self,$command,@arg) = @_;
1118 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1119 if ($command =~ /cpan/i) {
1120 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1121 my $fh = FileHandle->new($INC{'CPAN.pm'});
1125 local($SIG{__WARN__})
1127 if ( $_[0] =~ /Subroutine \w+ redefined/ ) {
1130 $CPAN::Frontend->myprint(".");
1137 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1138 } elsif ($command =~ /index/) {
1139 CPAN::Index->force_reload;
1141 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1142 index re-reads the index files
1147 #-> sub CPAN::Shell::_binary_extensions ;
1148 sub _binary_extensions {
1149 my($self) = shift @_;
1150 my(@result,$module,%seen,%need,$headerdone);
1151 my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$};
1152 for $module ($self->expand('Module','/./')) {
1153 my $file = $module->cpan_file;
1154 next if $file eq "N/A";
1155 next if $file =~ /^Contact Author/;
1156 next if $file =~ / $isaperl /xo;
1157 next unless $module->xs_file;
1159 $CPAN::Frontend->myprint(".");
1160 push @result, $module;
1162 # print join " | ", @result;
1163 $CPAN::Frontend->myprint("\n");
1167 #-> sub CPAN::Shell::recompile ;
1169 my($self) = shift @_;
1170 my($module,@module,$cpan_file,%dist);
1171 @module = $self->_binary_extensions();
1172 for $module (@module){ # we force now and compile later, so we
1174 $cpan_file = $module->cpan_file;
1175 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1177 $dist{$cpan_file}++;
1179 for $cpan_file (sort keys %dist) {
1180 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1181 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1183 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1184 # stop a package from recompiling,
1185 # e.g. IO-1.12 when we have perl5.003_10
1189 #-> sub CPAN::Shell::_u_r_common ;
1191 my($self) = shift @_;
1192 my($what) = shift @_;
1193 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1194 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1195 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1197 @args = '/./' unless @args;
1198 my(@result,$module,%seen,%need,$headerdone,
1199 $version_undefs,$version_zeroes);
1200 $version_undefs = $version_zeroes = 0;
1201 my $sprintf = "%-25s %9s %9s %s\n";
1202 for $module ($self->expand('Module',@args)) {
1203 my $file = $module->cpan_file;
1204 next unless defined $file; # ??
1205 my($latest) = $module->cpan_version;
1206 my($inst_file) = $module->inst_file;
1210 $have = $module->inst_version;
1211 } elsif ($what eq "r") {
1212 $have = $module->inst_version;
1214 if ($have eq "undef"){
1216 } elsif ($have == 0){
1219 next if $have >= $latest;
1220 # to be pedantic we should probably say:
1221 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1222 # to catch the case where CPAN has a version 0 and we have a version undef
1223 } elsif ($what eq "u") {
1229 } elsif ($what eq "r") {
1231 } elsif ($what eq "u") {
1235 return if $CPAN::Signal; # this is sometimes lengthy
1238 push @result, sprintf "%s %s\n", $module->id, $have;
1239 } elsif ($what eq "r") {
1240 push @result, $module->id;
1241 next if $seen{$file}++;
1242 } elsif ($what eq "u") {
1243 push @result, $module->id;
1244 next if $seen{$file}++;
1245 next if $file =~ /^Contact/;
1247 unless ($headerdone++){
1248 $CPAN::Frontend->myprint("\n");
1249 $CPAN::Frontend->myprint(sprintf(
1251 "Package namespace",
1257 $latest = substr($latest,0,8) if length($latest) > 8;
1258 $have = substr($have,0,8) if length($have) > 8;
1259 $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
1260 $need{$module->id}++;
1264 $CPAN::Frontend->myprint("No modules found for @args\n");
1265 } elsif ($what eq "r") {
1266 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1270 if ($version_zeroes) {
1271 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1272 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1273 qq{a version number of 0\n});
1275 if ($version_undefs) {
1276 my $s_has = $version_undefs > 1 ? "s have" : " has";
1277 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1278 qq{parseable version number\n});
1284 #-> sub CPAN::Shell::r ;
1286 shift->_u_r_common("r",@_);
1289 #-> sub CPAN::Shell::u ;
1291 shift->_u_r_common("u",@_);
1294 #-> sub CPAN::Shell::autobundle ;
1297 my(@bundle) = $self->_u_r_common("a",@_);
1298 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1299 File::Path::mkpath($todir);
1300 unless (-d $todir) {
1301 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1304 my($y,$m,$d) = (localtime)[5,4,3];
1308 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1309 my($to) = MM->catfile($todir,"$me.pm");
1311 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1312 $to = MM->catfile($todir,"$me.pm");
1314 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1316 "package Bundle::$me;\n\n",
1317 "\$VERSION = '0.01';\n\n",
1321 "Bundle::$me - Snapshot of installation on ",
1322 $Config::Config{'myhostname'},
1325 "\n\n=head1 SYNOPSIS\n\n",
1326 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1327 "=head1 CONTENTS\n\n",
1328 join("\n", @bundle),
1329 "\n\n=head1 CONFIGURATION\n\n",
1331 "\n\n=head1 AUTHOR\n\n",
1332 "This Bundle has been generated automatically ",
1333 "by the autobundle routine in CPAN.pm.\n",
1336 $CPAN::Frontend->myprint("\nWrote bundle file
1340 #-> sub CPAN::Shell::expand ;
1343 my($type,@args) = @_;
1347 if ($arg =~ m|^/(.*)/$|) {
1350 my $class = "CPAN::$type";
1352 if (defined $regex) {
1353 for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
1356 $obj->id =~ /$regex/i
1360 $] < 5.00303 ### provide sort of compatibility with 5.003
1365 $obj->name =~ /$regex/i
1370 if ( $type eq 'Bundle' ) {
1371 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1373 if ($CPAN::META->exists($class,$xarg)) {
1374 $obj = $CPAN::META->instance($class,$xarg);
1375 } elsif ($CPAN::META->exists($class,$arg)) {
1376 $obj = $CPAN::META->instance($class,$arg);
1383 return wantarray ? @m : $m[0];
1386 #-> sub CPAN::Shell::format_result ;
1389 my($type,@args) = @_;
1390 @args = '/./' unless @args;
1391 my(@result) = $self->expand($type,@args);
1392 my $result = @result == 1 ?
1393 $result[0]->as_string :
1394 join "", map {$_->as_glimpse} @result;
1395 $result ||= "No objects of type $type found for argument @args\n";
1399 # The only reason for this method is currently to have a reliable
1400 # debugging utility that reveals which output is going through which
1401 # channel. No, I don't like the colors ;-)
1402 sub print_ornamented {
1403 my($self,$what,$ornament) = @_;
1405 my $ornamenting = 0; # turn the colors on
1408 unless (defined &color) {
1409 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1410 import Term::ANSIColor "color";
1412 *color = sub { return "" };
1415 for my $line (split /\n/, $what) {
1416 $longest = length($line) if length($line) > $longest;
1418 my $sprintf = "%-" . $longest . "s";
1420 $what =~ s/(.*\n?)//m;
1423 my($nl) = chomp $line ? "\n" : "";
1424 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1425 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1433 my($self,$what) = @_;
1434 $self->print_ornamented($what, 'bold blue on_yellow');
1438 my($self,$what) = @_;
1439 $self->myprint($what);
1444 my($self,$what) = @_;
1445 $self->print_ornamented($what, 'bold red on_yellow');
1449 my($self,$what) = @_;
1450 $self->print_ornamented($what, 'bold red on_white');
1451 Carp::confess "died";
1455 my($self,$what) = @_;
1456 $self->print_ornamented($what, 'bold red on_white');
1460 #-> sub CPAN::Shell::rematein ;
1463 my($meth,@some) = @_;
1465 if ($meth eq 'force') {
1467 $meth = shift @some;
1469 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1471 foreach $s (@some) {
1475 } elsif ($s =~ m|/|) { # looks like a file
1476 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1477 } elsif ($s =~ m|^Bundle::|) {
1478 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1480 $obj = $CPAN::META->instance('CPAN::Module',$s)
1481 if $CPAN::META->exists('CPAN::Module',$s);
1485 qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.
1493 ($] < 5.00303 || $obj->can($pragma)); ### compatibility with 5.003
1495 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1496 $obj = $CPAN::META->instance('CPAN::Author',$s);
1497 $CPAN::Frontend->myprint(
1499 "Don't be silly, you can't $meth ",
1504 $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is.
1509 to find objects with similar identifiers.
1515 #-> sub CPAN::Shell::force ;
1516 sub force { shift->rematein('force',@_); }
1517 #-> sub CPAN::Shell::get ;
1518 sub get { shift->rematein('get',@_); }
1519 #-> sub CPAN::Shell::readme ;
1520 sub readme { shift->rematein('readme',@_); }
1521 #-> sub CPAN::Shell::make ;
1522 sub make { shift->rematein('make',@_); }
1523 #-> sub CPAN::Shell::test ;
1524 sub test { shift->rematein('test',@_); }
1525 #-> sub CPAN::Shell::install ;
1526 sub install { shift->rematein('install',@_); }
1527 #-> sub CPAN::Shell::clean ;
1528 sub clean { shift->rematein('clean',@_); }
1529 #-> sub CPAN::Shell::look ;
1530 sub look { shift->rematein('look',@_); }
1534 #-> sub CPAN::FTP::ftp_get ;
1536 my($class,$host,$dir,$file,$target) = @_;
1538 qq[Going to fetch file [$file] from dir [$dir]
1539 on host [$host] as local [$target]\n]
1541 my $ftp = Net::FTP->new($host);
1542 return 0 unless defined $ftp;
1543 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1544 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1545 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1546 warn "Couldn't login on $host";
1549 unless ( $ftp->cwd($dir) ){
1550 warn "Couldn't cwd $dir";
1554 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1555 unless ( $ftp->get($file,$target) ){
1556 warn "Couldn't fetch $file from $host\n";
1559 $ftp->quit; # it's ok if this fails
1564 my($self,$url) = @_;
1565 return 1; # we can't simply roll our own, firewalls may break ping
1566 return 0 unless $url;
1567 return 1 if substr($url,0,4) eq "file";
1568 return 1 unless $url =~ m|://([^/]+)|;
1571 return 1 unless $Net::Ping::VERSION >= 2;
1573 eval {$p = Net::Ping->new("icmp");};
1574 eval {$p = Net::Ping->new("tcp");} if $@;
1575 $CPAN::Frontend->mydie($@) if $@;
1576 return $p->ping($host, 3);
1579 #-> sub CPAN::FTP::localize ;
1580 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
1583 my($self,$file,$aslocal,$force) = @_;
1585 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
1586 unless defined $aslocal;
1587 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
1590 return $aslocal if -f $aslocal && -r _ && !($force & 1);
1593 rename $aslocal, "$aslocal.bak";
1597 my($aslocal_dir) = File::Basename::dirname($aslocal);
1598 File::Path::mkpath($aslocal_dir);
1599 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
1600 qq{directory "$aslocal_dir".
1601 I\'ll continue, but if you encounter problems, they may be due
1602 to insufficient permissions.\n}) unless -w $aslocal_dir;
1604 # Inheritance is not easier to manage than a few if/else branches
1605 if ($CPAN::META->has_inst('LWP')) {
1606 require LWP::UserAgent;
1608 $Ua = LWP::UserAgent->new;
1610 $Ua->proxy('ftp', $var)
1611 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
1612 $Ua->proxy('http', $var)
1613 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1615 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1619 # Try the list of urls for each single object. We keep a record
1620 # where we did get a file from
1621 my(@reordered,$last);
1623 $last = $#{$CPAN::Config->{urllist}};
1624 if ($force & 2) { # local cpans probably out of date, don't reorder
1625 @reordered = (0..$last);
1629 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
1631 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
1640 # ((grep { substr($CPAN::Config->{urllist}[$_],0,4)
1641 # eq "file" } 0..$last),
1642 # (grep { substr($CPAN::Config->{urllist}[$_],0,4)
1643 # ne "file" } 0..$last));
1647 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
1649 @levels = qw/easy hard hardest/;
1651 for $level (@levels) {
1652 my $method = "host$level";
1653 my @host_seq = $level eq "easy" ?
1654 @reordered : 0..$last; # reordered has CDROM up front
1655 my $ret = $self->$method(\@host_seq,$file,$aslocal);
1657 $Themethod = $level;
1658 $self->debug("level[$level]") if $CPAN::DEBUG;
1664 qq{Please check, if the URLs I found in your configuration file \(}.
1665 join(", ", @{$CPAN::Config->{urllist}}).
1666 qq{\) are valid. The urllist can be edited.},
1667 qq{E.g. with ``o conf urllist push ftp://myurl/''};
1668 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
1670 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
1672 rename "$aslocal.bak", $aslocal;
1673 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
1674 $self->ls($aslocal));
1681 my($self,$host_seq,$file,$aslocal) = @_;
1683 HOSTEASY: for $i (@$host_seq) {
1684 my $url = $CPAN::Config->{urllist}[$i];
1685 unless ($self->is_reachable($url)) {
1686 $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
1690 $url .= "/" unless substr($url,-1) eq "/";
1692 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
1693 if ($url =~ /^file:/) {
1695 if ($CPAN::META->has_inst('LWP')) {
1697 my $u = URI::URL->new($url);
1699 } else { # works only on Unix, is poorly constructed, but
1700 # hopefully better than nothing.
1701 # RFC 1738 says fileurl BNF is
1702 # fileurl = "file://" [ host | "localhost" ] "/" fpath
1703 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
1705 ($l = $url) =~ s,^file://[^/]+,,; # discard the host part
1706 $l =~ s/^file://; # assume they meant file://localhost
1708 if ( -f $l && -r _) {
1712 # Maybe mirror has compressed it?
1714 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
1715 system("$CPAN::Config->{gzip} -dc $l.gz > $aslocal");
1722 if ($CPAN::META->has_inst('LWP')) {
1723 $CPAN::Frontend->myprint("Fetching with LWP:
1726 my $res = $Ua->mirror($url, $aslocal);
1727 if ($res->is_success) {
1730 } elsif ($url !~ /\.gz$/) {
1731 my $gzurl = "$url.gz";
1732 $CPAN::Frontend->myprint("Fetching with LWP:
1735 $res = $Ua->mirror($gzurl, "$aslocal.gz");
1736 if ($res->is_success &&
1737 system("$CPAN::Config->{gzip} -d $aslocal.gz")==0) {
1747 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
1748 # that's the nice and easy way thanks to Graham
1749 my($host,$dir,$getfile) = ($1,$2,$3);
1750 if ($CPAN::META->has_inst('Net::FTP')) {
1752 $CPAN::Frontend->myprint("Fetching with Net::FTP:
1755 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
1756 "aslocal[$aslocal]") if $CPAN::DEBUG;
1757 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
1761 if ($aslocal !~ /\.gz$/) {
1762 my $gz = "$aslocal.gz";
1763 $CPAN::Frontend->myprint("Fetching with Net::FTP
1766 if (CPAN::FTP->ftp_get($host,
1770 system("$CPAN::Config->{gzip} -d $gz")==0 ){
1782 my($self,$host_seq,$file,$aslocal) = @_;
1784 # Came back if Net::FTP couldn't establish connection (or
1785 # failed otherwise) Maybe they are behind a firewall, but they
1786 # gave us a socksified (or other) ftp program...
1789 my($aslocal_dir) = File::Basename::dirname($aslocal);
1790 File::Path::mkpath($aslocal_dir);
1791 HOSTHARD: for $i (@$host_seq) {
1792 my $url = $CPAN::Config->{urllist}[$i];
1793 unless ($self->is_reachable($url)) {
1794 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
1797 $url .= "/" unless substr($url,-1) eq "/";
1799 my($host,$dir,$getfile);
1800 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
1801 ($host,$dir,$getfile) = ($1,$2,$3);
1803 next HOSTHARD; # who said, we could ftp anything except ftp?
1805 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
1807 for $f ('lynx','ncftp') {
1808 next unless exists $CPAN::Config->{$f};
1809 $funkyftp = $CPAN::Config->{$f};
1810 next unless defined $funkyftp;
1811 next if $funkyftp =~ /^\s*$/;
1812 my($want_compressed);
1813 my $aslocal_uncompressed;
1814 ($aslocal_uncompressed = $aslocal) =~ s/\.gz//;
1815 my($source_switch) = "";
1816 $source_switch = "-source" if $funkyftp =~ /\blynx$/;
1817 $source_switch = "-c" if $funkyftp =~ /\bncftp$/;
1818 $CPAN::Frontend->myprint(
1820 Trying with "$funkyftp $source_switch" to get
1823 my($system) = "$funkyftp $source_switch '$url' > ".
1824 "$aslocal_uncompressed";
1825 $self->debug("system[$system]") if $CPAN::DEBUG;
1827 if (($wstatus = system($system)) == 0
1829 -s $aslocal_uncompressed # lynx returns 0 on my
1830 # system even if it fails
1832 if ($aslocal_uncompressed ne $aslocal) {
1833 # test gzip integrity
1835 "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed";
1836 if (system($system) == 0) {
1837 rename $aslocal_uncompressed, $aslocal;
1840 "$CPAN::Config->{'gzip'} $aslocal_uncompressed";
1846 } elsif ($url !~ /\.gz$/) {
1847 my $gz = "$aslocal.gz";
1848 my $gzurl = "$url.gz";
1849 $CPAN::Frontend->myprint(
1851 Trying with "$funkyftp $source_switch" to get
1854 my($system) = "$funkyftp $source_switch '$url.gz' > ".
1855 "$aslocal_uncompressed.gz";
1856 $self->debug("system[$system]") if $CPAN::DEBUG;
1858 if (($wstatus = system($system)) == 0
1860 -s "$aslocal_uncompressed.gz"
1862 # test gzip integrity
1864 "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed.gz";
1865 $CPAN::Frontend->mywarn("system[$system]");
1866 if (system($system) == 0) {
1867 $system = "$CPAN::Config->{'gzip'} -dc ".
1868 "$aslocal_uncompressed.gz > $aslocal";
1869 $CPAN::Frontend->mywarn("system[$system]");
1872 rename $aslocal_uncompressed, $aslocal;
1879 my $estatus = $wstatus >> 8;
1880 my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : "";
1881 $CPAN::Frontend->myprint(qq{
1882 System call "$system"
1883 returned status $estatus (wstat $wstatus)$size
1891 my($self,$host_seq,$file,$aslocal) = @_;
1894 my($aslocal_dir) = File::Basename::dirname($aslocal);
1895 File::Path::mkpath($aslocal_dir);
1896 HOSTHARDEST: for $i (@$host_seq) {
1897 unless (length $CPAN::Config->{'ftp'}) {
1898 $CPAN::Frontend->myprint("No external ftp command available\n\n");
1901 my $url = $CPAN::Config->{urllist}[$i];
1902 unless ($self->is_reachable($url)) {
1903 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
1906 $url .= "/" unless substr($url,-1) eq "/";
1908 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
1909 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
1912 my($host,$dir,$getfile) = ($1,$2,$3);
1915 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
1916 $ctime,$blksize,$blocks) = stat($aslocal);
1917 $timestamp = $mtime ||= 0;
1918 my($netrc) = CPAN::FTP::netrc->new;
1919 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
1920 my $targetfile = File::Basename::basename($aslocal);
1926 map("cd $_", split "/", $dir), # RFC 1738
1928 "get $getfile $targetfile",
1931 if (! $netrc->netrc) {
1932 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
1933 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
1934 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
1936 $netrc->contains($host))) if $CPAN::DEBUG;
1937 if ($netrc->protected) {
1938 $CPAN::Frontend->myprint(qq{
1939 Trying with external ftp to get
1941 As this requires some features that are not thoroughly tested, we\'re
1942 not sure, that we get it right....
1946 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
1948 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
1949 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
1951 if ($mtime > $timestamp) {
1952 $CPAN::Frontend->myprint("GOT $aslocal\n");
1956 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
1959 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
1960 qq{correctly protected.\n});
1963 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
1964 nor does it have a default entry\n");
1967 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
1968 # then and login manually to host, using e-mail as
1970 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
1974 "user anonymous $Config::Config{'cf_email'}"
1976 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
1977 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
1978 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
1980 if ($mtime > $timestamp) {
1981 $CPAN::Frontend->myprint("GOT $aslocal\n");
1985 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
1987 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
1993 my($self,$command,@dialog) = @_;
1994 my $fh = FileHandle->new;
1995 $fh->open("|$command") or die "Couldn't open ftp: $!";
1996 foreach (@dialog) { $fh->print("$_\n") }
1997 $fh->close; # Wait for process to complete
1999 my $estatus = $wstatus >> 8;
2000 $CPAN::Frontend->myprint(qq{
2001 Subprocess "|$command"
2002 returned status $estatus (wstat $wstatus)
2007 # find2perl needs modularization, too, all the following is stolen
2010 my($self,$name) = @_;
2011 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2012 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2014 my($perms,%user,%group);
2018 $blocks = int(($blocks + 1) / 2);
2021 $blocks = int(($sizemm + 1023) / 1024);
2024 if (-f _) { $perms = '-'; }
2025 elsif (-d _) { $perms = 'd'; }
2026 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2027 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2028 elsif (-p _) { $perms = 'p'; }
2029 elsif (-S _) { $perms = 's'; }
2030 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2032 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2033 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2034 my $tmpmode = $mode;
2035 my $tmp = $rwx[$tmpmode & 7];
2037 $tmp = $rwx[$tmpmode & 7] . $tmp;
2039 $tmp = $rwx[$tmpmode & 7] . $tmp;
2040 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2041 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2042 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2045 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2046 my $group = $group{$gid} || $gid;
2048 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2050 my($moname) = $moname[$mon];
2051 if (-M _ > 365.25 / 2) {
2052 $timeyear = $year + 1900;
2055 $timeyear = sprintf("%02d:%02d", $hour, $min);
2058 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2072 package CPAN::FTP::netrc;
2076 my $file = MM->catfile($ENV{HOME},".netrc");
2078 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2079 $atime,$mtime,$ctime,$blksize,$blocks)
2084 my($fh,@machines,$hasdefault);
2086 $fh = FileHandle->new or die "Could not create a filehandle";
2088 if($fh->open($file)){
2089 $protected = ($mode & 077) == 0;
2091 NETRC: while (<$fh>) {
2092 my(@tokens) = split " ", $_;
2093 TOKEN: while (@tokens) {
2094 my($t) = shift @tokens;
2095 if ($t eq "default"){
2099 last TOKEN if $t eq "macdef";
2100 if ($t eq "machine") {
2101 push @machines, shift @tokens;
2106 $file = $hasdefault = $protected = "";
2110 'mach' => [@machines],
2112 'hasdefault' => $hasdefault,
2113 'protected' => $protected,
2117 sub hasdefault { shift->{'hasdefault'} }
2118 sub netrc { shift->{'netrc'} }
2119 sub protected { shift->{'protected'} }
2121 my($self,$mach) = @_;
2122 for ( @{$self->{'mach'}} ) {
2123 return 1 if $_ eq $mach;
2128 package CPAN::Complete;
2130 #-> sub CPAN::Complete::cpl ;
2132 my($word,$line,$pos) = @_;
2136 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2138 if ($line =~ s/^(force\s*)//) {
2146 ! a b d h i m o q r u autobundle clean
2147 make test install force reload look
2150 } elsif ( $line !~ /^[\!abdhimorutl]/ ) {
2152 } elsif ($line =~ /^a\s/) {
2153 @return = cplx('CPAN::Author',$word);
2154 } elsif ($line =~ /^b\s/) {
2155 @return = cplx('CPAN::Bundle',$word);
2156 } elsif ($line =~ /^d\s/) {
2157 @return = cplx('CPAN::Distribution',$word);
2158 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) {
2159 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2160 } elsif ($line =~ /^i\s/) {
2161 @return = cpl_any($word);
2162 } elsif ($line =~ /^reload\s/) {
2163 @return = cpl_reload($word,$line,$pos);
2164 } elsif ($line =~ /^o\s/) {
2165 @return = cpl_option($word,$line,$pos);
2172 #-> sub CPAN::Complete::cplx ;
2174 my($class, $word) = @_;
2175 grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
2178 #-> sub CPAN::Complete::cpl_any ;
2182 cplx('CPAN::Author',$word),
2183 cplx('CPAN::Bundle',$word),
2184 cplx('CPAN::Distribution',$word),
2185 cplx('CPAN::Module',$word),
2189 #-> sub CPAN::Complete::cpl_reload ;
2191 my($word,$line,$pos) = @_;
2193 my(@words) = split " ", $line;
2194 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2195 my(@ok) = qw(cpan index);
2196 return @ok if @words == 1;
2197 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2200 #-> sub CPAN::Complete::cpl_option ;
2202 my($word,$line,$pos) = @_;
2204 my(@words) = split " ", $line;
2205 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2206 my(@ok) = qw(conf debug);
2207 return @ok if @words == 1;
2208 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2210 } elsif ($words[1] eq 'index') {
2212 } elsif ($words[1] eq 'conf') {
2213 return CPAN::Config::cpl(@_);
2214 } elsif ($words[1] eq 'debug') {
2215 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2219 package CPAN::Index;
2221 #-> sub CPAN::Index::force_reload ;
2224 $CPAN::Index::last_time = 0;
2228 #-> sub CPAN::Index::reload ;
2230 my($cl,$force) = @_;
2233 # XXX check if a newer one is available. (We currently read it
2234 # from time to time)
2235 for ($CPAN::Config->{index_expire}) {
2236 $_ = 0.001 unless $_ > 0.001;
2238 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2243 my $needshort = $^O eq "dos";
2245 $cl->rd_authindex($cl->reload_x(
2246 "authors/01mailrc.txt.gz",
2247 $needshort ? "01mailrc.gz" : "",
2250 $debug = "timing reading 01[".($t2 - $time)."]";
2252 return if $CPAN::Signal; # this is sometimes lengthy
2253 $cl->rd_modpacks($cl->reload_x(
2254 "modules/02packages.details.txt.gz",
2255 $needshort ? "02packag.gz" : "",
2258 $debug .= "02[".($t2 - $time)."]";
2260 return if $CPAN::Signal; # this is sometimes lengthy
2261 $cl->rd_modlist($cl->reload_x(
2262 "modules/03modlist.data.gz",
2263 $needshort ? "03mlist.gz" : "",
2266 $debug .= "03[".($t2 - $time)."]";
2268 CPAN->debug($debug) if $CPAN::DEBUG;
2271 #-> sub CPAN::Index::reload_x ;
2273 my($cl,$wanted,$localname,$force) = @_;
2274 $force |= 2; # means we're dealing with an index here
2275 CPAN::Config->load; # we should guarantee loading wherever we rely
2277 $localname ||= $wanted;
2278 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2282 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2285 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2286 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2287 qq{day$s. I\'ll use that.});
2290 $force |= 1; # means we're quite serious about it.
2292 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2295 #-> sub CPAN::Index::rd_authindex ;
2297 my($cl,$index_target) = @_;
2298 return unless defined $index_target;
2299 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
2300 $CPAN::Frontend->myprint("Going to read $index_target\n");
2301 my $fh = FileHandle->new("$pipe|");
2304 my($userid,$fullname,$email) =
2305 /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/;
2306 next unless $userid && $fullname && $email;
2308 # instantiate an author object
2309 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2310 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2311 return if $CPAN::Signal;
2314 $? and Carp::croak "FAILED $pipe: exit status [$?]";
2317 #-> sub CPAN::Index::rd_modpacks ;
2319 my($cl,$index_target) = @_;
2320 return unless defined $index_target;
2321 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
2322 $CPAN::Frontend->myprint("Going to read $index_target\n");
2323 my $fh = FileHandle->new("$pipe|");
2329 my($mod,$version,$dist) = split;
2330 ### $version =~ s/^\+//;
2332 # if it as a bundle, instatiate a bundle object
2333 my($bundle,$id,$userid);
2335 if ($mod eq 'CPAN') {
2337 if ($version > $CPAN::VERSION){
2338 $CPAN::Frontend->myprint(qq{
2339 There\'s a new CPAN.pm version (v$version) available!
2340 You might want to try
2343 without quitting the current session. It should be a seamless upgrade
2344 while we are running...
2347 $CPAN::Frontend->myprint(qq{\n});
2349 last if $CPAN::Signal;
2350 } elsif ($mod =~ /^Bundle::(.*)/) {
2355 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2356 # Let's make it a module too, because bundles have so much
2357 # in common with modules
2358 $CPAN::META->instance('CPAN::Module',$mod);
2360 # This "next" makes us faster but if the job is running long, we ignore
2361 # rereads which is bad. So we have to be a bit slower again.
2362 # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2367 # instantiate a module object
2368 $id = $CPAN::META->instance('CPAN::Module',$mod);
2371 if ($id->cpan_file ne $dist){
2372 # determine the author
2373 ($userid) = $dist =~ /([^\/]+)/;
2375 'CPAN_USERID' => $userid,
2376 'CPAN_VERSION' => $version,
2377 'CPAN_FILE' => $dist
2381 # instantiate a distribution object
2382 unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2383 $CPAN::META->instance(
2384 'CPAN::Distribution' => $dist
2386 'CPAN_USERID' => $userid
2390 return if $CPAN::Signal;
2393 $? and Carp::croak "FAILED $pipe: exit status [$?]";
2396 #-> sub CPAN::Index::rd_modlist ;
2398 my($cl,$index_target) = @_;
2399 return unless defined $index_target;
2400 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
2401 $CPAN::Frontend->myprint("Going to read $index_target\n");
2402 my $fh = FileHandle->new("$pipe|");
2405 if (/^Date:\s+(.*)/){
2406 return if $date_of_03 eq $1;
2414 $eval .= q{CPAN::Modulelist->data;};
2416 my($comp) = Safe->new("CPAN::Safe1");
2417 my $ret = $comp->reval($eval);
2418 Carp::confess($@) if $@;
2419 return if $CPAN::Signal;
2421 my $obj = $CPAN::META->instance(CPAN::Module,$_);
2422 $obj->set(%{$ret->{$_}});
2423 return if $CPAN::Signal;
2427 package CPAN::InfoObj;
2429 #-> sub CPAN::InfoObj::new ;
2430 sub new { my $this = bless {}, shift; %$this = @_; $this }
2432 #-> sub CPAN::InfoObj::set ;
2434 my($self,%att) = @_;
2435 my(%oldatt) = %$self;
2436 %$self = (%oldatt, %att);
2439 #-> sub CPAN::InfoObj::id ;
2440 sub id { shift->{'ID'} }
2442 #-> sub CPAN::InfoObj::as_glimpse ;
2446 my $class = ref($self);
2447 $class =~ s/^CPAN:://;
2448 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
2452 #-> sub CPAN::InfoObj::as_string ;
2456 my $class = ref($self);
2457 $class =~ s/^CPAN:://;
2458 push @m, $class, " id = $self->{ID}\n";
2459 for (sort keys %$self) {
2462 $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
2463 if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX
2464 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
2466 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
2472 #-> sub CPAN::InfoObj::author ;
2475 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
2478 package CPAN::Author;
2480 #-> sub CPAN::Author::as_glimpse ;
2484 my $class = ref($self);
2485 $class =~ s/^CPAN:://;
2486 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
2490 # Dead code, I would have liked to have,,, but it was never reached,,,
2493 # return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
2496 #-> sub CPAN::Author::fullname ;
2497 sub fullname { shift->{'FULLNAME'} }
2499 #-> sub CPAN::Author::email ;
2500 sub email { shift->{'EMAIL'} }
2502 package CPAN::Distribution;
2504 #-> sub CPAN::Distribution::called_for ;
2507 $self->{'CALLED_FOR'} = $id if defined $id;
2508 return $self->{'CALLED_FOR'};
2511 #-> sub CPAN::Distribution::get ;
2516 exists $self->{'build_dir'} and push @e,
2517 "Unwrapped into directory $self->{'build_dir'}";
2518 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
2523 $CPAN::Config->{keep_source_where},
2526 split("/",$self->{ID})
2529 $self->debug("Doing localize") if $CPAN::DEBUG;
2531 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
2532 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
2533 $self->{localfile} = $local_file;
2534 my $builddir = $CPAN::META->{cachemgr}->dir;
2535 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
2536 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2539 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
2540 if ($CPAN::META->has_inst('MD5')) {
2541 $self->debug("MD5 is installed, verifying");
2544 $self->debug("MD5 is NOT installed");
2546 $self->debug("Removing tmp") if $CPAN::DEBUG;
2547 File::Path::rmtree("tmp");
2548 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
2550 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
2551 if (! $local_file) {
2552 Carp::croak "bad download, can't do anything :-(\n";
2553 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
2554 $self->untar_me($local_file);
2555 } elsif ( $local_file =~ /\.zip$/i ) {
2556 $self->unzip_me($local_file);
2557 } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
2558 $self->pm2dir_me($local_file);
2560 $self->{archived} = "NO";
2563 if ($self->{archived} ne 'NO') {
2565 # Let's check if the package has its own directory.
2566 my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!");
2567 my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
2569 my ($distdir,$packagedir);
2570 if (@readdir == 1 && -d $readdir[0]) {
2571 $distdir = $readdir[0];
2572 $packagedir = MM->catdir($builddir,$distdir);
2573 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
2574 File::Path::rmtree($packagedir);
2575 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
2577 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
2578 $pragmatic_dir =~ s/\W_//g;
2579 $pragmatic_dir++ while -d "../$pragmatic_dir";
2580 $packagedir = MM->catdir($builddir,$pragmatic_dir);
2581 File::Path::mkpath($packagedir);
2583 for $f (@readdir) { # is already without "." and ".."
2584 my $to = MM->catdir($packagedir,$f);
2585 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
2588 $self->{'build_dir'} = $packagedir;
2591 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
2593 File::Path::rmtree("tmp");
2594 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
2595 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
2596 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
2598 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
2599 unless (-f $makefilepl) {
2600 my($configure) = MM->catfile($packagedir,"Configure");
2601 if (-f $configure) {
2602 # do we have anything to do?
2603 $self->{'configure'} = $configure;
2605 my $fh = FileHandle->new(">$makefilepl")
2606 or Carp::croak("Could not open >$makefilepl");
2607 my $cf = $self->called_for || "unknown";
2609 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
2610 # because there was no Makefile.PL supplied.
2611 # Autogenerated on: }.scalar localtime().qq{
2613 use ExtUtils::MakeMaker;
2614 WriteMakefile(NAME => q[$cf]);
2617 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.\n}.
2618 qq{ Writing one on our own (calling it $cf)\n});
2626 my($self,$local_file) = @_;
2627 $self->{archived} = "tar";
2628 my $system = "$CPAN::Config->{gzip} --decompress --stdout " .
2629 "$local_file | $CPAN::Config->{tar} xvf -";
2630 if (system($system)== 0) {
2631 $self->{unwrapped} = "YES";
2633 $self->{unwrapped} = "NO";
2638 my($self,$local_file) = @_;
2639 $self->{archived} = "zip";
2640 my $system = "$CPAN::Config->{unzip} $local_file";
2641 if (system($system) == 0) {
2642 $self->{unwrapped} = "YES";
2644 $self->{unwrapped} = "NO";
2649 my($self,$local_file) = @_;
2650 $self->{archived} = "pm";
2651 my $to = File::Basename::basename($local_file);
2652 $to =~ s/\.(gz|Z)$//;
2653 my $system = "$CPAN::Config->{gzip} --decompress --stdout ".
2654 "$local_file > $to";
2655 if (system($system) == 0) {
2656 $self->{unwrapped} = "YES";
2658 $self->{unwrapped} = "NO";
2662 #-> sub CPAN::Distribution::new ;
2664 my($class,%att) = @_;
2666 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
2668 my $this = { %att };
2669 return bless $this, $class;
2672 #-> sub CPAN::Distribution::look ;
2675 if ( $CPAN::Config->{'shell'} ) {
2676 $CPAN::Frontend->myprint(qq{
2677 Trying to open a subshell in the build directory...
2680 $CPAN::Frontend->myprint(qq{
2681 Your configuration does not define a value for subshells.
2682 Please define it with "o conf shell <your shell>"
2686 my $dist = $self->id;
2687 my $dir = $self->dir or $self->get;
2690 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2691 my $pwd = CPAN->$getcwd();
2693 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
2694 system($CPAN::Config->{'shell'}) == 0
2695 or $CPAN::Frontend->mydie("Subprocess shell error");
2699 #-> sub CPAN::Distribution::readme ;
2702 my($dist) = $self->id;
2703 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
2704 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
2708 $CPAN::Config->{keep_source_where},
2711 split("/","$sans.readme"),
2713 $self->debug("Doing localize") if $CPAN::DEBUG;
2714 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
2716 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
2717 my $fh_pager = FileHandle->new;
2718 local($SIG{PIPE}) = "IGNORE";
2719 $fh_pager->open("|$CPAN::Config->{'pager'}")
2720 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
2721 my $fh_readme = FileHandle->new;
2722 $fh_readme->open($local_file)
2723 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
2724 $CPAN::Frontend->myprint(qq{
2727 with pager "$CPAN::Config->{'pager'}"
2730 $fh_pager->print(<$fh_readme>);
2733 #-> sub CPAN::Distribution::verifyMD5 ;
2738 $self->{MD5_STATUS} ||= "";
2739 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
2740 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
2742 my($lc_want,$lc_file,@local,$basename);
2743 @local = split("/",$self->{ID});
2745 push @local, "CHECKSUMS";
2747 MM->catfile($CPAN::Config->{keep_source_where},
2748 "authors", "id", @local);
2753 $self->MD5_check_file($lc_want)
2755 return $self->{MD5_STATUS} = "OK";
2757 $lc_file = CPAN::FTP->localize("authors/id/@local",
2760 $local[-1] .= ".gz";
2761 $lc_file = CPAN::FTP->localize("authors/id/@local",
2764 my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file);
2765 system(@system) == 0 or die "Could not uncompress $lc_file";
2766 $lc_file =~ s/\.gz$//;
2771 $self->MD5_check_file($lc_file);
2774 #-> sub CPAN::Distribution::MD5_check_file ;
2775 sub MD5_check_file {
2776 my($self,$chk_file) = @_;
2777 my($cksum,$file,$basename);
2778 $file = $self->{localfile};
2779 $basename = File::Basename::basename($file);
2780 my $fh = FileHandle->new;
2781 if (open $fh, $chk_file){
2785 my($comp) = Safe->new();
2786 $cksum = $comp->reval($eval);
2788 rename $chk_file, "$chk_file.bad";
2789 Carp::confess($@) if $@;
2792 Carp::carp "Could not open $chk_file for reading";
2794 if ($cksum->{$basename}->{md5}) {
2795 $self->debug("Found checksum for $basename:" .
2796 "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
2797 my $pipe = "$CPAN::Config->{gzip} --decompress ".
2802 $self->eq_MD5($fh,$cksum->{$basename}->{md5})
2806 $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
2808 $CPAN::Frontend->myprint("Checksum for $file ok\n");
2809 return $self->{MD5_STATUS} = "OK";
2811 $CPAN::Frontend->myprint(qq{Checksum mismatch for }.
2812 qq{distribution file. }.
2813 qq{Please investigate.\n\n}.
2815 $CPAN::META->instance(
2817 $self->{CPAN_USERID}
2819 my $wrap = qq{I\'d recommend removing $file. It seems to
2820 be a bogus file. Maybe you have configured your \`urllist\' with a
2821 bad URL. Please check this array with \`o conf urllist\', and
2823 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
2824 $CPAN::Frontend->myprint("\n\n");
2828 close $fh if fileno($fh);
2830 $self->{MD5_STATUS} ||= "";
2831 if ($self->{MD5_STATUS} eq "NIL") {
2832 $CPAN::Frontend->myprint(qq{
2833 No md5 checksum for $basename in local $chk_file.
2836 unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
2839 $self->{MD5_STATUS} = "NIL";
2844 #-> sub CPAN::Distribution::eq_MD5 ;
2846 my($self,$fh,$expectMD5) = @_;
2849 my $hexdigest = $md5->hexdigest;
2850 $hexdigest eq $expectMD5;
2853 #-> sub CPAN::Distribution::force ;
2856 $self->{'force_update'}++;
2857 delete $self->{'MD5_STATUS'};
2858 delete $self->{'archived'};
2859 delete $self->{'build_dir'};
2860 delete $self->{'localfile'};
2861 delete $self->{'make'};
2862 delete $self->{'install'};
2863 delete $self->{'unwrapped'};
2864 delete $self->{'writemakefile'};
2867 #-> sub CPAN::Distribution::perl ;
2870 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
2871 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
2872 my $pwd = CPAN->$getcwd();
2873 my $candidate = MM->catfile($pwd,$^X);
2874 $perl ||= $candidate if MM->maybe_command($candidate);
2876 my ($component,$perl_name);
2877 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
2878 PATH_COMPONENT: foreach $component (MM->path(),
2879 $Config::Config{'binexp'}) {
2880 next unless defined($component) && $component;
2881 my($abs) = MM->catfile($component,$perl_name);
2882 if (MM->maybe_command($abs)) {
2892 #-> sub CPAN::Distribution::make ;
2895 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
2899 $self->{archived} eq "NO" and push @e,
2900 "Is neither a tar nor a zip archive.";
2902 $self->{unwrapped} eq "NO" and push @e,
2903 "had problems unarchiving. Please build manually";
2905 exists $self->{writemakefile} &&
2906 $self->{writemakefile} eq "NO" and push @e,
2907 "Had some problem writing Makefile";
2909 defined $self->{'make'} and push @e,
2910 "Has already been processed within this session";
2912 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
2914 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
2915 my $builddir = $self->dir;
2916 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
2917 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
2920 if ($self->{'configure'}) {
2921 $system = $self->{'configure'};
2923 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
2925 # This needs a handler that can be turned on or off:
2926 # $switch = "-MExtUtils::MakeMaker ".
2927 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
2929 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
2932 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
2935 if ($CPAN::Config->{inactivity_timeout}) {
2937 alarm $CPAN::Config->{inactivity_timeout};
2938 local $SIG{CHLD} = sub { wait };
2939 if (defined($pid = fork)) {
2946 $CPAN::Frontend->myprint("Cannot fork: $!");
2954 $CPAN::Frontend->myprint($@);
2955 $self->{writemakefile} = "NO - $@";
2960 $ret = system($system);
2962 $self->{writemakefile} = "NO";
2967 $self->{writemakefile} = "YES";
2968 return if $CPAN::Signal;
2969 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
2970 if (system($system) == 0) {
2971 $CPAN::Frontend->myprint(" $system -- OK\n");
2972 $self->{'make'} = "YES";
2974 $self->{writemakefile} = "YES";
2975 $self->{'make'} = "NO";
2976 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
2980 #-> sub CPAN::Distribution::test ;
2984 return if $CPAN::Signal;
2985 $CPAN::Frontend->myprint("Running make test\n");
2988 exists $self->{'make'} or push @e,
2989 "Make had some problems, maybe interrupted? Won't test";
2991 exists $self->{'make'} and
2992 $self->{'make'} eq 'NO' and
2993 push @e, "Oops, make had returned bad status";
2995 exists $self->{'build_dir'} or push @e, "Has no own directory";
2996 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
2998 chdir $self->{'build_dir'} or
2999 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3000 $self->debug("Changed directory to $self->{'build_dir'}")
3002 my $system = join " ", $CPAN::Config->{'make'}, "test";
3003 if (system($system) == 0) {
3004 $CPAN::Frontend->myprint(" $system -- OK\n");
3005 $self->{'make_test'} = "YES";
3007 $self->{'make_test'} = "NO";
3008 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3012 #-> sub CPAN::Distribution::clean ;
3015 $CPAN::Frontend->myprint("Running make clean\n");
3018 exists $self->{'build_dir'} or push @e, "Has no own directory";
3019 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3021 chdir $self->{'build_dir'} or
3022 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3023 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3024 my $system = join " ", $CPAN::Config->{'make'}, "clean";
3025 if (system($system) == 0) {
3026 $CPAN::Frontend->myprint(" $system -- OK\n");
3029 # Hmmm, what to do if make clean failed?
3033 #-> sub CPAN::Distribution::install ;
3037 return if $CPAN::Signal;
3038 $CPAN::Frontend->myprint("Running make install\n");
3041 exists $self->{'build_dir'} or push @e, "Has no own directory";
3043 exists $self->{'make'} or push @e,
3044 "Make had some problems, maybe interrupted? Won't install";
3046 exists $self->{'make'} and
3047 $self->{'make'} eq 'NO' and
3048 push @e, "Oops, make had returned bad status";
3050 push @e, "make test had returned bad status, ".
3051 "won't install without force"
3052 if exists $self->{'make_test'} and
3053 $self->{'make_test'} eq 'NO' and
3054 ! $self->{'force_update'};
3056 exists $self->{'install'} and push @e,
3057 $self->{'install'} eq "YES" ?
3058 "Already done" : "Already tried without success";
3060 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3062 chdir $self->{'build_dir'} or
3063 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3064 $self->debug("Changed directory to $self->{'build_dir'}")
3066 my $system = join(" ", $CPAN::Config->{'make'},
3067 "install", $CPAN::Config->{make_install_arg});
3068 my($pipe) = FileHandle->new("$system 2>&1 |");
3071 $CPAN::Frontend->myprint($_);
3076 $CPAN::Frontend->myprint(" $system -- OK\n");
3077 $self->{'install'} = "YES";
3079 $self->{'install'} = "NO";
3080 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3081 if ($makeout =~ /permission/s && $> > 0) {
3082 $CPAN::Frontend->myprint(qq{ You may have to su }.
3083 qq{to root to install the package\n});
3088 #-> sub CPAN::Distribution::dir ;
3090 shift->{'build_dir'};
3093 package CPAN::Bundle;
3095 #-> sub CPAN::Bundle::as_string ;
3099 $self->{INST_VERSION} = $self->inst_version;
3100 return $self->SUPER::as_string;
3103 #-> sub CPAN::Bundle::contains ;
3106 my($parsefile) = $self->inst_file;
3107 my($id) = $self->id;
3108 $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
3109 unless ($parsefile) {
3110 # Try to get at it in the cpan directory
3111 $self->debug("no parsefile") if $CPAN::DEBUG;
3112 Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
3113 my $dist = $CPAN::META->instance('CPAN::Distribution',
3114 $self->{CPAN_FILE});
3116 $self->debug($dist->as_string) if $CPAN::DEBUG;
3117 my($todir) = $CPAN::Config->{'cpan_home'};
3118 my(@me,$from,$to,$me);
3119 @me = split /::/, $self->id;
3121 $me = MM->catfile(@me);
3122 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
3123 $to = MM->catfile($todir,$me);
3124 File::Path::mkpath(File::Basename::dirname($to));
3125 File::Copy::copy($from, $to)
3126 or Carp::confess("Couldn't copy $from to $to: $!");
3130 my $fh = FileHandle->new;
3132 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
3134 $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
3136 $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 :
3137 /^=head1\s+CONTENTS/ ? 1 : $inpod;
3142 push @result, (split " ", $_, 2)[0];
3145 delete $self->{STATUS};
3146 $self->{CONTAINS} = join ", ", @result;
3147 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
3151 #-> sub CPAN::Bundle::find_bundle_file
3152 sub find_bundle_file {
3153 my($self,$where,$what) = @_;
3154 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
3155 my $bu = MM->catfile($where,$what);
3156 return $bu if -f $bu;
3157 my $manifest = MM->catfile($where,"MANIFEST");
3158 unless (-f $manifest) {
3159 require ExtUtils::Manifest;
3160 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3161 my $cwd = CPAN->$getcwd();
3163 ExtUtils::Manifest::mkmanifest();
3166 my $fh = FileHandle->new($manifest)
3167 or Carp::croak("Couldn't open $manifest: $!");
3171 my($file) = /(\S+)/;
3172 if ($file =~ m|\Q$what\E$|) {
3174 return MM->catfile($where,$bu);
3175 } elsif ($what =~ s|Bundle/||) { # retry if she managed to
3176 # have no Bundle directory
3177 if ($file =~ m|\Q$what\E$|) {
3179 return MM->catfile($where,$bu);
3183 Carp::croak("Couldn't find a Bundle file in $where");
3186 #-> sub CPAN::Bundle::inst_file ;
3190 ($me = $self->id) =~ s/.*://;
3191 ## my(@me,$inst_file);
3192 ## @me = split /::/, $self->id;
3193 ## $me[-1] .= ".pm";
3194 $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
3195 "Bundle", "$me.pm");
3197 return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3199 $self->SUPER::inst_file;
3200 # return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
3201 # return $self->{'INST_FILE'}; # even if undefined?
3204 #-> sub CPAN::Bundle::rematein ;
3206 my($self,$meth) = @_;
3207 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
3208 my($id) = $self->id;
3209 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
3210 unless $self->inst_file || $self->{CPAN_FILE};
3212 for $s ($self->contains) {
3213 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
3214 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
3215 if ($type eq 'CPAN::Distribution') {
3216 $CPAN::Frontend->mywarn(qq{
3217 The Bundle }.$self->id.qq{ contains
3218 explicitly a file $s.
3222 $CPAN::META->instance($type,$s)->$meth();
3226 #sub CPAN::Bundle::xs_file
3228 # If a bundle contains another that contains an xs_file we have
3229 # here, we just don't bother I suppose
3233 #-> sub CPAN::Bundle::force ;
3234 sub force { shift->rematein('force',@_); }
3235 #-> sub CPAN::Bundle::get ;
3236 sub get { shift->rematein('get',@_); }
3237 #-> sub CPAN::Bundle::make ;
3238 sub make { shift->rematein('make',@_); }
3239 #-> sub CPAN::Bundle::test ;
3240 sub test { shift->rematein('test',@_); }
3241 #-> sub CPAN::Bundle::install ;
3242 sub install { shift->rematein('install',@_); }
3243 #-> sub CPAN::Bundle::clean ;
3244 sub clean { shift->rematein('clean',@_); }
3246 #-> sub CPAN::Bundle::readme ;
3249 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
3250 No File found for bundle } . $self->id . qq{\n}), return;
3251 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
3252 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
3255 package CPAN::Module;
3257 #-> sub CPAN::Module::as_glimpse ;
3261 my $class = ref($self);
3262 $class =~ s/^CPAN:://;
3263 push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
3268 #-> sub CPAN::Module::as_string ;
3272 CPAN->debug($self) if $CPAN::DEBUG;
3273 my $class = ref($self);
3274 $class =~ s/^CPAN:://;
3276 push @m, $class, " id = $self->{ID}\n";
3277 my $sprintf = " %-12s %s\n";
3278 push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
3279 if $self->{description};
3280 my $sprintf2 = " %-12s %s (%s)\n";
3282 if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
3284 if ($author = CPAN::Shell->expand('Author',$userid)) {
3293 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
3294 if $self->{CPAN_VERSION};
3295 push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
3296 if $self->{CPAN_FILE};
3297 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
3298 my(%statd,%stats,%statl,%stati);
3299 @statd{qw,? i c a b R M S,} = qw,unknown idea
3300 pre-alpha alpha beta released mature standard,;
3301 @stats{qw,? m d u n,} = qw,unknown mailing-list
3302 developer comp.lang.perl.* none,;
3303 @statl{qw,? p c + o,} = qw,unknown perl C C++ other,;
3304 @stati{qw,? f r O,} = qw,unknown functions
3305 references+ties object-oriented,;
3306 $statd{' '} = 'unknown';
3307 $stats{' '} = 'unknown';
3308 $statl{' '} = 'unknown';
3309 $stati{' '} = 'unknown';
3317 $statd{$self->{statd}},
3318 $stats{$self->{stats}},
3319 $statl{$self->{statl}},
3320 $stati{$self->{stati}}
3321 ) if $self->{statd};
3322 my $local_file = $self->inst_file;
3323 if ($local_file && ! exists $self->{MANPAGE}) {
3324 my $fh = FileHandle->new($local_file)
3325 or Carp::croak("Couldn't open $local_file: $!");
3330 $inpod = /^=(?!head1\s+NAME)/ ? 0 :
3331 /^=head1\s+NAME/ ? 1 : $inpod;
3339 $self->{MANPAGE} = join " ", @result;
3342 for $item (qw/MANPAGE CONTAINS/) {
3343 push @m, sprintf($sprintf, $item, $self->{$item})
3344 if exists $self->{$item};
3346 push @m, sprintf($sprintf, 'INST_FILE',
3347 $local_file || "(not installed)");
3348 push @m, sprintf($sprintf, 'INST_VERSION',
3349 $self->inst_version) if $local_file;
3353 #-> sub CPAN::Module::cpan_file ;
3356 CPAN->debug($self->id) if $CPAN::DEBUG;
3357 unless (defined $self->{'CPAN_FILE'}) {
3358 CPAN::Index->reload;
3360 if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
3361 return $self->{'CPAN_FILE'};
3362 } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
3363 my $fullname = $CPAN::META->instance(CPAN::Author,
3364 $self->{'userid'})->fullname;
3365 unless (defined $fullname) {
3366 $CPAN::Frontend->mywarn(qq{Full name of author }.
3367 qq{$self->{userid} not known});
3368 return "Contact Author $self->{userid}";
3370 return "Contact Author $self->{userid} ($fullname)"
3376 *name = \&cpan_file;
3378 #-> sub CPAN::Module::cpan_version ;
3381 $self->{'CPAN_VERSION'} = 'undef'
3382 unless defined $self->{'CPAN_VERSION'}; # I believe this is
3383 # always a bug in the
3384 # index and should be
3386 # but usually I find
3388 # and do not want to
3391 $self->{'CPAN_VERSION'};
3394 #-> sub CPAN::Module::force ;
3397 $self->{'force_update'}++;
3400 #-> sub CPAN::Module::rematein ;
3402 my($self,$meth) = @_;
3403 $self->debug($self->id) if $CPAN::DEBUG;
3404 my $cpan_file = $self->cpan_file;
3405 return if $cpan_file eq "N/A";
3406 return if $cpan_file =~ /^Contact Author/;
3407 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
3408 $pack->called_for($self->id);
3409 $pack->force if exists $self->{'force_update'};
3411 delete $self->{'force_update'};
3414 #-> sub CPAN::Module::readme ;
3415 sub readme { shift->rematein('readme') }
3416 #-> sub CPAN::Module::look ;
3417 sub look { shift->rematein('look') }
3418 #-> sub CPAN::Module::get ;
3419 sub get { shift->rematein('get',@_); }
3420 #-> sub CPAN::Module::make ;
3421 sub make { shift->rematein('make') }
3422 #-> sub CPAN::Module::test ;
3423 sub test { shift->rematein('test') }
3424 #-> sub CPAN::Module::install ;
3428 my($latest) = $self->cpan_version;
3430 my($inst_file) = $self->inst_file;
3432 if (defined $inst_file) {
3433 $have = $self->inst_version;
3435 if (1){ # A block for scoping $^W, the if is just for the visual
3442 not exists $self->{'force_update'}
3444 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
3449 $self->rematein('install') if $doit;
3451 #-> sub CPAN::Module::clean ;
3452 sub clean { shift->rematein('clean') }
3454 #-> sub CPAN::Module::inst_file ;
3458 @packpath = split /::/, $self->{ID};
3459 $packpath[-1] .= ".pm";
3460 foreach $dir (@INC) {
3461 my $pmfile = MM->catfile($dir,@packpath);
3469 #-> sub CPAN::Module::xs_file ;
3473 @packpath = split /::/, $self->{ID};
3474 push @packpath, $packpath[-1];
3475 $packpath[-1] .= "." . $Config::Config{'dlext'};
3476 foreach $dir (@INC) {
3477 my $xsfile = MM->catfile($dir,'auto',@packpath);
3485 #-> sub CPAN::Module::inst_version ;
3488 my $parsefile = $self->inst_file or return;
3489 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
3490 my $have = MM->parse_version($parsefile) || "undef";
3503 CPAN - query, download and build perl modules from CPAN sites
3509 perl -MCPAN -e shell;
3515 autobundle, clean, install, make, recompile, test
3519 The CPAN module is designed to automate the make and install of perl
3520 modules and extensions. It includes some searching capabilities and
3521 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
3522 to fetch the raw data from the net.
3524 Modules are fetched from one or more of the mirrored CPAN
3525 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
3528 The CPAN module also supports the concept of named and versioned
3529 'bundles' of modules. Bundles simplify the handling of sets of
3530 related modules. See BUNDLES below.
3532 The package contains a session manager and a cache manager. There is
3533 no status retained between sessions. The session manager keeps track
3534 of what has been fetched, built and installed in the current
3535 session. The cache manager keeps track of the disk space occupied by
3536 the make processes and deletes excess space according to a simple FIFO
3539 All methods provided are accessible in a programmer style and in an
3540 interactive shell style.
3542 =head2 Interactive Mode
3544 The interactive mode is entered by running
3546 perl -MCPAN -e shell
3548 which puts you into a readline interface. You will have most fun if
3549 you install Term::ReadKey and Term::ReadLine to enjoy both history and
3552 Once you are on the command line, type 'h' and the rest should be
3555 The most common uses of the interactive modes are
3559 =item Searching for authors, bundles, distribution files and modules
3561 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
3562 for each of the four categories and another, C<i> for any of the
3563 mentioned four. Each of the four entities is implemented as a class
3564 with slightly differing methods for displaying an object.
3566 Arguments you pass to these commands are either strings matching exact
3567 the identification string of an object or regular expressions that are
3568 then matched case-insensitively against various attributes of the
3569 objects. The parser recognizes a regualar expression only if you
3570 enclose it between two slashes.
3572 The principle is that the number of found objects influences how an
3573 item is displayed. If the search finds one item, we display the result
3574 of object-E<gt>as_string, but if we find more than one, we display
3575 each as object-E<gt>as_glimpse. E.g.
3579 EMAIL a.koenig@franz.ww.TU-Berlin.DE
3580 FULLNAME Andreas König
3585 EMAIL a.koenig@franz.ww.TU-Berlin.DE
3586 FULLNAME Andreas König
3590 Author ANDYD (Andy Dougherty)
3591 Author MERLYN (Randal L. Schwartz)
3593 =item make, test, install, clean modules or distributions
3595 These commands do indeed exist just as written above. Each of them
3596 takes any number of arguments and investigates for each what it might
3597 be. Is it a distribution file (recognized by embedded slashes), this
3598 file is being processed. Is it a module, CPAN determines the
3599 distribution file where this module is included and processes that.
3601 Any C<make>, C<test>, and C<readme> are run unconditionally. A
3603 install <distribution_file>
3605 also is run unconditionally. But for
3609 CPAN checks if an install is actually needed for it and prints
3610 I<Foo up to date> in case the module doesnE<39>t need to be updated.
3612 CPAN also keeps track of what it has done within the current session
3613 and doesnE<39>t try to build a package a second time regardless if it
3614 succeeded or not. The C<force > command takes as first argument the
3615 method to invoke (currently: make, test, or install) and executes the
3616 command from scratch.
3620 cpan> install OpenGL
3621 OpenGL is up to date.
3622 cpan> force install OpenGL
3625 OpenGL-0.4/COPYRIGHT
3628 =item readme, look module or distribution
3630 These two commands take only one argument, be it a module or a
3631 distribution file. C<readme> displays the README of the associated
3632 distribution file. C<Look> gets and untars (if not yet done) the
3633 distribution file, changes to the appropriate directory and opens a
3634 subshell process in that directory.
3640 The commands that are available in the shell interface are methods in
3641 the package CPAN::Shell. If you enter the shell command, all your
3642 input is split by the Text::ParseWords::shellwords() routine which
3643 acts like most shells do. The first word is being interpreted as the
3644 method to be called and the rest of the words are treated as arguments
3645 to this method. Continuation lines are supported if a line ends with a
3650 C<autobundle> writes a bundle file into the
3651 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
3652 a list of all modules that are both available from CPAN and currently
3653 installed within @INC. The name of the bundle file is based on the
3654 current date and a counter.
3658 recompile() is a very special command in that it takes no argument and
3659 runs the make/test/install cycle with brute force over all installed
3660 dynamically loadable extensions (aka XS modules) with 'force' in
3661 effect. Primary purpose of this command is to finish a network
3662 installation. Imagine, you have a common source tree for two different
3663 architectures. You decide to do a completely independent fresh
3664 installation. You start on one architecture with the help of a Bundle
3665 file produced earlier. CPAN installs the whole Bundle for you, but
3666 when you try to repeat the job on the second architecture, CPAN
3667 responds with a C<"Foo up to date"> message for all modules. So you
3668 will be glad to run recompile in the second architecture and
3671 Another popular use for C<recompile> is to act as a rescue in case your
3672 perl breaks binary compatibility. If one of the modules that CPAN uses
3673 is in turn depending on binary compatibility (so you cannot run CPAN
3674 commands), then you should try the CPAN::Nox module for recovery.
3676 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
3678 Although it may be considered internal, the class hierarchie does
3679 matter for both users and programmer. CPAN.pm deals with above
3680 mentioned four classes, and all those classes share a set of
3681 methods. It is a classical single polymorphism that is in effect. A
3682 metaclass object registers all objects of all kinds and indexes them
3683 with a string. The strings referencing objects have a separated
3684 namespace (well, not completely separated):
3688 words containing a "/" (slash) Distribution
3689 words starting with Bundle:: Bundle
3690 everything else Module or Author
3692 Modules know their associated Distribution objects. They always refer
3693 to the most recent official release. Developers may mark their
3694 releases as unstable development versions (by inserting an underbar
3695 into the visible version number), so not always is the default
3696 distribution for a given module the really hottest and newest. If a
3697 module Foo circulates on CPAN in both version 1.23 and 1.23_90,
3698 CPAN.pm offers a convenient way to install version 1.23 by saying
3702 This would install the complete distribution file (say
3703 BAR/Foo-1.23.tar.gz) with all accompanying material in there. But if
3704 you would like to install version 1.23_90, you need to know where the
3705 distribution file resides on CPAN relative to the authors/id/
3706 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz,
3707 so you would have to say
3709 install BAR/Foo-1.23_90.tar.gz
3711 The first example will be driven by an object of the class
3712 CPAN::Module, the second by an object of class CPAN::Distribution.
3714 =head2 ProgrammerE<39>s interface
3716 If you do not enter the shell, the available shell commands are both
3717 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
3718 functions in the calling package (C<install(...)>).
3720 There's currently only one class that has a stable interface,
3721 CPAN::Shell. All commands that are available in the CPAN shell are
3722 methods of the class CPAN::Shell. Each of the commands that produce
3723 listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the
3724 IDs of all modules within the list.
3728 =item expand($type,@things)
3730 The IDs of all objects available within a program are strings that can
3731 be expanded to the corresponding real objects with the
3732 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
3733 list of CPAN::Module objects according to the C<@things> arguments
3734 given. In scalar context it only returns the first element of the
3737 =item Programming Examples
3739 This enables the programmer to do operations that combine
3740 functionalities that are available in the shell.
3742 # install everything that is outdated on my disk:
3743 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
3745 # install my favorite programs if necessary:
3746 for $mod (qw(Net::FTP MD5 Data::Dumper)){
3747 my $obj = CPAN::Shell->expand('Module',$mod);
3751 # list all modules on my disk that have no VERSION number
3752 for $mod (CPAN::Shell->expand("Module","/./")){
3753 next unless $mod->inst_file;
3754 # MakeMaker convention for undefined $VERSION:
3755 next unless $mod->inst_version eq "undef";
3756 print "No VERSION in ", $mod->id, "\n";
3761 =head2 Methods in the four
3763 =head2 Cache Manager
3765 Currently the cache manager only keeps track of the build directory
3766 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
3767 deletes complete directories below C<build_dir> as soon as the size of
3768 all directories there gets bigger than $CPAN::Config->{build_cache}
3769 (in MB). The contents of this cache may be used for later
3770 re-installations that you intend to do manually, but will never be
3771 trusted by CPAN itself. This is due to the fact that the user might
3772 use these directories for building modules on different architectures.
3774 There is another directory ($CPAN::Config->{keep_source_where}) where
3775 the original distribution files are kept. This directory is not
3776 covered by the cache manager and must be controlled by the user. If
3777 you choose to have the same directory as build_dir and as
3778 keep_source_where directory, then your sources will be deleted with
3779 the same fifo mechanism.
3783 A bundle is just a perl module in the namespace Bundle:: that does not
3784 define any functions or methods. It usually only contains documentation.
3786 It starts like a perl module with a package declaration and a $VERSION
3787 variable. After that the pod section looks like any other pod with the
3788 only difference, that I<one special pod section> exists starting with
3793 In this pod section each line obeys the format
3795 Module_Name [Version_String] [- optional text]
3797 The only required part is the first field, the name of a module
3798 (eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest
3799 of the line is optional. The comment part is delimited by a dash just
3800 as in the man page header.
3802 The distribution of a bundle should follow the same convention as
3803 other distributions.
3805 Bundles are treated specially in the CPAN package. If you say 'install
3806 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
3807 the modules in the CONTENTS section of the pod. You can install your
3808 own Bundles locally by placing a conformant Bundle file somewhere into
3809 your @INC path. The autobundle() command which is available in the
3810 shell interface does that for you by including all currently installed
3811 modules in a snapshot bundle file.
3813 =head2 Prerequisites
3815 If you have a local mirror of CPAN and can access all files with
3816 "file:" URLs, then you only need a perl better than perl5.003 to run
3817 this module. Otherwise Net::FTP is strongly recommended. LWP may be
3818 required for non-UNIX systems or if your nearest CPAN site is
3819 associated with an URL that is not C<ftp:>.
3821 If you have neither Net::FTP nor LWP, there is a fallback mechanism
3822 implemented for an external ftp command or for an external lynx
3825 This module presumes that all packages on CPAN
3831 declare their $VERSION variable in an easy to parse manner. This
3832 prerequisite can hardly be relaxed because it consumes by far too much
3833 memory to load all packages into the running program just to determine
3834 the $VERSION variable . Currently all programs that are dealing with
3835 version use something like this
3837 perl -MExtUtils::MakeMaker -le \
3838 'print MM->parse_version($ARGV[0])' filename
3840 If you are author of a package and wonder if your $VERSION can be
3841 parsed, please try the above method.
3845 come as compressed or gzipped tarfiles or as zip files and contain a
3846 Makefile.PL (well we try to handle a bit more, but without much
3853 The debugging of this module is pretty difficult, because we have
3854 interferences of the software producing the indices on CPAN, of the
3855 mirroring process on CPAN, of packaging, of configuration, of
3856 synchronicity, and of bugs within CPAN.pm.
3858 In interactive mode you can try "o debug" which will list options for
3859 debugging the various parts of the package. The output may not be very
3860 useful for you as it's just a byproduct of my own testing, but if you
3861 have an idea which part of the package may have a bug, it's sometimes
3862 worth to give it a try and send me more specific output. You should
3863 know that "o debug" has built-in completion support.
3865 =head2 Floppy, Zip, and all that Jazz
3867 CPAN.pm works nicely without network too. If you maintain machines
3868 that are not networked at all, you should consider working with file:
3869 URLs. Of course, you have to collect your modules somewhere first. So
3870 you might use CPAN.pm to put together all you need on a networked
3871 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
3872 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
3873 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
3876 =head1 CONFIGURATION
3878 When the CPAN module is installed a site wide configuration file is
3879 created as CPAN/Config.pm. The default values defined there can be
3880 overridden in another configuration file: CPAN/MyConfig.pm. You can
3881 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
3882 $HOME/.cpan is added to the search path of the CPAN module before the
3883 use() or require() statements.
3885 Currently the following keys in the hash reference $CPAN::Config are
3888 build_cache size of cache for directories to build modules
3889 build_dir locally accessible directory to build modules
3890 index_expire after how many days refetch index files
3891 cpan_home local directory reserved for this package
3892 gzip location of external program gzip
3893 inactivity_timeout breaks interactive Makefile.PLs after that
3894 many seconds inactivity. Set to 0 to never break.
3895 inhibit_startup_message
3896 if true, does not print the startup message
3897 keep_source keep the source in a local directory?
3898 keep_source_where where keep the source (if we do)
3899 make location of external program make
3900 make_arg arguments that should always be passed to 'make'
3901 make_install_arg same as make_arg for 'make install'
3902 makepl_arg arguments passed to 'perl Makefile.PL'
3903 pager location of external program more (or any pager)
3904 tar location of external program tar
3905 unzip location of external program unzip
3906 urllist arrayref to nearby CPAN sites (or equivalent locations)
3908 You can set and query each of these options interactively in the cpan
3909 shell with the command set defined within the C<o conf> command:
3913 =item o conf E<lt>scalar optionE<gt>
3915 prints the current value of the I<scalar option>
3917 =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
3919 Sets the value of the I<scalar option> to I<value>
3921 =item o conf E<lt>list optionE<gt>
3923 prints the current value of the I<list option> in MakeMaker's
3926 =item o conf E<lt>list optionE<gt> [shift|pop]
3928 shifts or pops the array in the I<list option> variable
3930 =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
3932 works like the corresponding perl commands.
3936 =head2 CD-ROM support
3938 The C<urllist> parameter of the configuration table contains a list of
3939 URLs that are to be used for downloading. If the list contains any
3940 C<file> URLs, CPAN always tries to get files from there first. This
3941 feature is disabled for index files. So the recommendation for the
3942 owner of a CD-ROM with CPAN contents is: include your local, possibly
3943 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
3945 o conf urllist push file://localhost/CDROM/CPAN
3947 CPAN.pm will then fetch the index files from one of the CPAN sites
3948 that come at the beginning of urllist. It will later check for each
3949 module if there is a local copy of the most recent version.
3953 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
3954 install foreign, unmasked, unsigned code on your machine. We compare
3955 to a checksum that comes from the net just as the distribution file
3956 itself. If somebody has managed to tamper with the distribution file,
3957 they may have as well tampered with the CHECKSUMS file. Future
3958 development will go towards strong authentification.
3962 Most functions in package CPAN are exported per default. The reason
3963 for this is that the primary use is intended for the cpan shell or for
3968 we should give coverage for _all_ of the CPAN and not just the
3969 PAUSE part, right? In this discussion CPAN and PAUSE have become
3970 equal -- but they are not. PAUSE is authors/ and modules/. CPAN is
3971 PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/.
3973 Future development should be directed towards a better integration of
3978 Andreas König E<lt>a.koenig@mind.deE<gt>
3982 perl(1), CPAN::Nox(3)