1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
3 $VERSION = '1.57_68RC';
5 # $Id: CPAN.pm,v 1.354 2000/10/08 14:20:57 k Exp $
7 # only used during development:
9 # $Revision = "[".substr(q$Revision: 1.354 $, 10)."]";
16 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
17 use File::Basename ();
23 use Text::ParseWords ();
26 no lib "."; # we need to run chdir all over and we would get at wrong
29 END { $End++; &cleanup; }
52 $CPAN::Frontend ||= "CPAN::Shell";
53 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
58 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
59 $Revision $Signal $Cwd $End $Suppress_readline $Frontend
60 $Defaultsite $Have_warned);
62 @CPAN::ISA = qw(CPAN::Debug Exporter);
65 autobundle bundle expand force get cvs_import
66 install make readme recompile shell test clean
69 #-> sub CPAN::AUTOLOAD ;
74 @EXPORT{@EXPORT} = '';
75 CPAN::Config->load unless $CPAN::Config_loaded++;
76 if (exists $EXPORT{$l}){
79 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
88 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
89 CPAN::Config->load unless $CPAN::Config_loaded++;
91 CPAN::Index->read_metadata_cache;
93 my $prompt = "cpan> ";
95 unless ($Suppress_readline) {
96 require Term::ReadLine;
97 # import Term::ReadLine;
98 $term = Term::ReadLine->new('CPAN Monitor');
99 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
100 my $attribs = $term->Attribs;
101 # $attribs->{completion_entry_function} =
102 # $attribs->{'list_completion_function'};
103 $attribs->{attempted_completion_function} = sub {
104 &CPAN::Complete::gnu_cpl;
106 # $attribs->{completion_word} =
107 # [qw(help me somebody to find out how
108 # to use completion with GNU)];
110 $readline::rl_completion_function =
111 $readline::rl_completion_function = 'CPAN::Complete::cpl';
113 # $term->OUT is autoflushed anyway
114 my $odef = select STDERR;
121 # no strict; # I do not recall why no strict was here (2000-09-03)
124 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
125 my $cwd = CPAN->$getcwd();
126 my $try_detect_readline;
127 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
128 my $rl_avail = $Suppress_readline ? "suppressed" :
129 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
130 "available (try 'install Bundle::CPAN')";
132 $CPAN::Frontend->myprint(
134 cpan shell -- CPAN exploration and modules installation (v%s%s)
142 unless $CPAN::Config->{'inhibit_startup_message'} ;
143 my($continuation) = "";
145 if ($Suppress_readline) {
147 last unless defined ($_ = <> );
150 last unless defined ($_ = $term->readline($prompt));
152 $_ = "$continuation$_" if $continuation;
155 $_ = 'h' if /^\s*\?/;
156 if (/^(?:q(?:uit)?|bye|exit)$/i) {
166 use vars qw($import_done);
167 CPAN->import(':DEFAULT') unless $import_done++;
168 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
175 if ($] < 5.00322) { # parsewords had a bug until recently
178 eval { @line = Text::ParseWords::shellwords($_) };
179 warn($@), next if $@;
181 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
182 my $command = shift @line;
183 eval { CPAN::Shell->$command(@line) };
185 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
186 $CPAN::Frontend->myprint("\n");
192 CPAN::Queue->nullify_queue;
193 if ($try_detect_readline) {
194 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
196 $CPAN::META->has_inst("Term::ReadLine::Perl")
198 delete $INC{"Term/ReadLine.pm"};
200 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
201 require Term::ReadLine;
202 $CPAN::Frontend->myprint("\n$redef subroutines in ".
203 "Term::ReadLine redefined\n");
210 package CPAN::CacheMgr;
211 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
214 package CPAN::Config;
215 use vars qw(%can $dot_cpan);
218 'commit' => "Commit changes to disk",
219 'defaults' => "Reload defaults from disk",
220 'init' => "Interactive setting of all options",
224 use vars qw($Ua $Thesite $Themethod);
225 @CPAN::FTP::ISA = qw(CPAN::Debug);
227 package CPAN::Complete;
228 @CPAN::Complete::ISA = qw(CPAN::Debug);
231 use vars qw($last_time $date_of_03);
232 @CPAN::Index::ISA = qw(CPAN::Debug);
235 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
238 package CPAN::InfoObj;
239 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
241 package CPAN::Author;
242 @CPAN::Author::ISA = qw(CPAN::InfoObj);
244 package CPAN::Distribution;
245 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
247 package CPAN::Bundle;
248 @CPAN::Bundle::ISA = qw(CPAN::Module);
250 package CPAN::Module;
251 @CPAN::Module::ISA = qw(CPAN::InfoObj);
254 use vars qw($AUTOLOAD @ISA);
255 @CPAN::Shell::ISA = qw(CPAN::Debug);
257 #-> sub CPAN::Shell::AUTOLOAD ;
259 my($autoload) = $AUTOLOAD;
260 my $class = shift(@_);
261 # warn "autoload[$autoload] class[$class]";
262 $autoload =~ s/.*:://;
263 if ($autoload =~ /^w/) {
264 if ($CPAN::META->has_inst('CPAN::WAIT')) {
265 CPAN::WAIT->$autoload(@_);
267 $CPAN::Frontend->mywarn(qq{
268 Commands starting with "w" require CPAN::WAIT to be installed.
269 Please consider installing CPAN::WAIT to use the fulltext index.
270 For this you just need to type
275 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
281 package CPAN::Tarzip;
282 use vars qw($AUTOLOAD @ISA);
283 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
287 # One use of the queue is to determine if we should or shouldn't
288 # announce the availability of a new CPAN module
290 # Now we try to use it for dependency tracking. For that to happen
291 # we need to draw a dependency tree and do the leaves first. This can
292 # easily be reached by running CPAN.pm recursively, but we don't want
293 # to waste memory and run into deep recursion. So what we can do is
296 # CPAN::Queue is the package where the queue is maintained. Dependencies
297 # often have high priority and must be brought to the head of the queue,
298 # possibly by jumping the queue if they are already there. My first code
299 # attempt tried to be extremely correct. Whenever a module needed
300 # immediate treatment, I either unshifted it to the front of the queue,
301 # or, if it was already in the queue, I spliced and let it bypass the
302 # others. This became a too correct model that made it impossible to put
303 # an item more than once into the queue. Why would you need that? Well,
304 # you need temporary duplicates as the manager of the queue is a loop
307 # (1) looks at the first item in the queue without shifting it off
309 # (2) cares for the item
311 # (3) removes the item from the queue, *even if its agenda failed and
312 # even if the item isn't the first in the queue anymore* (that way
313 # protecting against never ending queues)
315 # So if an item has prerequisites, the installation fails now, but we
316 # want to retry later. That's easy if we have it twice in the queue.
318 # I also expect insane dependency situations where an item gets more
319 # than two lives in the queue. Simplest example is triggered by 'install
320 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
321 # get in the way. I wanted the queue manager to be a dumb servant, not
322 # one that knows everything.
324 # Who would I tell in this model that the user wants to be asked before
325 # processing? I can't attach that information to the module object,
326 # because not modules are installed but distributions. So I'd have to
327 # tell the distribution object that it should ask the user before
328 # processing. Where would the question be triggered then? Most probably
329 # in CPAN::Distribution::rematein.
330 # Hope that makes sense, my head is a bit off:-) -- AK
337 my $self = bless { qmod => $s }, $class;
342 # CPAN::Queue::first ;
348 # CPAN::Queue::delete_first ;
350 my($class,$what) = @_;
352 for my $i (0..$#All) {
353 if ( $All[$i]->{qmod} eq $what ) {
360 # CPAN::Queue::jumpqueue ;
364 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
365 join(",",map {$_->{qmod}} @All),
368 WHAT: for my $what (reverse @what) {
370 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
371 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
372 if ($All[$i]->{qmod} eq $what){
374 if ($jumped > 100) { # one's OK if e.g. just
375 # processing now; more are OK if
376 # user typed it several times
377 $CPAN::Frontend->mywarn(
378 qq{Object [$what] queued more than 100 times, ignoring}
384 my $obj = bless { qmod => $what }, $class;
387 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
388 join(",",map {$_->{qmod}} @All),
393 # CPAN::Queue::exists ;
395 my($self,$what) = @_;
396 my @all = map { $_->{qmod} } @All;
397 my $exists = grep { $_->{qmod} eq $what } @All;
398 # warn "in exists what[$what] all[@all] exists[$exists]";
402 # CPAN::Queue::delete ;
405 @All = grep { $_->{qmod} ne $mod } @All;
408 # CPAN::Queue::nullify_queue ;
417 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
419 # from here on only subs.
420 ################################################################################
422 #-> sub CPAN::all_objects ;
424 my($mgr,$class) = @_;
425 CPAN::Config->load unless $CPAN::Config_loaded++;
426 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
428 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
430 *all = \&all_objects;
432 # Called by shell, not in batch mode. In batch mode I see no risk in
433 # having many processes updating something as installations are
434 # continually checked at runtime. In shell mode I suspect it is
435 # unintentional to open more than one shell at a time
437 #-> sub CPAN::checklock ;
440 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
441 if (-f $lockfile && -M _ > 0) {
442 my $fh = FileHandle->new($lockfile) or
443 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
446 if (defined $other && $other) {
448 return if $$==$other; # should never happen
449 $CPAN::Frontend->mywarn(
451 There seems to be running another CPAN process ($other). Contacting...
453 if (kill 0, $other) {
454 $CPAN::Frontend->mydie(qq{Other job is running.
455 You may want to kill it and delete the lockfile, maybe. On UNIX try:
459 } elsif (-w $lockfile) {
461 ExtUtils::MakeMaker::prompt
462 (qq{Other job not responding. Shall I overwrite }.
463 qq{the lockfile? (Y/N)},"y");
464 $CPAN::Frontend->myexit("Ok, bye\n")
465 unless $ans =~ /^y/i;
468 qq{Lockfile $lockfile not writeable by you. }.
469 qq{Cannot proceed.\n}.
472 qq{ and then rerun us.\n}
476 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
477 "reports other process with ID ".
478 "$other. Cannot proceed.\n"));
481 my $dotcpan = $CPAN::Config->{cpan_home};
482 eval { File::Path::mkpath($dotcpan);};
484 # A special case at least for Jarkko.
489 $symlinkcpan = readlink $dotcpan;
490 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
491 eval { File::Path::mkpath($symlinkcpan); };
495 $CPAN::Frontend->mywarn(qq{
496 Working directory $symlinkcpan created.
500 unless (-d $dotcpan) {
502 Your configuration suggests "$dotcpan" as your
503 CPAN.pm working directory. I could not create this directory due
504 to this error: $firsterror\n};
506 As "$dotcpan" is a symlink to "$symlinkcpan",
507 I tried to create that, but I failed with this error: $seconderror
510 Please make sure the directory exists and is writable.
512 $CPAN::Frontend->mydie($diemess);
516 unless ($fh = FileHandle->new(">$lockfile")) {
517 if ($! =~ /Permission/) {
518 my $incc = $INC{'CPAN/Config.pm'};
519 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
520 $CPAN::Frontend->myprint(qq{
522 Your configuration suggests that CPAN.pm should use a working
524 $CPAN::Config->{cpan_home}
525 Unfortunately we could not create the lock file
527 due to permission problems.
529 Please make sure that the configuration variable
530 \$CPAN::Config->{cpan_home}
531 points to a directory where you can write a .lock file. You can set
532 this variable in either
539 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
541 $fh->print($$, "\n");
542 $self->{LOCK} = $lockfile;
546 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
551 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
552 print "Caught SIGINT\n";
556 # From: Larry Wall <larry@wall.org>
557 # Subject: Re: deprecating SIGDIE
558 # To: perl5-porters@perl.org
559 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
561 # The original intent of __DIE__ was only to allow you to substitute one
562 # kind of death for another on an application-wide basis without respect
563 # to whether you were in an eval or not. As a global backstop, it should
564 # not be used any more lightly (or any more heavily :-) than class
565 # UNIVERSAL. Any attempt to build a general exception model on it should
566 # be politely squashed. Any bug that causes every eval {} to have to be
567 # modified should be not so politely squashed.
569 # Those are my current opinions. It is also my optinion that polite
570 # arguments degenerate to personal arguments far too frequently, and that
571 # when they do, it's because both people wanted it to, or at least didn't
572 # sufficiently want it not to.
576 # global backstop to cleanup if we should really die
577 $SIG{__DIE__} = \&cleanup;
578 $self->debug("Signal handler set.") if $CPAN::DEBUG;
581 #-> sub CPAN::DESTROY ;
583 &cleanup; # need an eval?
587 sub cwd {Cwd::cwd();}
589 #-> sub CPAN::getcwd ;
590 sub getcwd {Cwd::getcwd();}
592 #-> sub CPAN::exists ;
594 my($mgr,$class,$id) = @_;
596 ### Carp::croak "exists called without class argument" unless $class;
598 exists $META->{readonly}{$class}{$id} or
599 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
602 #-> sub CPAN::delete ;
604 my($mgr,$class,$id) = @_;
605 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
606 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
609 #-> sub CPAN::has_usable
610 # has_inst is sometimes too optimistic, we should replace it with this
611 # has_usable whenever a case is given
613 my($self,$mod,$message) = @_;
614 return 1 if $HAS_USABLE->{$mod};
615 my $has_inst = $self->has_inst($mod,$message);
616 return unless $has_inst;
619 LWP => [ # we frequently had "Can't locate object
620 # method "new" via package "LWP::UserAgent" at
621 # (eval 69) line 2006
623 sub {require LWP::UserAgent},
624 sub {require HTTP::Request},
625 sub {require URI::URL},
628 sub {require Net::FTP},
629 sub {require Net::Config},
632 if ($usable->{$mod}) {
633 for my $c (0..$#{$usable->{$mod}}) {
634 my $code = $usable->{$mod}[$c];
635 my $ret = eval { &$code() };
637 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
642 return $HAS_USABLE->{$mod} = 1;
645 #-> sub CPAN::has_inst
647 my($self,$mod,$message) = @_;
648 Carp::croak("CPAN->has_inst() called without an argument")
650 if (defined $message && $message eq "no"
652 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
654 exists $CPAN::Config->{dontload_hash}{$mod}
656 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
662 $file =~ s|/|\\|g if $^O eq 'MSWin32';
665 # checking %INC is wrong, because $INC{LWP} may be true
666 # although $INC{"URI/URL.pm"} may have failed. But as
667 # I really want to say "bla loaded OK", I have to somehow
669 ### warn "$file in %INC"; #debug
671 } elsif (eval { require $file }) {
672 # eval is good: if we haven't yet read the database it's
673 # perfect and if we have installed the module in the meantime,
674 # it tries again. The second require is only a NOOP returning
675 # 1 if we had success, otherwise it's retrying
677 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
678 if ($mod eq "CPAN::WAIT") {
679 push @CPAN::Shell::ISA, CPAN::WAIT;
682 } elsif ($mod eq "Net::FTP") {
683 $CPAN::Frontend->mywarn(qq{
684 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
686 install Bundle::libnet
688 }) unless $Have_warned->{"Net::FTP"}++;
690 } elsif ($mod eq "MD5"){
691 $CPAN::Frontend->myprint(qq{
692 CPAN: MD5 security checks disabled because MD5 not installed.
693 Please consider installing the MD5 module.
698 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
703 #-> sub CPAN::instance ;
705 my($mgr,$class,$id) = @_;
708 # unsafe meta access, ok?
709 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
710 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
718 #-> sub CPAN::cleanup ;
720 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
721 local $SIG{__DIE__} = '';
726 0 && # disabled, try reload cpan with it
727 $] > 5.004_60 # thereabouts
732 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
734 $subroutine eq '(eval)';
737 return if $ineval && !$End;
738 return unless defined $META->{LOCK}; # unsafe meta access, ok
739 return unless -f $META->{LOCK}; # unsafe meta access, ok
740 unlink $META->{LOCK}; # unsafe meta access, ok
742 # Carp::cluck("DEBUGGING");
743 $CPAN::Frontend->mywarn("Lockfile removed.\n");
746 package CPAN::CacheMgr;
748 #-> sub CPAN::CacheMgr::as_string ;
750 eval { require Data::Dumper };
752 return shift->SUPER::as_string;
754 return Data::Dumper::Dumper(shift);
758 #-> sub CPAN::CacheMgr::cachesize ;
763 #-> sub CPAN::CacheMgr::tidyup ;
766 return unless -d $self->{ID};
767 while ($self->{DU} > $self->{'MAX'} ) {
768 my($toremove) = shift @{$self->{FIFO}};
769 $CPAN::Frontend->myprint(sprintf(
770 "Deleting from cache".
771 ": $toremove (%.1f>%.1f MB)\n",
772 $self->{DU}, $self->{'MAX'})
774 return if $CPAN::Signal;
775 $self->force_clean_cache($toremove);
776 return if $CPAN::Signal;
780 #-> sub CPAN::CacheMgr::dir ;
785 #-> sub CPAN::CacheMgr::entries ;
788 return unless defined $dir;
789 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
790 $dir ||= $self->{ID};
792 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
793 my($cwd) = CPAN->$getcwd();
794 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
795 my $dh = DirHandle->new(File::Spec->curdir)
796 or Carp::croak("Couldn't opendir $dir: $!");
799 next if $_ eq "." || $_ eq "..";
801 push @entries, MM->catfile($dir,$_);
803 push @entries, MM->catdir($dir,$_);
805 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
808 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
809 sort { -M $b <=> -M $a} @entries;
812 #-> sub CPAN::CacheMgr::disk_usage ;
815 return if exists $self->{SIZE}{$dir};
816 return if $CPAN::Signal;
820 $File::Find::prune++ if $CPAN::Signal;
822 if ($^O eq 'MacOS') {
824 my $cat = Mac::Files::FSpGetCatInfo($_);
825 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
832 return if $CPAN::Signal;
833 $self->{SIZE}{$dir} = $Du/1024/1024;
834 push @{$self->{FIFO}}, $dir;
835 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
836 $self->{DU} += $Du/1024/1024;
840 #-> sub CPAN::CacheMgr::force_clean_cache ;
841 sub force_clean_cache {
843 return unless -e $dir;
844 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
846 File::Path::rmtree($dir);
847 $self->{DU} -= $self->{SIZE}{$dir};
848 delete $self->{SIZE}{$dir};
851 #-> sub CPAN::CacheMgr::new ;
858 ID => $CPAN::Config->{'build_dir'},
859 MAX => $CPAN::Config->{'build_cache'},
860 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
863 File::Path::mkpath($self->{ID});
864 my $dh = DirHandle->new($self->{ID});
868 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
870 CPAN->debug($debug) if $CPAN::DEBUG;
874 #-> sub CPAN::CacheMgr::scan_cache ;
877 return if $self->{SCAN} eq 'never';
878 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
879 unless $self->{SCAN} eq 'atstart';
880 $CPAN::Frontend->myprint(
881 sprintf("Scanning cache %s for sizes\n",
884 for $e ($self->entries($self->{ID})) {
885 next if $e eq ".." || $e eq ".";
886 $self->disk_usage($e);
887 return if $CPAN::Signal;
894 #-> sub CPAN::Debug::debug ;
897 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
898 # Complete, caller(1)
900 ($caller) = caller(0);
902 $arg = "" unless defined $arg;
903 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
904 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
905 if ($arg and ref $arg) {
906 eval { require Data::Dumper };
908 $CPAN::Frontend->myprint($arg->as_string);
910 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
913 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
918 package CPAN::Config;
920 #-> sub CPAN::Config::edit ;
921 # returns true on successful action
923 my($self,@args) = @_;
925 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
926 my($o,$str,$func,$args,$key_exists);
932 CPAN->debug("o[$o]") if $CPAN::DEBUG;
936 CPAN->debug("func[$func]") if $CPAN::DEBUG;
938 # Let's avoid eval, it's easier to comprehend without.
939 if ($func eq "push") {
940 push @{$CPAN::Config->{$o}}, @args;
942 } elsif ($func eq "pop") {
943 pop @{$CPAN::Config->{$o}};
945 } elsif ($func eq "shift") {
946 shift @{$CPAN::Config->{$o}};
948 } elsif ($func eq "unshift") {
949 unshift @{$CPAN::Config->{$o}}, @args;
951 } elsif ($func eq "splice") {
952 splice @{$CPAN::Config->{$o}}, @args;
955 $CPAN::Config->{$o} = [@args];
958 $self->prettyprint($o);
960 if ($o eq "urllist" && $changed) {
961 # reset the cached values
962 undef $CPAN::FTP::Thesite;
963 undef $CPAN::FTP::Themethod;
967 $CPAN::Config->{$o} = $args[0] if defined $args[0];
968 $self->prettyprint($o);
975 my $v = $CPAN::Config->{$k};
977 my(@report) = ref $v eq "ARRAY" ?
979 map { sprintf(" %-18s => %s\n",
981 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
983 $CPAN::Frontend->myprint(
990 map {"\t$_\n"} @report
993 } elsif (defined $v) {
994 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
996 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1000 #-> sub CPAN::Config::commit ;
1002 my($self,$configpm) = @_;
1003 unless (defined $configpm){
1004 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1005 $configpm ||= $INC{"CPAN/Config.pm"};
1006 $configpm || Carp::confess(q{
1007 CPAN::Config::commit called without an argument.
1008 Please specify a filename where to save the configuration or try
1009 "o conf init" to have an interactive course through configing.
1014 $mode = (stat $configpm)[2];
1015 if ($mode && ! -w _) {
1016 Carp::confess("$configpm is not writable");
1021 $msg = <<EOF unless $configpm =~ /MyConfig/;
1023 # This is CPAN.pm's systemwide configuration file. This file provides
1024 # defaults for users, and the values can be changed in a per-user
1025 # configuration file. The user-config file is being looked for as
1026 # ~/.cpan/CPAN/MyConfig.pm.
1030 my($fh) = FileHandle->new;
1031 rename $configpm, "$configpm~" if -f $configpm;
1032 open $fh, ">$configpm" or
1033 $CPAN::Frontend->mywarn("Couldn't open >$configpm: $!");
1034 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1035 foreach (sort keys %$CPAN::Config) {
1038 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1043 $fh->print("};\n1;\n__END__\n");
1046 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1047 #chmod $mode, $configpm;
1048 ###why was that so? $self->defaults;
1049 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1053 *default = \&defaults;
1054 #-> sub CPAN::Config::defaults ;
1064 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1073 #-> sub CPAN::Config::load ;
1078 eval {require CPAN::Config;}; # We eval because of some
1079 # MakeMaker problems
1080 unless ($dot_cpan++){
1081 unshift @INC, MM->catdir($ENV{HOME},".cpan");
1082 eval {require CPAN::MyConfig;}; # where you can override
1083 # system wide settings
1086 return unless @miss = $self->missing_config_data;
1088 require CPAN::FirstTime;
1089 my($configpm,$fh,$redo,$theycalled);
1091 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1092 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1093 $configpm = $INC{"CPAN/Config.pm"};
1095 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1096 $configpm = $INC{"CPAN/MyConfig.pm"};
1099 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1100 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1101 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1102 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1103 if (-w $configpmtest) {
1104 $configpm = $configpmtest;
1105 } elsif (-w $configpmdir) {
1106 #_#_# following code dumped core on me with 5.003_11, a.k.
1107 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1108 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1109 my $fh = FileHandle->new;
1110 if ($fh->open(">$configpmtest")) {
1112 $configpm = $configpmtest;
1114 # Should never happen
1115 Carp::confess("Cannot open >$configpmtest");
1119 unless ($configpm) {
1120 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1121 File::Path::mkpath($configpmdir);
1122 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1123 if (-w $configpmtest) {
1124 $configpm = $configpmtest;
1125 } elsif (-w $configpmdir) {
1126 #_#_# following code dumped core on me with 5.003_11, a.k.
1127 my $fh = FileHandle->new;
1128 if ($fh->open(">$configpmtest")) {
1130 $configpm = $configpmtest;
1132 # Should never happen
1133 Carp::confess("Cannot open >$configpmtest");
1136 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1137 qq{create a configuration file.});
1142 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1143 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1147 $CPAN::Frontend->myprint(qq{
1148 $configpm initialized.
1151 CPAN::FirstTime::init($configpm);
1154 #-> sub CPAN::Config::missing_config_data ;
1155 sub missing_config_data {
1158 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1159 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1161 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1162 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1163 "prerequisites_policy",
1166 push @miss, $_ unless defined $CPAN::Config->{$_};
1171 #-> sub CPAN::Config::unload ;
1173 delete $INC{'CPAN/MyConfig.pm'};
1174 delete $INC{'CPAN/Config.pm'};
1177 #-> sub CPAN::Config::help ;
1179 $CPAN::Frontend->myprint(q[
1181 defaults reload default config values from disk
1182 commit commit session changes to disk
1183 init go through a dialog to set all parameters
1185 You may edit key values in the follow fashion (the "o" is a literal
1188 o conf build_cache 15
1190 o conf build_dir "/foo/bar"
1192 o conf urllist shift
1194 o conf urllist unshift ftp://ftp.foo.bar/
1197 undef; #don't reprint CPAN::Config
1200 #-> sub CPAN::Config::cpl ;
1202 my($word,$line,$pos) = @_;
1204 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1205 my(@words) = split " ", substr($line,0,$pos+1);
1210 $words[2] =~ /list$/ && @words == 3
1212 $words[2] =~ /list$/ && @words == 4 && length($word)
1215 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1216 } elsif (@words >= 4) {
1219 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1220 return grep /^\Q$word\E/, @o_conf;
1223 package CPAN::Shell;
1225 #-> sub CPAN::Shell::h ;
1227 my($class,$about) = @_;
1228 if (defined $about) {
1229 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1231 $CPAN::Frontend->myprint(q{
1234 b string display bundles
1235 d or info distributions
1236 m /regex/ about modules
1237 i or anything of above
1238 r none reinstall recommendations
1239 u uninstalled distributions
1241 Download, Test, Make, Install...
1243 make make (implies get)
1244 test modules, make test (implies make)
1245 install dists, bundles make install (implies test)
1247 look open subshell in these dists' directories
1248 readme display these dists' README files
1251 h,? display this menu ! perl-code eval a perl command
1252 o conf [opt] set and query options q quit the cpan shell
1253 reload cpan load CPAN.pm again reload index load newer indices
1254 autobundle Snapshot force cmd unconditionally do cmd});
1260 #-> sub CPAN::Shell::a ;
1262 my($self,@arg) = @_;
1263 # authors are always UPPERCASE
1267 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1270 #-> sub CPAN::Shell::local_bundles ;
1273 my($self,@which) = @_;
1274 my($incdir,$bdir,$dh);
1275 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1276 $bdir = MM->catdir($incdir,"Bundle");
1277 if ($dh = DirHandle->new($bdir)) { # may fail
1279 for $entry ($dh->read) {
1280 next if -d MM->catdir($bdir,$entry);
1281 next unless $entry =~ s/\.pm(?!\n)\Z//;
1282 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1288 #-> sub CPAN::Shell::b ;
1290 my($self,@which) = @_;
1291 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1292 $self->local_bundles;
1293 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1296 #-> sub CPAN::Shell::d ;
1297 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1299 #-> sub CPAN::Shell::m ;
1300 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1301 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1304 #-> sub CPAN::Shell::i ;
1309 @type = qw/Author Bundle Distribution Module/;
1310 @args = '/./' unless @args;
1313 push @result, $self->expand($type,@args);
1315 my $result = @result == 1 ?
1316 $result[0]->as_string :
1317 join "", map {$_->as_glimpse} @result;
1318 $result ||= "No objects found of any type for argument @args\n";
1319 $CPAN::Frontend->myprint($result);
1322 #-> sub CPAN::Shell::o ;
1324 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1325 # should have been called set and 'o debug' maybe 'set debug'
1327 my($self,$o_type,@o_what) = @_;
1329 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1330 if ($o_type eq 'conf') {
1331 shift @o_what if @o_what && $o_what[0] eq 'help';
1332 if (!@o_what) { # print all things, "o conf"
1334 $CPAN::Frontend->myprint("CPAN::Config options");
1335 if (exists $INC{'CPAN/Config.pm'}) {
1336 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1338 if (exists $INC{'CPAN/MyConfig.pm'}) {
1339 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1341 $CPAN::Frontend->myprint(":\n");
1342 for $k (sort keys %CPAN::Config::can) {
1343 $v = $CPAN::Config::can{$k};
1344 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1346 $CPAN::Frontend->myprint("\n");
1347 for $k (sort keys %$CPAN::Config) {
1348 CPAN::Config->prettyprint($k);
1350 $CPAN::Frontend->myprint("\n");
1351 } elsif (!CPAN::Config->edit(@o_what)) {
1352 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1353 qq{edit options\n\n});
1355 } elsif ($o_type eq 'debug') {
1357 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1360 my($what) = shift @o_what;
1361 if ( exists $CPAN::DEBUG{$what} ) {
1362 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1363 } elsif ($what =~ /^\d/) {
1364 $CPAN::DEBUG = $what;
1365 } elsif (lc $what eq 'all') {
1367 for (values %CPAN::DEBUG) {
1370 $CPAN::DEBUG = $max;
1373 for (keys %CPAN::DEBUG) {
1374 next unless lc($_) eq lc($what);
1375 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1378 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1383 my $raw = "Valid options for debug are ".
1384 join(", ",sort(keys %CPAN::DEBUG), 'all').
1385 qq{ or a number. Completion works on the options. }.
1386 qq{Case is ignored.};
1388 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1389 $CPAN::Frontend->myprint("\n\n");
1392 $CPAN::Frontend->myprint("Options set for debugging:\n");
1394 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1395 $v = $CPAN::DEBUG{$k};
1396 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1397 if $v & $CPAN::DEBUG;
1400 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1403 $CPAN::Frontend->myprint(qq{
1405 conf set or get configuration variables
1406 debug set or get debugging options
1411 sub paintdots_onreload {
1414 if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1418 # $CPAN::Frontend->myprint(".($subr)");
1419 $CPAN::Frontend->myprint(".");
1426 #-> sub CPAN::Shell::reload ;
1428 my($self,$command,@arg) = @_;
1430 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1431 if ($command =~ /cpan/i) {
1432 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1433 my $fh = FileHandle->new($INC{'CPAN.pm'});
1436 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1439 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1440 } elsif ($command =~ /index/) {
1441 CPAN::Index->force_reload;
1443 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1444 index re-reads the index files\n});
1448 #-> sub CPAN::Shell::_binary_extensions ;
1449 sub _binary_extensions {
1450 my($self) = shift @_;
1451 my(@result,$module,%seen,%need,$headerdone);
1452 for $module ($self->expand('Module','/./')) {
1453 my $file = $module->cpan_file;
1454 next if $file eq "N/A";
1455 next if $file =~ /^Contact Author/;
1456 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1457 next if $dist->isa_perl;
1458 next unless $module->xs_file;
1460 $CPAN::Frontend->myprint(".");
1461 push @result, $module;
1463 # print join " | ", @result;
1464 $CPAN::Frontend->myprint("\n");
1468 #-> sub CPAN::Shell::recompile ;
1470 my($self) = shift @_;
1471 my($module,@module,$cpan_file,%dist);
1472 @module = $self->_binary_extensions();
1473 for $module (@module){ # we force now and compile later, so we
1475 $cpan_file = $module->cpan_file;
1476 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1478 $dist{$cpan_file}++;
1480 for $cpan_file (sort keys %dist) {
1481 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1482 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1484 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1485 # stop a package from recompiling,
1486 # e.g. IO-1.12 when we have perl5.003_10
1490 #-> sub CPAN::Shell::_u_r_common ;
1492 my($self) = shift @_;
1493 my($what) = shift @_;
1494 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1495 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1496 $what && $what =~ /^[aru]$/;
1498 @args = '/./' unless @args;
1499 my(@result,$module,%seen,%need,$headerdone,
1500 $version_undefs,$version_zeroes);
1501 $version_undefs = $version_zeroes = 0;
1502 my $sprintf = "%-25s %9s %9s %s\n";
1503 my @expand = $self->expand('Module',@args);
1504 my $expand = scalar @expand;
1505 if (0) { # Looks like noise to me, was very useful for debugging
1506 # for metadata cache
1507 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1509 for $module (@expand) {
1510 my $file = $module->cpan_file;
1511 next unless defined $file; # ??
1512 my($latest) = $module->cpan_version;
1513 my($inst_file) = $module->inst_file;
1515 return if $CPAN::Signal;
1518 $have = $module->inst_version;
1519 } elsif ($what eq "r") {
1520 $have = $module->inst_version;
1522 if ($have eq "undef"){
1524 } elsif ($have == 0){
1527 next unless CPAN::Version->vgt($latest, $have);
1528 # to be pedantic we should probably say:
1529 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1530 # to catch the case where CPAN has a version 0 and we have a version undef
1531 } elsif ($what eq "u") {
1537 } elsif ($what eq "r") {
1539 } elsif ($what eq "u") {
1543 return if $CPAN::Signal; # this is sometimes lengthy
1546 push @result, sprintf "%s %s\n", $module->id, $have;
1547 } elsif ($what eq "r") {
1548 push @result, $module->id;
1549 next if $seen{$file}++;
1550 } elsif ($what eq "u") {
1551 push @result, $module->id;
1552 next if $seen{$file}++;
1553 next if $file =~ /^Contact/;
1555 unless ($headerdone++){
1556 $CPAN::Frontend->myprint("\n");
1557 $CPAN::Frontend->myprint(sprintf(
1559 "Package namespace",
1565 $CPAN::Frontend->myprint(sprintf $sprintf,
1570 $need{$module->id}++;
1574 $CPAN::Frontend->myprint("No modules found for @args\n");
1575 } elsif ($what eq "r") {
1576 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1580 if ($version_zeroes) {
1581 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1582 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1583 qq{a version number of 0\n});
1585 if ($version_undefs) {
1586 my $s_has = $version_undefs > 1 ? "s have" : " has";
1587 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1588 qq{parseable version number\n});
1594 #-> sub CPAN::Shell::r ;
1596 shift->_u_r_common("r",@_);
1599 #-> sub CPAN::Shell::u ;
1601 shift->_u_r_common("u",@_);
1604 #-> sub CPAN::Shell::autobundle ;
1607 CPAN::Config->load unless $CPAN::Config_loaded++;
1608 my(@bundle) = $self->_u_r_common("a",@_);
1609 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1610 File::Path::mkpath($todir);
1611 unless (-d $todir) {
1612 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1615 my($y,$m,$d) = (localtime)[5,4,3];
1619 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1620 my($to) = MM->catfile($todir,"$me.pm");
1622 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1623 $to = MM->catfile($todir,"$me.pm");
1625 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1627 "package Bundle::$me;\n\n",
1628 "\$VERSION = '0.01';\n\n",
1632 "Bundle::$me - Snapshot of installation on ",
1633 $Config::Config{'myhostname'},
1636 "\n\n=head1 SYNOPSIS\n\n",
1637 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1638 "=head1 CONTENTS\n\n",
1639 join("\n", @bundle),
1640 "\n\n=head1 CONFIGURATION\n\n",
1642 "\n\n=head1 AUTHOR\n\n",
1643 "This Bundle has been generated automatically ",
1644 "by the autobundle routine in CPAN.pm.\n",
1647 $CPAN::Frontend->myprint("\nWrote bundle file
1651 #-> sub CPAN::Shell::expandany ;
1654 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1655 if ($s =~ m|/|) { # looks like a file
1656 return $CPAN::META->instance('CPAN::Distribution',$s);
1657 # Distributions spring into existence, not expand
1658 } elsif ($s =~ m|^Bundle::|) {
1659 $self->local_bundles; # scanning so late for bundles seems
1660 # both attractive and crumpy: always
1661 # current state but easy to forget
1663 return $self->expand('Bundle',$s);
1665 return $self->expand('Module',$s)
1666 if $CPAN::META->exists('CPAN::Module',$s);
1671 #-> sub CPAN::Shell::expand ;
1674 my($type,@args) = @_;
1677 my($regex,$command);
1678 if ($arg =~ m|^/(.*)/$|) {
1680 } elsif ($arg =~ m/^=/) {
1681 $command = substr($arg,1);
1683 my $class = "CPAN::$type";
1685 if (defined $regex) {
1689 $CPAN::META->all_objects($class)
1692 # BUG, we got an empty object somewhere
1693 CPAN->debug(sprintf(
1694 "Empty id on obj[%s]%%[%s]",
1701 if $obj->id =~ /$regex/i
1705 $] < 5.00303 ### provide sort of
1706 ### compatibility with 5.003
1711 $obj->name =~ /$regex/i
1714 } elsif ($command) {
1715 die "leading equal sign in command disabled, ".
1716 "please edit CPAN.pm to enable eval() or ".
1717 "do not use = on argument list";
1721 $CPAN::META->all_objects($class)
1723 push @m, $self if eval $command;
1727 if ( $type eq 'Bundle' ) {
1728 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1730 if ($CPAN::META->exists($class,$xarg)) {
1731 $obj = $CPAN::META->instance($class,$xarg);
1732 } elsif ($CPAN::META->exists($class,$arg)) {
1733 $obj = $CPAN::META->instance($class,$arg);
1740 return wantarray ? @m : $m[0];
1743 #-> sub CPAN::Shell::format_result ;
1746 my($type,@args) = @_;
1747 @args = '/./' unless @args;
1748 my(@result) = $self->expand($type,@args);
1749 my $result = @result == 1 ?
1750 $result[0]->as_string :
1751 join "", map {$_->as_glimpse} @result;
1752 $result ||= "No objects of type $type found for argument @args\n";
1756 # The only reason for this method is currently to have a reliable
1757 # debugging utility that reveals which output is going through which
1758 # channel. No, I don't like the colors ;-)
1759 sub print_ornamented {
1760 my($self,$what,$ornament) = @_;
1762 my $ornamenting = 0; # turn the colors on
1765 unless (defined &color) {
1766 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1767 import Term::ANSIColor "color";
1769 *color = sub { return "" };
1773 for $line (split /\n/, $what) {
1774 $longest = length($line) if length($line) > $longest;
1776 my $sprintf = "%-" . $longest . "s";
1778 $what =~ s/(.*\n?)//m;
1781 my($nl) = chomp $line ? "\n" : "";
1782 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1783 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1791 my($self,$what) = @_;
1792 $self->print_ornamented($what, 'bold blue on_yellow');
1796 my($self,$what) = @_;
1797 $self->myprint($what);
1802 my($self,$what) = @_;
1803 $self->print_ornamented($what, 'bold red on_yellow');
1807 my($self,$what) = @_;
1808 $self->print_ornamented($what, 'bold red on_white');
1809 Carp::confess "died";
1813 my($self,$what) = @_;
1814 $self->print_ornamented($what, 'bold red on_white');
1819 return if -t STDOUT;
1820 my $odef = select STDERR;
1827 #-> sub CPAN::Shell::rematein ;
1828 # RE-adme||MA-ke||TE-st||IN-stall
1831 my($meth,@some) = @_;
1833 if ($meth eq 'force') {
1835 $meth = shift @some;
1838 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1840 # Here is the place to set "test_count" on all involved parties to
1841 # 0. We then can pass this counter on to the involved
1842 # distributions and those can refuse to test if test_count > X. In
1843 # the first stab at it we could use a 1 for "X".
1845 # But when do I reset the distributions to start with 0 again?
1846 # Jost suggested to have a random or cycling interaction ID that
1847 # we pass through. But the ID is something that is just left lying
1848 # around in addition to the counter, so I'd prefer to set the
1849 # counter to 0 now, and repeat at the end of the loop. But what
1850 # about dependencies? They appear later and are not reset, they
1851 # enter the queue but not its copy. How do they get a sensible
1854 # construct the queue
1856 foreach $s (@some) {
1859 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1861 } elsif ($s =~ m|^/|) { # looks like a regexp
1862 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1867 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1868 $obj = CPAN::Shell->expandany($s);
1871 $obj->color_cmd_tmps(0,1);
1872 CPAN::Queue->new($s);
1874 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1875 $obj = $CPAN::META->instance('CPAN::Author',$s);
1876 $CPAN::Frontend->myprint(
1878 "Don't be silly, you can't $meth ",
1885 ->myprint(qq{Warning: Cannot $meth $s, }.
1886 qq{don\'t know what it is.
1891 to find objects with matching identifiers.
1897 # queuerunner (please be warned: when I started to change the
1898 # queue to hold objects instead of names, I made one or two
1899 # mistakes and never found which. I reverted back instead)
1900 while ($s = CPAN::Queue->first) {
1903 $obj = $s; # I do not believe, we would survive if this happened
1905 $obj = CPAN::Shell->expandany($s);
1909 ($] < 5.00303 || $obj->can($pragma))){
1910 ### compatibility with 5.003
1911 $obj->$pragma($meth); # the pragma "force" in
1912 # "CPAN::Distribution" must know
1913 # what we are intending
1915 if ($]>=5.00303 && $obj->can('called_for')) {
1916 $obj->called_for($s);
1919 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1925 CPAN::Queue->delete($s);
1927 CPAN->debug("failed");
1931 CPAN::Queue->delete_first($s);
1933 for my $obj (@qcopy) {
1934 $obj->color_cmd_tmps(0,0);
1938 #-> sub CPAN::Shell::dump ;
1939 sub dump { shift->rematein('dump',@_); }
1940 #-> sub CPAN::Shell::force ;
1941 sub force { shift->rematein('force',@_); }
1942 #-> sub CPAN::Shell::get ;
1943 sub get { shift->rematein('get',@_); }
1944 #-> sub CPAN::Shell::readme ;
1945 sub readme { shift->rematein('readme',@_); }
1946 #-> sub CPAN::Shell::make ;
1947 sub make { shift->rematein('make',@_); }
1948 #-> sub CPAN::Shell::test ;
1949 sub test { shift->rematein('test',@_); }
1950 #-> sub CPAN::Shell::install ;
1951 sub install { shift->rematein('install',@_); }
1952 #-> sub CPAN::Shell::clean ;
1953 sub clean { shift->rematein('clean',@_); }
1954 #-> sub CPAN::Shell::look ;
1955 sub look { shift->rematein('look',@_); }
1956 #-> sub CPAN::Shell::cvs_import ;
1957 sub cvs_import { shift->rematein('cvs_import',@_); }
1961 #-> sub CPAN::FTP::ftp_get ;
1963 my($class,$host,$dir,$file,$target) = @_;
1965 qq[Going to fetch file [$file] from dir [$dir]
1966 on host [$host] as local [$target]\n]
1968 my $ftp = Net::FTP->new($host);
1969 return 0 unless defined $ftp;
1970 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1971 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
1972 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1973 warn "Couldn't login on $host";
1976 unless ( $ftp->cwd($dir) ){
1977 warn "Couldn't cwd $dir";
1981 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1982 unless ( $ftp->get($file,$target) ){
1983 warn "Couldn't fetch $file from $host\n";
1986 $ftp->quit; # it's ok if this fails
1990 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1992 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
1993 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
1995 # > *** 1562,1567 ****
1996 # > --- 1562,1580 ----
1997 # > return 1 if substr($url,0,4) eq "file";
1998 # > return 1 unless $url =~ m|://([^/]+)|;
2000 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2002 # > + $proxy =~ m|://([^/:]+)|;
2004 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2005 # > + if ($noproxy) {
2006 # > + if ($host !~ /$noproxy$/) {
2007 # > + $host = $proxy;
2010 # > + $host = $proxy;
2013 # > require Net::Ping;
2014 # > return 1 unless $Net::Ping::VERSION >= 2;
2018 #-> sub CPAN::FTP::localize ;
2020 my($self,$file,$aslocal,$force) = @_;
2022 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2023 unless defined $aslocal;
2024 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2027 if ($^O eq 'MacOS') {
2028 # Comment by AK on 2000-09-03: Uniq short filenames would be
2029 # available in CHECKSUMS file
2030 my($name, $path) = File::Basename::fileparse($aslocal, '');
2031 if (length($name) > 31) {
2042 my $size = 31 - length($suf);
2043 while (length($name) > $size) {
2047 $aslocal = File::Spec->catfile($path, $name);
2051 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2054 rename $aslocal, "$aslocal.bak";
2058 my($aslocal_dir) = File::Basename::dirname($aslocal);
2059 File::Path::mkpath($aslocal_dir);
2060 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2061 qq{directory "$aslocal_dir".
2062 I\'ll continue, but if you encounter problems, they may be due
2063 to insufficient permissions.\n}) unless -w $aslocal_dir;
2065 # Inheritance is not easier to manage than a few if/else branches
2066 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2068 $Ua = LWP::UserAgent->new;
2070 $Ua->proxy('ftp', $var)
2071 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2072 $Ua->proxy('http', $var)
2073 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2075 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2078 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2079 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2080 if $CPAN::Config->{http_proxy};
2081 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2083 # Try the list of urls for each single object. We keep a record
2084 # where we did get a file from
2085 my(@reordered,$last);
2086 $CPAN::Config->{urllist} ||= [];
2087 $last = $#{$CPAN::Config->{urllist}};
2088 if ($force & 2) { # local cpans probably out of date, don't reorder
2089 @reordered = (0..$last);
2093 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2095 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2106 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2108 @levels = qw/easy hard hardest/;
2110 @levels = qw/easy/ if $^O eq 'MacOS';
2112 for $levelno (0..$#levels) {
2113 my $level = $levels[$levelno];
2114 my $method = "host$level";
2115 my @host_seq = $level eq "easy" ?
2116 @reordered : 0..$last; # reordered has CDROM up front
2117 @host_seq = (0) unless @host_seq;
2118 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2120 $Themethod = $level;
2122 # utime $now, $now, $aslocal; # too bad, if we do that, we
2123 # might alter a local mirror
2124 $self->debug("level[$level]") if $CPAN::DEBUG;
2128 last if $CPAN::Signal; # need to cleanup
2131 unless ($CPAN::Signal) {
2134 qq{Please check, if the URLs I found in your configuration file \(}.
2135 join(", ", @{$CPAN::Config->{urllist}}).
2136 qq{\) are valid. The urllist can be edited.},
2137 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2138 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2140 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
2143 rename "$aslocal.bak", $aslocal;
2144 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2145 $self->ls($aslocal));
2152 my($self,$host_seq,$file,$aslocal) = @_;
2154 HOSTEASY: for $i (@$host_seq) {
2155 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2156 $url .= "/" unless substr($url,-1) eq "/";
2158 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2159 if ($url =~ /^file:/) {
2161 if ($CPAN::META->has_inst('URI::URL')) {
2162 my $u = URI::URL->new($url);
2164 } else { # works only on Unix, is poorly constructed, but
2165 # hopefully better than nothing.
2166 # RFC 1738 says fileurl BNF is
2167 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2168 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2170 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2171 $l =~ s|^file:||; # assume they
2174 $l =~ s|^/||s unless -f $l; # e.g. /P:
2176 if ( -f $l && -r _) {
2180 # Maybe mirror has compressed it?
2182 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2183 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2190 if ($CPAN::META->has_usable('LWP')) {
2191 $CPAN::Frontend->myprint("Fetching with LWP:
2195 require LWP::UserAgent;
2196 $Ua = LWP::UserAgent->new;
2198 my $res = $Ua->mirror($url, $aslocal);
2199 if ($res->is_success) {
2202 utime $now, $now, $aslocal; # download time is more
2203 # important than upload time
2205 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2206 my $gzurl = "$url.gz";
2207 $CPAN::Frontend->myprint("Fetching with LWP:
2210 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2211 if ($res->is_success &&
2212 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2218 # Alan Burlison informed me that in firewall environments
2219 # Net::FTP can still succeed where LWP fails. So we do not
2220 # skip Net::FTP anymore when LWP is available.
2223 $self->debug("LWP not installed") if $CPAN::DEBUG;
2225 return if $CPAN::Signal;
2226 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2227 # that's the nice and easy way thanks to Graham
2228 my($host,$dir,$getfile) = ($1,$2,$3);
2229 if ($CPAN::META->has_usable('Net::FTP')) {
2231 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2234 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2235 "aslocal[$aslocal]") if $CPAN::DEBUG;
2236 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2240 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2241 my $gz = "$aslocal.gz";
2242 $CPAN::Frontend->myprint("Fetching with Net::FTP
2245 if (CPAN::FTP->ftp_get($host,
2249 CPAN::Tarzip->gunzip($gz,$aslocal)
2258 return if $CPAN::Signal;
2263 my($self,$host_seq,$file,$aslocal) = @_;
2265 # Came back if Net::FTP couldn't establish connection (or
2266 # failed otherwise) Maybe they are behind a firewall, but they
2267 # gave us a socksified (or other) ftp program...
2270 my($devnull) = $CPAN::Config->{devnull} || "";
2272 my($aslocal_dir) = File::Basename::dirname($aslocal);
2273 File::Path::mkpath($aslocal_dir);
2274 HOSTHARD: for $i (@$host_seq) {
2275 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2276 $url .= "/" unless substr($url,-1) eq "/";
2278 my($proto,$host,$dir,$getfile);
2280 # Courtesy Mark Conty mark_conty@cargill.com change from
2281 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2283 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2284 # proto not yet used
2285 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2287 next HOSTHARD; # who said, we could ftp anything except ftp?
2289 next HOSTHARD if $proto eq "file"; # file URLs would have had
2290 # success above. Likely a bogus URL
2292 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2294 for $f ('lynx','ncftpget','ncftp') {
2295 next unless exists $CPAN::Config->{$f};
2296 $funkyftp = $CPAN::Config->{$f};
2297 next unless defined $funkyftp;
2298 next if $funkyftp =~ /^\s*$/;
2299 my($asl_ungz, $asl_gz);
2300 ($asl_ungz = $aslocal) =~ s/\.gz//;
2301 $asl_gz = "$asl_ungz.gz";
2302 my($src_switch) = "";
2304 $src_switch = " -source";
2305 } elsif ($f eq "ncftp"){
2306 $src_switch = " -c";
2309 my($stdout_redir) = " > $asl_ungz";
2310 if ($f eq "ncftpget"){
2311 $chdir = "cd $aslocal_dir && ";
2314 $CPAN::Frontend->myprint(
2316 Trying with "$funkyftp$src_switch" to get
2320 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2321 $self->debug("system[$system]") if $CPAN::DEBUG;
2323 if (($wstatus = system($system)) == 0
2326 -s $asl_ungz # lynx returns 0 when it fails somewhere
2332 } elsif ($asl_ungz ne $aslocal) {
2333 # test gzip integrity
2334 if (CPAN::Tarzip->gtest($asl_ungz)) {
2335 # e.g. foo.tar is gzipped --> foo.tar.gz
2336 rename $asl_ungz, $aslocal;
2338 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2343 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2345 -f $asl_ungz && -s _ == 0;
2346 my $gz = "$aslocal.gz";
2347 my $gzurl = "$url.gz";
2348 $CPAN::Frontend->myprint(
2350 Trying with "$funkyftp$src_switch" to get
2353 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2354 $self->debug("system[$system]") if $CPAN::DEBUG;
2356 if (($wstatus = system($system)) == 0
2360 # test gzip integrity
2361 if (CPAN::Tarzip->gtest($asl_gz)) {
2362 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2364 # somebody uncompressed file for us?
2365 rename $asl_ungz, $aslocal;
2370 unlink $asl_gz if -f $asl_gz;
2373 my $estatus = $wstatus >> 8;
2374 my $size = -f $aslocal ?
2375 ", left\n$aslocal with size ".-s _ :
2376 "\nWarning: expected file [$aslocal] doesn't exist";
2377 $CPAN::Frontend->myprint(qq{
2378 System call "$system"
2379 returned status $estatus (wstat $wstatus)$size
2382 return if $CPAN::Signal;
2383 } # lynx,ncftpget,ncftp
2388 my($self,$host_seq,$file,$aslocal) = @_;
2391 my($aslocal_dir) = File::Basename::dirname($aslocal);
2392 File::Path::mkpath($aslocal_dir);
2393 HOSTHARDEST: for $i (@$host_seq) {
2394 unless (length $CPAN::Config->{'ftp'}) {
2395 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2398 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2399 $url .= "/" unless substr($url,-1) eq "/";
2401 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2402 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2405 my($host,$dir,$getfile) = ($1,$2,$3);
2407 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2408 $ctime,$blksize,$blocks) = stat($aslocal);
2409 $timestamp = $mtime ||= 0;
2410 my($netrc) = CPAN::FTP::netrc->new;
2411 my($netrcfile) = $netrc->netrc;
2412 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2413 my $targetfile = File::Basename::basename($aslocal);
2419 map("cd $_", split "/", $dir), # RFC 1738
2421 "get $getfile $targetfile",
2425 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2426 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2427 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2429 $netrc->contains($host))) if $CPAN::DEBUG;
2430 if ($netrc->protected) {
2431 $CPAN::Frontend->myprint(qq{
2432 Trying with external ftp to get
2434 As this requires some features that are not thoroughly tested, we\'re
2435 not sure, that we get it right....
2439 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2441 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2442 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2444 if ($mtime > $timestamp) {
2445 $CPAN::Frontend->myprint("GOT $aslocal\n");
2449 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2451 return if $CPAN::Signal;
2453 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2454 qq{correctly protected.\n});
2457 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2458 nor does it have a default entry\n");
2461 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2462 # then and login manually to host, using e-mail as
2464 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2468 "user anonymous $Config::Config{'cf_email'}"
2470 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2471 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2472 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2474 if ($mtime > $timestamp) {
2475 $CPAN::Frontend->myprint("GOT $aslocal\n");
2479 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2481 return if $CPAN::Signal;
2482 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2488 my($self,$command,@dialog) = @_;
2489 my $fh = FileHandle->new;
2490 $fh->open("|$command") or die "Couldn't open ftp: $!";
2491 foreach (@dialog) { $fh->print("$_\n") }
2492 $fh->close; # Wait for process to complete
2494 my $estatus = $wstatus >> 8;
2495 $CPAN::Frontend->myprint(qq{
2496 Subprocess "|$command"
2497 returned status $estatus (wstat $wstatus)
2501 # find2perl needs modularization, too, all the following is stolen
2505 my($self,$name) = @_;
2506 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2507 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2509 my($perms,%user,%group);
2513 $blocks = int(($blocks + 1) / 2);
2516 $blocks = int(($sizemm + 1023) / 1024);
2519 if (-f _) { $perms = '-'; }
2520 elsif (-d _) { $perms = 'd'; }
2521 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2522 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2523 elsif (-p _) { $perms = 'p'; }
2524 elsif (-S _) { $perms = 's'; }
2525 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2527 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2528 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2529 my $tmpmode = $mode;
2530 my $tmp = $rwx[$tmpmode & 7];
2532 $tmp = $rwx[$tmpmode & 7] . $tmp;
2534 $tmp = $rwx[$tmpmode & 7] . $tmp;
2535 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2536 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2537 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2540 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2541 my $group = $group{$gid} || $gid;
2543 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2545 my($moname) = $moname[$mon];
2546 if (-M _ > 365.25 / 2) {
2547 $timeyear = $year + 1900;
2550 $timeyear = sprintf("%02d:%02d", $hour, $min);
2553 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2567 package CPAN::FTP::netrc;
2571 my $file = MM->catfile($ENV{HOME},".netrc");
2573 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2574 $atime,$mtime,$ctime,$blksize,$blocks)
2579 my($fh,@machines,$hasdefault);
2581 $fh = FileHandle->new or die "Could not create a filehandle";
2583 if($fh->open($file)){
2584 $protected = ($mode & 077) == 0;
2586 NETRC: while (<$fh>) {
2587 my(@tokens) = split " ", $_;
2588 TOKEN: while (@tokens) {
2589 my($t) = shift @tokens;
2590 if ($t eq "default"){
2594 last TOKEN if $t eq "macdef";
2595 if ($t eq "machine") {
2596 push @machines, shift @tokens;
2601 $file = $hasdefault = $protected = "";
2605 'mach' => [@machines],
2607 'hasdefault' => $hasdefault,
2608 'protected' => $protected,
2612 sub hasdefault { shift->{'hasdefault'} }
2613 sub netrc { shift->{'netrc'} }
2614 sub protected { shift->{'protected'} }
2616 my($self,$mach) = @_;
2617 for ( @{$self->{'mach'}} ) {
2618 return 1 if $_ eq $mach;
2623 package CPAN::Complete;
2626 my($text, $line, $start, $end) = @_;
2627 my(@perlret) = cpl($text, $line, $start);
2628 # find longest common match. Can anybody show me how to peruse
2629 # T::R::Gnu to have this done automatically? Seems expensive.
2630 return () unless @perlret;
2631 my($newtext) = $text;
2632 for (my $i = length($text)+1;;$i++) {
2633 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2634 my $try = substr($perlret[0],0,$i);
2635 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2636 # warn "try[$try]tries[@tries]";
2637 if (@tries == @perlret) {
2643 ($newtext,@perlret);
2646 #-> sub CPAN::Complete::cpl ;
2648 my($word,$line,$pos) = @_;
2652 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2654 if ($line =~ s/^(force\s*)//) {
2662 ! a b d h i m o q r u autobundle clean dump
2663 make test install force readme reload look cvs_import
2666 } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
2668 } elsif ($line =~ /^a\s/) {
2669 @return = cplx('CPAN::Author',$word);
2670 } elsif ($line =~ /^b\s/) {
2671 @return = cplx('CPAN::Bundle',$word);
2672 } elsif ($line =~ /^d\s/) {
2673 @return = cplx('CPAN::Distribution',$word);
2674 } elsif ($line =~ m/^(
2675 [mru]|make|clean|dump|test|install|readme|look|cvs_import
2677 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2678 } elsif ($line =~ /^i\s/) {
2679 @return = cpl_any($word);
2680 } elsif ($line =~ /^reload\s/) {
2681 @return = cpl_reload($word,$line,$pos);
2682 } elsif ($line =~ /^o\s/) {
2683 @return = cpl_option($word,$line,$pos);
2690 #-> sub CPAN::Complete::cplx ;
2692 my($class, $word) = @_;
2693 # I believed for many years that this was sorted, today I
2694 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2695 # make it sorted again. Maybe sort was dropped when GNU-readline
2696 # support came in? The RCS file is difficult to read on that:-(
2697 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2700 #-> sub CPAN::Complete::cpl_any ;
2704 cplx('CPAN::Author',$word),
2705 cplx('CPAN::Bundle',$word),
2706 cplx('CPAN::Distribution',$word),
2707 cplx('CPAN::Module',$word),
2711 #-> sub CPAN::Complete::cpl_reload ;
2713 my($word,$line,$pos) = @_;
2715 my(@words) = split " ", $line;
2716 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2717 my(@ok) = qw(cpan index);
2718 return @ok if @words == 1;
2719 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2722 #-> sub CPAN::Complete::cpl_option ;
2724 my($word,$line,$pos) = @_;
2726 my(@words) = split " ", $line;
2727 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2728 my(@ok) = qw(conf debug);
2729 return @ok if @words == 1;
2730 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2732 } elsif ($words[1] eq 'index') {
2734 } elsif ($words[1] eq 'conf') {
2735 return CPAN::Config::cpl(@_);
2736 } elsif ($words[1] eq 'debug') {
2737 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2741 package CPAN::Index;
2743 #-> sub CPAN::Index::force_reload ;
2746 $CPAN::Index::last_time = 0;
2750 #-> sub CPAN::Index::reload ;
2752 my($cl,$force) = @_;
2755 # XXX check if a newer one is available. (We currently read it
2756 # from time to time)
2757 for ($CPAN::Config->{index_expire}) {
2758 $_ = 0.001 unless $_ && $_ > 0.001;
2760 $CPAN::META->{PROTOCOL} ||= "1.0";
2761 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
2762 # warn "Setting last_time to 0";
2763 $last_time = 0; # No warning necessary
2765 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2768 # IFF we are developing, it helps to wipe out the memory
2769 # between reloads, otherwise it is not what a user expects.
2770 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2771 $CPAN::META = CPAN->new;
2775 local $last_time = $time;
2776 local $CPAN::META->{PROTOCOL} = PROTOCOL;
2778 my $needshort = $^O eq "dos";
2780 $cl->rd_authindex($cl
2782 "authors/01mailrc.txt.gz",
2784 File::Spec->catfile('authors', '01mailrc.gz') :
2785 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2788 $debug = "timing reading 01[".($t2 - $time)."]";
2790 return if $CPAN::Signal; # this is sometimes lengthy
2791 $cl->rd_modpacks($cl
2793 "modules/02packages.details.txt.gz",
2795 File::Spec->catfile('modules', '02packag.gz') :
2796 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2799 $debug .= "02[".($t2 - $time)."]";
2801 return if $CPAN::Signal; # this is sometimes lengthy
2804 "modules/03modlist.data.gz",
2806 File::Spec->catfile('modules', '03mlist.gz') :
2807 File::Spec->catfile('modules', '03modlist.data.gz'),
2809 $cl->write_metadata_cache;
2811 $debug .= "03[".($t2 - $time)."]";
2813 CPAN->debug($debug) if $CPAN::DEBUG;
2816 $CPAN::META->{PROTOCOL} = PROTOCOL;
2819 #-> sub CPAN::Index::reload_x ;
2821 my($cl,$wanted,$localname,$force) = @_;
2822 $force |= 2; # means we're dealing with an index here
2823 CPAN::Config->load; # we should guarantee loading wherever we rely
2825 $localname ||= $wanted;
2826 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2830 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2833 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2834 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2835 qq{day$s. I\'ll use that.});
2838 $force |= 1; # means we're quite serious about it.
2840 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2843 #-> sub CPAN::Index::rd_authindex ;
2845 my($cl, $index_target) = @_;
2847 return unless defined $index_target;
2848 $CPAN::Frontend->myprint("Going to read $index_target\n");
2849 # my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2850 # while ($_ = $fh->READLINE) {
2853 tie *FH, CPAN::Tarzip, $index_target;
2855 push @lines, split /\012/ while <FH>;
2857 my($userid,$fullname,$email) =
2858 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2859 next unless $userid && $fullname && $email;
2861 # instantiate an author object
2862 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2863 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2864 return if $CPAN::Signal;
2869 my($self,$dist) = @_;
2870 $dist = $self->{'id'} unless defined $dist;
2871 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2875 #-> sub CPAN::Index::rd_modpacks ;
2877 my($self, $index_target) = @_;
2879 return unless defined $index_target;
2880 $CPAN::Frontend->myprint("Going to read $index_target\n");
2881 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2883 while ($_ = $fh->READLINE) {
2885 my @ls = map {"$_\n"} split /\n/, $_;
2886 unshift @ls, "\n" x length($1) if /^(\n+)/;
2892 my $shift = shift(@lines);
2893 $shift =~ /^Line-Count:\s+(\d+)/;
2894 $line_count = $1 if $1;
2895 last if $shift =~ /^\s*$/;
2897 if (not defined $line_count) {
2899 warn qq{Warning: Your $index_target does not contain a Line-Count header.
2900 Please check the validity of the index file by comparing it to more
2901 than one CPAN mirror. I'll continue but problems seem likely to
2906 } elsif ($line_count != scalar @lines) {
2908 warn sprintf qq{Warning: Your %s
2909 contains a Line-Count header of %d but I see %d lines there. Please
2910 check the validity of the index file by comparing it to more than one
2911 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
2912 $index_target, $line_count, scalar(@lines);
2915 # A necessity since we have metadata_cache: delete what isn't
2917 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
2918 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
2922 # before 1.56 we split into 3 and discarded the rest. From
2923 # 1.57 we assign remaining text to $comment thus allowing to
2924 # influence isa_perl
2925 my($mod,$version,$dist,$comment) = split " ", $_, 4;
2926 my($bundle,$id,$userid);
2928 if ($mod eq 'CPAN' &&
2930 CPAN::Queue->exists('Bundle::CPAN') ||
2931 CPAN::Queue->exists('CPAN')
2935 if ($version > $CPAN::VERSION){
2936 $CPAN::Frontend->myprint(qq{
2937 There's a new CPAN.pm version (v$version) available!
2938 [Current version is v$CPAN::VERSION]
2939 You might want to try
2940 install Bundle::CPAN
2942 without quitting the current session. It should be a seamless upgrade
2943 while we are running...
2946 $CPAN::Frontend->myprint(qq{\n});
2948 last if $CPAN::Signal;
2949 } elsif ($mod =~ /^Bundle::(.*)/) {
2954 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2955 # Let's make it a module too, because bundles have so much
2956 # in common with modules.
2958 # Changed in 1.57_63: seems like memory bloat now without
2959 # any value, so commented out
2961 # $CPAN::META->instance('CPAN::Module',$mod);
2965 # instantiate a module object
2966 $id = $CPAN::META->instance('CPAN::Module',$mod);
2970 if ($id->cpan_file ne $dist){ # update only if file is
2971 # different. CPAN prohibits same
2972 # name with different version
2973 $userid = $self->userid($dist);
2975 'CPAN_USERID' => $userid,
2976 'CPAN_VERSION' => $version,
2977 'CPAN_FILE' => $dist,
2981 # instantiate a distribution object
2982 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2983 # we do not need CONTAINSMODS unless we do something with
2984 # this dist, so we better produce it on demand.
2986 ## my $obj = $CPAN::META->instance(
2987 ## 'CPAN::Distribution' => $dist
2989 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
2991 $CPAN::META->instance(
2992 'CPAN::Distribution' => $dist
2994 'CPAN_USERID' => $userid,
2995 'CPAN_COMMENT' => $comment,
2999 for my $name ($mod,$dist) {
3000 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3001 $exists{$name} = undef;
3004 return if $CPAN::Signal;
3008 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3009 for my $o ($CPAN::META->all_objects($class)) {
3010 next if exists $exists{$o->{ID}};
3011 $CPAN::META->delete($class,$o->{ID});
3012 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3019 #-> sub CPAN::Index::rd_modlist ;
3021 my($cl,$index_target) = @_;
3022 return unless defined $index_target;
3023 $CPAN::Frontend->myprint("Going to read $index_target\n");
3024 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3027 while ($_ = $fh->READLINE) {
3029 my @ls = map {"$_\n"} split /\n/, $_;
3030 unshift @ls, "\n" x length($1) if /^(\n+)/;
3034 my $shift = shift(@eval);
3035 if ($shift =~ /^Date:\s+(.*)/){
3036 return if $date_of_03 eq $1;
3039 last if $shift =~ /^\s*$/;
3042 push @eval, q{CPAN::Modulelist->data;};
3044 my($comp) = Safe->new("CPAN::Safe1");
3045 my($eval) = join("", @eval);
3046 my $ret = $comp->reval($eval);
3047 Carp::confess($@) if $@;
3048 return if $CPAN::Signal;
3050 my $obj = $CPAN::META->instance(CPAN::Module,$_);
3051 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3052 $obj->set(%{$ret->{$_}});
3053 return if $CPAN::Signal;
3057 #-> sub CPAN::Index::write_metadata_cache ;
3058 sub write_metadata_cache {
3060 return unless $CPAN::Config->{'cache_metadata'};
3061 return unless $CPAN::META->has_usable("Storable");
3063 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3064 CPAN::Distribution)) {
3065 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3067 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3068 $cache->{last_time} = $last_time;
3069 $cache->{PROTOCOL} = PROTOCOL;
3070 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3071 eval { Storable::nstore($cache, $metadata_file) };
3072 $CPAN::Frontend->mywarn($@) if $@;
3075 #-> sub CPAN::Index::read_metadata_cache ;
3076 sub read_metadata_cache {
3078 return unless $CPAN::Config->{'cache_metadata'};
3079 return unless $CPAN::META->has_usable("Storable");
3080 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3081 return unless -r $metadata_file and -f $metadata_file;
3082 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3084 eval { $cache = Storable::retrieve($metadata_file) };
3085 $CPAN::Frontend->mywarn($@) if $@;
3086 if (!$cache || ref $cache ne 'HASH'){
3090 if (exists $cache->{PROTOCOL}) {
3091 if (PROTOCOL > $cache->{PROTOCOL}) {
3092 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3093 "with protocol v%s, requiring v%s",
3100 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3101 "with protocol v1.0");
3106 while(my($class,$v) = each %$cache) {
3107 next unless $class =~ /^CPAN::/;
3108 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3109 while (my($id,$ro) = each %$v) {
3110 $CPAN::META->{readwrite}{$class}{$id} ||=
3111 $class->new(ID=>$id, RO=>$ro);
3116 unless ($clcnt) { # sanity check
3117 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3120 if ($idcnt < 1000) {
3121 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3122 "in $metadata_file\n");
3125 $CPAN::META->{PROTOCOL} ||=
3126 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3127 # does initialize to some protocol
3128 $last_time = $cache->{last_time};
3131 package CPAN::InfoObj;
3134 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3135 sub id { shift->{ID} }
3137 #-> sub CPAN::InfoObj::new ;
3139 my $this = bless {}, shift;
3144 # The set method may only be used by code that reads index data or
3145 # otherwise "objective" data from the outside world. All session
3146 # related material may do anything else with instance variables but
3147 # must not touch the hash under the RO attribute. The reason is that
3148 # the RO hash gets written to Metadata file and is thus persistent.
3150 #-> sub CPAN::InfoObj::set ;
3152 my($self,%att) = @_;
3153 my $class = ref $self;
3155 # This must be ||=, not ||, because only if we write an empty
3156 # reference, only then the set method will write into the readonly
3157 # area. But for Distributions that spring into existence, maybe
3158 # because of a typo, we do not like it that they are written into
3159 # the readonly area and made permanent (at least for a while) and
3160 # that is why we do not "allow" other places to call ->set.
3161 my $ro = $self->{RO} =
3162 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3164 while (my($k,$v) = each %att) {
3169 #-> sub CPAN::InfoObj::as_glimpse ;
3173 my $class = ref($self);
3174 $class =~ s/^CPAN:://;
3175 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3179 #-> sub CPAN::InfoObj::as_string ;
3183 my $class = ref($self);
3184 $class =~ s/^CPAN:://;
3185 push @m, $class, " id = $self->{ID}\n";
3186 for (sort keys %{$self->{RO}}) {
3187 # next if m/^(ID|RO)$/;
3189 if ($_ eq "CPAN_USERID") {
3190 $extra .= " (".$self->author;
3191 my $email; # old perls!
3192 if ($email = $CPAN::META->instance(CPAN::Author,
3195 $extra .= " <$email>";
3197 $extra .= " <no email>";
3201 next unless defined $self->{RO}{$_};
3202 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3204 for (sort keys %$self) {
3205 next if m/^(ID|RO)$/;
3206 if (ref($self->{$_}) eq "ARRAY") {
3207 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3208 } elsif (ref($self->{$_}) eq "HASH") {
3212 join(" ",keys %{$self->{$_}}),
3215 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3221 #-> sub CPAN::InfoObj::author ;
3224 $CPAN::META->instance(CPAN::Author,$self->cpan_userid)->fullname;
3227 #-> sub CPAN::InfoObj::dump ;
3230 require Data::Dumper;
3231 print Data::Dumper::Dumper($self);
3234 package CPAN::Author;
3236 #-> sub CPAN::Author::as_glimpse ;
3240 my $class = ref($self);
3241 $class =~ s/^CPAN:://;
3242 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3246 #-> sub CPAN::Author::fullname ;
3247 sub fullname { shift->{RO}{FULLNAME} }
3250 #-> sub CPAN::Author::email ;
3251 sub email { shift->{RO}{EMAIL} }
3253 package CPAN::Distribution;
3256 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3260 delete $self->{later};
3263 #-> sub CPAN::Distribution::color_cmd_tmps ;
3264 sub color_cmd_tmps {
3266 my($depth) = shift || 0;
3267 my($color) = shift || 0;
3268 # a distribution needs to recurse into its prereq_pms
3270 return if exists $self->{incommandcolor}
3271 && $self->{incommandcolor}==$color;
3272 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3273 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3278 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3279 my $prereq_pm = $self->prereq_pm;
3280 if (defined $prereq_pm) {
3281 for my $pre (keys %$prereq_pm) {
3282 my $premo = CPAN::Shell->expand("Module",$pre);
3283 $premo->color_cmd_tmps($depth+1,$color);
3287 delete $self->{sponsored_mods};
3288 delete $self->{badtestcnt};
3290 $self->{incommandcolor} = $color;
3293 #-> sub CPAN::Distribution::as_string ;
3296 $self->containsmods;
3297 $self->SUPER::as_string(@_);
3300 #-> sub CPAN::Distribution::containsmods ;
3303 return if exists $self->{CONTAINSMODS};
3304 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3305 my $mod_file = $mod->cpan_file or next;
3306 my $dist_id = $self->{ID} or next;
3307 my $mod_id = $mod->{ID} or next;
3308 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3310 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3314 #-> sub CPAN::Distribution::called_for ;
3317 $self->{CALLED_FOR} = $id if defined $id;
3318 return $self->{CALLED_FOR};
3321 #-> sub CPAN::Distribution::get ;
3326 exists $self->{'build_dir'} and push @e,
3327 "Is already unwrapped into directory $self->{'build_dir'}";
3328 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3333 $CPAN::Config->{keep_source_where},
3336 split("/",$self->id)
3339 $self->debug("Doing localize") if $CPAN::DEBUG;
3341 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3342 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
3343 return if $CPAN::Signal;
3344 $self->{localfile} = $local_file;
3345 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3346 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3347 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3348 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3351 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3352 if ($CPAN::META->has_inst("MD5")) {
3353 $self->debug("MD5 is installed, verifying");
3356 $self->debug("MD5 is NOT installed");
3358 $self->debug("Removing tmp") if $CPAN::DEBUG;
3359 File::Path::rmtree("tmp");
3360 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3361 chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
3362 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
3363 return if $CPAN::Signal;
3364 if (! $local_file) {
3365 Carp::croak "bad download, can't do anything :-(\n";
3366 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3367 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3368 $self->untar_me($local_file);
3369 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3370 $self->unzip_me($local_file);
3371 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3372 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3373 $self->pm2dir_me($local_file);
3375 $self->{archived} = "NO";
3377 my $cwd = File::Spec->updir;
3378 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
3379 if ($self->{archived} ne 'NO') {
3380 $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
3381 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3382 # Let's check if the package has its own directory.
3383 my $dh = DirHandle->new(File::Spec->curdir)
3384 or Carp::croak("Couldn't opendir .: $!");
3385 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3387 my ($distdir,$packagedir);
3388 if (@readdir == 1 && -d $readdir[0]) {
3389 $distdir = $readdir[0];
3390 $packagedir = MM->catdir($builddir,$distdir);
3391 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3393 File::Path::rmtree($packagedir);
3394 rename($distdir,$packagedir) or
3395 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3397 my $userid = $self->cpan_userid;
3399 CPAN->debug("no userid? self[$self]");
3402 my $pragmatic_dir = $userid . '000';
3403 $pragmatic_dir =~ s/\W_//g;
3404 $pragmatic_dir++ while -d "../$pragmatic_dir";
3405 $packagedir = MM->catdir($builddir,$pragmatic_dir);
3406 File::Path::mkpath($packagedir);
3408 for $f (@readdir) { # is already without "." and ".."
3409 my $to = MM->catdir($packagedir,$f);
3410 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3413 $self->{'build_dir'} = $packagedir;
3414 $cwd = File::Spec->updir;
3415 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3417 $self->debug("Changed directory to .. (self[$self]=[".
3418 $self->as_string."])") if $CPAN::DEBUG;
3419 File::Path::rmtree("tmp");
3420 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
3421 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
3422 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3424 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
3425 unless (-f $makefilepl) {
3426 my($configure) = MM->catfile($packagedir,"Configure");
3427 if (-f $configure) {
3428 # do we have anything to do?
3429 $self->{'configure'} = $configure;
3430 } elsif (-f MM->catfile($packagedir,"Makefile")) {
3431 $CPAN::Frontend->myprint(qq{
3432 Package comes with a Makefile and without a Makefile.PL.
3433 We\'ll try to build it with that Makefile then.
3435 $self->{writemakefile} = "YES";
3438 my $cf = $self->called_for || "unknown";
3443 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3444 $cf = "unknown" unless length($cf);
3445 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
3446 Writing one on our own (calling it $cf)\n});
3447 $self->{had_no_makefile_pl}++;
3448 my $fh = FileHandle->new(">$makefilepl")
3449 or Carp::croak("Could not open >$makefilepl");
3451 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3452 # because there was no Makefile.PL supplied.
3453 # Autogenerated on: }.scalar localtime().qq{
3455 use ExtUtils::MakeMaker;
3456 WriteMakefile(NAME => q[$cf]);
3466 # CPAN::Distribution::untar_me ;
3468 my($self,$local_file) = @_;
3469 $self->{archived} = "tar";
3470 if (CPAN::Tarzip->untar($local_file)) {
3471 $self->{unwrapped} = "YES";
3473 $self->{unwrapped} = "NO";
3477 # CPAN::Distribution::unzip_me ;
3479 my($self,$local_file) = @_;
3480 $self->{archived} = "zip";
3481 if (CPAN::Tarzip->unzip($local_file)) {
3482 $self->{unwrapped} = "YES";
3484 $self->{unwrapped} = "NO";
3490 my($self,$local_file) = @_;
3491 $self->{archived} = "pm";
3492 my $to = File::Basename::basename($local_file);
3493 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3494 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3495 $self->{unwrapped} = "YES";
3497 $self->{unwrapped} = "NO";
3501 #-> sub CPAN::Distribution::new ;
3503 my($class,%att) = @_;
3505 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3507 my $this = { %att };
3508 return bless $this, $class;
3511 #-> sub CPAN::Distribution::look ;
3515 if ($^O eq 'MacOS') {
3516 $self->ExtUtils::MM_MacOS::look;
3520 if ( $CPAN::Config->{'shell'} ) {
3521 $CPAN::Frontend->myprint(qq{
3522 Trying to open a subshell in the build directory...
3525 $CPAN::Frontend->myprint(qq{
3526 Your configuration does not define a value for subshells.
3527 Please define it with "o conf shell <your shell>"
3531 my $dist = $self->id;
3532 my $dir = $self->dir or $self->get;
3535 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3536 my $pwd = CPAN->$getcwd();
3537 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3538 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3539 system($CPAN::Config->{'shell'}) == 0
3540 or $CPAN::Frontend->mydie("Subprocess shell error");
3541 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3544 # CPAN::Distribution::cvs_import ;
3548 my $dir = $self->dir;
3550 my $package = $self->called_for;
3551 my $module = $CPAN::META->instance('CPAN::Module', $package);
3552 my $version = $module->cpan_version;
3554 my $userid = $self->cpan_userid;
3556 my $cvs_dir = (split '/', $dir)[-1];
3557 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
3559 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3561 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3562 if ($cvs_site_perl) {
3563 $cvs_dir = "$cvs_site_perl/$cvs_dir";
3565 my $cvs_log = qq{"imported $package $version sources"};
3566 $version =~ s/\./_/g;
3567 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3568 "$cvs_dir", $userid, "v$version");
3571 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3572 my $pwd = CPAN->$getcwd();
3573 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3575 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3577 $CPAN::Frontend->myprint(qq{@cmd\n});
3578 system(@cmd) == 0 or
3579 $CPAN::Frontend->mydie("cvs import failed");
3580 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3583 #-> sub CPAN::Distribution::readme ;
3586 my($dist) = $self->id;
3587 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3588 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3592 $CPAN::Config->{keep_source_where},
3595 split("/","$sans.readme"),
3597 $self->debug("Doing localize") if $CPAN::DEBUG;
3598 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3600 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3602 if ($^O eq 'MacOS') {
3603 ExtUtils::MM_MacOS::launch_file($local_file);
3607 my $fh_pager = FileHandle->new;
3608 local($SIG{PIPE}) = "IGNORE";
3609 $fh_pager->open("|$CPAN::Config->{'pager'}")
3610 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3611 my $fh_readme = FileHandle->new;
3612 $fh_readme->open($local_file)
3613 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3614 $CPAN::Frontend->myprint(qq{
3617 with pager "$CPAN::Config->{'pager'}"
3620 $fh_pager->print(<$fh_readme>);
3623 #-> sub CPAN::Distribution::verifyMD5 ;
3628 $self->{MD5_STATUS} ||= "";
3629 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3630 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3632 my($lc_want,$lc_file,@local,$basename);
3633 @local = split("/",$self->{ID});
3635 push @local, "CHECKSUMS";
3637 MM->catfile($CPAN::Config->{keep_source_where},
3638 "authors", "id", @local);
3643 $self->MD5_check_file($lc_want)
3645 return $self->{MD5_STATUS} = "OK";
3647 $lc_file = CPAN::FTP->localize("authors/id/@local",
3650 $local[-1] .= ".gz";
3651 $lc_file = CPAN::FTP->localize("authors/id/@local",
3654 $lc_file =~ s/\.gz(?!\n)\Z//;
3655 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3660 $self->MD5_check_file($lc_file);
3663 #-> sub CPAN::Distribution::MD5_check_file ;
3664 sub MD5_check_file {
3665 my($self,$chk_file) = @_;
3666 my($cksum,$file,$basename);
3667 $file = $self->{localfile};
3668 $basename = File::Basename::basename($file);
3669 my $fh = FileHandle->new;
3670 if (open $fh, $chk_file){
3673 $eval =~ s/\015?\012/\n/g;
3675 my($comp) = Safe->new();
3676 $cksum = $comp->reval($eval);
3678 rename $chk_file, "$chk_file.bad";
3679 Carp::confess($@) if $@;
3682 Carp::carp "Could not open $chk_file for reading";
3685 if (exists $cksum->{$basename}{md5}) {
3686 $self->debug("Found checksum for $basename:" .
3687 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3691 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3693 $fh = CPAN::Tarzip->TIEHANDLE($file);
3696 # had to inline it, when I tied it, the tiedness got lost on
3697 # the call to eq_MD5. (Jan 1998)
3701 while ($fh->READ($ref, 4096) > 0){
3704 my $hexdigest = $md5->hexdigest;
3705 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3709 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3710 return $self->{MD5_STATUS} = "OK";
3712 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
3713 qq{distribution file. }.
3714 qq{Please investigate.\n\n}.
3716 $CPAN::META->instance(
3721 my $wrap = qq{I\'d recommend removing $file. Its MD5
3722 checksum is incorrect. Maybe you have configured your 'urllist' with
3723 a bad URL. Please check this array with 'o conf urllist', and
3726 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
3728 # former versions just returned here but this seems a
3729 # serious threat that deserves a die
3731 # $CPAN::Frontend->myprint("\n\n");
3735 # close $fh if fileno($fh);
3737 $self->{MD5_STATUS} ||= "";
3738 if ($self->{MD5_STATUS} eq "NIL") {
3739 $CPAN::Frontend->mywarn(qq{
3740 Warning: No md5 checksum for $basename in $chk_file.
3742 The cause for this may be that the file is very new and the checksum
3743 has not yet been calculated, but it may also be that something is
3744 going awry right now.
3746 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
3747 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
3749 $self->{MD5_STATUS} = "NIL";
3754 #-> sub CPAN::Distribution::eq_MD5 ;
3756 my($self,$fh,$expectMD5) = @_;
3759 while (read($fh, $data, 4096)){
3762 # $md5->addfile($fh);
3763 my $hexdigest = $md5->hexdigest;
3764 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3765 $hexdigest eq $expectMD5;
3768 #-> sub CPAN::Distribution::force ;
3770 # Both modules and distributions know if "force" is in effect by
3771 # autoinspection, not by inspecting a global variable. One of the
3772 # reason why this was chosen to work that way was the treatment of
3773 # dependencies. They should not autpomatically inherit the force
3774 # status. But this has the downside that ^C and die() will return to
3775 # the prompt but will not be able to reset the force_update
3776 # attributes. We try to correct for it currently in the read_metadata
3777 # routine, and immediately before we check for a Signal. I hope this
3778 # works out in one of v1.57_53ff
3781 my($self, $method) = @_;
3783 MD5_STATUS archived build_dir localfile make install unwrapped
3786 delete $self->{$att};
3788 if ($method && $method eq "install") {
3789 $self->{"force_update"}++; # name should probably have been force_install
3793 #-> sub CPAN::Distribution::unforce ;
3796 delete $self->{'force_update'};
3799 #-> sub CPAN::Distribution::isa_perl ;
3802 my $file = File::Basename::basename($self->id);
3803 if ($file =~ m{ ^ perl
3816 } elsif ($self->cpan_comment
3818 $self->cpan_comment =~ /isa_perl\(.+?\)/){
3823 #-> sub CPAN::Distribution::perl ;
3826 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3827 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3828 my $pwd = CPAN->$getcwd();
3829 my $candidate = MM->catfile($pwd,$^X);
3830 $perl ||= $candidate if MM->maybe_command($candidate);
3832 my ($component,$perl_name);
3833 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3834 PATH_COMPONENT: foreach $component (MM->path(),
3835 $Config::Config{'binexp'}) {
3836 next unless defined($component) && $component;
3837 my($abs) = MM->catfile($component,$perl_name);
3838 if (MM->maybe_command($abs)) {
3848 #-> sub CPAN::Distribution::make ;
3851 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3852 # Emergency brake if they said install Pippi and get newest perl
3853 if ($self->isa_perl) {
3855 $self->called_for ne $self->id &&
3856 ! $self->{force_update}
3858 # if we die here, we break bundles
3859 $CPAN::Frontend->mywarn(sprintf qq{
3860 The most recent version "%s" of the module "%s"
3861 comes with the current version of perl (%s).
3862 I\'ll build that only if you ask for something like
3867 $CPAN::META->instance(
3881 $self->{archived} eq "NO" and push @e,
3882 "Is neither a tar nor a zip archive.";
3884 $self->{unwrapped} eq "NO" and push @e,
3885 "had problems unarchiving. Please build manually";
3887 exists $self->{writemakefile} &&
3888 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3889 $1 || "Had some problem writing Makefile";
3891 defined $self->{'make'} and push @e,
3892 "Has already been processed within this session";
3894 exists $self->{later} and length($self->{later}) and
3895 push @e, $self->{later};
3897 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3899 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
3900 my $builddir = $self->dir;
3901 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3902 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3904 if ($^O eq 'MacOS') {
3905 ExtUtils::MM_MacOS::make($self);
3910 if ($self->{'configure'}) {
3911 $system = $self->{'configure'};
3913 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3915 # This needs a handler that can be turned on or off:
3916 # $switch = "-MExtUtils::MakeMaker ".
3917 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3919 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3921 unless (exists $self->{writemakefile}) {
3922 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3925 if ($CPAN::Config->{inactivity_timeout}) {
3927 alarm $CPAN::Config->{inactivity_timeout};
3928 local $SIG{CHLD}; # = sub { wait };
3929 if (defined($pid = fork)) {
3934 # note, this exec isn't necessary if
3935 # inactivity_timeout is 0. On the Mac I'd
3936 # suggest, we set it always to 0.
3940 $CPAN::Frontend->myprint("Cannot fork: $!");
3948 $CPAN::Frontend->myprint($@);
3949 $self->{writemakefile} = "NO $@";
3954 $ret = system($system);
3956 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
3960 if (-f "Makefile") {
3961 $self->{writemakefile} = "YES";
3962 delete $self->{make_clean}; # if cleaned before, enable next
3964 $self->{writemakefile} =
3965 qq{NO Makefile.PL refused to write a Makefile.};
3966 # It's probably worth to record the reason, so let's retry
3968 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
3969 # $self->{writemakefile} .= <$fh>;
3973 delete $self->{force_update};
3976 if (my @prereq = $self->unsat_prereq){
3977 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
3979 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3980 if (system($system) == 0) {
3981 $CPAN::Frontend->myprint(" $system -- OK\n");
3982 $self->{'make'} = "YES";
3984 $self->{writemakefile} ||= "YES";
3985 $self->{'make'} = "NO";
3986 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
3990 sub follow_prereqs {
3994 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
3995 "during [$id] -----\n");
3997 for my $p (@prereq) {
3998 $CPAN::Frontend->myprint(" $p\n");
4001 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4003 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4004 require ExtUtils::MakeMaker;
4005 my $answer = ExtUtils::MakeMaker::prompt(
4006 "Shall I follow them and prepend them to the queue
4007 of modules we are processing right now?", "yes");
4008 $follow = $answer =~ /^\s*y/i;
4012 myprint(" Ignoring dependencies on modules @prereq\n");
4015 # color them as dirty
4016 for my $p (@prereq) {
4017 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4019 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4020 $self->{later} = "Delayed until after prerequisites";
4021 return 1; # signal success to the queuerunner
4025 #-> sub CPAN::Distribution::unsat_prereq ;
4028 my $prereq_pm = $self->prereq_pm or return;
4030 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4031 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4032 # we were too demanding:
4033 next if $nmo->uptodate;
4035 # if they have not specified a version, we accept any installed one
4036 if (not defined $need_version or
4037 $need_version == 0 or
4038 $need_version eq "undef") {
4039 next if defined $nmo->inst_file;
4042 # We only want to install prereqs if either they're not installed
4043 # or if the installed version is too old. We cannot omit this
4044 # check, because if 'force' is in effect, nobody else will check.
4048 defined $nmo->inst_file &&
4049 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4051 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4055 CPAN::Version->readable($need_version)
4061 if ($self->{sponsored_mods}{$need_module}++){
4062 # We have already sponsored it and for some reason it's still
4063 # not available. So we do nothing. Or what should we do?
4064 # if we push it again, we have a potential infinite loop
4067 push @need, $need_module;
4072 #-> sub CPAN::Distribution::prereq_pm ;
4075 return $self->{prereq_pm} if
4076 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4077 return unless $self->{writemakefile}; # no need to have succeeded
4078 # but we must have run it
4079 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4080 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4085 $fh = FileHandle->new("<$makefile\0")) {
4089 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4091 last if /MakeMaker post_initialize section/;
4093 \s+PREREQ_PM\s+=>\s+(.+)
4096 # warn "Found prereq expr[$p]";
4098 # Regexp modified by A.Speer to remember actual version of file
4099 # PREREQ_PM hash key wants, then add to
4100 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4101 # In case a prereq is mentioned twice, complain.
4102 if ( defined $p{$1} ) {
4103 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4110 $self->{prereq_pm_detected}++;
4111 return $self->{prereq_pm} = \%p;
4114 #-> sub CPAN::Distribution::test ;
4119 delete $self->{force_update};
4122 $CPAN::Frontend->myprint("Running make test\n");
4123 if (my @prereq = $self->unsat_prereq){
4124 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4128 exists $self->{make} or exists $self->{later} or push @e,
4129 "Make had some problems, maybe interrupted? Won't test";
4131 exists $self->{'make'} and
4132 $self->{'make'} eq 'NO' and
4133 push @e, "Can't test without successful make";
4135 exists $self->{build_dir} or push @e, "Has no own directory";
4136 $self->{badtestcnt} ||= 0;
4137 $self->{badtestcnt} > 0 and
4138 push @e, "Won't repeat unsuccessful test during this command";
4140 exists $self->{later} and length($self->{later}) and
4141 push @e, $self->{later};
4143 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4145 chdir $self->{'build_dir'} or
4146 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4147 $self->debug("Changed directory to $self->{'build_dir'}")
4150 if ($^O eq 'MacOS') {
4151 ExtUtils::MM_MacOS::make_test($self);
4155 my $system = join " ", $CPAN::Config->{'make'}, "test";
4156 if (system($system) == 0) {
4157 $CPAN::Frontend->myprint(" $system -- OK\n");
4158 $self->{make_test} = "YES";
4160 $self->{make_test} = "NO";
4161 $self->{badtestcnt}++;
4162 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4166 #-> sub CPAN::Distribution::clean ;
4169 $CPAN::Frontend->myprint("Running make clean\n");
4172 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4173 push @e, "make clean already called once";
4174 exists $self->{build_dir} or push @e, "Has no own directory";
4175 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4177 chdir $self->{'build_dir'} or
4178 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4179 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4181 if ($^O eq 'MacOS') {
4182 ExtUtils::MM_MacOS::make_clean($self);
4186 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4187 if (system($system) == 0) {
4188 $CPAN::Frontend->myprint(" $system -- OK\n");
4192 # Jost Krieger pointed out that this "force" was wrong because
4193 # it has the effect that the next "install" on this distribution
4194 # will untar everything again. Instead we should bring the
4195 # object's state back to where it is after untarring.
4197 delete $self->{force_update};
4198 delete $self->{install};
4199 delete $self->{writemakefile};
4200 delete $self->{make};
4201 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4202 $self->{make_clean} = "YES";
4205 # Hmmm, what to do if make clean failed?
4207 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4209 make clean did not succeed, marking directory as unusable for further work.
4211 $self->force("make"); # so that this directory won't be used again
4216 #-> sub CPAN::Distribution::install ;
4221 delete $self->{force_update};
4224 $CPAN::Frontend->myprint("Running make install\n");
4227 exists $self->{build_dir} or push @e, "Has no own directory";
4229 exists $self->{make} or exists $self->{later} or push @e,
4230 "Make had some problems, maybe interrupted? Won't install";
4232 exists $self->{'make'} and
4233 $self->{'make'} eq 'NO' and
4234 push @e, "make had returned bad status, install seems impossible";
4236 push @e, "make test had returned bad status, ".
4237 "won't install without force"
4238 if exists $self->{'make_test'} and
4239 $self->{'make_test'} eq 'NO' and
4240 ! $self->{'force_update'};
4242 exists $self->{'install'} and push @e,
4243 $self->{'install'} eq "YES" ?
4244 "Already done" : "Already tried without success";
4246 exists $self->{later} and length($self->{later}) and
4247 push @e, $self->{later};
4249 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4251 chdir $self->{'build_dir'} or
4252 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4253 $self->debug("Changed directory to $self->{'build_dir'}")
4256 if ($^O eq 'MacOS') {
4257 ExtUtils::MM_MacOS::make_install($self);
4261 my $system = join(" ", $CPAN::Config->{'make'},
4262 "install", $CPAN::Config->{make_install_arg});
4263 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4264 my($pipe) = FileHandle->new("$system $stderr |");
4267 $CPAN::Frontend->myprint($_);
4272 $CPAN::Frontend->myprint(" $system -- OK\n");
4273 return $self->{'install'} = "YES";
4275 $self->{'install'} = "NO";
4276 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4277 if ($makeout =~ /permission/s && $> > 0) {
4278 $CPAN::Frontend->myprint(qq{ You may have to su }.
4279 qq{to root to install the package\n});
4282 delete $self->{force_update};
4285 #-> sub CPAN::Distribution::dir ;
4287 shift->{'build_dir'};
4290 package CPAN::Bundle;
4294 delete $self->{later};
4295 for my $c ( $self->contains ) {
4296 my $obj = CPAN::Shell->expandany($c) or next;
4301 #-> sub CPAN::Bundle::color_cmd_tmps ;
4302 sub color_cmd_tmps {
4304 my($depth) = shift || 0;
4305 my($color) = shift || 0;
4306 # a module needs to recurse to its cpan_file, a distribution needs
4307 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4309 return if exists $self->{incommandcolor}
4310 && $self->{incommandcolor}==$color;
4311 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4312 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4317 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4319 for my $c ( $self->contains ) {
4320 my $obj = CPAN::Shell->expandany($c) or next;
4321 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4322 $obj->color_cmd_tmps($depth+1,$color);
4325 delete $self->{badtestcnt};
4327 $self->{incommandcolor} = $color;
4330 #-> sub CPAN::Bundle::as_string ;
4334 # following line must be "=", not "||=" because we have a moving target
4335 $self->{INST_VERSION} = $self->inst_version;
4336 return $self->SUPER::as_string;
4339 #-> sub CPAN::Bundle::contains ;
4342 my($parsefile) = $self->inst_file;
4343 my($id) = $self->id;
4344 $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
4345 unless ($parsefile) {
4346 # Try to get at it in the cpan directory
4347 $self->debug("no parsefile") if $CPAN::DEBUG;
4348 Carp::confess "I don't know a $id" unless $self->cpan_file;
4349 my $dist = $CPAN::META->instance('CPAN::Distribution',
4352 $self->debug($dist->as_string) if $CPAN::DEBUG;
4353 my($todir) = $CPAN::Config->{'cpan_home'};
4354 my(@me,$from,$to,$me);
4355 @me = split /::/, $self->id;
4357 $me = MM->catfile(@me);
4358 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4359 $to = MM->catfile($todir,$me);
4360 File::Path::mkpath(File::Basename::dirname($to));
4361 File::Copy::copy($from, $to)
4362 or Carp::confess("Couldn't copy $from to $to: $!");
4366 my $fh = FileHandle->new;
4368 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
4370 $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
4372 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4373 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4374 next unless $in_cont;
4379 push @result, (split " ", $_, 2)[0];
4382 delete $self->{STATUS};
4383 $self->{CONTAINS} = \@result;
4384 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4386 $CPAN::Frontend->mywarn(qq{
4387 The bundle file "$parsefile" may be a broken
4388 bundlefile. It seems not to contain any bundle definition.
4389 Please check the file and if it is bogus, please delete it.
4390 Sorry for the inconvenience.
4396 #-> sub CPAN::Bundle::find_bundle_file
4397 sub find_bundle_file {
4398 my($self,$where,$what) = @_;
4399 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4400 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4401 ### my $bu = MM->catfile($where,$what);
4402 ### return $bu if -f $bu;
4403 my $manifest = MM->catfile($where,"MANIFEST");
4404 unless (-f $manifest) {
4405 require ExtUtils::Manifest;
4406 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
4407 my $cwd = CPAN->$getcwd();
4408 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4409 ExtUtils::Manifest::mkmanifest();
4410 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4412 my $fh = FileHandle->new($manifest)
4413 or Carp::croak("Couldn't open $manifest: $!");
4416 if ($^O eq 'MacOS') {
4419 $what2 =~ s/:Bundle://;
4422 $what2 =~ s|Bundle[/\\]||;
4427 my($file) = /(\S+)/;
4428 if ($file =~ m|\Q$what\E$|) {
4430 # return MM->catfile($where,$bu); # bad
4433 # retry if she managed to
4434 # have no Bundle directory
4435 $bu = $file if $file =~ m|\Q$what2\E$|;
4437 $bu =~ tr|/|:| if $^O eq 'MacOS';
4438 return MM->catfile($where, $bu) if $bu;
4439 Carp::croak("Couldn't find a Bundle file in $where");
4442 # needs to work slightly different from Module::inst_file because of
4443 # cpan_home/Bundle/ directory.
4445 #-> sub CPAN::Bundle::inst_file ;
4448 return $self->{INST_FILE} if
4449 exists $self->{INST_FILE} && $self->{INST_FILE};
4452 @me = split /::/, $self->id;
4454 $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, @me);
4455 return $self->{INST_FILE} = $inst_file if -f $inst_file;
4456 $self->SUPER::inst_file;
4459 #-> sub CPAN::Bundle::rematein ;
4461 my($self,$meth) = @_;
4462 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4463 my($id) = $self->id;
4464 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4465 unless $self->inst_file || $self->cpan_file;
4467 for $s ($self->contains) {
4468 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4469 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4470 if ($type eq 'CPAN::Distribution') {
4471 $CPAN::Frontend->mywarn(qq{
4472 The Bundle }.$self->id.qq{ contains
4473 explicitly a file $s.
4477 # possibly noisy action:
4478 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4479 my $obj = $CPAN::META->instance($type,$s);
4481 if ($obj->isa(CPAN::Bundle)
4483 exists $obj->{install_failed}
4485 ref($obj->{install_failed}) eq "HASH"
4487 for (keys %{$obj->{install_failed}}) {
4488 $self->{install_failed}{$_} = undef; # propagate faiure up
4491 $fail{$s} = 1; # the bundle itself may have succeeded but
4496 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4497 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4499 delete $self->{install_failed}{$s};
4506 # recap with less noise
4507 if ( $meth eq "install" ) {
4510 my $raw = sprintf(qq{Bundle summary:
4511 The following items in bundle %s had installation problems:},
4514 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4515 $CPAN::Frontend->myprint("\n");
4518 for $s ($self->contains) {
4520 $paragraph .= "$s ";
4521 $self->{install_failed}{$s} = undef;
4522 $reported{$s} = undef;
4525 my $report_propagated;
4526 for $s (sort keys %{$self->{install_failed}}) {
4527 next if exists $reported{$s};
4528 $paragraph .= "and the following items had problems
4529 during recursive bundle calls: " unless $report_propagated++;
4530 $paragraph .= "$s ";
4532 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
4533 $CPAN::Frontend->myprint("\n");
4535 $self->{'install'} = 'YES';
4540 #sub CPAN::Bundle::xs_file
4542 # If a bundle contains another that contains an xs_file we have
4543 # here, we just don't bother I suppose
4547 #-> sub CPAN::Bundle::force ;
4548 sub force { shift->rematein('force',@_); }
4549 #-> sub CPAN::Bundle::get ;
4550 sub get { shift->rematein('get',@_); }
4551 #-> sub CPAN::Bundle::make ;
4552 sub make { shift->rematein('make',@_); }
4553 #-> sub CPAN::Bundle::test ;
4556 $self->{badtestcnt} ||= 0;
4557 $self->rematein('test',@_);
4559 #-> sub CPAN::Bundle::install ;
4562 $self->rematein('install',@_);
4564 #-> sub CPAN::Bundle::clean ;
4565 sub clean { shift->rematein('clean',@_); }
4567 #-> sub CPAN::Bundle::readme ;
4570 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
4571 No File found for bundle } . $self->id . qq{\n}), return;
4572 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
4573 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
4576 package CPAN::Module;
4579 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
4582 return unless exists $self->{RO}{userid};
4583 $self->{RO}{userid};
4585 sub description { shift->{RO}{description} }
4589 delete $self->{later};
4590 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
4595 #-> sub CPAN::Module::color_cmd_tmps ;
4596 sub color_cmd_tmps {
4598 my($depth) = shift || 0;
4599 my($color) = shift || 0;
4600 # a module needs to recurse to its cpan_file
4602 return if exists $self->{incommandcolor}
4603 && $self->{incommandcolor}==$color;
4604 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4605 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4610 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4612 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
4613 $dist->color_cmd_tmps($depth+1,$color);
4616 delete $self->{badtestcnt};
4618 $self->{incommandcolor} = $color;
4621 #-> sub CPAN::Module::as_glimpse ;
4625 my $class = ref($self);
4626 $class =~ s/^CPAN:://;
4627 push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
4632 #-> sub CPAN::Module::as_string ;
4636 CPAN->debug($self) if $CPAN::DEBUG;
4637 my $class = ref($self);
4638 $class =~ s/^CPAN:://;
4640 push @m, $class, " id = $self->{ID}\n";
4641 my $sprintf = " %-12s %s\n";
4642 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
4643 if $self->description;
4644 my $sprintf2 = " %-12s %s (%s)\n";
4646 if ($userid = $self->cpan_userid || $self->userid){
4648 if ($author = CPAN::Shell->expand('Author',$userid)) {
4651 if ($m = $author->email) {
4658 $author->fullname . $email
4662 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
4663 if $self->cpan_version;
4664 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
4665 if $self->cpan_file;
4666 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
4667 my(%statd,%stats,%statl,%stati);
4668 @statd{qw,? i c a b R M S,} = qw,unknown idea
4669 pre-alpha alpha beta released mature standard,;
4670 @stats{qw,? m d u n,} = qw,unknown mailing-list
4671 developer comp.lang.perl.* none,;
4672 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
4673 @stati{qw,? f r O h,} = qw,unknown functions
4674 references+ties object-oriented hybrid,;
4675 $statd{' '} = 'unknown';
4676 $stats{' '} = 'unknown';
4677 $statl{' '} = 'unknown';
4678 $stati{' '} = 'unknown';
4686 $statd{$self->{RO}{statd}},
4687 $stats{$self->{RO}{stats}},
4688 $statl{$self->{RO}{statl}},
4689 $stati{$self->{RO}{stati}}
4690 ) if $self->{RO}{statd};
4691 my $local_file = $self->inst_file;
4693 $self->{MANPAGE} ||= $self->manpage_headline($local_file);
4696 for $item (qw/MANPAGE/) {
4697 push @m, sprintf($sprintf, $item, $self->{$item})
4698 if exists $self->{$item};
4700 for $item (qw/CONTAINS/) {
4701 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
4702 if exists $self->{$item} && @{$self->{$item}};
4704 push @m, sprintf($sprintf, 'INST_FILE',
4705 $local_file || "(not installed)");
4706 push @m, sprintf($sprintf, 'INST_VERSION',
4707 $self->inst_version) if $local_file;
4711 sub manpage_headline {
4712 my($self,$local_file) = @_;
4713 my(@local_file) = $local_file;
4714 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
4715 push @local_file, $local_file;
4717 for $locf (@local_file) {
4718 next unless -f $locf;
4719 my $fh = FileHandle->new($locf)
4720 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
4724 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
4725 m/^=head1\s+NAME/ ? 1 : $inpod;
4738 #-> sub CPAN::Module::cpan_file ;
4741 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
4742 unless (defined $self->{RO}{CPAN_FILE}) {
4743 CPAN::Index->reload;
4745 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
4746 return $self->{RO}{CPAN_FILE};
4747 } elsif ( defined $self->userid ) {
4748 my $fullname = $CPAN::META->instance("CPAN::Author",
4749 $self->userid)->fullname;
4750 my $email = $CPAN::META->instance("CPAN::Author",
4751 $self->userid)->email;
4752 unless (defined $fullname && defined $email) {
4753 my $userid = $self->userid;
4754 return sprintf("Contact Author %s (Try 'a %s')",
4759 return "Contact Author $fullname <$email>";
4765 *name = \&cpan_file;
4767 #-> sub CPAN::Module::cpan_version ;
4771 $self->{RO}{CPAN_VERSION} = 'undef'
4772 unless defined $self->{RO}{CPAN_VERSION};
4773 # I believe this is always a bug in the index and should be reported
4774 # as such, but usually I find out such an error and do not want to
4775 # provoke too many bugreports
4777 $self->{RO}{CPAN_VERSION};
4780 #-> sub CPAN::Module::force ;
4783 $self->{'force_update'}++;
4786 #-> sub CPAN::Module::rematein ;
4788 my($self,$meth) = @_;
4789 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
4792 my $cpan_file = $self->cpan_file;
4793 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
4794 $CPAN::Frontend->mywarn(sprintf qq{
4795 The module %s isn\'t available on CPAN.
4797 Either the module has not yet been uploaded to CPAN, or it is
4798 temporary unavailable. Please contact the author to find out
4799 more about the status. Try 'i %s'.
4806 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
4807 $pack->called_for($self->id);
4808 $pack->force($meth) if exists $self->{'force_update'};
4810 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
4811 delete $self->{'force_update'};
4814 #-> sub CPAN::Module::readme ;
4815 sub readme { shift->rematein('readme') }
4816 #-> sub CPAN::Module::look ;
4817 sub look { shift->rematein('look') }
4818 #-> sub CPAN::Module::cvs_import ;
4819 sub cvs_import { shift->rematein('cvs_import') }
4820 #-> sub CPAN::Module::get ;
4821 sub get { shift->rematein('get',@_); }
4822 #-> sub CPAN::Module::make ;
4825 $self->rematein('make');
4827 #-> sub CPAN::Module::test ;
4830 $self->{badtestcnt} ||= 0;
4831 $self->rematein('test',@_);
4833 #-> sub CPAN::Module::uptodate ;
4836 my($latest) = $self->cpan_version;
4838 my($inst_file) = $self->inst_file;
4840 if (defined $inst_file) {
4841 $have = $self->inst_version;
4846 ! CPAN::Version->vgt($latest, $have)
4848 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
4849 "latest[$latest] have[$have]") if $CPAN::DEBUG;
4854 #-> sub CPAN::Module::install ;
4860 not exists $self->{'force_update'}
4862 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
4866 $self->rematein('install') if $doit;
4868 #-> sub CPAN::Module::clean ;
4869 sub clean { shift->rematein('clean') }
4871 #-> sub CPAN::Module::inst_file ;
4875 @packpath = split /::/, $self->{ID};
4876 $packpath[-1] .= ".pm";
4877 foreach $dir (@INC) {
4878 my $pmfile = MM->catfile($dir,@packpath);
4886 #-> sub CPAN::Module::xs_file ;
4890 @packpath = split /::/, $self->{ID};
4891 push @packpath, $packpath[-1];
4892 $packpath[-1] .= "." . $Config::Config{'dlext'};
4893 foreach $dir (@INC) {
4894 my $xsfile = MM->catfile($dir,'auto',@packpath);
4902 #-> sub CPAN::Module::inst_version ;
4905 my $parsefile = $self->inst_file or return;
4906 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4909 # there was a bug in 5.6.0 that let lots of unini warnings out of
4910 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
4911 # the following workaround after 5.6.1 is out.
4912 local($SIG{__WARN__}) = sub { my $w = shift;
4913 return if $w =~ /uninitialized/i;
4917 $have = MM->parse_version($parsefile) || "undef";
4918 $have =~ s/^ //; # since the %vd hack these two lines here are needed
4919 $have =~ s/ $//; # trailing whitespace happens all the time
4921 # My thoughts about why %vd processing should happen here
4923 # Alt1 maintain it as string with leading v:
4924 # read index files do nothing
4925 # compare it use utility for compare
4926 # print it do nothing
4928 # Alt2 maintain it as what is is
4929 # read index files convert
4930 # compare it use utility because there's still a ">" vs "gt" issue
4931 # print it use CPAN::Version for print
4933 # Seems cleaner to hold it in memory as a string starting with a "v"
4935 # If the author of this module made a mistake and wrote a quoted
4936 # "v1.13" instead of v1.13, we simply leave it at that with the
4937 # effect that *we* will treat it like a v-tring while the rest of
4938 # perl won't. Seems sensible when we consider that any action we
4939 # could take now would just add complexity.
4941 $have = CPAN::Version->readable($have);
4943 $have =~ s/\s*//g; # stringify to float around floating point issues
4944 $have; # no stringify needed, \s* above matches always
4947 package CPAN::Tarzip;
4949 # CPAN::Tarzip::gzip
4951 my($class,$read,$write) = @_;
4952 if ($CPAN::META->has_inst("Compress::Zlib")) {
4954 $fhw = FileHandle->new($read)
4955 or $CPAN::Frontend->mydie("Could not open $read: $!");
4956 my $gz = Compress::Zlib::gzopen($write, "wb")
4957 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
4958 $gz->gzwrite($buffer)
4959 while read($fhw,$buffer,4096) > 0 ;
4964 system("$CPAN::Config->{gzip} -c $read > $write")==0;
4969 # CPAN::Tarzip::gunzip
4971 my($class,$read,$write) = @_;
4972 if ($CPAN::META->has_inst("Compress::Zlib")) {
4974 $fhw = FileHandle->new(">$write")
4975 or $CPAN::Frontend->mydie("Could not open >$write: $!");
4976 my $gz = Compress::Zlib::gzopen($read, "rb")
4977 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
4978 $fhw->print($buffer)
4979 while $gz->gzread($buffer) > 0 ;
4980 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
4981 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
4986 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
4991 # CPAN::Tarzip::gtest
4993 my($class,$read) = @_;
4994 # After I had reread the documentation in zlib.h, I discovered that
4995 # uncompressed files do not lead to an gzerror (anymore?).
4996 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
4999 my $gz = Compress::Zlib::gzopen($read, "rb")
5000 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5002 $Compress::Zlib::gzerrno));
5003 while ($gz->gzread($buffer) > 0 ){
5004 $len += length($buffer);
5007 my $err = $gz->gzerror;
5008 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5009 if ($len == -s $read){
5011 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5014 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5017 return system("$CPAN::Config->{gzip} -dt $read")==0;
5022 # CPAN::Tarzip::TIEHANDLE
5024 my($class,$file) = @_;
5026 $class->debug("file[$file]");
5027 if ($CPAN::META->has_inst("Compress::Zlib")) {
5028 my $gz = Compress::Zlib::gzopen($file,"rb") or
5029 die "Could not gzopen $file";
5030 $ret = bless {GZ => $gz}, $class;
5032 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5033 my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
5035 $ret = bless {FH => $fh}, $class;
5041 # CPAN::Tarzip::READLINE
5044 if (exists $self->{GZ}) {
5045 my $gz = $self->{GZ};
5046 my($line,$bytesread);
5047 $bytesread = $gz->gzreadline($line);
5048 return undef if $bytesread <= 0;
5051 my $fh = $self->{FH};
5052 return scalar <$fh>;
5057 # CPAN::Tarzip::READ
5059 my($self,$ref,$length,$offset) = @_;
5060 die "read with offset not implemented" if defined $offset;
5061 if (exists $self->{GZ}) {
5062 my $gz = $self->{GZ};
5063 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5066 my $fh = $self->{FH};
5067 return read($fh,$$ref,$length);
5072 # CPAN::Tarzip::DESTROY
5075 if (exists $self->{GZ}) {
5076 my $gz = $self->{GZ};
5077 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5078 # to be undef ever. AK, 2000-09
5080 my $fh = $self->{FH};
5081 $fh->close if defined $fh;
5087 # CPAN::Tarzip::untar
5089 my($class,$file) = @_;
5090 if (0) { # makes changing order easier
5091 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5093 MM->maybe_command($CPAN::Config->{'tar'})) {
5095 my $is_compressed = $class->gtest($file);
5096 if ($is_compressed) {
5097 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5098 "< $file | $CPAN::Config->{tar} xvf -";
5100 $system = "$CPAN::Config->{tar} xvf $file";
5102 if (system($system) != 0) {
5103 # people find the most curious tar binaries that cannot handle
5105 if ($is_compressed) {
5106 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5107 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5108 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5110 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5114 $system = "$CPAN::Config->{tar} xvf $file";
5115 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5116 if (system($system)==0) {
5117 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5119 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5125 } elsif ($CPAN::META->has_inst("Archive::Tar")
5127 $CPAN::META->has_inst("Compress::Zlib") ) {
5128 my $tar = Archive::Tar->new($file,1);
5129 my $af; # archive file
5131 for $af ($tar->list_files) {
5132 if ($af =~ m!^(/|\.\./)!) {
5133 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5134 "illegal member [$af]");
5136 $CPAN::Frontend->myprint("$af\n");
5138 return if $CPAN::Signal;
5142 ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
5143 if ($^O eq 'MacOS');
5147 $CPAN::Frontend->mydie(qq{
5148 CPAN.pm needs either both external programs tar and gzip installed or
5149 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5150 is available. Can\'t continue.
5156 my($class,$file) = @_;
5157 if ($CPAN::META->has_inst("Archive::Zip")) {
5158 # blueprint of the code from Archive::Zip::Tree::extractTree();
5159 my $zip = Archive::Zip->new();
5161 $status = $zip->read($file);
5162 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5163 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5164 my @members = $zip->members();
5165 for my $member ( @members ) {
5166 my $af = $member->fileName();
5167 if ($af =~ m!^(/|\.\./)!) {
5168 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5169 "illegal member [$af]");
5171 my $status = $member->extractToFileNamed( $af );
5172 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5173 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5174 $status != Archive::Zip::AZ_OK();
5175 return if $CPAN::Signal;
5179 my $unzip = $CPAN::Config->{unzip} or
5180 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5181 my @system = ($unzip, $file);
5182 return system(@system) == 0;
5187 package CPAN::Version;
5188 # CPAN::Version::vcmp courtesy Jost Krieger
5190 my($self,$l,$r) = @_;
5192 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5194 return 0 if $l eq $r; # short circuit for quicker success
5196 if ($l=~/^v/ <=> $r=~/^v/) {
5199 $_ = $self->float2vv($_);
5204 ($l ne "undef") <=> ($r ne "undef") ||
5208 $self->vstring($l) cmp $self->vstring($r)) ||
5214 my($self,$l,$r) = @_;
5215 $self->vcmp($l,$r) > 0;
5220 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5221 pack "U*", split /\./, $n;
5224 # vv => visible vstring
5229 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits so that
5230 # architecture cannot
5233 $mantissa .= "0" while length($mantissa)%3;
5234 my $ret = "v" . $rev;
5236 $mantissa =~ s/(\d{1,3})// or
5237 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5238 $ret .= ".".int($1);
5240 # warn "n[$n]ret[$ret]";
5246 $n =~ /^([\w\-\+\.]+)/;
5248 return $1 if defined $1 && length($1)>0;
5249 # if the first user reaches version v43, he will be treated as "+".
5250 # We'll have to decide about a new rule here then, depending on what
5251 # will be the prevailing versioning behavior then.
5253 if ($] < 5.006) { # or whenever v-strings were introduced
5254 # we get them wrong anyway, whatever we do, because 5.005 will
5255 # have already interpreted 0.2.4 to be "0.24". So even if he
5256 # indexer sends us something like "v0.2.4" we compare wrongly.
5258 # And if they say v1.2, then the old perl takes it as "v12"
5260 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5263 my $better = sprintf "v%vd", $n;
5264 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5276 CPAN - query, download and build perl modules from CPAN sites
5282 perl -MCPAN -e shell;
5288 autobundle, clean, install, make, recompile, test
5292 The CPAN module is designed to automate the make and install of perl
5293 modules and extensions. It includes some searching capabilities and
5294 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5295 to fetch the raw data from the net.
5297 Modules are fetched from one or more of the mirrored CPAN
5298 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5301 The CPAN module also supports the concept of named and versioned
5302 I<bundles> of modules. Bundles simplify the handling of sets of
5303 related modules. See Bundles below.
5305 The package contains a session manager and a cache manager. There is
5306 no status retained between sessions. The session manager keeps track
5307 of what has been fetched, built and installed in the current
5308 session. The cache manager keeps track of the disk space occupied by
5309 the make processes and deletes excess space according to a simple FIFO
5312 For extended searching capabilities there's a plugin for CPAN available,
5313 L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
5314 all documents available in CPAN authors directories. If C<CPAN::WAIT>
5315 is installed on your system, the interactive shell of <CPAN.pm> will
5316 enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
5317 queries to the WAIT server that has been configured for your
5320 All other methods provided are accessible in a programmer style and in an
5321 interactive shell style.
5323 =head2 Interactive Mode
5325 The interactive mode is entered by running
5327 perl -MCPAN -e shell
5329 which puts you into a readline interface. You will have the most fun if
5330 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5333 Once you are on the command line, type 'h' and the rest should be
5336 The most common uses of the interactive modes are
5340 =item Searching for authors, bundles, distribution files and modules
5342 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5343 for each of the four categories and another, C<i> for any of the
5344 mentioned four. Each of the four entities is implemented as a class
5345 with slightly differing methods for displaying an object.
5347 Arguments you pass to these commands are either strings exactly matching
5348 the identification string of an object or regular expressions that are
5349 then matched case-insensitively against various attributes of the
5350 objects. The parser recognizes a regular expression only if you
5351 enclose it between two slashes.
5353 The principle is that the number of found objects influences how an
5354 item is displayed. If the search finds one item, the result is
5355 displayed with the rather verbose method C<as_string>, but if we find
5356 more than one, we display each object with the terse method
5359 =item make, test, install, clean modules or distributions
5361 These commands take any number of arguments and investigate what is
5362 necessary to perform the action. If the argument is a distribution
5363 file name (recognized by embedded slashes), it is processed. If it is
5364 a module, CPAN determines the distribution file in which this module
5365 is included and processes that, following any dependencies named in
5366 the module's Makefile.PL (this behavior is controlled by
5367 I<prerequisites_policy>.)
5369 Any C<make> or C<test> are run unconditionally. An
5371 install <distribution_file>
5373 also is run unconditionally. But for
5377 CPAN checks if an install is actually needed for it and prints
5378 I<module up to date> in the case that the distribution file containing
5379 the module doesn't need to be updated.
5381 CPAN also keeps track of what it has done within the current session
5382 and doesn't try to build a package a second time regardless if it
5383 succeeded or not. The C<force> command takes as a first argument the
5384 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5385 command from scratch.
5389 cpan> install OpenGL
5390 OpenGL is up to date.
5391 cpan> force install OpenGL
5394 OpenGL-0.4/COPYRIGHT
5397 A C<clean> command results in a
5401 being executed within the distribution file's working directory.
5403 =item get, readme, look module or distribution
5405 C<get> downloads a distribution file without further action. C<readme>
5406 displays the README file of the associated distribution. C<Look> gets
5407 and untars (if not yet done) the distribution file, changes to the
5408 appropriate directory and opens a subshell process in that directory.
5412 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
5413 in the cpan-shell it is intended that you can press C<^C> anytime and
5414 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
5415 to clean up and leave the shell loop. You can emulate the effect of a
5416 SIGTERM by sending two consecutive SIGINTs, which usually means by
5417 pressing C<^C> twice.
5419 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
5420 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
5426 The commands that are available in the shell interface are methods in
5427 the package CPAN::Shell. If you enter the shell command, all your
5428 input is split by the Text::ParseWords::shellwords() routine which
5429 acts like most shells do. The first word is being interpreted as the
5430 method to be called and the rest of the words are treated as arguments
5431 to this method. Continuation lines are supported if a line ends with a
5436 C<autobundle> writes a bundle file into the
5437 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
5438 a list of all modules that are both available from CPAN and currently
5439 installed within @INC. The name of the bundle file is based on the
5440 current date and a counter.
5444 recompile() is a very special command in that it takes no argument and
5445 runs the make/test/install cycle with brute force over all installed
5446 dynamically loadable extensions (aka XS modules) with 'force' in
5447 effect. The primary purpose of this command is to finish a network
5448 installation. Imagine, you have a common source tree for two different
5449 architectures. You decide to do a completely independent fresh
5450 installation. You start on one architecture with the help of a Bundle
5451 file produced earlier. CPAN installs the whole Bundle for you, but
5452 when you try to repeat the job on the second architecture, CPAN
5453 responds with a C<"Foo up to date"> message for all modules. So you
5454 invoke CPAN's recompile on the second architecture and you're done.
5456 Another popular use for C<recompile> is to act as a rescue in case your
5457 perl breaks binary compatibility. If one of the modules that CPAN uses
5458 is in turn depending on binary compatibility (so you cannot run CPAN
5459 commands), then you should try the CPAN::Nox module for recovery.
5461 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
5463 Although it may be considered internal, the class hierarchy does matter
5464 for both users and programmer. CPAN.pm deals with above mentioned four
5465 classes, and all those classes share a set of methods. A classical
5466 single polymorphism is in effect. A metaclass object registers all
5467 objects of all kinds and indexes them with a string. The strings
5468 referencing objects have a separated namespace (well, not completely
5473 words containing a "/" (slash) Distribution
5474 words starting with Bundle:: Bundle
5475 everything else Module or Author
5477 Modules know their associated Distribution objects. They always refer
5478 to the most recent official release. Developers may mark their releases
5479 as unstable development versions (by inserting an underbar into the
5480 visible version number), so the really hottest and newest distribution
5481 file is not always the default. If a module Foo circulates on CPAN in
5482 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
5483 install version 1.23 by saying
5487 This would install the complete distribution file (say
5488 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
5489 like to install version 1.23_90, you need to know where the
5490 distribution file resides on CPAN relative to the authors/id/
5491 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
5492 so you would have to say
5494 install BAR/Foo-1.23_90.tar.gz
5496 The first example will be driven by an object of the class
5497 CPAN::Module, the second by an object of class CPAN::Distribution.
5499 =head2 Programmer's interface
5501 If you do not enter the shell, the available shell commands are both
5502 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
5503 functions in the calling package (C<install(...)>).
5505 There's currently only one class that has a stable interface -
5506 CPAN::Shell. All commands that are available in the CPAN shell are
5507 methods of the class CPAN::Shell. Each of the commands that produce
5508 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
5509 the IDs of all modules within the list.
5513 =item expand($type,@things)
5515 The IDs of all objects available within a program are strings that can
5516 be expanded to the corresponding real objects with the
5517 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
5518 list of CPAN::Module objects according to the C<@things> arguments
5519 given. In scalar context it only returns the first element of the
5522 =item Programming Examples
5524 This enables the programmer to do operations that combine
5525 functionalities that are available in the shell.
5527 # install everything that is outdated on my disk:
5528 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
5530 # install my favorite programs if necessary:
5531 for $mod (qw(Net::FTP MD5 Data::Dumper)){
5532 my $obj = CPAN::Shell->expand('Module',$mod);
5536 # list all modules on my disk that have no VERSION number
5537 for $mod (CPAN::Shell->expand("Module","/./")){
5538 next unless $mod->inst_file;
5539 # MakeMaker convention for undefined $VERSION:
5540 next unless $mod->inst_version eq "undef";
5541 print "No VERSION in ", $mod->id, "\n";
5544 # find out which distribution on CPAN contains a module:
5545 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
5547 Or if you want to write a cronjob to watch The CPAN, you could list
5548 all modules that need updating. First a quick and dirty way:
5550 perl -e 'use CPAN; CPAN::Shell->r;'
5552 If you don't want to get any output if all modules are up to date, you
5553 can parse the output of above command for the regular expression
5554 //modules are up to date// and decide to mail the output only if it
5557 If you prefer to do it more in a programmer style in one single
5558 process, maybe something like this suites you better:
5560 # list all modules on my disk that have newer versions on CPAN
5561 for $mod (CPAN::Shell->expand("Module","/./")){
5562 next unless $mod->inst_file;
5563 next if $mod->uptodate;
5564 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
5565 $mod->id, $mod->inst_version, $mod->cpan_version;
5568 If that gives you too much output every day, you maybe only want to
5569 watch for three modules. You can write
5571 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
5573 as the first line instead. Or you can combine some of the above
5576 # watch only for a new mod_perl module
5577 $mod = CPAN::Shell->expand("Module","mod_perl");
5578 exit if $mod->uptodate;
5579 # new mod_perl arrived, let me know all update recommendations
5584 =head2 Methods in the four Classes
5586 =head2 Cache Manager
5588 Currently the cache manager only keeps track of the build directory
5589 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
5590 deletes complete directories below C<build_dir> as soon as the size of
5591 all directories there gets bigger than $CPAN::Config->{build_cache}
5592 (in MB). The contents of this cache may be used for later
5593 re-installations that you intend to do manually, but will never be
5594 trusted by CPAN itself. This is due to the fact that the user might
5595 use these directories for building modules on different architectures.
5597 There is another directory ($CPAN::Config->{keep_source_where}) where
5598 the original distribution files are kept. This directory is not
5599 covered by the cache manager and must be controlled by the user. If
5600 you choose to have the same directory as build_dir and as
5601 keep_source_where directory, then your sources will be deleted with
5602 the same fifo mechanism.
5606 A bundle is just a perl module in the namespace Bundle:: that does not
5607 define any functions or methods. It usually only contains documentation.
5609 It starts like a perl module with a package declaration and a $VERSION
5610 variable. After that the pod section looks like any other pod with the
5611 only difference being that I<one special pod section> exists starting with
5616 In this pod section each line obeys the format
5618 Module_Name [Version_String] [- optional text]
5620 The only required part is the first field, the name of a module
5621 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
5622 of the line is optional. The comment part is delimited by a dash just
5623 as in the man page header.
5625 The distribution of a bundle should follow the same convention as
5626 other distributions.
5628 Bundles are treated specially in the CPAN package. If you say 'install
5629 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
5630 the modules in the CONTENTS section of the pod. You can install your
5631 own Bundles locally by placing a conformant Bundle file somewhere into
5632 your @INC path. The autobundle() command which is available in the
5633 shell interface does that for you by including all currently installed
5634 modules in a snapshot bundle file.
5636 =head2 Prerequisites
5638 If you have a local mirror of CPAN and can access all files with
5639 "file:" URLs, then you only need a perl better than perl5.003 to run
5640 this module. Otherwise Net::FTP is strongly recommended. LWP may be
5641 required for non-UNIX systems or if your nearest CPAN site is
5642 associated with an URL that is not C<ftp:>.
5644 If you have neither Net::FTP nor LWP, there is a fallback mechanism
5645 implemented for an external ftp command or for an external lynx
5648 =head2 Finding packages and VERSION
5650 This module presumes that all packages on CPAN
5656 declare their $VERSION variable in an easy to parse manner. This
5657 prerequisite can hardly be relaxed because it consumes far too much
5658 memory to load all packages into the running program just to determine
5659 the $VERSION variable. Currently all programs that are dealing with
5660 version use something like this
5662 perl -MExtUtils::MakeMaker -le \
5663 'print MM->parse_version(shift)' filename
5665 If you are author of a package and wonder if your $VERSION can be
5666 parsed, please try the above method.
5670 come as compressed or gzipped tarfiles or as zip files and contain a
5671 Makefile.PL (well, we try to handle a bit more, but without much
5678 The debugging of this module is a bit complex, because we have
5679 interferences of the software producing the indices on CPAN, of the
5680 mirroring process on CPAN, of packaging, of configuration, of
5681 synchronicity, and of bugs within CPAN.pm.
5683 For code debugging in interactive mode you can try "o debug" which
5684 will list options for debugging the various parts of the code. You
5685 should know that "o debug" has built-in completion support.
5687 For data debugging there is the C<dump> command which takes the same
5688 arguments as make/test/install and outputs the object's Data::Dumper
5691 =head2 Floppy, Zip, Offline Mode
5693 CPAN.pm works nicely without network too. If you maintain machines
5694 that are not networked at all, you should consider working with file:
5695 URLs. Of course, you have to collect your modules somewhere first. So
5696 you might use CPAN.pm to put together all you need on a networked
5697 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
5698 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
5699 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
5700 with this floppy. See also below the paragraph about CD-ROM support.
5702 =head1 CONFIGURATION
5704 When the CPAN module is installed, a site wide configuration file is
5705 created as CPAN/Config.pm. The default values defined there can be
5706 overridden in another configuration file: CPAN/MyConfig.pm. You can
5707 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
5708 $HOME/.cpan is added to the search path of the CPAN module before the
5709 use() or require() statements.
5711 Currently the following keys in the hash reference $CPAN::Config are
5714 build_cache size of cache for directories to build modules
5715 build_dir locally accessible directory to build modules
5716 index_expire after this many days refetch index files
5717 cache_metadata use serializer to cache metadata
5718 cpan_home local directory reserved for this package
5719 dontload_hash anonymous hash: modules in the keys will not be
5720 loaded by the CPAN::has_inst() routine
5721 gzip location of external program gzip
5722 inactivity_timeout breaks interactive Makefile.PLs after this
5723 many seconds inactivity. Set to 0 to never break.
5724 inhibit_startup_message
5725 if true, does not print the startup message
5726 keep_source_where directory in which to keep the source (if we do)
5727 make location of external make program
5728 make_arg arguments that should always be passed to 'make'
5729 make_install_arg same as make_arg for 'make install'
5730 makepl_arg arguments passed to 'perl Makefile.PL'
5731 pager location of external program more (or any pager)
5732 prerequisites_policy
5733 what to do if you are missing module prerequisites
5734 ('follow' automatically, 'ask' me, or 'ignore')
5735 scan_cache controls scanning of cache ('atstart' or 'never')
5736 tar location of external program tar
5737 unzip location of external program unzip
5738 urllist arrayref to nearby CPAN sites (or equivalent locations)
5739 wait_list arrayref to a wait server to try (See CPAN::WAIT)
5740 ftp_proxy, } the three usual variables for configuring
5741 http_proxy, } proxy requests. Both as CPAN::Config variables
5742 no_proxy } and as environment variables configurable.
5744 You can set and query each of these options interactively in the cpan
5745 shell with the command set defined within the C<o conf> command:
5749 =item C<o conf E<lt>scalar optionE<gt>>
5751 prints the current value of the I<scalar option>
5753 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
5755 Sets the value of the I<scalar option> to I<value>
5757 =item C<o conf E<lt>list optionE<gt>>
5759 prints the current value of the I<list option> in MakeMaker's
5762 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
5764 shifts or pops the array in the I<list option> variable
5766 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
5768 works like the corresponding perl commands.
5772 =head2 Note on urllist parameter's format
5774 urllist parameters are URLs according to RFC 1738. We do a little
5775 guessing if your URL is not compliant, but if you have problems with
5776 file URLs, please try the correct format. Either:
5778 file://localhost/whatever/ftp/pub/CPAN/
5782 file:///home/ftp/pub/CPAN/
5784 =head2 urllist parameter has CD-ROM support
5786 The C<urllist> parameter of the configuration table contains a list of
5787 URLs that are to be used for downloading. If the list contains any
5788 C<file> URLs, CPAN always tries to get files from there first. This
5789 feature is disabled for index files. So the recommendation for the
5790 owner of a CD-ROM with CPAN contents is: include your local, possibly
5791 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
5793 o conf urllist push file://localhost/CDROM/CPAN
5795 CPAN.pm will then fetch the index files from one of the CPAN sites
5796 that come at the beginning of urllist. It will later check for each
5797 module if there is a local copy of the most recent version.
5799 Another peculiarity of urllist is that the site that we could
5800 successfully fetch the last file from automatically gets a preference
5801 token and is tried as the first site for the next request. So if you
5802 add a new site at runtime it may happen that the previously preferred
5803 site will be tried another time. This means that if you want to disallow
5804 a site for the next transfer, it must be explicitly removed from
5809 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
5810 install foreign, unmasked, unsigned code on your machine. We compare
5811 to a checksum that comes from the net just as the distribution file
5812 itself. If somebody has managed to tamper with the distribution file,
5813 they may have as well tampered with the CHECKSUMS file. Future
5814 development will go towards strong authentication.
5818 Most functions in package CPAN are exported per default. The reason
5819 for this is that the primary use is intended for the cpan shell or for
5822 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
5824 To populate a freshly installed perl with my favorite modules is pretty
5825 easiest by maintaining a private bundle definition file. To get a useful
5826 blueprint of a bundle definition file, the command autobundle can be used
5827 on the CPAN shell command line. This command writes a bundle definition
5828 file for all modules that are installed for the currently running perl
5829 interpreter. It's recommended to run this command only once and from then
5830 on maintain the file manually under a private name, say
5831 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
5833 cpan> install Bundle::my_bundle
5835 then answer a few questions and then go out for a coffee.
5837 Maintaining a bundle definition file means to keep track of two
5838 things: dependencies and interactivity. CPAN.pm sometimes fails on
5839 calculating dependencies because not all modules define all MakeMaker
5840 attributes correctly, so a bundle definition file should specify
5841 prerequisites as early as possible. On the other hand, it's a bit
5842 annoying that many distributions need some interactive configuring. So
5843 what I try to accomplish in my private bundle file is to have the
5844 packages that need to be configured early in the file and the gentle
5845 ones later, so I can go out after a few minutes and leave CPAN.pm
5848 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
5850 Thanks to Graham Barr for contributing the following paragraphs about
5851 the interaction between perl, and various firewall configurations. For
5852 further informations on firewalls, it is recommended to consult the
5853 documentation that comes with the ncftp program. If you are unable to
5854 go through the firewall with a simple Perl setup, it is very likely
5855 that you can configure ncftp so that it works for your firewall.
5857 =head2 Three basic types of firewalls
5859 Firewalls can be categorized into three basic types.
5865 This is where the firewall machine runs a web server and to access the
5866 outside world you must do it via the web server. If you set environment
5867 variables like http_proxy or ftp_proxy to a values beginning with http://
5868 or in your web browser you have to set proxy information then you know
5869 you are running a http firewall.
5871 To access servers outside these types of firewalls with perl (even for
5872 ftp) you will need to use LWP.
5876 This where the firewall machine runs a ftp server. This kind of
5877 firewall will only let you access ftp servers outside the firewall.
5878 This is usually done by connecting to the firewall with ftp, then
5879 entering a username like "user@outside.host.com"
5881 To access servers outside these type of firewalls with perl you
5882 will need to use Net::FTP.
5884 =item One way visibility
5886 I say one way visibility as these firewalls try to make themselve look
5887 invisible to the users inside the firewall. An FTP data connection is
5888 normally created by sending the remote server your IP address and then
5889 listening for the connection. But the remote server will not be able to
5890 connect to you because of the firewall. So for these types of firewall
5891 FTP connections need to be done in a passive mode.
5893 There are two that I can think off.
5899 If you are using a SOCKS firewall you will need to compile perl and link
5900 it with the SOCKS library, this is what is normally called a 'socksified'
5901 perl. With this executable you will be able to connect to servers outside
5902 the firewall as if it is not there.
5906 This is the firewall implemented in the Linux kernel, it allows you to
5907 hide a complete network behind one IP address. With this firewall no
5908 special compiling is need as you can access hosts directly.
5914 =head2 Configuring lynx or ncftp for going through a firewall
5916 If you can go through your firewall with e.g. lynx, presumably with a
5919 /usr/local/bin/lynx -pscott:tiger
5921 then you would configure CPAN.pm with the command
5923 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
5925 That's all. Similarly for ncftp or ftp, you would configure something
5928 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
5930 Your milage may vary...
5936 =item 1) I installed a new version of module X but CPAN keeps saying,
5937 I have the old version installed
5939 Most probably you B<do> have the old version installed. This can
5940 happen if a module installs itself into a different directory in the
5941 @INC path than it was previously installed. This is not really a
5942 CPAN.pm problem, you would have the same problem when installing the
5943 module manually. The easiest way to prevent this behaviour is to add
5944 the argument C<UNINST=1> to the C<make install> call, and that is why
5945 many people add this argument permanently by configuring
5947 o conf make_install_arg UNINST=1
5949 =item 2) So why is UNINST=1 not the default?
5951 Because there are people who have their precise expectations about who
5952 may install where in the @INC path and who uses which @INC array. In
5953 fine tuned environments C<UNINST=1> can cause damage.
5955 =item 3) When I install bundles or multiple modules with one command
5956 there is too much output to keep track of
5958 You may want to configure something like
5960 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
5961 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
5963 so that STDOUT is captured in a file for later inspection.
5966 =item 4) I am not root, how can I install a module in a personal
5969 You will most probably like something like this:
5971 o conf makepl_arg "LIB=~/myperl/lib \
5972 INSTALLMAN1DIR=~/myperl/man/man1 \
5973 INSTALLMAN3DIR=~/myperl/man/man3"
5974 install Sybase::Sybperl
5976 You can make this setting permanent like all C<o conf> settings with
5979 You will have to add ~/myperl/man to the MANPATH environment variable
5980 and also tell your perl programs to look into ~/myperl/lib, e.g. by
5983 use lib "$ENV{HOME}/myperl/lib";
5985 or setting the PERL5LIB environment variable.
5987 Another thing you should bear in mind is that the UNINST parameter
5988 should never be set if you are not root.
5990 =item 5) How to get a package, unwrap it, and make a change before
5993 look Sybase::Sybperl
5995 =item 6) I installed a Bundle and had a couple of fails. When I
5996 retried, everything resolved nicely. Can this be fixed to work
5999 The reason for this is that CPAN does not know the dependencies of all
6000 modules when it starts out. To decide about the additional items to
6001 install, it just uses data found in the generated Makefile. An
6002 undetected missing piece breaks the process. But it may well be that
6003 your Bundle installs some prerequisite later than some depending item
6004 and thus your second try is able to resolve everything. Please note,
6005 CPAN.pm does not know the dependency tree in advance and cannot sort
6006 the queue of things to install in a topologically correct order. It
6007 resolves perfectly well IFF all modules declare the prerequisites
6008 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6009 fail and you need to install often, it is recommended sort the Bundle
6010 definition file manually. It is planned to improve the metadata
6011 situation for dependencies on CPAN in general, but this will still
6014 =item 7) In our intranet we have many modules for internal use. How
6015 can I integrate these modules with CPAN.pm but without uploading
6016 the modules to CPAN?
6018 Have a look at the CPAN::Site module.
6024 We should give coverage for B<all> of the CPAN and not just the PAUSE
6025 part, right? In this discussion CPAN and PAUSE have become equal --
6026 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6027 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6029 Future development should be directed towards a better integration of
6032 If a Makefile.PL requires special customization of libraries, prompts
6033 the user for special input, etc. then you may find CPAN is not able to
6034 build the distribution. In that case, you should attempt the
6035 traditional method of building a Perl module package from a shell.
6039 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
6043 perl(1), CPAN::Nox(3)