1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
5 # $Id: CPAN.pm,v 1.376 2000/11/15 07:14:58 k Exp $
7 # only used during development:
9 # $Revision = "[".substr(q$Revision: 1.376 $, 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 $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 my $oprompt = shift || "cpan> ";
92 my $prompt = $oprompt;
93 my $commandline = shift || "";
96 unless ($Suppress_readline) {
97 require Term::ReadLine;
100 $term->ReadLine eq "Term::ReadLine::Stub"
102 $term = Term::ReadLine->new('CPAN Monitor');
104 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
105 my $attribs = $term->Attribs;
106 $attribs->{attempted_completion_function} = sub {
107 &CPAN::Complete::gnu_cpl;
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)
123 my $cwd = CPAN::anycwd();
124 my $try_detect_readline;
125 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
126 my $rl_avail = $Suppress_readline ? "suppressed" :
127 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
128 "available (try 'install Bundle::CPAN')";
130 $CPAN::Frontend->myprint(
132 cpan shell -- CPAN exploration and modules installation (v%s%s)
140 unless $CPAN::Config->{'inhibit_startup_message'} ;
141 my($continuation) = "";
142 SHELLCOMMAND: while () {
143 if ($Suppress_readline) {
145 last SHELLCOMMAND unless defined ($_ = <> );
148 last SHELLCOMMAND unless
149 defined ($_ = $term->readline($prompt, $commandline));
151 $_ = "$continuation$_" if $continuation;
153 next SHELLCOMMAND if /^$/;
154 $_ = 'h' if /^\s*\?/;
155 if (/^(?:q(?:uit)?|bye|exit)$/i) {
165 use vars qw($import_done);
166 CPAN->import(':DEFAULT') unless $import_done++;
167 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
174 if ($] < 5.00322) { # parsewords had a bug until recently
177 eval { @line = Text::ParseWords::shellwords($_) };
178 warn($@), next SHELLCOMMAND if $@;
179 warn("Text::Parsewords could not parse the line [$_]"),
180 next SHELLCOMMAND unless @line;
182 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
183 my $command = shift @line;
184 eval { CPAN::Shell->$command(@line) };
186 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
187 $CPAN::Frontend->myprint("\n");
192 $commandline = ""; # I do want to be able to pass a default to
193 # shell, but on the second command I see no
196 CPAN::Queue->nullify_queue;
197 if ($try_detect_readline) {
198 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
200 $CPAN::META->has_inst("Term::ReadLine::Perl")
202 delete $INC{"Term/ReadLine.pm"};
204 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
205 require Term::ReadLine;
206 $CPAN::Frontend->myprint("\n$redef subroutines in ".
207 "Term::ReadLine redefined\n");
213 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
216 package CPAN::CacheMgr;
217 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
220 package CPAN::Config;
221 use vars qw(%can $dot_cpan);
224 'commit' => "Commit changes to disk",
225 'defaults' => "Reload defaults from disk",
226 'init' => "Interactive setting of all options",
230 use vars qw($Ua $Thesite $Themethod);
231 @CPAN::FTP::ISA = qw(CPAN::Debug);
233 package CPAN::Complete;
234 @CPAN::Complete::ISA = qw(CPAN::Debug);
235 @CPAN::Complete::COMMANDS = sort qw(
236 ! a b d h i m o q r u autobundle clean dump
237 make test install force readme reload look
239 ) unless @CPAN::Complete::COMMANDS;
242 use vars qw($last_time $date_of_03);
243 @CPAN::Index::ISA = qw(CPAN::Debug);
246 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
249 package CPAN::InfoObj;
250 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
252 package CPAN::Author;
253 @CPAN::Author::ISA = qw(CPAN::InfoObj);
255 package CPAN::Distribution;
256 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
258 package CPAN::Bundle;
259 @CPAN::Bundle::ISA = qw(CPAN::Module);
261 package CPAN::Module;
262 @CPAN::Module::ISA = qw(CPAN::InfoObj);
265 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
266 @CPAN::Shell::ISA = qw(CPAN::Debug);
267 $COLOR_REGISTERED ||= 0;
268 $PRINT_ORNAMENTING ||= 0;
270 #-> sub CPAN::Shell::AUTOLOAD ;
272 my($autoload) = $AUTOLOAD;
273 my $class = shift(@_);
274 # warn "autoload[$autoload] class[$class]";
275 $autoload =~ s/.*:://;
276 if ($autoload =~ /^w/) {
277 if ($CPAN::META->has_inst('CPAN::WAIT')) {
278 CPAN::WAIT->$autoload(@_);
280 $CPAN::Frontend->mywarn(qq{
281 Commands starting with "w" require CPAN::WAIT to be installed.
282 Please consider installing CPAN::WAIT to use the fulltext index.
283 For this you just need to type
288 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
294 package CPAN::Tarzip;
295 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
296 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
297 $BUGHUNTING = 0; # released code must have turned off
301 # One use of the queue is to determine if we should or shouldn't
302 # announce the availability of a new CPAN module
304 # Now we try to use it for dependency tracking. For that to happen
305 # we need to draw a dependency tree and do the leaves first. This can
306 # easily be reached by running CPAN.pm recursively, but we don't want
307 # to waste memory and run into deep recursion. So what we can do is
310 # CPAN::Queue is the package where the queue is maintained. Dependencies
311 # often have high priority and must be brought to the head of the queue,
312 # possibly by jumping the queue if they are already there. My first code
313 # attempt tried to be extremely correct. Whenever a module needed
314 # immediate treatment, I either unshifted it to the front of the queue,
315 # or, if it was already in the queue, I spliced and let it bypass the
316 # others. This became a too correct model that made it impossible to put
317 # an item more than once into the queue. Why would you need that? Well,
318 # you need temporary duplicates as the manager of the queue is a loop
321 # (1) looks at the first item in the queue without shifting it off
323 # (2) cares for the item
325 # (3) removes the item from the queue, *even if its agenda failed and
326 # even if the item isn't the first in the queue anymore* (that way
327 # protecting against never ending queues)
329 # So if an item has prerequisites, the installation fails now, but we
330 # want to retry later. That's easy if we have it twice in the queue.
332 # I also expect insane dependency situations where an item gets more
333 # than two lives in the queue. Simplest example is triggered by 'install
334 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
335 # get in the way. I wanted the queue manager to be a dumb servant, not
336 # one that knows everything.
338 # Who would I tell in this model that the user wants to be asked before
339 # processing? I can't attach that information to the module object,
340 # because not modules are installed but distributions. So I'd have to
341 # tell the distribution object that it should ask the user before
342 # processing. Where would the question be triggered then? Most probably
343 # in CPAN::Distribution::rematein.
344 # Hope that makes sense, my head is a bit off:-) -- AK
351 my $self = bless { qmod => $s }, $class;
356 # CPAN::Queue::first ;
362 # CPAN::Queue::delete_first ;
364 my($class,$what) = @_;
366 for my $i (0..$#All) {
367 if ( $All[$i]->{qmod} eq $what ) {
374 # CPAN::Queue::jumpqueue ;
378 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
379 join(",",map {$_->{qmod}} @All),
382 WHAT: for my $what (reverse @what) {
384 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
385 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
386 if ($All[$i]->{qmod} eq $what){
388 if ($jumped > 100) { # one's OK if e.g. just
389 # processing now; more are OK if
390 # user typed it several times
391 $CPAN::Frontend->mywarn(
392 qq{Object [$what] queued more than 100 times, ignoring}
398 my $obj = bless { qmod => $what }, $class;
401 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
402 join(",",map {$_->{qmod}} @All),
407 # CPAN::Queue::exists ;
409 my($self,$what) = @_;
410 my @all = map { $_->{qmod} } @All;
411 my $exists = grep { $_->{qmod} eq $what } @All;
412 # warn "in exists what[$what] all[@all] exists[$exists]";
416 # CPAN::Queue::delete ;
419 @All = grep { $_->{qmod} ne $mod } @All;
422 # CPAN::Queue::nullify_queue ;
431 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
433 # from here on only subs.
434 ################################################################################
436 #-> sub CPAN::all_objects ;
438 my($mgr,$class) = @_;
439 CPAN::Config->load unless $CPAN::Config_loaded++;
440 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
442 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
444 *all = \&all_objects;
446 # Called by shell, not in batch mode. In batch mode I see no risk in
447 # having many processes updating something as installations are
448 # continually checked at runtime. In shell mode I suspect it is
449 # unintentional to open more than one shell at a time
451 #-> sub CPAN::checklock ;
454 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
455 if (-f $lockfile && -M _ > 0) {
456 my $fh = FileHandle->new($lockfile) or
457 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
460 if (defined $other && $other) {
462 return if $$==$other; # should never happen
463 $CPAN::Frontend->mywarn(
465 There seems to be running another CPAN process ($other). Contacting...
467 if (kill 0, $other) {
468 $CPAN::Frontend->mydie(qq{Other job is running.
469 You may want to kill it and delete the lockfile, maybe. On UNIX try:
473 } elsif (-w $lockfile) {
475 ExtUtils::MakeMaker::prompt
476 (qq{Other job not responding. Shall I overwrite }.
477 qq{the lockfile? (Y/N)},"y");
478 $CPAN::Frontend->myexit("Ok, bye\n")
479 unless $ans =~ /^y/i;
482 qq{Lockfile $lockfile not writeable by you. }.
483 qq{Cannot proceed.\n}.
486 qq{ and then rerun us.\n}
490 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
491 "reports other process with ID ".
492 "$other. Cannot proceed.\n"));
495 my $dotcpan = $CPAN::Config->{cpan_home};
496 eval { File::Path::mkpath($dotcpan);};
498 # A special case at least for Jarkko.
503 $symlinkcpan = readlink $dotcpan;
504 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
505 eval { File::Path::mkpath($symlinkcpan); };
509 $CPAN::Frontend->mywarn(qq{
510 Working directory $symlinkcpan created.
514 unless (-d $dotcpan) {
516 Your configuration suggests "$dotcpan" as your
517 CPAN.pm working directory. I could not create this directory due
518 to this error: $firsterror\n};
520 As "$dotcpan" is a symlink to "$symlinkcpan",
521 I tried to create that, but I failed with this error: $seconderror
524 Please make sure the directory exists and is writable.
526 $CPAN::Frontend->mydie($diemess);
530 unless ($fh = FileHandle->new(">$lockfile")) {
531 if ($! =~ /Permission/) {
532 my $incc = $INC{'CPAN/Config.pm'};
533 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
534 $CPAN::Frontend->myprint(qq{
536 Your configuration suggests that CPAN.pm should use a working
538 $CPAN::Config->{cpan_home}
539 Unfortunately we could not create the lock file
541 due to permission problems.
543 Please make sure that the configuration variable
544 \$CPAN::Config->{cpan_home}
545 points to a directory where you can write a .lock file. You can set
546 this variable in either
553 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
555 $fh->print($$, "\n");
556 $self->{LOCK} = $lockfile;
560 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
565 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
566 print "Caught SIGINT\n";
570 # From: Larry Wall <larry@wall.org>
571 # Subject: Re: deprecating SIGDIE
572 # To: perl5-porters@perl.org
573 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
575 # The original intent of __DIE__ was only to allow you to substitute one
576 # kind of death for another on an application-wide basis without respect
577 # to whether you were in an eval or not. As a global backstop, it should
578 # not be used any more lightly (or any more heavily :-) than class
579 # UNIVERSAL. Any attempt to build a general exception model on it should
580 # be politely squashed. Any bug that causes every eval {} to have to be
581 # modified should be not so politely squashed.
583 # Those are my current opinions. It is also my optinion that polite
584 # arguments degenerate to personal arguments far too frequently, and that
585 # when they do, it's because both people wanted it to, or at least didn't
586 # sufficiently want it not to.
590 # global backstop to cleanup if we should really die
591 $SIG{__DIE__} = \&cleanup;
592 $self->debug("Signal handler set.") if $CPAN::DEBUG;
595 #-> sub CPAN::DESTROY ;
597 &cleanup; # need an eval?
600 #-> sub CPAN::anycwd ;
603 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
608 sub cwd {Cwd::cwd();}
610 #-> sub CPAN::getcwd ;
611 sub getcwd {Cwd::getcwd();}
613 #-> sub CPAN::exists ;
615 my($mgr,$class,$id) = @_;
616 CPAN::Config->load unless $CPAN::Config_loaded++;
618 ### Carp::croak "exists called without class argument" unless $class;
620 exists $META->{readonly}{$class}{$id} or
621 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
624 #-> sub CPAN::delete ;
626 my($mgr,$class,$id) = @_;
627 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
628 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
631 #-> sub CPAN::has_usable
632 # has_inst is sometimes too optimistic, we should replace it with this
633 # has_usable whenever a case is given
635 my($self,$mod,$message) = @_;
636 return 1 if $HAS_USABLE->{$mod};
637 my $has_inst = $self->has_inst($mod,$message);
638 return unless $has_inst;
641 LWP => [ # we frequently had "Can't locate object
642 # method "new" via package "LWP::UserAgent" at
643 # (eval 69) line 2006
645 sub {require LWP::UserAgent},
646 sub {require HTTP::Request},
647 sub {require URI::URL},
650 sub {require Net::FTP},
651 sub {require Net::Config},
654 if ($usable->{$mod}) {
655 for my $c (0..$#{$usable->{$mod}}) {
656 my $code = $usable->{$mod}[$c];
657 my $ret = eval { &$code() };
659 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
664 return $HAS_USABLE->{$mod} = 1;
667 #-> sub CPAN::has_inst
669 my($self,$mod,$message) = @_;
670 Carp::croak("CPAN->has_inst() called without an argument")
672 if (defined $message && $message eq "no"
674 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
676 exists $CPAN::Config->{dontload_hash}{$mod}
678 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
684 $file =~ s|/|\\|g if $^O eq 'MSWin32';
687 # checking %INC is wrong, because $INC{LWP} may be true
688 # although $INC{"URI/URL.pm"} may have failed. But as
689 # I really want to say "bla loaded OK", I have to somehow
691 ### warn "$file in %INC"; #debug
693 } elsif (eval { require $file }) {
694 # eval is good: if we haven't yet read the database it's
695 # perfect and if we have installed the module in the meantime,
696 # it tries again. The second require is only a NOOP returning
697 # 1 if we had success, otherwise it's retrying
699 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
700 if ($mod eq "CPAN::WAIT") {
701 push @CPAN::Shell::ISA, CPAN::WAIT;
704 } elsif ($mod eq "Net::FTP") {
705 $CPAN::Frontend->mywarn(qq{
706 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
708 install Bundle::libnet
710 }) unless $Have_warned->{"Net::FTP"}++;
712 } elsif ($mod eq "MD5"){
713 $CPAN::Frontend->myprint(qq{
714 CPAN: MD5 security checks disabled because MD5 not installed.
715 Please consider installing the MD5 module.
720 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
725 #-> sub CPAN::instance ;
727 my($mgr,$class,$id) = @_;
730 # unsafe meta access, ok?
731 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
732 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
740 #-> sub CPAN::cleanup ;
742 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
743 local $SIG{__DIE__} = '';
748 0 && # disabled, try reload cpan with it
749 $] > 5.004_60 # thereabouts
754 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
756 $subroutine eq '(eval)';
759 return if $ineval && !$End;
760 return unless defined $META->{LOCK}; # unsafe meta access, ok
761 return unless -f $META->{LOCK}; # unsafe meta access, ok
762 unlink $META->{LOCK}; # unsafe meta access, ok
764 # Carp::cluck("DEBUGGING");
765 $CPAN::Frontend->mywarn("Lockfile removed.\n");
768 package CPAN::CacheMgr;
770 #-> sub CPAN::CacheMgr::as_string ;
772 eval { require Data::Dumper };
774 return shift->SUPER::as_string;
776 return Data::Dumper::Dumper(shift);
780 #-> sub CPAN::CacheMgr::cachesize ;
785 #-> sub CPAN::CacheMgr::tidyup ;
788 return unless -d $self->{ID};
789 while ($self->{DU} > $self->{'MAX'} ) {
790 my($toremove) = shift @{$self->{FIFO}};
791 $CPAN::Frontend->myprint(sprintf(
792 "Deleting from cache".
793 ": $toremove (%.1f>%.1f MB)\n",
794 $self->{DU}, $self->{'MAX'})
796 return if $CPAN::Signal;
797 $self->force_clean_cache($toremove);
798 return if $CPAN::Signal;
802 #-> sub CPAN::CacheMgr::dir ;
807 #-> sub CPAN::CacheMgr::entries ;
810 return unless defined $dir;
811 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
812 $dir ||= $self->{ID};
813 my($cwd) = CPAN::anycwd();
814 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
815 my $dh = DirHandle->new(File::Spec->curdir)
816 or Carp::croak("Couldn't opendir $dir: $!");
819 next if $_ eq "." || $_ eq "..";
821 push @entries, MM->catfile($dir,$_);
823 push @entries, MM->catdir($dir,$_);
825 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
828 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
829 sort { -M $b <=> -M $a} @entries;
832 #-> sub CPAN::CacheMgr::disk_usage ;
835 return if exists $self->{SIZE}{$dir};
836 return if $CPAN::Signal;
840 $File::Find::prune++ if $CPAN::Signal;
842 if ($^O eq 'MacOS') {
844 my $cat = Mac::Files::FSpGetCatInfo($_);
845 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
852 return if $CPAN::Signal;
853 $self->{SIZE}{$dir} = $Du/1024/1024;
854 push @{$self->{FIFO}}, $dir;
855 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
856 $self->{DU} += $Du/1024/1024;
860 #-> sub CPAN::CacheMgr::force_clean_cache ;
861 sub force_clean_cache {
863 return unless -e $dir;
864 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
866 File::Path::rmtree($dir);
867 $self->{DU} -= $self->{SIZE}{$dir};
868 delete $self->{SIZE}{$dir};
871 #-> sub CPAN::CacheMgr::new ;
878 ID => $CPAN::Config->{'build_dir'},
879 MAX => $CPAN::Config->{'build_cache'},
880 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
883 File::Path::mkpath($self->{ID});
884 my $dh = DirHandle->new($self->{ID});
888 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
890 CPAN->debug($debug) if $CPAN::DEBUG;
894 #-> sub CPAN::CacheMgr::scan_cache ;
897 return if $self->{SCAN} eq 'never';
898 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
899 unless $self->{SCAN} eq 'atstart';
900 $CPAN::Frontend->myprint(
901 sprintf("Scanning cache %s for sizes\n",
904 for $e ($self->entries($self->{ID})) {
905 next if $e eq ".." || $e eq ".";
906 $self->disk_usage($e);
907 return if $CPAN::Signal;
914 #-> sub CPAN::Debug::debug ;
917 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
918 # Complete, caller(1)
920 ($caller) = caller(0);
922 $arg = "" unless defined $arg;
923 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
924 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
925 if ($arg and ref $arg) {
926 eval { require Data::Dumper };
928 $CPAN::Frontend->myprint($arg->as_string);
930 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
933 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
938 package CPAN::Config;
940 #-> sub CPAN::Config::edit ;
941 # returns true on successful action
943 my($self,@args) = @_;
945 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
946 my($o,$str,$func,$args,$key_exists);
952 CPAN->debug("o[$o]") if $CPAN::DEBUG;
956 CPAN->debug("func[$func]") if $CPAN::DEBUG;
958 # Let's avoid eval, it's easier to comprehend without.
959 if ($func eq "push") {
960 push @{$CPAN::Config->{$o}}, @args;
962 } elsif ($func eq "pop") {
963 pop @{$CPAN::Config->{$o}};
965 } elsif ($func eq "shift") {
966 shift @{$CPAN::Config->{$o}};
968 } elsif ($func eq "unshift") {
969 unshift @{$CPAN::Config->{$o}}, @args;
971 } elsif ($func eq "splice") {
972 splice @{$CPAN::Config->{$o}}, @args;
975 $CPAN::Config->{$o} = [@args];
978 $self->prettyprint($o);
980 if ($o eq "urllist" && $changed) {
981 # reset the cached values
982 undef $CPAN::FTP::Thesite;
983 undef $CPAN::FTP::Themethod;
987 $CPAN::Config->{$o} = $args[0] if defined $args[0];
988 $self->prettyprint($o);
995 my $v = $CPAN::Config->{$k};
997 my(@report) = ref $v eq "ARRAY" ?
999 map { sprintf(" %-18s => %s\n",
1001 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1003 $CPAN::Frontend->myprint(
1010 map {"\t$_\n"} @report
1013 } elsif (defined $v) {
1014 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1016 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1020 #-> sub CPAN::Config::commit ;
1022 my($self,$configpm) = @_;
1023 unless (defined $configpm){
1024 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1025 $configpm ||= $INC{"CPAN/Config.pm"};
1026 $configpm || Carp::confess(q{
1027 CPAN::Config::commit called without an argument.
1028 Please specify a filename where to save the configuration or try
1029 "o conf init" to have an interactive course through configing.
1034 $mode = (stat $configpm)[2];
1035 if ($mode && ! -w _) {
1036 Carp::confess("$configpm is not writable");
1041 $msg = <<EOF unless $configpm =~ /MyConfig/;
1043 # This is CPAN.pm's systemwide configuration file. This file provides
1044 # defaults for users, and the values can be changed in a per-user
1045 # configuration file. The user-config file is being looked for as
1046 # ~/.cpan/CPAN/MyConfig.pm.
1050 my($fh) = FileHandle->new;
1051 rename $configpm, "$configpm~" if -f $configpm;
1052 open $fh, ">$configpm" or
1053 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1054 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1055 foreach (sort keys %$CPAN::Config) {
1058 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1063 $fh->print("};\n1;\n__END__\n");
1066 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1067 #chmod $mode, $configpm;
1068 ###why was that so? $self->defaults;
1069 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1073 *default = \&defaults;
1074 #-> sub CPAN::Config::defaults ;
1084 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1093 #-> sub CPAN::Config::load ;
1098 eval {require CPAN::Config;}; # We eval because of some
1099 # MakeMaker problems
1100 unless ($dot_cpan++){
1101 unshift @INC, MM->catdir($ENV{HOME},".cpan");
1102 eval {require CPAN::MyConfig;}; # where you can override
1103 # system wide settings
1106 return unless @miss = $self->missing_config_data;
1108 require CPAN::FirstTime;
1109 my($configpm,$fh,$redo,$theycalled);
1111 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1112 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1113 $configpm = $INC{"CPAN/Config.pm"};
1115 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1116 $configpm = $INC{"CPAN/MyConfig.pm"};
1119 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1120 my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1121 my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1122 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
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 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1128 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1129 my $fh = FileHandle->new;
1130 if ($fh->open(">$configpmtest")) {
1132 $configpm = $configpmtest;
1134 # Should never happen
1135 Carp::confess("Cannot open >$configpmtest");
1139 unless ($configpm) {
1140 $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1141 File::Path::mkpath($configpmdir);
1142 $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1143 if (-w $configpmtest) {
1144 $configpm = $configpmtest;
1145 } elsif (-w $configpmdir) {
1146 #_#_# following code dumped core on me with 5.003_11, a.k.
1147 my $fh = FileHandle->new;
1148 if ($fh->open(">$configpmtest")) {
1150 $configpm = $configpmtest;
1152 # Should never happen
1153 Carp::confess("Cannot open >$configpmtest");
1156 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1157 qq{create a configuration file.});
1162 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1163 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1167 $CPAN::Frontend->myprint(qq{
1168 $configpm initialized.
1171 CPAN::FirstTime::init($configpm);
1174 #-> sub CPAN::Config::missing_config_data ;
1175 sub missing_config_data {
1178 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1179 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1181 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1182 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1183 "prerequisites_policy",
1186 push @miss, $_ unless defined $CPAN::Config->{$_};
1191 #-> sub CPAN::Config::unload ;
1193 delete $INC{'CPAN/MyConfig.pm'};
1194 delete $INC{'CPAN/Config.pm'};
1197 #-> sub CPAN::Config::help ;
1199 $CPAN::Frontend->myprint(q[
1201 defaults reload default config values from disk
1202 commit commit session changes to disk
1203 init go through a dialog to set all parameters
1205 You may edit key values in the follow fashion (the "o" is a literal
1208 o conf build_cache 15
1210 o conf build_dir "/foo/bar"
1212 o conf urllist shift
1214 o conf urllist unshift ftp://ftp.foo.bar/
1217 undef; #don't reprint CPAN::Config
1220 #-> sub CPAN::Config::cpl ;
1222 my($word,$line,$pos) = @_;
1224 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1225 my(@words) = split " ", substr($line,0,$pos+1);
1230 $words[2] =~ /list$/ && @words == 3
1232 $words[2] =~ /list$/ && @words == 4 && length($word)
1235 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1236 } elsif (@words >= 4) {
1239 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1240 return grep /^\Q$word\E/, @o_conf;
1243 package CPAN::Shell;
1245 #-> sub CPAN::Shell::h ;
1247 my($class,$about) = @_;
1248 if (defined $about) {
1249 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1251 $CPAN::Frontend->myprint(q{
1254 b string display bundles
1255 d or info distributions
1256 m /regex/ about modules
1257 i or anything of above
1258 r none reinstall recommendations
1259 u uninstalled distributions
1261 Download, Test, Make, Install...
1263 make make (implies get)
1264 test modules, make test (implies make)
1265 install dists, bundles make install (implies test)
1267 look open subshell in these dists' directories
1268 readme display these dists' README files
1271 h,? display this menu ! perl-code eval a perl command
1272 o conf [opt] set and query options q quit the cpan shell
1273 reload cpan load CPAN.pm again reload index load newer indices
1274 autobundle Snapshot force cmd unconditionally do cmd});
1280 #-> sub CPAN::Shell::a ;
1282 my($self,@arg) = @_;
1283 # authors are always UPPERCASE
1287 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1290 #-> sub CPAN::Shell::ls ;
1292 my($self,@arg) = @_;
1297 my $author = $self->expand('Author',$a) or die "No author found for $a";
1302 #-> sub CPAN::Shell::local_bundles ;
1304 my($self,@which) = @_;
1305 my($incdir,$bdir,$dh);
1306 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1307 my @bbase = "Bundle";
1308 while (my $bbase = shift @bbase) {
1309 $bdir = MM->catdir($incdir,split /::/, $bbase);
1310 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1311 if ($dh = DirHandle->new($bdir)) { # may fail
1313 for $entry ($dh->read) {
1314 next if $entry =~ /^\./; #
1315 if (-d MM->catdir($bdir,$entry)){
1316 push @bbase, "$bbase\::$entry";
1318 next unless $entry =~ s/\.pm(?!\n)\Z//;
1319 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1327 #-> sub CPAN::Shell::b ;
1329 my($self,@which) = @_;
1330 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1331 $self->local_bundles;
1332 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1335 #-> sub CPAN::Shell::d ;
1336 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1338 #-> sub CPAN::Shell::m ;
1339 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1340 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1343 #-> sub CPAN::Shell::i ;
1348 @type = qw/Author Bundle Distribution Module/;
1349 @args = '/./' unless @args;
1352 push @result, $self->expand($type,@args);
1354 my $result = @result == 1 ?
1355 $result[0]->as_string :
1357 "No objects found of any type for argument @args\n" :
1359 (map {$_->as_glimpse} @result),
1360 scalar @result, " items found\n",
1362 $CPAN::Frontend->myprint($result);
1365 #-> sub CPAN::Shell::o ;
1367 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1368 # should have been called set and 'o debug' maybe 'set debug'
1370 my($self,$o_type,@o_what) = @_;
1372 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1373 if ($o_type eq 'conf') {
1374 shift @o_what if @o_what && $o_what[0] eq 'help';
1375 if (!@o_what) { # print all things, "o conf"
1377 $CPAN::Frontend->myprint("CPAN::Config options");
1378 if (exists $INC{'CPAN/Config.pm'}) {
1379 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1381 if (exists $INC{'CPAN/MyConfig.pm'}) {
1382 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1384 $CPAN::Frontend->myprint(":\n");
1385 for $k (sort keys %CPAN::Config::can) {
1386 $v = $CPAN::Config::can{$k};
1387 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1389 $CPAN::Frontend->myprint("\n");
1390 for $k (sort keys %$CPAN::Config) {
1391 CPAN::Config->prettyprint($k);
1393 $CPAN::Frontend->myprint("\n");
1394 } elsif (!CPAN::Config->edit(@o_what)) {
1395 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1396 qq{edit options\n\n});
1398 } elsif ($o_type eq 'debug') {
1400 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1403 my($what) = shift @o_what;
1404 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1405 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1408 if ( exists $CPAN::DEBUG{$what} ) {
1409 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1410 } elsif ($what =~ /^\d/) {
1411 $CPAN::DEBUG = $what;
1412 } elsif (lc $what eq 'all') {
1414 for (values %CPAN::DEBUG) {
1417 $CPAN::DEBUG = $max;
1420 for (keys %CPAN::DEBUG) {
1421 next unless lc($_) eq lc($what);
1422 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1425 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1430 my $raw = "Valid options for debug are ".
1431 join(", ",sort(keys %CPAN::DEBUG), 'all').
1432 qq{ or a number. Completion works on the options. }.
1433 qq{Case is ignored.};
1435 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1436 $CPAN::Frontend->myprint("\n\n");
1439 $CPAN::Frontend->myprint("Options set for debugging:\n");
1441 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1442 $v = $CPAN::DEBUG{$k};
1443 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1444 if $v & $CPAN::DEBUG;
1447 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1450 $CPAN::Frontend->myprint(qq{
1452 conf set or get configuration variables
1453 debug set or get debugging options
1458 sub paintdots_onreload {
1461 if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1465 # $CPAN::Frontend->myprint(".($subr)");
1466 $CPAN::Frontend->myprint(".");
1473 #-> sub CPAN::Shell::reload ;
1475 my($self,$command,@arg) = @_;
1477 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1478 if ($command =~ /cpan/i) {
1479 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1480 my $fh = FileHandle->new($INC{'CPAN.pm'});
1483 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1486 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1487 } elsif ($command =~ /index/) {
1488 CPAN::Index->force_reload;
1490 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1491 index re-reads the index files\n});
1495 #-> sub CPAN::Shell::_binary_extensions ;
1496 sub _binary_extensions {
1497 my($self) = shift @_;
1498 my(@result,$module,%seen,%need,$headerdone);
1499 for $module ($self->expand('Module','/./')) {
1500 my $file = $module->cpan_file;
1501 next if $file eq "N/A";
1502 next if $file =~ /^Contact Author/;
1503 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1504 next if $dist->isa_perl;
1505 next unless $module->xs_file;
1507 $CPAN::Frontend->myprint(".");
1508 push @result, $module;
1510 # print join " | ", @result;
1511 $CPAN::Frontend->myprint("\n");
1515 #-> sub CPAN::Shell::recompile ;
1517 my($self) = shift @_;
1518 my($module,@module,$cpan_file,%dist);
1519 @module = $self->_binary_extensions();
1520 for $module (@module){ # we force now and compile later, so we
1522 $cpan_file = $module->cpan_file;
1523 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1525 $dist{$cpan_file}++;
1527 for $cpan_file (sort keys %dist) {
1528 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1529 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1531 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1532 # stop a package from recompiling,
1533 # e.g. IO-1.12 when we have perl5.003_10
1537 #-> sub CPAN::Shell::_u_r_common ;
1539 my($self) = shift @_;
1540 my($what) = shift @_;
1541 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1542 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1543 $what && $what =~ /^[aru]$/;
1545 @args = '/./' unless @args;
1546 my(@result,$module,%seen,%need,$headerdone,
1547 $version_undefs,$version_zeroes);
1548 $version_undefs = $version_zeroes = 0;
1549 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1550 my @expand = $self->expand('Module',@args);
1551 my $expand = scalar @expand;
1552 if (0) { # Looks like noise to me, was very useful for debugging
1553 # for metadata cache
1554 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1556 for $module (@expand) {
1557 my $file = $module->cpan_file;
1558 next unless defined $file; # ??
1559 my($latest) = $module->cpan_version;
1560 my($inst_file) = $module->inst_file;
1562 return if $CPAN::Signal;
1565 $have = $module->inst_version;
1566 } elsif ($what eq "r") {
1567 $have = $module->inst_version;
1569 if ($have eq "undef"){
1571 } elsif ($have == 0){
1574 next unless CPAN::Version->vgt($latest, $have);
1575 # to be pedantic we should probably say:
1576 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1577 # to catch the case where CPAN has a version 0 and we have a version undef
1578 } elsif ($what eq "u") {
1584 } elsif ($what eq "r") {
1586 } elsif ($what eq "u") {
1590 return if $CPAN::Signal; # this is sometimes lengthy
1593 push @result, sprintf "%s %s\n", $module->id, $have;
1594 } elsif ($what eq "r") {
1595 push @result, $module->id;
1596 next if $seen{$file}++;
1597 } elsif ($what eq "u") {
1598 push @result, $module->id;
1599 next if $seen{$file}++;
1600 next if $file =~ /^Contact/;
1602 unless ($headerdone++){
1603 $CPAN::Frontend->myprint("\n");
1604 $CPAN::Frontend->myprint(sprintf(
1607 "Package namespace",
1619 $CPAN::META->has_inst("Term::ANSIColor")
1621 $module->{RO}{description}
1623 $color_on = Term::ANSIColor::color("green");
1624 $color_off = Term::ANSIColor::color("reset");
1626 $CPAN::Frontend->myprint(sprintf $sprintf,
1633 $need{$module->id}++;
1637 $CPAN::Frontend->myprint("No modules found for @args\n");
1638 } elsif ($what eq "r") {
1639 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1643 if ($version_zeroes) {
1644 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1645 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1646 qq{a version number of 0\n});
1648 if ($version_undefs) {
1649 my $s_has = $version_undefs > 1 ? "s have" : " has";
1650 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1651 qq{parseable version number\n});
1657 #-> sub CPAN::Shell::r ;
1659 shift->_u_r_common("r",@_);
1662 #-> sub CPAN::Shell::u ;
1664 shift->_u_r_common("u",@_);
1667 #-> sub CPAN::Shell::autobundle ;
1670 CPAN::Config->load unless $CPAN::Config_loaded++;
1671 my(@bundle) = $self->_u_r_common("a",@_);
1672 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1673 File::Path::mkpath($todir);
1674 unless (-d $todir) {
1675 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1678 my($y,$m,$d) = (localtime)[5,4,3];
1682 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1683 my($to) = MM->catfile($todir,"$me.pm");
1685 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1686 $to = MM->catfile($todir,"$me.pm");
1688 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1690 "package Bundle::$me;\n\n",
1691 "\$VERSION = '0.01';\n\n",
1695 "Bundle::$me - Snapshot of installation on ",
1696 $Config::Config{'myhostname'},
1699 "\n\n=head1 SYNOPSIS\n\n",
1700 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1701 "=head1 CONTENTS\n\n",
1702 join("\n", @bundle),
1703 "\n\n=head1 CONFIGURATION\n\n",
1705 "\n\n=head1 AUTHOR\n\n",
1706 "This Bundle has been generated automatically ",
1707 "by the autobundle routine in CPAN.pm.\n",
1710 $CPAN::Frontend->myprint("\nWrote bundle file
1714 #-> sub CPAN::Shell::expandany ;
1717 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1718 if ($s =~ m|/|) { # looks like a file
1719 $s = CPAN::Distribution->normalize($s);
1720 return $CPAN::META->instance('CPAN::Distribution',$s);
1721 # Distributions spring into existence, not expand
1722 } elsif ($s =~ m|^Bundle::|) {
1723 $self->local_bundles; # scanning so late for bundles seems
1724 # both attractive and crumpy: always
1725 # current state but easy to forget
1727 return $self->expand('Bundle',$s);
1729 return $self->expand('Module',$s)
1730 if $CPAN::META->exists('CPAN::Module',$s);
1735 #-> sub CPAN::Shell::expand ;
1738 my($type,@args) = @_;
1740 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1742 my($regex,$command);
1743 if ($arg =~ m|^/(.*)/$|) {
1745 } elsif ($arg =~ m/=/) {
1748 my $class = "CPAN::$type";
1750 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1752 defined $regex ? $regex : "UNDEFINED",
1753 $command || "UNDEFINED",
1755 if (defined $regex) {
1759 $CPAN::META->all_objects($class)
1762 # BUG, we got an empty object somewhere
1763 require Data::Dumper;
1764 CPAN->debug(sprintf(
1765 "Bug in CPAN: Empty id on obj[%s][%s]",
1767 Data::Dumper::Dumper($obj)
1772 if $obj->id =~ /$regex/i
1776 $] < 5.00303 ### provide sort of
1777 ### compatibility with 5.003
1782 $obj->name =~ /$regex/i
1785 } elsif ($command) {
1786 die "equal sign in command disabled (immature interface), ".
1788 ! \$CPAN::Shell::ADVANCED_QUERY=1
1789 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1790 that may go away anytime.\n"
1791 unless $ADVANCED_QUERY;
1792 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1793 my($matchcrit) = $criterion =~ m/^~(.+)/;
1797 $CPAN::META->all_objects($class)
1799 my $lhs = $self->$method() or next; # () for 5.00503
1801 push @m, $self if $lhs =~ m/$matchcrit/;
1803 push @m, $self if $lhs eq $criterion;
1808 if ( $type eq 'Bundle' ) {
1809 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1810 } elsif ($type eq "Distribution") {
1811 $xarg = CPAN::Distribution->normalize($arg);
1813 if ($CPAN::META->exists($class,$xarg)) {
1814 $obj = $CPAN::META->instance($class,$xarg);
1815 } elsif ($CPAN::META->exists($class,$arg)) {
1816 $obj = $CPAN::META->instance($class,$arg);
1823 return wantarray ? @m : $m[0];
1826 #-> sub CPAN::Shell::format_result ;
1829 my($type,@args) = @_;
1830 @args = '/./' unless @args;
1831 my(@result) = $self->expand($type,@args);
1832 my $result = @result == 1 ?
1833 $result[0]->as_string :
1835 "No objects of type $type found for argument @args\n" :
1837 (map {$_->as_glimpse} @result),
1838 scalar @result, " items found\n",
1843 # The only reason for this method is currently to have a reliable
1844 # debugging utility that reveals which output is going through which
1845 # channel. No, I don't like the colors ;-)
1847 #-> sub CPAN::Shell::print_ornameted ;
1848 sub print_ornamented {
1849 my($self,$what,$ornament) = @_;
1851 return unless defined $what;
1853 if ($CPAN::Config->{term_is_latin}){
1856 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1858 if ($PRINT_ORNAMENTING) {
1859 unless (defined &color) {
1860 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1861 import Term::ANSIColor "color";
1863 *color = sub { return "" };
1867 for $line (split /\n/, $what) {
1868 $longest = length($line) if length($line) > $longest;
1870 my $sprintf = "%-" . $longest . "s";
1872 $what =~ s/(.*\n?)//m;
1875 my($nl) = chomp $line ? "\n" : "";
1876 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1877 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1885 my($self,$what) = @_;
1887 $self->print_ornamented($what, 'bold blue on_yellow');
1891 my($self,$what) = @_;
1892 $self->myprint($what);
1897 my($self,$what) = @_;
1898 $self->print_ornamented($what, 'bold red on_yellow');
1902 my($self,$what) = @_;
1903 $self->print_ornamented($what, 'bold red on_white');
1904 Carp::confess "died";
1908 my($self,$what) = @_;
1909 $self->print_ornamented($what, 'bold red on_white');
1914 return if -t STDOUT;
1915 my $odef = select STDERR;
1922 #-> sub CPAN::Shell::rematein ;
1923 # RE-adme||MA-ke||TE-st||IN-stall
1926 my($meth,@some) = @_;
1928 if ($meth eq 'force') {
1930 $meth = shift @some;
1933 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1935 # Here is the place to set "test_count" on all involved parties to
1936 # 0. We then can pass this counter on to the involved
1937 # distributions and those can refuse to test if test_count > X. In
1938 # the first stab at it we could use a 1 for "X".
1940 # But when do I reset the distributions to start with 0 again?
1941 # Jost suggested to have a random or cycling interaction ID that
1942 # we pass through. But the ID is something that is just left lying
1943 # around in addition to the counter, so I'd prefer to set the
1944 # counter to 0 now, and repeat at the end of the loop. But what
1945 # about dependencies? They appear later and are not reset, they
1946 # enter the queue but not its copy. How do they get a sensible
1949 # construct the queue
1951 foreach $s (@some) {
1954 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1956 } elsif ($s =~ m|^/|) { # looks like a regexp
1957 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1962 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
1963 $obj = CPAN::Shell->expandany($s);
1966 $obj->color_cmd_tmps(0,1);
1967 CPAN::Queue->new($s);
1969 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1970 $obj = $CPAN::META->instance('CPAN::Author',$s);
1971 if ($meth eq "dump") {
1974 $CPAN::Frontend->myprint(
1976 "Don't be silly, you can't $meth ",
1984 ->myprint(qq{Warning: Cannot $meth $s, }.
1985 qq{don\'t know what it is.
1990 to find objects with matching identifiers.
1996 # queuerunner (please be warned: when I started to change the
1997 # queue to hold objects instead of names, I made one or two
1998 # mistakes and never found which. I reverted back instead)
1999 while ($s = CPAN::Queue->first) {
2002 $obj = $s; # I do not believe, we would survive if this happened
2004 $obj = CPAN::Shell->expandany($s);
2008 ($] < 5.00303 || $obj->can($pragma))){
2009 ### compatibility with 5.003
2010 $obj->$pragma($meth); # the pragma "force" in
2011 # "CPAN::Distribution" must know
2012 # what we are intending
2014 if ($]>=5.00303 && $obj->can('called_for')) {
2015 $obj->called_for($s);
2018 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2024 CPAN::Queue->delete($s);
2026 CPAN->debug("failed");
2030 CPAN::Queue->delete_first($s);
2032 for my $obj (@qcopy) {
2033 $obj->color_cmd_tmps(0,0);
2037 #-> sub CPAN::Shell::dump ;
2038 sub dump { shift->rematein('dump',@_); }
2039 #-> sub CPAN::Shell::force ;
2040 sub force { shift->rematein('force',@_); }
2041 #-> sub CPAN::Shell::get ;
2042 sub get { shift->rematein('get',@_); }
2043 #-> sub CPAN::Shell::readme ;
2044 sub readme { shift->rematein('readme',@_); }
2045 #-> sub CPAN::Shell::make ;
2046 sub make { shift->rematein('make',@_); }
2047 #-> sub CPAN::Shell::test ;
2048 sub test { shift->rematein('test',@_); }
2049 #-> sub CPAN::Shell::install ;
2050 sub install { shift->rematein('install',@_); }
2051 #-> sub CPAN::Shell::clean ;
2052 sub clean { shift->rematein('clean',@_); }
2053 #-> sub CPAN::Shell::look ;
2054 sub look { shift->rematein('look',@_); }
2055 #-> sub CPAN::Shell::cvs_import ;
2056 sub cvs_import { shift->rematein('cvs_import',@_); }
2060 #-> sub CPAN::FTP::ftp_get ;
2062 my($class,$host,$dir,$file,$target) = @_;
2064 qq[Going to fetch file [$file] from dir [$dir]
2065 on host [$host] as local [$target]\n]
2067 my $ftp = Net::FTP->new($host);
2068 return 0 unless defined $ftp;
2069 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2070 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2071 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2072 warn "Couldn't login on $host";
2075 unless ( $ftp->cwd($dir) ){
2076 warn "Couldn't cwd $dir";
2080 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2081 unless ( $ftp->get($file,$target) ){
2082 warn "Couldn't fetch $file from $host\n";
2085 $ftp->quit; # it's ok if this fails
2089 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2091 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2092 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2094 # > *** 1562,1567 ****
2095 # > --- 1562,1580 ----
2096 # > return 1 if substr($url,0,4) eq "file";
2097 # > return 1 unless $url =~ m|://([^/]+)|;
2099 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2101 # > + $proxy =~ m|://([^/:]+)|;
2103 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2104 # > + if ($noproxy) {
2105 # > + if ($host !~ /$noproxy$/) {
2106 # > + $host = $proxy;
2109 # > + $host = $proxy;
2112 # > require Net::Ping;
2113 # > return 1 unless $Net::Ping::VERSION >= 2;
2117 #-> sub CPAN::FTP::localize ;
2119 my($self,$file,$aslocal,$force) = @_;
2121 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2122 unless defined $aslocal;
2123 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2126 if ($^O eq 'MacOS') {
2127 # Comment by AK on 2000-09-03: Uniq short filenames would be
2128 # available in CHECKSUMS file
2129 my($name, $path) = File::Basename::fileparse($aslocal, '');
2130 if (length($name) > 31) {
2141 my $size = 31 - length($suf);
2142 while (length($name) > $size) {
2146 $aslocal = File::Spec->catfile($path, $name);
2150 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2153 rename $aslocal, "$aslocal.bak";
2157 my($aslocal_dir) = File::Basename::dirname($aslocal);
2158 File::Path::mkpath($aslocal_dir);
2159 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2160 qq{directory "$aslocal_dir".
2161 I\'ll continue, but if you encounter problems, they may be due
2162 to insufficient permissions.\n}) unless -w $aslocal_dir;
2164 # Inheritance is not easier to manage than a few if/else branches
2165 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2167 $Ua = LWP::UserAgent->new;
2169 $Ua->proxy('ftp', $var)
2170 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2171 $Ua->proxy('http', $var)
2172 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2174 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2177 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
2178 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2179 if $CPAN::Config->{http_proxy};
2180 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
2182 # Try the list of urls for each single object. We keep a record
2183 # where we did get a file from
2184 my(@reordered,$last);
2185 $CPAN::Config->{urllist} ||= [];
2186 $last = $#{$CPAN::Config->{urllist}};
2187 if ($force & 2) { # local cpans probably out of date, don't reorder
2188 @reordered = (0..$last);
2192 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2194 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2205 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2207 @levels = qw/easy hard hardest/;
2209 @levels = qw/easy/ if $^O eq 'MacOS';
2211 for $levelno (0..$#levels) {
2212 my $level = $levels[$levelno];
2213 my $method = "host$level";
2214 my @host_seq = $level eq "easy" ?
2215 @reordered : 0..$last; # reordered has CDROM up front
2216 @host_seq = (0) unless @host_seq;
2217 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2219 $Themethod = $level;
2221 # utime $now, $now, $aslocal; # too bad, if we do that, we
2222 # might alter a local mirror
2223 $self->debug("level[$level]") if $CPAN::DEBUG;
2227 last if $CPAN::Signal; # need to cleanup
2230 unless ($CPAN::Signal) {
2233 qq{Please check, if the URLs I found in your configuration file \(}.
2234 join(", ", @{$CPAN::Config->{urllist}}).
2235 qq{\) are valid. The urllist can be edited.},
2236 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2237 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2239 $CPAN::Frontend->myprint("Could not fetch $file\n");
2242 rename "$aslocal.bak", $aslocal;
2243 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2244 $self->ls($aslocal));
2251 my($self,$host_seq,$file,$aslocal) = @_;
2253 HOSTEASY: for $i (@$host_seq) {
2254 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2255 $url .= "/" unless substr($url,-1) eq "/";
2257 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2258 if ($url =~ /^file:/) {
2260 if ($CPAN::META->has_inst('URI::URL')) {
2261 my $u = URI::URL->new($url);
2263 } else { # works only on Unix, is poorly constructed, but
2264 # hopefully better than nothing.
2265 # RFC 1738 says fileurl BNF is
2266 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2267 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2269 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2270 $l =~ s|^file:||; # assume they
2273 $l =~ s|^/||s unless -f $l; # e.g. /P:
2275 if ( -f $l && -r _) {
2279 # Maybe mirror has compressed it?
2281 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2282 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2289 if ($CPAN::META->has_usable('LWP')) {
2290 $CPAN::Frontend->myprint("Fetching with LWP:
2294 require LWP::UserAgent;
2295 $Ua = LWP::UserAgent->new;
2297 my $res = $Ua->mirror($url, $aslocal);
2298 if ($res->is_success) {
2301 utime $now, $now, $aslocal; # download time is more
2302 # important than upload time
2304 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2305 my $gzurl = "$url.gz";
2306 $CPAN::Frontend->myprint("Fetching with LWP:
2309 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2310 if ($res->is_success &&
2311 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2317 # Alan Burlison informed me that in firewall environments
2318 # Net::FTP can still succeed where LWP fails. So we do not
2319 # skip Net::FTP anymore when LWP is available.
2322 $self->debug("LWP not installed") if $CPAN::DEBUG;
2324 return if $CPAN::Signal;
2325 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2326 # that's the nice and easy way thanks to Graham
2327 my($host,$dir,$getfile) = ($1,$2,$3);
2328 if ($CPAN::META->has_usable('Net::FTP')) {
2330 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2333 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2334 "aslocal[$aslocal]") if $CPAN::DEBUG;
2335 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2339 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2340 my $gz = "$aslocal.gz";
2341 $CPAN::Frontend->myprint("Fetching with Net::FTP
2344 if (CPAN::FTP->ftp_get($host,
2348 CPAN::Tarzip->gunzip($gz,$aslocal)
2357 return if $CPAN::Signal;
2362 my($self,$host_seq,$file,$aslocal) = @_;
2364 # Came back if Net::FTP couldn't establish connection (or
2365 # failed otherwise) Maybe they are behind a firewall, but they
2366 # gave us a socksified (or other) ftp program...
2369 my($devnull) = $CPAN::Config->{devnull} || "";
2371 my($aslocal_dir) = File::Basename::dirname($aslocal);
2372 File::Path::mkpath($aslocal_dir);
2373 HOSTHARD: for $i (@$host_seq) {
2374 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2375 $url .= "/" unless substr($url,-1) eq "/";
2377 my($proto,$host,$dir,$getfile);
2379 # Courtesy Mark Conty mark_conty@cargill.com change from
2380 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2382 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2383 # proto not yet used
2384 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2386 next HOSTHARD; # who said, we could ftp anything except ftp?
2388 next HOSTHARD if $proto eq "file"; # file URLs would have had
2389 # success above. Likely a bogus URL
2391 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2393 for $f ('lynx','ncftpget','ncftp','wget') {
2394 next unless exists $CPAN::Config->{$f};
2395 $funkyftp = $CPAN::Config->{$f};
2396 next unless defined $funkyftp;
2397 next if $funkyftp =~ /^\s*$/;
2398 my($asl_ungz, $asl_gz);
2399 ($asl_ungz = $aslocal) =~ s/\.gz//;
2400 $asl_gz = "$asl_ungz.gz";
2401 my($src_switch) = "";
2403 $src_switch = " -source";
2404 } elsif ($f eq "ncftp"){
2405 $src_switch = " -c";
2406 } elsif ($f eq "wget"){
2407 $src_switch = " -O -";
2410 my($stdout_redir) = " > $asl_ungz";
2411 if ($f eq "ncftpget"){
2412 $chdir = "cd $aslocal_dir && ";
2415 $CPAN::Frontend->myprint(
2417 Trying with "$funkyftp$src_switch" to get
2421 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2422 $self->debug("system[$system]") if $CPAN::DEBUG;
2424 if (($wstatus = system($system)) == 0
2427 -s $asl_ungz # lynx returns 0 when it fails somewhere
2433 } elsif ($asl_ungz ne $aslocal) {
2434 # test gzip integrity
2435 if (CPAN::Tarzip->gtest($asl_ungz)) {
2436 # e.g. foo.tar is gzipped --> foo.tar.gz
2437 rename $asl_ungz, $aslocal;
2439 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2444 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2446 -f $asl_ungz && -s _ == 0;
2447 my $gz = "$aslocal.gz";
2448 my $gzurl = "$url.gz";
2449 $CPAN::Frontend->myprint(
2451 Trying with "$funkyftp$src_switch" to get
2454 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2455 $self->debug("system[$system]") if $CPAN::DEBUG;
2457 if (($wstatus = system($system)) == 0
2461 # test gzip integrity
2462 if (CPAN::Tarzip->gtest($asl_gz)) {
2463 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2465 # somebody uncompressed file for us?
2466 rename $asl_ungz, $aslocal;
2471 unlink $asl_gz if -f $asl_gz;
2474 my $estatus = $wstatus >> 8;
2475 my $size = -f $aslocal ?
2476 ", left\n$aslocal with size ".-s _ :
2477 "\nWarning: expected file [$aslocal] doesn't exist";
2478 $CPAN::Frontend->myprint(qq{
2479 System call "$system"
2480 returned status $estatus (wstat $wstatus)$size
2483 return if $CPAN::Signal;
2484 } # lynx,ncftpget,ncftp
2489 my($self,$host_seq,$file,$aslocal) = @_;
2492 my($aslocal_dir) = File::Basename::dirname($aslocal);
2493 File::Path::mkpath($aslocal_dir);
2494 HOSTHARDEST: for $i (@$host_seq) {
2495 unless (length $CPAN::Config->{'ftp'}) {
2496 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2499 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2500 $url .= "/" unless substr($url,-1) eq "/";
2502 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2503 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2506 my($host,$dir,$getfile) = ($1,$2,$3);
2508 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2509 $ctime,$blksize,$blocks) = stat($aslocal);
2510 $timestamp = $mtime ||= 0;
2511 my($netrc) = CPAN::FTP::netrc->new;
2512 my($netrcfile) = $netrc->netrc;
2513 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2514 my $targetfile = File::Basename::basename($aslocal);
2520 map("cd $_", split "/", $dir), # RFC 1738
2522 "get $getfile $targetfile",
2526 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2527 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2528 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2530 $netrc->contains($host))) if $CPAN::DEBUG;
2531 if ($netrc->protected) {
2532 $CPAN::Frontend->myprint(qq{
2533 Trying with external ftp to get
2535 As this requires some features that are not thoroughly tested, we\'re
2536 not sure, that we get it right....
2540 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2542 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2543 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2545 if ($mtime > $timestamp) {
2546 $CPAN::Frontend->myprint("GOT $aslocal\n");
2550 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2552 return if $CPAN::Signal;
2554 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2555 qq{correctly protected.\n});
2558 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2559 nor does it have a default entry\n");
2562 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2563 # then and login manually to host, using e-mail as
2565 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2569 "user anonymous $Config::Config{'cf_email'}"
2571 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2572 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2573 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2575 if ($mtime > $timestamp) {
2576 $CPAN::Frontend->myprint("GOT $aslocal\n");
2580 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2582 return if $CPAN::Signal;
2583 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2589 my($self,$command,@dialog) = @_;
2590 my $fh = FileHandle->new;
2591 $fh->open("|$command") or die "Couldn't open ftp: $!";
2592 foreach (@dialog) { $fh->print("$_\n") }
2593 $fh->close; # Wait for process to complete
2595 my $estatus = $wstatus >> 8;
2596 $CPAN::Frontend->myprint(qq{
2597 Subprocess "|$command"
2598 returned status $estatus (wstat $wstatus)
2602 # find2perl needs modularization, too, all the following is stolen
2606 my($self,$name) = @_;
2607 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2608 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2610 my($perms,%user,%group);
2614 $blocks = int(($blocks + 1) / 2);
2617 $blocks = int(($sizemm + 1023) / 1024);
2620 if (-f _) { $perms = '-'; }
2621 elsif (-d _) { $perms = 'd'; }
2622 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2623 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2624 elsif (-p _) { $perms = 'p'; }
2625 elsif (-S _) { $perms = 's'; }
2626 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2628 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2629 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2630 my $tmpmode = $mode;
2631 my $tmp = $rwx[$tmpmode & 7];
2633 $tmp = $rwx[$tmpmode & 7] . $tmp;
2635 $tmp = $rwx[$tmpmode & 7] . $tmp;
2636 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2637 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2638 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2641 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2642 my $group = $group{$gid} || $gid;
2644 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2646 my($moname) = $moname[$mon];
2647 if (-M _ > 365.25 / 2) {
2648 $timeyear = $year + 1900;
2651 $timeyear = sprintf("%02d:%02d", $hour, $min);
2654 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2668 package CPAN::FTP::netrc;
2672 my $file = MM->catfile($ENV{HOME},".netrc");
2674 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2675 $atime,$mtime,$ctime,$blksize,$blocks)
2680 my($fh,@machines,$hasdefault);
2682 $fh = FileHandle->new or die "Could not create a filehandle";
2684 if($fh->open($file)){
2685 $protected = ($mode & 077) == 0;
2687 NETRC: while (<$fh>) {
2688 my(@tokens) = split " ", $_;
2689 TOKEN: while (@tokens) {
2690 my($t) = shift @tokens;
2691 if ($t eq "default"){
2695 last TOKEN if $t eq "macdef";
2696 if ($t eq "machine") {
2697 push @machines, shift @tokens;
2702 $file = $hasdefault = $protected = "";
2706 'mach' => [@machines],
2708 'hasdefault' => $hasdefault,
2709 'protected' => $protected,
2713 # CPAN::FTP::hasdefault;
2714 sub hasdefault { shift->{'hasdefault'} }
2715 sub netrc { shift->{'netrc'} }
2716 sub protected { shift->{'protected'} }
2718 my($self,$mach) = @_;
2719 for ( @{$self->{'mach'}} ) {
2720 return 1 if $_ eq $mach;
2725 package CPAN::Complete;
2728 my($text, $line, $start, $end) = @_;
2729 my(@perlret) = cpl($text, $line, $start);
2730 # find longest common match. Can anybody show me how to peruse
2731 # T::R::Gnu to have this done automatically? Seems expensive.
2732 return () unless @perlret;
2733 my($newtext) = $text;
2734 for (my $i = length($text)+1;;$i++) {
2735 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2736 my $try = substr($perlret[0],0,$i);
2737 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2738 # warn "try[$try]tries[@tries]";
2739 if (@tries == @perlret) {
2745 ($newtext,@perlret);
2748 #-> sub CPAN::Complete::cpl ;
2750 my($word,$line,$pos) = @_;
2754 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2756 if ($line =~ s/^(force\s*)//) {
2761 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2762 } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
2764 } elsif ($line =~ /^(a|ls)\s/) {
2765 @return = cplx('CPAN::Author',uc($word));
2766 } elsif ($line =~ /^b\s/) {
2767 CPAN::Shell->local_bundles;
2768 @return = cplx('CPAN::Bundle',$word);
2769 } elsif ($line =~ /^d\s/) {
2770 @return = cplx('CPAN::Distribution',$word);
2771 } elsif ($line =~ m/^(
2772 [mru]|make|clean|dump|test|install|readme|look|cvs_import
2774 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2775 } elsif ($line =~ /^i\s/) {
2776 @return = cpl_any($word);
2777 } elsif ($line =~ /^reload\s/) {
2778 @return = cpl_reload($word,$line,$pos);
2779 } elsif ($line =~ /^o\s/) {
2780 @return = cpl_option($word,$line,$pos);
2781 } elsif ($line =~ m/^\S+\s/ ) {
2782 # fallback for future commands and what we have forgotten above
2783 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2790 #-> sub CPAN::Complete::cplx ;
2792 my($class, $word) = @_;
2793 # I believed for many years that this was sorted, today I
2794 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2795 # make it sorted again. Maybe sort was dropped when GNU-readline
2796 # support came in? The RCS file is difficult to read on that:-(
2797 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2800 #-> sub CPAN::Complete::cpl_any ;
2804 cplx('CPAN::Author',$word),
2805 cplx('CPAN::Bundle',$word),
2806 cplx('CPAN::Distribution',$word),
2807 cplx('CPAN::Module',$word),
2811 #-> sub CPAN::Complete::cpl_reload ;
2813 my($word,$line,$pos) = @_;
2815 my(@words) = split " ", $line;
2816 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2817 my(@ok) = qw(cpan index);
2818 return @ok if @words == 1;
2819 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2822 #-> sub CPAN::Complete::cpl_option ;
2824 my($word,$line,$pos) = @_;
2826 my(@words) = split " ", $line;
2827 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2828 my(@ok) = qw(conf debug);
2829 return @ok if @words == 1;
2830 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2832 } elsif ($words[1] eq 'index') {
2834 } elsif ($words[1] eq 'conf') {
2835 return CPAN::Config::cpl(@_);
2836 } elsif ($words[1] eq 'debug') {
2837 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2841 package CPAN::Index;
2843 #-> sub CPAN::Index::force_reload ;
2846 $CPAN::Index::last_time = 0;
2850 #-> sub CPAN::Index::reload ;
2852 my($cl,$force) = @_;
2855 # XXX check if a newer one is available. (We currently read it
2856 # from time to time)
2857 for ($CPAN::Config->{index_expire}) {
2858 $_ = 0.001 unless $_ && $_ > 0.001;
2860 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
2861 # debug here when CPAN doesn't seem to read the Metadata
2863 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
2865 unless ($CPAN::META->{PROTOCOL}) {
2866 $cl->read_metadata_cache;
2867 $CPAN::META->{PROTOCOL} ||= "1.0";
2869 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
2870 # warn "Setting last_time to 0";
2871 $last_time = 0; # No warning necessary
2873 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2876 # IFF we are developing, it helps to wipe out the memory
2877 # between reloads, otherwise it is not what a user expects.
2878 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2879 $CPAN::META = CPAN->new;
2883 local $last_time = $time;
2884 local $CPAN::META->{PROTOCOL} = PROTOCOL;
2886 my $needshort = $^O eq "dos";
2888 $cl->rd_authindex($cl
2890 "authors/01mailrc.txt.gz",
2892 File::Spec->catfile('authors', '01mailrc.gz') :
2893 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2896 $debug = "timing reading 01[".($t2 - $time)."]";
2898 return if $CPAN::Signal; # this is sometimes lengthy
2899 $cl->rd_modpacks($cl
2901 "modules/02packages.details.txt.gz",
2903 File::Spec->catfile('modules', '02packag.gz') :
2904 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2907 $debug .= "02[".($t2 - $time)."]";
2909 return if $CPAN::Signal; # this is sometimes lengthy
2912 "modules/03modlist.data.gz",
2914 File::Spec->catfile('modules', '03mlist.gz') :
2915 File::Spec->catfile('modules', '03modlist.data.gz'),
2917 $cl->write_metadata_cache;
2919 $debug .= "03[".($t2 - $time)."]";
2921 CPAN->debug($debug) if $CPAN::DEBUG;
2924 $CPAN::META->{PROTOCOL} = PROTOCOL;
2927 #-> sub CPAN::Index::reload_x ;
2929 my($cl,$wanted,$localname,$force) = @_;
2930 $force |= 2; # means we're dealing with an index here
2931 CPAN::Config->load; # we should guarantee loading wherever we rely
2933 $localname ||= $wanted;
2934 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2938 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2941 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2942 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2943 qq{day$s. I\'ll use that.});
2946 $force |= 1; # means we're quite serious about it.
2948 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2951 #-> sub CPAN::Index::rd_authindex ;
2953 my($cl, $index_target) = @_;
2955 return unless defined $index_target;
2956 $CPAN::Frontend->myprint("Going to read $index_target\n");
2958 tie *FH, CPAN::Tarzip, $index_target;
2960 push @lines, split /\012/ while <FH>;
2962 my($userid,$fullname,$email) =
2963 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2964 next unless $userid && $fullname && $email;
2966 # instantiate an author object
2967 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2968 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2969 return if $CPAN::Signal;
2974 my($self,$dist) = @_;
2975 $dist = $self->{'id'} unless defined $dist;
2976 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2980 #-> sub CPAN::Index::rd_modpacks ;
2982 my($self, $index_target) = @_;
2984 return unless defined $index_target;
2985 $CPAN::Frontend->myprint("Going to read $index_target\n");
2986 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2988 while ($_ = $fh->READLINE) {
2990 my @ls = map {"$_\n"} split /\n/, $_;
2991 unshift @ls, "\n" x length($1) if /^(\n+)/;
2997 my $shift = shift(@lines);
2998 $shift =~ /^Line-Count:\s+(\d+)/;
2999 $line_count = $1 if $1;
3000 last if $shift =~ /^\s*$/;
3002 if (not defined $line_count) {
3004 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3005 Please check the validity of the index file by comparing it to more
3006 than one CPAN mirror. I'll continue but problems seem likely to
3011 } elsif ($line_count != scalar @lines) {
3013 warn sprintf qq{Warning: Your %s
3014 contains a Line-Count header of %d but I see %d lines there. Please
3015 check the validity of the index file by comparing it to more than one
3016 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3017 $index_target, $line_count, scalar(@lines);
3020 # A necessity since we have metadata_cache: delete what isn't
3022 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3023 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3027 # before 1.56 we split into 3 and discarded the rest. From
3028 # 1.57 we assign remaining text to $comment thus allowing to
3029 # influence isa_perl
3030 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3031 my($bundle,$id,$userid);
3033 if ($mod eq 'CPAN' &&
3035 CPAN::Queue->exists('Bundle::CPAN') ||
3036 CPAN::Queue->exists('CPAN')
3040 if ($version > $CPAN::VERSION){
3041 $CPAN::Frontend->myprint(qq{
3042 There's a new CPAN.pm version (v$version) available!
3043 [Current version is v$CPAN::VERSION]
3044 You might want to try
3045 install Bundle::CPAN
3047 without quitting the current session. It should be a seamless upgrade
3048 while we are running...
3051 $CPAN::Frontend->myprint(qq{\n});
3053 last if $CPAN::Signal;
3054 } elsif ($mod =~ /^Bundle::(.*)/) {
3059 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3060 # Let's make it a module too, because bundles have so much
3061 # in common with modules.
3063 # Changed in 1.57_63: seems like memory bloat now without
3064 # any value, so commented out
3066 # $CPAN::META->instance('CPAN::Module',$mod);
3070 # instantiate a module object
3071 $id = $CPAN::META->instance('CPAN::Module',$mod);
3075 if ($id->cpan_file ne $dist){ # update only if file is
3076 # different. CPAN prohibits same
3077 # name with different version
3078 $userid = $self->userid($dist);
3080 'CPAN_USERID' => $userid,
3081 'CPAN_VERSION' => $version,
3082 'CPAN_FILE' => $dist,
3086 # instantiate a distribution object
3087 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3088 # we do not need CONTAINSMODS unless we do something with
3089 # this dist, so we better produce it on demand.
3091 ## my $obj = $CPAN::META->instance(
3092 ## 'CPAN::Distribution' => $dist
3094 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3096 $CPAN::META->instance(
3097 'CPAN::Distribution' => $dist
3099 'CPAN_USERID' => $userid,
3100 'CPAN_COMMENT' => $comment,
3104 for my $name ($mod,$dist) {
3105 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3106 $exists{$name} = undef;
3109 return if $CPAN::Signal;
3113 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3114 for my $o ($CPAN::META->all_objects($class)) {
3115 next if exists $exists{$o->{ID}};
3116 $CPAN::META->delete($class,$o->{ID});
3117 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3124 #-> sub CPAN::Index::rd_modlist ;
3126 my($cl,$index_target) = @_;
3127 return unless defined $index_target;
3128 $CPAN::Frontend->myprint("Going to read $index_target\n");
3129 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3132 while ($_ = $fh->READLINE) {
3134 my @ls = map {"$_\n"} split /\n/, $_;
3135 unshift @ls, "\n" x length($1) if /^(\n+)/;
3139 my $shift = shift(@eval);
3140 if ($shift =~ /^Date:\s+(.*)/){
3141 return if $date_of_03 eq $1;
3144 last if $shift =~ /^\s*$/;
3147 push @eval, q{CPAN::Modulelist->data;};
3149 my($comp) = Safe->new("CPAN::Safe1");
3150 my($eval) = join("", @eval);
3151 my $ret = $comp->reval($eval);
3152 Carp::confess($@) if $@;
3153 return if $CPAN::Signal;
3155 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3156 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3157 $obj->set(%{$ret->{$_}});
3158 return if $CPAN::Signal;
3162 #-> sub CPAN::Index::write_metadata_cache ;
3163 sub write_metadata_cache {
3165 return unless $CPAN::Config->{'cache_metadata'};
3166 return unless $CPAN::META->has_usable("Storable");
3168 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3169 CPAN::Distribution)) {
3170 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3172 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3173 $cache->{last_time} = $last_time;
3174 $cache->{PROTOCOL} = PROTOCOL;
3175 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3176 eval { Storable::nstore($cache, $metadata_file) };
3177 $CPAN::Frontend->mywarn($@) if $@;
3180 #-> sub CPAN::Index::read_metadata_cache ;
3181 sub read_metadata_cache {
3183 return unless $CPAN::Config->{'cache_metadata'};
3184 return unless $CPAN::META->has_usable("Storable");
3185 my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3186 return unless -r $metadata_file and -f $metadata_file;
3187 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3189 eval { $cache = Storable::retrieve($metadata_file) };
3190 $CPAN::Frontend->mywarn($@) if $@;
3191 if (!$cache || ref $cache ne 'HASH'){
3195 if (exists $cache->{PROTOCOL}) {
3196 if (PROTOCOL > $cache->{PROTOCOL}) {
3197 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3198 "with protocol v%s, requiring v%s",
3205 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3206 "with protocol v1.0");
3211 while(my($class,$v) = each %$cache) {
3212 next unless $class =~ /^CPAN::/;
3213 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3214 while (my($id,$ro) = each %$v) {
3215 $CPAN::META->{readwrite}{$class}{$id} ||=
3216 $class->new(ID=>$id, RO=>$ro);
3221 unless ($clcnt) { # sanity check
3222 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3225 if ($idcnt < 1000) {
3226 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3227 "in $metadata_file\n");
3230 $CPAN::META->{PROTOCOL} ||=
3231 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3232 # does initialize to some protocol
3233 $last_time = $cache->{last_time};
3236 package CPAN::InfoObj;
3239 sub cpan_userid { shift->{RO}{CPAN_USERID} }
3240 sub id { shift->{ID} }
3242 #-> sub CPAN::InfoObj::new ;
3244 my $this = bless {}, shift;
3249 # The set method may only be used by code that reads index data or
3250 # otherwise "objective" data from the outside world. All session
3251 # related material may do anything else with instance variables but
3252 # must not touch the hash under the RO attribute. The reason is that
3253 # the RO hash gets written to Metadata file and is thus persistent.
3255 #-> sub CPAN::InfoObj::set ;
3257 my($self,%att) = @_;
3258 my $class = ref $self;
3260 # This must be ||=, not ||, because only if we write an empty
3261 # reference, only then the set method will write into the readonly
3262 # area. But for Distributions that spring into existence, maybe
3263 # because of a typo, we do not like it that they are written into
3264 # the readonly area and made permanent (at least for a while) and
3265 # that is why we do not "allow" other places to call ->set.
3266 unless ($self->id) {
3267 CPAN->debug("Bug? Empty ID, rejecting");
3270 my $ro = $self->{RO} =
3271 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3273 while (my($k,$v) = each %att) {
3278 #-> sub CPAN::InfoObj::as_glimpse ;
3282 my $class = ref($self);
3283 $class =~ s/^CPAN:://;
3284 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3288 #-> sub CPAN::InfoObj::as_string ;
3292 my $class = ref($self);
3293 $class =~ s/^CPAN:://;
3294 push @m, $class, " id = $self->{ID}\n";
3295 for (sort keys %{$self->{RO}}) {
3296 # next if m/^(ID|RO)$/;
3298 if ($_ eq "CPAN_USERID") {
3299 $extra .= " (".$self->author;
3300 my $email; # old perls!
3301 if ($email = $CPAN::META->instance("CPAN::Author",
3304 $extra .= " <$email>";
3306 $extra .= " <no email>";
3309 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3310 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3313 next unless defined $self->{RO}{$_};
3314 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3316 for (sort keys %$self) {
3317 next if m/^(ID|RO)$/;
3318 if (ref($self->{$_}) eq "ARRAY") {
3319 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3320 } elsif (ref($self->{$_}) eq "HASH") {
3324 join(" ",keys %{$self->{$_}}),
3327 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3333 #-> sub CPAN::InfoObj::author ;
3336 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3339 #-> sub CPAN::InfoObj::dump ;
3342 require Data::Dumper;
3343 print Data::Dumper::Dumper($self);
3346 package CPAN::Author;
3348 #-> sub CPAN::Author::as_glimpse ;
3352 my $class = ref($self);
3353 $class =~ s/^CPAN:://;
3354 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3358 #-> sub CPAN::Author::fullname ;
3360 shift->{RO}{FULLNAME};
3364 #-> sub CPAN::Author::email ;
3365 sub email { shift->{RO}{EMAIL}; }
3371 # adapted from CPAN::Distribution::verifyMD5 ;
3373 @chksumfile = $self->id =~ /(.)(.)(.*)/;
3374 $chksumfile[1] = join "", @chksumfile[0,1];
3375 $chksumfile[2] = join "", @chksumfile[1,2];
3376 push @chksumfile, "CHECKSUMS";
3377 print join "", map {
3378 sprintf("%8d %10s %s\n", @$_)
3379 } sort { $a->[2] cmp $b->[2] } $self->dir_listing(\@chksumfile);
3384 my $chksumfile = shift;
3386 MM->catfile($CPAN::Config->{keep_source_where},
3387 "authors", "id", @$chksumfile);
3389 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3392 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3393 $chksumfile->[-1] .= ".gz";
3394 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3397 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3398 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3404 # adapted from CPAN::Distribution::MD5_check_file ;
3405 my $fh = FileHandle->new;
3407 if (open $fh, $lc_file){
3410 $eval =~ s/\015?\012/\n/g;
3412 my($comp) = Safe->new();
3413 $cksum = $comp->reval($eval);
3415 rename $lc_file, "$lc_file.bad";
3416 Carp::confess($@) if $@;
3419 Carp::carp "Could not open $lc_file for reading";
3422 for $f (sort keys %$cksum) {
3423 if (exists $cksum->{$f}{isdir}) {
3424 my(@dir) = @$chksumfile;
3426 push @dir, $f, "CHECKSUMS";
3428 [$_->[0], $_->[1], "$f/$_->[2]"]
3429 } $self->dir_listing(\@dir);
3432 ($cksum->{$f}{"size"}||0),
3433 $cksum->{$f}{"mtime"}||"---",
3441 package CPAN::Distribution;
3444 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3448 delete $self->{later};
3453 if ($s =~ tr|/|| == 1) {
3454 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3455 $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3456 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3461 #-> sub CPAN::Distribution::color_cmd_tmps ;
3462 sub color_cmd_tmps {
3464 my($depth) = shift || 0;
3465 my($color) = shift || 0;
3466 # a distribution needs to recurse into its prereq_pms
3468 return if exists $self->{incommandcolor}
3469 && $self->{incommandcolor}==$color;
3470 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3471 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3476 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3477 my $prereq_pm = $self->prereq_pm;
3478 if (defined $prereq_pm) {
3479 for my $pre (keys %$prereq_pm) {
3480 my $premo = CPAN::Shell->expand("Module",$pre);
3481 $premo->color_cmd_tmps($depth+1,$color);
3485 delete $self->{sponsored_mods};
3486 delete $self->{badtestcnt};
3488 $self->{incommandcolor} = $color;
3491 #-> sub CPAN::Distribution::as_string ;
3494 $self->containsmods;
3495 $self->SUPER::as_string(@_);
3498 #-> sub CPAN::Distribution::containsmods ;
3501 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3502 my $dist_id = $self->{ID};
3503 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3504 my $mod_file = $mod->cpan_file or next;
3505 my $mod_id = $mod->{ID} or next;
3506 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3508 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3510 keys %{$self->{CONTAINSMODS}};
3513 #-> sub CPAN::Distribution::called_for ;
3516 $self->{CALLED_FOR} = $id if defined $id;
3517 return $self->{CALLED_FOR};
3520 #-> sub CPAN::Distribution::get ;
3525 exists $self->{'build_dir'} and push @e,
3526 "Is already unwrapped into directory $self->{'build_dir'}";
3527 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3532 $CPAN::Config->{keep_source_where},
3535 split("/",$self->id)
3538 $self->debug("Doing localize") if $CPAN::DEBUG;
3539 my $CWD = CPAN::anycwd();
3541 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3542 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
3543 return if $CPAN::Signal;
3544 $self->{localfile} = $local_file;
3545 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3546 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3547 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3548 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3551 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3552 if ($CPAN::META->has_inst("MD5")) {
3553 $self->debug("MD5 is installed, verifying");
3556 $self->debug("MD5 is NOT installed");
3558 $self->debug("Removing tmp") if $CPAN::DEBUG;
3559 File::Path::rmtree("tmp");
3560 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3561 chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
3562 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
3563 return if $CPAN::Signal;
3564 if (! $local_file) {
3565 Carp::croak "bad download, can't do anything :-(\n";
3566 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3567 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3568 $self->untar_me($local_file);
3569 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3570 $self->unzip_me($local_file);
3571 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3572 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3573 $self->pm2dir_me($local_file);
3575 $self->{archived} = "NO";
3577 my $updir = File::Spec->updir;
3578 unless (chdir $updir) {
3579 my $cwd = CPAN::anycwd();
3580 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] to updir[$updir]: $!});
3582 if ($self->{archived} ne 'NO') {
3583 my $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
3584 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3585 # Let's check if the package has its own directory.
3586 my $dh = DirHandle->new(File::Spec->curdir)
3587 or Carp::croak("Couldn't opendir .: $!");
3588 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3590 my ($distdir,$packagedir);
3591 if (@readdir == 1 && -d $readdir[0]) {
3592 $distdir = $readdir[0];
3593 $packagedir = MM->catdir($builddir,$distdir);
3594 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3596 File::Path::rmtree($packagedir);
3597 rename($distdir,$packagedir) or
3598 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3600 my $userid = $self->cpan_userid;
3602 CPAN->debug("no userid? self[$self]");
3605 my $pragmatic_dir = $userid . '000';
3606 $pragmatic_dir =~ s/\W_//g;
3607 $pragmatic_dir++ while -d "../$pragmatic_dir";
3608 $packagedir = MM->catdir($builddir,$pragmatic_dir);
3609 File::Path::mkpath($packagedir);
3611 for $f (@readdir) { # is already without "." and ".."
3612 my $to = MM->catdir($packagedir,$f);
3613 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3616 $self->{'build_dir'} = $packagedir;
3618 unless (chdir $updir) {
3619 my $cwd = CPAN::anycwd();
3620 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] to updir[$updir]: $!});
3623 $self->debug("Changed directory to .. (self[$self]=[".
3624 $self->as_string."])") if $CPAN::DEBUG;
3625 File::Path::rmtree("tmp");
3626 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
3627 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
3628 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3630 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
3631 unless (-f $makefilepl) {
3632 my($configure) = MM->catfile($packagedir,"Configure");
3633 if (-f $configure) {
3634 # do we have anything to do?
3635 $self->{'configure'} = $configure;
3636 } elsif (-f MM->catfile($packagedir,"Makefile")) {
3637 $CPAN::Frontend->myprint(qq{
3638 Package comes with a Makefile and without a Makefile.PL.
3639 We\'ll try to build it with that Makefile then.
3641 $self->{writemakefile} = "YES";
3644 my $cf = $self->called_for || "unknown";
3649 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3650 $cf = "unknown" unless length($cf);
3651 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
3652 Writing one on our own (calling it $cf)\n});
3653 $self->{had_no_makefile_pl}++;
3654 my $fh = FileHandle->new(">$makefilepl")
3655 or Carp::croak("Could not open >$makefilepl");
3657 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3658 # because there was no Makefile.PL supplied.
3659 # Autogenerated on: }.scalar localtime().qq{
3661 use ExtUtils::MakeMaker;
3662 WriteMakefile(NAME => q[$cf]);
3669 chdir $CWD or die "Could not chdir to $CWD: $!";
3673 # CPAN::Distribution::untar_me ;
3675 my($self,$local_file) = @_;
3676 $self->{archived} = "tar";
3677 if (CPAN::Tarzip->untar($local_file)) {
3678 $self->{unwrapped} = "YES";
3680 $self->{unwrapped} = "NO";
3684 # CPAN::Distribution::unzip_me ;
3686 my($self,$local_file) = @_;
3687 $self->{archived} = "zip";
3688 if (CPAN::Tarzip->unzip($local_file)) {
3689 $self->{unwrapped} = "YES";
3691 $self->{unwrapped} = "NO";
3697 my($self,$local_file) = @_;
3698 $self->{archived} = "pm";
3699 my $to = File::Basename::basename($local_file);
3700 $to =~ s/\.(gz|Z)(?!\n)\Z//;
3701 if (CPAN::Tarzip->gunzip($local_file,$to)) {
3702 $self->{unwrapped} = "YES";
3704 $self->{unwrapped} = "NO";
3708 #-> sub CPAN::Distribution::new ;
3710 my($class,%att) = @_;
3712 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3714 my $this = { %att };
3715 return bless $this, $class;
3718 #-> sub CPAN::Distribution::look ;
3722 if ($^O eq 'MacOS') {
3723 $self->ExtUtils::MM_MacOS::look;
3727 if ( $CPAN::Config->{'shell'} ) {
3728 $CPAN::Frontend->myprint(qq{
3729 Trying to open a subshell in the build directory...
3732 $CPAN::Frontend->myprint(qq{
3733 Your configuration does not define a value for subshells.
3734 Please define it with "o conf shell <your shell>"
3738 my $dist = $self->id;
3739 my $dir = $self->dir or $self->get;
3741 my $pwd = CPAN::anycwd();
3742 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3743 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3744 system($CPAN::Config->{'shell'}) == 0
3745 or $CPAN::Frontend->mydie("Subprocess shell error");
3746 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3749 # CPAN::Distribution::cvs_import ;
3753 my $dir = $self->dir;
3755 my $package = $self->called_for;
3756 my $module = $CPAN::META->instance('CPAN::Module', $package);
3757 my $version = $module->cpan_version;
3759 my $userid = $self->cpan_userid;
3761 my $cvs_dir = (split '/', $dir)[-1];
3762 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
3764 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3766 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3767 if ($cvs_site_perl) {
3768 $cvs_dir = "$cvs_site_perl/$cvs_dir";
3770 my $cvs_log = qq{"imported $package $version sources"};
3771 $version =~ s/\./_/g;
3772 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3773 "$cvs_dir", $userid, "v$version");
3775 my $pwd = CPAN::anycwd();
3776 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3778 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3780 $CPAN::Frontend->myprint(qq{@cmd\n});
3781 system(@cmd) == 0 or
3782 $CPAN::Frontend->mydie("cvs import failed");
3783 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3786 #-> sub CPAN::Distribution::readme ;
3789 my($dist) = $self->id;
3790 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3791 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3795 $CPAN::Config->{keep_source_where},
3798 split("/","$sans.readme"),
3800 $self->debug("Doing localize") if $CPAN::DEBUG;
3801 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3803 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3805 if ($^O eq 'MacOS') {
3806 ExtUtils::MM_MacOS::launch_file($local_file);
3810 my $fh_pager = FileHandle->new;
3811 local($SIG{PIPE}) = "IGNORE";
3812 $fh_pager->open("|$CPAN::Config->{'pager'}")
3813 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3814 my $fh_readme = FileHandle->new;
3815 $fh_readme->open($local_file)
3816 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3817 $CPAN::Frontend->myprint(qq{
3820 with pager "$CPAN::Config->{'pager'}"
3823 $fh_pager->print(<$fh_readme>);
3826 #-> sub CPAN::Distribution::verifyMD5 ;
3831 $self->{MD5_STATUS} ||= "";
3832 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3833 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3835 my($lc_want,$lc_file,@local,$basename);
3836 @local = split("/",$self->id);
3838 push @local, "CHECKSUMS";
3840 MM->catfile($CPAN::Config->{keep_source_where},
3841 "authors", "id", @local);
3846 $self->MD5_check_file($lc_want)
3848 return $self->{MD5_STATUS} = "OK";
3850 $lc_file = CPAN::FTP->localize("authors/id/@local",
3853 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3854 $local[-1] .= ".gz";
3855 $lc_file = CPAN::FTP->localize("authors/id/@local",
3858 $lc_file =~ s/\.gz(?!\n)\Z//;
3859 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3864 $self->MD5_check_file($lc_file);
3867 #-> sub CPAN::Distribution::MD5_check_file ;
3868 sub MD5_check_file {
3869 my($self,$chk_file) = @_;
3870 my($cksum,$file,$basename);
3871 $file = $self->{localfile};
3872 $basename = File::Basename::basename($file);
3873 my $fh = FileHandle->new;
3874 if (open $fh, $chk_file){
3877 $eval =~ s/\015?\012/\n/g;
3879 my($comp) = Safe->new();
3880 $cksum = $comp->reval($eval);
3882 rename $chk_file, "$chk_file.bad";
3883 Carp::confess($@) if $@;
3886 Carp::carp "Could not open $chk_file for reading";
3889 if (exists $cksum->{$basename}{md5}) {
3890 $self->debug("Found checksum for $basename:" .
3891 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3895 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3897 $fh = CPAN::Tarzip->TIEHANDLE($file);
3900 # had to inline it, when I tied it, the tiedness got lost on
3901 # the call to eq_MD5. (Jan 1998)
3905 while ($fh->READ($ref, 4096) > 0){
3908 my $hexdigest = $md5->hexdigest;
3909 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3913 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3914 return $self->{MD5_STATUS} = "OK";
3916 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
3917 qq{distribution file. }.
3918 qq{Please investigate.\n\n}.
3920 $CPAN::META->instance(
3925 my $wrap = qq{I\'d recommend removing $file. Its MD5
3926 checksum is incorrect. Maybe you have configured your 'urllist' with
3927 a bad URL. Please check this array with 'o conf urllist', and
3930 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
3932 # former versions just returned here but this seems a
3933 # serious threat that deserves a die
3935 # $CPAN::Frontend->myprint("\n\n");
3939 # close $fh if fileno($fh);
3941 $self->{MD5_STATUS} ||= "";
3942 if ($self->{MD5_STATUS} eq "NIL") {
3943 $CPAN::Frontend->mywarn(qq{
3944 Warning: No md5 checksum for $basename in $chk_file.
3946 The cause for this may be that the file is very new and the checksum
3947 has not yet been calculated, but it may also be that something is
3948 going awry right now.
3950 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
3951 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
3953 $self->{MD5_STATUS} = "NIL";
3958 #-> sub CPAN::Distribution::eq_MD5 ;
3960 my($self,$fh,$expectMD5) = @_;
3963 while (read($fh, $data, 4096)){
3966 # $md5->addfile($fh);
3967 my $hexdigest = $md5->hexdigest;
3968 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3969 $hexdigest eq $expectMD5;
3972 #-> sub CPAN::Distribution::force ;
3974 # Both modules and distributions know if "force" is in effect by
3975 # autoinspection, not by inspecting a global variable. One of the
3976 # reason why this was chosen to work that way was the treatment of
3977 # dependencies. They should not autpomatically inherit the force
3978 # status. But this has the downside that ^C and die() will return to
3979 # the prompt but will not be able to reset the force_update
3980 # attributes. We try to correct for it currently in the read_metadata
3981 # routine, and immediately before we check for a Signal. I hope this
3982 # works out in one of v1.57_53ff
3985 my($self, $method) = @_;
3987 MD5_STATUS archived build_dir localfile make install unwrapped
3990 delete $self->{$att};
3992 if ($method && $method eq "install") {
3993 $self->{"force_update"}++; # name should probably have been force_install
3997 #-> sub CPAN::Distribution::unforce ;
4000 delete $self->{'force_update'};
4003 #-> sub CPAN::Distribution::isa_perl ;
4006 my $file = File::Basename::basename($self->id);
4007 if ($file =~ m{ ^ perl
4020 } elsif ($self->cpan_comment
4022 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4027 #-> sub CPAN::Distribution::perl ;
4030 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
4031 my $pwd = CPAN::anycwd();
4032 my $candidate = MM->catfile($pwd,$^X);
4033 $perl ||= $candidate if MM->maybe_command($candidate);
4035 my ($component,$perl_name);
4036 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4037 PATH_COMPONENT: foreach $component (MM->path(),
4038 $Config::Config{'binexp'}) {
4039 next unless defined($component) && $component;
4040 my($abs) = MM->catfile($component,$perl_name);
4041 if (MM->maybe_command($abs)) {
4051 #-> sub CPAN::Distribution::make ;
4054 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4055 # Emergency brake if they said install Pippi and get newest perl
4056 if ($self->isa_perl) {
4058 $self->called_for ne $self->id &&
4059 ! $self->{force_update}
4061 # if we die here, we break bundles
4062 $CPAN::Frontend->mywarn(sprintf qq{
4063 The most recent version "%s" of the module "%s"
4064 comes with the current version of perl (%s).
4065 I\'ll build that only if you ask for something like
4070 $CPAN::META->instance(
4084 $self->{archived} eq "NO" and push @e,
4085 "Is neither a tar nor a zip archive.";
4087 $self->{unwrapped} eq "NO" and push @e,
4088 "had problems unarchiving. Please build manually";
4090 exists $self->{writemakefile} &&
4091 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4092 $1 || "Had some problem writing Makefile";
4094 defined $self->{'make'} and push @e,
4095 "Has already been processed within this session";
4097 exists $self->{later} and length($self->{later}) and
4098 push @e, $self->{later};
4100 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4102 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4103 my $builddir = $self->dir;
4104 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4105 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4107 if ($^O eq 'MacOS') {
4108 ExtUtils::MM_MacOS::make($self);
4113 if ($self->{'configure'}) {
4114 $system = $self->{'configure'};
4116 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4118 # This needs a handler that can be turned on or off:
4119 # $switch = "-MExtUtils::MakeMaker ".
4120 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4122 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4124 unless (exists $self->{writemakefile}) {
4125 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4128 if ($CPAN::Config->{inactivity_timeout}) {
4130 alarm $CPAN::Config->{inactivity_timeout};
4131 local $SIG{CHLD}; # = sub { wait };
4132 if (defined($pid = fork)) {
4137 # note, this exec isn't necessary if
4138 # inactivity_timeout is 0. On the Mac I'd
4139 # suggest, we set it always to 0.
4143 $CPAN::Frontend->myprint("Cannot fork: $!");
4151 $CPAN::Frontend->myprint($@);
4152 $self->{writemakefile} = "NO $@";
4157 $ret = system($system);
4159 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4163 if (-f "Makefile") {
4164 $self->{writemakefile} = "YES";
4165 delete $self->{make_clean}; # if cleaned before, enable next
4167 $self->{writemakefile} =
4168 qq{NO Makefile.PL refused to write a Makefile.};
4169 # It's probably worth to record the reason, so let's retry
4171 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4172 # $self->{writemakefile} .= <$fh>;
4176 delete $self->{force_update};
4179 if (my @prereq = $self->unsat_prereq){
4180 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4182 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4183 if (system($system) == 0) {
4184 $CPAN::Frontend->myprint(" $system -- OK\n");
4185 $self->{'make'} = "YES";
4187 $self->{writemakefile} ||= "YES";
4188 $self->{'make'} = "NO";
4189 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4193 sub follow_prereqs {
4197 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4198 "during [$id] -----\n");
4200 for my $p (@prereq) {
4201 $CPAN::Frontend->myprint(" $p\n");
4204 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4206 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4207 require ExtUtils::MakeMaker;
4208 my $answer = ExtUtils::MakeMaker::prompt(
4209 "Shall I follow them and prepend them to the queue
4210 of modules we are processing right now?", "yes");
4211 $follow = $answer =~ /^\s*y/i;
4215 myprint(" Ignoring dependencies on modules @prereq\n");
4218 # color them as dirty
4219 for my $p (@prereq) {
4220 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4222 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4223 $self->{later} = "Delayed until after prerequisites";
4224 return 1; # signal success to the queuerunner
4228 #-> sub CPAN::Distribution::unsat_prereq ;
4231 my $prereq_pm = $self->prereq_pm or return;
4233 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4234 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4235 # we were too demanding:
4236 next if $nmo->uptodate;
4238 # if they have not specified a version, we accept any installed one
4239 if (not defined $need_version or
4240 $need_version == 0 or
4241 $need_version eq "undef") {
4242 next if defined $nmo->inst_file;
4245 # We only want to install prereqs if either they're not installed
4246 # or if the installed version is too old. We cannot omit this
4247 # check, because if 'force' is in effect, nobody else will check.
4251 defined $nmo->inst_file &&
4252 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4254 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4258 CPAN::Version->readable($need_version)
4264 if ($self->{sponsored_mods}{$need_module}++){
4265 # We have already sponsored it and for some reason it's still
4266 # not available. So we do nothing. Or what should we do?
4267 # if we push it again, we have a potential infinite loop
4270 push @need, $need_module;
4275 #-> sub CPAN::Distribution::prereq_pm ;
4278 return $self->{prereq_pm} if
4279 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4280 return unless $self->{writemakefile}; # no need to have succeeded
4281 # but we must have run it
4282 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4283 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4288 $fh = FileHandle->new("<$makefile\0")) {
4292 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4294 last if /MakeMaker post_initialize section/;
4296 \s+PREREQ_PM\s+=>\s+(.+)
4299 # warn "Found prereq expr[$p]";
4301 # Regexp modified by A.Speer to remember actual version of file
4302 # PREREQ_PM hash key wants, then add to
4303 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4304 # In case a prereq is mentioned twice, complain.
4305 if ( defined $p{$1} ) {
4306 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4313 $self->{prereq_pm_detected}++;
4314 return $self->{prereq_pm} = \%p;
4317 #-> sub CPAN::Distribution::test ;
4322 delete $self->{force_update};
4325 $CPAN::Frontend->myprint("Running make test\n");
4326 if (my @prereq = $self->unsat_prereq){
4327 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4331 exists $self->{make} or exists $self->{later} or push @e,
4332 "Make had some problems, maybe interrupted? Won't test";
4334 exists $self->{'make'} and
4335 $self->{'make'} eq 'NO' and
4336 push @e, "Can't test without successful make";
4338 exists $self->{build_dir} or push @e, "Has no own directory";
4339 $self->{badtestcnt} ||= 0;
4340 $self->{badtestcnt} > 0 and
4341 push @e, "Won't repeat unsuccessful test during this command";
4343 exists $self->{later} and length($self->{later}) and
4344 push @e, $self->{later};
4346 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4348 chdir $self->{'build_dir'} or
4349 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4350 $self->debug("Changed directory to $self->{'build_dir'}")
4353 if ($^O eq 'MacOS') {
4354 ExtUtils::MM_MacOS::make_test($self);
4358 my $system = join " ", $CPAN::Config->{'make'}, "test";
4359 if (system($system) == 0) {
4360 $CPAN::Frontend->myprint(" $system -- OK\n");
4361 $self->{make_test} = "YES";
4363 $self->{make_test} = "NO";
4364 $self->{badtestcnt}++;
4365 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4369 #-> sub CPAN::Distribution::clean ;
4372 $CPAN::Frontend->myprint("Running make clean\n");
4375 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4376 push @e, "make clean already called once";
4377 exists $self->{build_dir} or push @e, "Has no own directory";
4378 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4380 chdir $self->{'build_dir'} or
4381 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4382 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4384 if ($^O eq 'MacOS') {
4385 ExtUtils::MM_MacOS::make_clean($self);
4389 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4390 if (system($system) == 0) {
4391 $CPAN::Frontend->myprint(" $system -- OK\n");
4395 # Jost Krieger pointed out that this "force" was wrong because
4396 # it has the effect that the next "install" on this distribution
4397 # will untar everything again. Instead we should bring the
4398 # object's state back to where it is after untarring.
4400 delete $self->{force_update};
4401 delete $self->{install};
4402 delete $self->{writemakefile};
4403 delete $self->{make};
4404 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4405 $self->{make_clean} = "YES";
4408 # Hmmm, what to do if make clean failed?
4410 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4412 make clean did not succeed, marking directory as unusable for further work.
4414 $self->force("make"); # so that this directory won't be used again
4419 #-> sub CPAN::Distribution::install ;
4424 delete $self->{force_update};
4427 $CPAN::Frontend->myprint("Running make install\n");
4430 exists $self->{build_dir} or push @e, "Has no own directory";
4432 exists $self->{make} or exists $self->{later} or push @e,
4433 "Make had some problems, maybe interrupted? Won't install";
4435 exists $self->{'make'} and
4436 $self->{'make'} eq 'NO' and
4437 push @e, "make had returned bad status, install seems impossible";
4439 push @e, "make test had returned bad status, ".
4440 "won't install without force"
4441 if exists $self->{'make_test'} and
4442 $self->{'make_test'} eq 'NO' and
4443 ! $self->{'force_update'};
4445 exists $self->{'install'} and push @e,
4446 $self->{'install'} eq "YES" ?
4447 "Already done" : "Already tried without success";
4449 exists $self->{later} and length($self->{later}) and
4450 push @e, $self->{later};
4452 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4454 chdir $self->{'build_dir'} or
4455 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4456 $self->debug("Changed directory to $self->{'build_dir'}")
4459 if ($^O eq 'MacOS') {
4460 ExtUtils::MM_MacOS::make_install($self);
4464 my $system = join(" ", $CPAN::Config->{'make'},
4465 "install", $CPAN::Config->{make_install_arg});
4466 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4467 my($pipe) = FileHandle->new("$system $stderr |");
4470 $CPAN::Frontend->myprint($_);
4475 $CPAN::Frontend->myprint(" $system -- OK\n");
4476 return $self->{'install'} = "YES";
4478 $self->{'install'} = "NO";
4479 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4480 if ($makeout =~ /permission/s && $> > 0) {
4481 $CPAN::Frontend->myprint(qq{ You may have to su }.
4482 qq{to root to install the package\n});
4485 delete $self->{force_update};
4488 #-> sub CPAN::Distribution::dir ;
4490 shift->{'build_dir'};
4493 package CPAN::Bundle;
4497 delete $self->{later};
4498 for my $c ( $self->contains ) {
4499 my $obj = CPAN::Shell->expandany($c) or next;
4504 #-> sub CPAN::Bundle::color_cmd_tmps ;
4505 sub color_cmd_tmps {
4507 my($depth) = shift || 0;
4508 my($color) = shift || 0;
4509 # a module needs to recurse to its cpan_file, a distribution needs
4510 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4512 return if exists $self->{incommandcolor}
4513 && $self->{incommandcolor}==$color;
4514 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4515 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4520 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4522 for my $c ( $self->contains ) {
4523 my $obj = CPAN::Shell->expandany($c) or next;
4524 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4525 $obj->color_cmd_tmps($depth+1,$color);
4528 delete $self->{badtestcnt};
4530 $self->{incommandcolor} = $color;
4533 #-> sub CPAN::Bundle::as_string ;
4537 # following line must be "=", not "||=" because we have a moving target
4538 $self->{INST_VERSION} = $self->inst_version;
4539 return $self->SUPER::as_string;
4542 #-> sub CPAN::Bundle::contains ;
4545 my($parsefile) = $self->inst_file;
4546 my($id) = $self->id;
4547 $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
4548 unless ($parsefile) {
4549 # Try to get at it in the cpan directory
4550 $self->debug("no parsefile") if $CPAN::DEBUG;
4551 Carp::confess "I don't know a $id" unless $self->cpan_file;
4552 my $dist = $CPAN::META->instance('CPAN::Distribution',
4555 $self->debug($dist->as_string) if $CPAN::DEBUG;
4556 my($todir) = $CPAN::Config->{'cpan_home'};
4557 my(@me,$from,$to,$me);
4558 @me = split /::/, $self->id;
4560 $me = MM->catfile(@me);
4561 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4562 $to = MM->catfile($todir,$me);
4563 File::Path::mkpath(File::Basename::dirname($to));
4564 File::Copy::copy($from, $to)
4565 or Carp::confess("Couldn't copy $from to $to: $!");
4569 my $fh = FileHandle->new;
4571 open($fh,$parsefile) or die "Could not open '$parsefile': $!";
4573 $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
4575 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4576 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4577 next unless $in_cont;
4582 push @result, (split " ", $_, 2)[0];
4585 delete $self->{STATUS};
4586 $self->{CONTAINS} = \@result;
4587 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4589 $CPAN::Frontend->mywarn(qq{
4590 The bundle file "$parsefile" may be a broken
4591 bundlefile. It seems not to contain any bundle definition.
4592 Please check the file and if it is bogus, please delete it.
4593 Sorry for the inconvenience.
4599 #-> sub CPAN::Bundle::find_bundle_file
4600 sub find_bundle_file {
4601 my($self,$where,$what) = @_;
4602 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4603 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4604 ### my $bu = MM->catfile($where,$what);
4605 ### return $bu if -f $bu;
4606 my $manifest = MM->catfile($where,"MANIFEST");
4607 unless (-f $manifest) {
4608 require ExtUtils::Manifest;
4609 my $cwd = CPAN::anycwd();
4610 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4611 ExtUtils::Manifest::mkmanifest();
4612 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4614 my $fh = FileHandle->new($manifest)
4615 or Carp::croak("Couldn't open $manifest: $!");
4618 if ($^O eq 'MacOS') {
4621 $what2 =~ s/:Bundle://;
4624 $what2 =~ s|Bundle[/\\]||;
4629 my($file) = /(\S+)/;
4630 if ($file =~ m|\Q$what\E$|) {
4632 # return MM->catfile($where,$bu); # bad
4635 # retry if she managed to
4636 # have no Bundle directory
4637 $bu = $file if $file =~ m|\Q$what2\E$|;
4639 $bu =~ tr|/|:| if $^O eq 'MacOS';
4640 return MM->catfile($where, $bu) if $bu;
4641 Carp::croak("Couldn't find a Bundle file in $where");
4644 # needs to work slightly different from Module::inst_file because of
4645 # cpan_home/Bundle/ directory.
4647 #-> sub CPAN::Bundle::inst_file ;
4650 return $self->{INST_FILE} if
4651 exists $self->{INST_FILE} && $self->{INST_FILE};
4654 @me = split /::/, $self->id;
4656 $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, @me);
4657 return $self->{INST_FILE} = $inst_file if -f $inst_file;
4658 $self->SUPER::inst_file;
4661 #-> sub CPAN::Bundle::rematein ;
4663 my($self,$meth) = @_;
4664 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4665 my($id) = $self->id;
4666 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4667 unless $self->inst_file || $self->cpan_file;
4669 for $s ($self->contains) {
4670 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4671 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4672 if ($type eq 'CPAN::Distribution') {
4673 $CPAN::Frontend->mywarn(qq{
4674 The Bundle }.$self->id.qq{ contains
4675 explicitly a file $s.
4679 # possibly noisy action:
4680 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4681 my $obj = $CPAN::META->instance($type,$s);
4683 if ($obj->isa(CPAN::Bundle)
4685 exists $obj->{install_failed}
4687 ref($obj->{install_failed}) eq "HASH"
4689 for (keys %{$obj->{install_failed}}) {
4690 $self->{install_failed}{$_} = undef; # propagate faiure up
4693 $fail{$s} = 1; # the bundle itself may have succeeded but
4698 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4699 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4701 delete $self->{install_failed}{$s};
4708 # recap with less noise
4709 if ( $meth eq "install" ) {
4712 my $raw = sprintf(qq{Bundle summary:
4713 The following items in bundle %s had installation problems:},
4716 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4717 $CPAN::Frontend->myprint("\n");
4720 for $s ($self->contains) {
4722 $paragraph .= "$s ";
4723 $self->{install_failed}{$s} = undef;
4724 $reported{$s} = undef;
4727 my $report_propagated;
4728 for $s (sort keys %{$self->{install_failed}}) {
4729 next if exists $reported{$s};
4730 $paragraph .= "and the following items had problems
4731 during recursive bundle calls: " unless $report_propagated++;
4732 $paragraph .= "$s ";
4734 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
4735 $CPAN::Frontend->myprint("\n");
4737 $self->{'install'} = 'YES';
4742 #sub CPAN::Bundle::xs_file
4744 # If a bundle contains another that contains an xs_file we have
4745 # here, we just don't bother I suppose
4749 #-> sub CPAN::Bundle::force ;
4750 sub force { shift->rematein('force',@_); }
4751 #-> sub CPAN::Bundle::get ;
4752 sub get { shift->rematein('get',@_); }
4753 #-> sub CPAN::Bundle::make ;
4754 sub make { shift->rematein('make',@_); }
4755 #-> sub CPAN::Bundle::test ;
4758 $self->{badtestcnt} ||= 0;
4759 $self->rematein('test',@_);
4761 #-> sub CPAN::Bundle::install ;
4764 $self->rematein('install',@_);
4766 #-> sub CPAN::Bundle::clean ;
4767 sub clean { shift->rematein('clean',@_); }
4769 #-> sub CPAN::Bundle::readme ;
4772 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
4773 No File found for bundle } . $self->id . qq{\n}), return;
4774 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
4775 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
4778 package CPAN::Module;
4781 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
4784 return unless exists $self->{RO}; # should never happen
4785 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
4787 sub description { shift->{RO}{description} }
4791 delete $self->{later};
4792 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
4797 #-> sub CPAN::Module::color_cmd_tmps ;
4798 sub color_cmd_tmps {
4800 my($depth) = shift || 0;
4801 my($color) = shift || 0;
4802 # a module needs to recurse to its cpan_file
4804 return if exists $self->{incommandcolor}
4805 && $self->{incommandcolor}==$color;
4806 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4807 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4812 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4814 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
4815 $dist->color_cmd_tmps($depth+1,$color);
4818 delete $self->{badtestcnt};
4820 $self->{incommandcolor} = $color;
4823 #-> sub CPAN::Module::as_glimpse ;
4827 my $class = ref($self);
4828 $class =~ s/^CPAN:://;
4832 $CPAN::Shell::COLOR_REGISTERED
4834 $CPAN::META->has_inst("Term::ANSIColor")
4836 $self->{RO}{description}
4838 $color_on = Term::ANSIColor::color("green");
4839 $color_off = Term::ANSIColor::color("reset");
4841 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
4850 #-> sub CPAN::Module::as_string ;
4854 CPAN->debug($self) if $CPAN::DEBUG;
4855 my $class = ref($self);
4856 $class =~ s/^CPAN:://;
4858 push @m, $class, " id = $self->{ID}\n";
4859 my $sprintf = " %-12s %s\n";
4860 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
4861 if $self->description;
4862 my $sprintf2 = " %-12s %s (%s)\n";
4864 if ($userid = $self->cpan_userid || $self->userid){
4866 if ($author = CPAN::Shell->expand('Author',$userid)) {
4869 if ($m = $author->email) {
4876 $author->fullname . $email
4880 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
4881 if $self->cpan_version;
4882 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
4883 if $self->cpan_file;
4884 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
4885 my(%statd,%stats,%statl,%stati);
4886 @statd{qw,? i c a b R M S,} = qw,unknown idea
4887 pre-alpha alpha beta released mature standard,;
4888 @stats{qw,? m d u n,} = qw,unknown mailing-list
4889 developer comp.lang.perl.* none,;
4890 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
4891 @stati{qw,? f r O h,} = qw,unknown functions
4892 references+ties object-oriented hybrid,;
4893 $statd{' '} = 'unknown';
4894 $stats{' '} = 'unknown';
4895 $statl{' '} = 'unknown';
4896 $stati{' '} = 'unknown';
4904 $statd{$self->{RO}{statd}},
4905 $stats{$self->{RO}{stats}},
4906 $statl{$self->{RO}{statl}},
4907 $stati{$self->{RO}{stati}}
4908 ) if $self->{RO}{statd};
4909 my $local_file = $self->inst_file;
4910 unless ($self->{MANPAGE}) {
4912 $self->{MANPAGE} = $self->manpage_headline($local_file);
4914 # If we have already untarred it, we should look there
4915 my $dist = $CPAN::META->instance('CPAN::Distribution',
4917 # warn "dist[$dist]";
4918 # mff=manifest file; mfh=manifest handle
4920 if ($dist->{build_dir} and
4921 -f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")) and
4922 $mfh = FileHandle->new($mff)
4924 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
4925 my $lfre = $self->id; # local file RE
4928 my($lfl); # local file file
4930 my(@mflines) = <$mfh>;
4935 while (length($lfre)>5 and !$lfl) {
4936 ($lfl) = grep /$lfre/, @mflines;
4937 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
4940 $lfl =~ s/\s.*//; # remove comments
4941 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
4942 my $lfl_abs = MM->catfile($dist->{build_dir},$lfl);
4943 # warn "lfl_abs[$lfl_abs]";
4945 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
4951 for $item (qw/MANPAGE/) {
4952 push @m, sprintf($sprintf, $item, $self->{$item})
4953 if exists $self->{$item};
4955 for $item (qw/CONTAINS/) {
4956 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
4957 if exists $self->{$item} && @{$self->{$item}};
4959 push @m, sprintf($sprintf, 'INST_FILE',
4960 $local_file || "(not installed)");
4961 push @m, sprintf($sprintf, 'INST_VERSION',
4962 $self->inst_version) if $local_file;
4966 sub manpage_headline {
4967 my($self,$local_file) = @_;
4968 my(@local_file) = $local_file;
4969 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
4970 push @local_file, $local_file;
4972 for $locf (@local_file) {
4973 next unless -f $locf;
4974 my $fh = FileHandle->new($locf)
4975 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
4979 $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
4980 m/^=head1\s+NAME/ ? 1 : $inpod;
4993 #-> sub CPAN::Module::cpan_file ;
4996 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
4997 unless (defined $self->{RO}{CPAN_FILE}) {
4998 CPAN::Index->reload;
5000 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5001 return $self->{RO}{CPAN_FILE};
5003 my $userid = $self->userid;
5005 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5006 my $author = $CPAN::META->instance("CPAN::Author",
5008 my $fullname = $author->fullname;
5009 my $email = $author->email;
5010 unless (defined $fullname && defined $email) {
5011 return sprintf("Contact Author %s",
5015 return "Contact Author $fullname <$email>";
5017 return "UserID $userid";
5025 #-> sub CPAN::Module::cpan_version ;
5029 $self->{RO}{CPAN_VERSION} = 'undef'
5030 unless defined $self->{RO}{CPAN_VERSION};
5031 # I believe this is always a bug in the index and should be reported
5032 # as such, but usually I find out such an error and do not want to
5033 # provoke too many bugreports
5035 $self->{RO}{CPAN_VERSION};
5038 #-> sub CPAN::Module::force ;
5041 $self->{'force_update'}++;
5044 #-> sub CPAN::Module::rematein ;
5046 my($self,$meth) = @_;
5047 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5050 my $cpan_file = $self->cpan_file;
5051 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5052 $CPAN::Frontend->mywarn(sprintf qq{
5053 The module %s isn\'t available on CPAN.
5055 Either the module has not yet been uploaded to CPAN, or it is
5056 temporary unavailable. Please contact the author to find out
5057 more about the status. Try 'i %s'.
5064 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5065 $pack->called_for($self->id);
5066 $pack->force($meth) if exists $self->{'force_update'};
5068 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5069 delete $self->{'force_update'};
5072 #-> sub CPAN::Module::readme ;
5073 sub readme { shift->rematein('readme') }
5074 #-> sub CPAN::Module::look ;
5075 sub look { shift->rematein('look') }
5076 #-> sub CPAN::Module::cvs_import ;
5077 sub cvs_import { shift->rematein('cvs_import') }
5078 #-> sub CPAN::Module::get ;
5079 sub get { shift->rematein('get',@_); }
5080 #-> sub CPAN::Module::make ;
5083 $self->rematein('make');
5085 #-> sub CPAN::Module::test ;
5088 $self->{badtestcnt} ||= 0;
5089 $self->rematein('test',@_);
5091 #-> sub CPAN::Module::uptodate ;
5094 my($latest) = $self->cpan_version;
5096 my($inst_file) = $self->inst_file;
5098 if (defined $inst_file) {
5099 $have = $self->inst_version;
5104 ! CPAN::Version->vgt($latest, $have)
5106 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5107 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5112 #-> sub CPAN::Module::install ;
5118 not exists $self->{'force_update'}
5120 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5124 $self->rematein('install') if $doit;
5126 #-> sub CPAN::Module::clean ;
5127 sub clean { shift->rematein('clean') }
5129 #-> sub CPAN::Module::inst_file ;
5133 @packpath = split /::/, $self->{ID};
5134 $packpath[-1] .= ".pm";
5135 foreach $dir (@INC) {
5136 my $pmfile = MM->catfile($dir,@packpath);
5144 #-> sub CPAN::Module::xs_file ;
5148 @packpath = split /::/, $self->{ID};
5149 push @packpath, $packpath[-1];
5150 $packpath[-1] .= "." . $Config::Config{'dlext'};
5151 foreach $dir (@INC) {
5152 my $xsfile = MM->catfile($dir,'auto',@packpath);
5160 #-> sub CPAN::Module::inst_version ;
5163 my $parsefile = $self->inst_file or return;
5164 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5167 # there was a bug in 5.6.0 that let lots of unini warnings out of
5168 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5169 # the following workaround after 5.6.1 is out.
5170 local($SIG{__WARN__}) = sub { my $w = shift;
5171 return if $w =~ /uninitialized/i;
5175 $have = MM->parse_version($parsefile) || "undef";
5176 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5177 $have =~ s/ $//; # trailing whitespace happens all the time
5179 # My thoughts about why %vd processing should happen here
5181 # Alt1 maintain it as string with leading v:
5182 # read index files do nothing
5183 # compare it use utility for compare
5184 # print it do nothing
5186 # Alt2 maintain it as what is is
5187 # read index files convert
5188 # compare it use utility because there's still a ">" vs "gt" issue
5189 # print it use CPAN::Version for print
5191 # Seems cleaner to hold it in memory as a string starting with a "v"
5193 # If the author of this module made a mistake and wrote a quoted
5194 # "v1.13" instead of v1.13, we simply leave it at that with the
5195 # effect that *we* will treat it like a v-tring while the rest of
5196 # perl won't. Seems sensible when we consider that any action we
5197 # could take now would just add complexity.
5199 $have = CPAN::Version->readable($have);
5201 $have =~ s/\s*//g; # stringify to float around floating point issues
5202 $have; # no stringify needed, \s* above matches always
5205 package CPAN::Tarzip;
5207 # CPAN::Tarzip::gzip
5209 my($class,$read,$write) = @_;
5210 if ($CPAN::META->has_inst("Compress::Zlib")) {
5212 $fhw = FileHandle->new($read)
5213 or $CPAN::Frontend->mydie("Could not open $read: $!");
5214 my $gz = Compress::Zlib::gzopen($write, "wb")
5215 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5216 $gz->gzwrite($buffer)
5217 while read($fhw,$buffer,4096) > 0 ;
5222 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5227 # CPAN::Tarzip::gunzip
5229 my($class,$read,$write) = @_;
5230 if ($CPAN::META->has_inst("Compress::Zlib")) {
5232 $fhw = FileHandle->new(">$write")
5233 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5234 my $gz = Compress::Zlib::gzopen($read, "rb")
5235 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5236 $fhw->print($buffer)
5237 while $gz->gzread($buffer) > 0 ;
5238 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5239 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5244 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5249 # CPAN::Tarzip::gtest
5251 my($class,$read) = @_;
5252 # After I had reread the documentation in zlib.h, I discovered that
5253 # uncompressed files do not lead to an gzerror (anymore?).
5254 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5257 my $gz = Compress::Zlib::gzopen($read, "rb")
5258 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5260 $Compress::Zlib::gzerrno));
5261 while ($gz->gzread($buffer) > 0 ){
5262 $len += length($buffer);
5265 my $err = $gz->gzerror;
5266 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5267 if ($len == -s $read){
5269 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5272 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5275 return system("$CPAN::Config->{gzip} -dt $read")==0;
5280 # CPAN::Tarzip::TIEHANDLE
5282 my($class,$file) = @_;
5284 $class->debug("file[$file]");
5285 if ($CPAN::META->has_inst("Compress::Zlib")) {
5286 my $gz = Compress::Zlib::gzopen($file,"rb") or
5287 die "Could not gzopen $file";
5288 $ret = bless {GZ => $gz}, $class;
5290 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5291 my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
5293 $ret = bless {FH => $fh}, $class;
5299 # CPAN::Tarzip::READLINE
5302 if (exists $self->{GZ}) {
5303 my $gz = $self->{GZ};
5304 my($line,$bytesread);
5305 $bytesread = $gz->gzreadline($line);
5306 return undef if $bytesread <= 0;
5309 my $fh = $self->{FH};
5310 return scalar <$fh>;
5315 # CPAN::Tarzip::READ
5317 my($self,$ref,$length,$offset) = @_;
5318 die "read with offset not implemented" if defined $offset;
5319 if (exists $self->{GZ}) {
5320 my $gz = $self->{GZ};
5321 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5324 my $fh = $self->{FH};
5325 return read($fh,$$ref,$length);
5330 # CPAN::Tarzip::DESTROY
5333 if (exists $self->{GZ}) {
5334 my $gz = $self->{GZ};
5335 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5336 # to be undef ever. AK, 2000-09
5338 my $fh = $self->{FH};
5339 $fh->close if defined $fh;
5345 # CPAN::Tarzip::untar
5347 my($class,$file) = @_;
5350 if (0) { # makes changing order easier
5351 } elsif ($BUGHUNTING){
5353 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5355 MM->maybe_command($CPAN::Config->{'tar'})) {
5356 # should be default until Archive::Tar is fixed
5359 $CPAN::META->has_inst("Archive::Tar")
5361 $CPAN::META->has_inst("Compress::Zlib") ) {
5364 $CPAN::Frontend->mydie(qq{
5365 CPAN.pm needs either both external programs tar and gzip installed or
5366 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5367 is available. Can\'t continue.
5370 if ($prefer==1) { # 1 => external gzip+tar
5372 my $is_compressed = $class->gtest($file);
5373 if ($is_compressed) {
5374 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5375 "< $file | $CPAN::Config->{tar} xvf -";
5377 $system = "$CPAN::Config->{tar} xvf $file";
5379 if (system($system) != 0) {
5380 # people find the most curious tar binaries that cannot handle
5382 if ($is_compressed) {
5383 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5384 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5385 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5387 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5391 $system = "$CPAN::Config->{tar} xvf $file";
5392 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5393 if (system($system)==0) {
5394 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5396 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5402 } elsif ($prefer==2) { # 2 => modules
5403 my $tar = Archive::Tar->new($file,1);
5404 my $af; # archive file
5407 # RCS 1.337 had this code, it turned out unacceptable slow but
5408 # it revealed a bug in Archive::Tar. Code is only here to hunt
5409 # the bug again. It should never be enabled in published code.
5410 # GDGraph3d-0.53 was an interesting case according to Larry
5412 warn(">>>Bughunting code enabled<<< " x 20);
5413 for $af ($tar->list_files) {
5414 if ($af =~ m!^(/|\.\./)!) {
5415 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5416 "illegal member [$af]");
5418 $CPAN::Frontend->myprint("$af\n");
5419 $tar->extract($af); # slow but effective for finding the bug
5420 return if $CPAN::Signal;
5423 for $af ($tar->list_files) {
5424 if ($af =~ m!^(/|\.\./)!) {
5425 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5426 "illegal member [$af]");
5428 $CPAN::Frontend->myprint("$af\n");
5430 return if $CPAN::Signal;
5435 ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
5436 if ($^O eq 'MacOS');
5443 my($class,$file) = @_;
5444 if ($CPAN::META->has_inst("Archive::Zip")) {
5445 # blueprint of the code from Archive::Zip::Tree::extractTree();
5446 my $zip = Archive::Zip->new();
5448 $status = $zip->read($file);
5449 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5450 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5451 my @members = $zip->members();
5452 for my $member ( @members ) {
5453 my $af = $member->fileName();
5454 if ($af =~ m!^(/|\.\./)!) {
5455 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5456 "illegal member [$af]");
5458 my $status = $member->extractToFileNamed( $af );
5459 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5460 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5461 $status != Archive::Zip::AZ_OK();
5462 return if $CPAN::Signal;
5466 my $unzip = $CPAN::Config->{unzip} or
5467 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5468 my @system = ($unzip, $file);
5469 return system(@system) == 0;
5474 package CPAN::Version;
5475 # CPAN::Version::vcmp courtesy Jost Krieger
5477 my($self,$l,$r) = @_;
5479 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5481 return 0 if $l eq $r; # short circuit for quicker success
5483 if ($l=~/^v/ <=> $r=~/^v/) {
5486 $_ = $self->float2vv($_);
5491 ($l ne "undef") <=> ($r ne "undef") ||
5495 $self->vstring($l) cmp $self->vstring($r)) ||
5501 my($self,$l,$r) = @_;
5502 $self->vcmp($l,$r) > 0;
5507 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5508 pack "U*", split /\./, $n;
5511 # vv => visible vstring
5516 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5517 # architecture influence
5519 $mantissa .= "0" while length($mantissa)%3;
5520 my $ret = "v" . $rev;
5522 $mantissa =~ s/(\d{1,3})// or
5523 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5524 $ret .= ".".int($1);
5526 # warn "n[$n]ret[$ret]";
5532 $n =~ /^([\w\-\+\.]+)/;
5534 return $1 if defined $1 && length($1)>0;
5535 # if the first user reaches version v43, he will be treated as "+".
5536 # We'll have to decide about a new rule here then, depending on what
5537 # will be the prevailing versioning behavior then.
5539 if ($] < 5.006) { # or whenever v-strings were introduced
5540 # we get them wrong anyway, whatever we do, because 5.005 will
5541 # have already interpreted 0.2.4 to be "0.24". So even if he
5542 # indexer sends us something like "v0.2.4" we compare wrongly.
5544 # And if they say v1.2, then the old perl takes it as "v12"
5546 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5549 my $better = sprintf "v%vd", $n;
5550 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5562 CPAN - query, download and build perl modules from CPAN sites
5568 perl -MCPAN -e shell;
5574 autobundle, clean, install, make, recompile, test
5578 The CPAN module is designed to automate the make and install of perl
5579 modules and extensions. It includes some searching capabilities and
5580 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5581 to fetch the raw data from the net.
5583 Modules are fetched from one or more of the mirrored CPAN
5584 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5587 The CPAN module also supports the concept of named and versioned
5588 I<bundles> of modules. Bundles simplify the handling of sets of
5589 related modules. See Bundles below.
5591 The package contains a session manager and a cache manager. There is
5592 no status retained between sessions. The session manager keeps track
5593 of what has been fetched, built and installed in the current
5594 session. The cache manager keeps track of the disk space occupied by
5595 the make processes and deletes excess space according to a simple FIFO
5598 For extended searching capabilities there's a plugin for CPAN available,
5599 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5600 that indexes all documents available in CPAN authors directories. If
5601 C<CPAN::WAIT> is installed on your system, the interactive shell
5602 of CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh>
5603 commands which send queries to the WAIT server that has been configured
5604 for your installation.
5606 All other methods provided are accessible in a programmer style and in an
5607 interactive shell style.
5609 =head2 Interactive Mode
5611 The interactive mode is entered by running
5613 perl -MCPAN -e shell
5615 which puts you into a readline interface. You will have the most fun if
5616 you install Term::ReadKey and Term::ReadLine to enjoy both history and
5619 Once you are on the command line, type 'h' and the rest should be
5622 The function call C<shell> takes two optional arguments, one is the
5623 prompt, the second is the default initial command line (the latter
5624 only works if a real ReadLine interface module is installed).
5626 The most common uses of the interactive modes are
5630 =item Searching for authors, bundles, distribution files and modules
5632 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
5633 for each of the four categories and another, C<i> for any of the
5634 mentioned four. Each of the four entities is implemented as a class
5635 with slightly differing methods for displaying an object.
5637 Arguments you pass to these commands are either strings exactly matching
5638 the identification string of an object or regular expressions that are
5639 then matched case-insensitively against various attributes of the
5640 objects. The parser recognizes a regular expression only if you
5641 enclose it between two slashes.
5643 The principle is that the number of found objects influences how an
5644 item is displayed. If the search finds one item, the result is
5645 displayed with the rather verbose method C<as_string>, but if we find
5646 more than one, we display each object with the terse method
5649 =item make, test, install, clean modules or distributions
5651 These commands take any number of arguments and investigate what is
5652 necessary to perform the action. If the argument is a distribution
5653 file name (recognized by embedded slashes), it is processed. If it is
5654 a module, CPAN determines the distribution file in which this module
5655 is included and processes that, following any dependencies named in
5656 the module's Makefile.PL (this behavior is controlled by
5657 I<prerequisites_policy>.)
5659 Any C<make> or C<test> are run unconditionally. An
5661 install <distribution_file>
5663 also is run unconditionally. But for
5667 CPAN checks if an install is actually needed for it and prints
5668 I<module up to date> in the case that the distribution file containing
5669 the module doesn't need to be updated.
5671 CPAN also keeps track of what it has done within the current session
5672 and doesn't try to build a package a second time regardless if it
5673 succeeded or not. The C<force> command takes as a first argument the
5674 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
5675 command from scratch.
5679 cpan> install OpenGL
5680 OpenGL is up to date.
5681 cpan> force install OpenGL
5684 OpenGL-0.4/COPYRIGHT
5687 A C<clean> command results in a
5691 being executed within the distribution file's working directory.
5693 =item get, readme, look module or distribution
5695 C<get> downloads a distribution file without further action. C<readme>
5696 displays the README file of the associated distribution. C<Look> gets
5697 and untars (if not yet done) the distribution file, changes to the
5698 appropriate directory and opens a subshell process in that directory.
5702 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
5703 in the cpan-shell it is intended that you can press C<^C> anytime and
5704 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
5705 to clean up and leave the shell loop. You can emulate the effect of a
5706 SIGTERM by sending two consecutive SIGINTs, which usually means by
5707 pressing C<^C> twice.
5709 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
5710 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
5716 The commands that are available in the shell interface are methods in
5717 the package CPAN::Shell. If you enter the shell command, all your
5718 input is split by the Text::ParseWords::shellwords() routine which
5719 acts like most shells do. The first word is being interpreted as the
5720 method to be called and the rest of the words are treated as arguments
5721 to this method. Continuation lines are supported if a line ends with a
5726 C<autobundle> writes a bundle file into the
5727 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
5728 a list of all modules that are both available from CPAN and currently
5729 installed within @INC. The name of the bundle file is based on the
5730 current date and a counter.
5734 recompile() is a very special command in that it takes no argument and
5735 runs the make/test/install cycle with brute force over all installed
5736 dynamically loadable extensions (aka XS modules) with 'force' in
5737 effect. The primary purpose of this command is to finish a network
5738 installation. Imagine, you have a common source tree for two different
5739 architectures. You decide to do a completely independent fresh
5740 installation. You start on one architecture with the help of a Bundle
5741 file produced earlier. CPAN installs the whole Bundle for you, but
5742 when you try to repeat the job on the second architecture, CPAN
5743 responds with a C<"Foo up to date"> message for all modules. So you
5744 invoke CPAN's recompile on the second architecture and you're done.
5746 Another popular use for C<recompile> is to act as a rescue in case your
5747 perl breaks binary compatibility. If one of the modules that CPAN uses
5748 is in turn depending on binary compatibility (so you cannot run CPAN
5749 commands), then you should try the CPAN::Nox module for recovery.
5751 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
5753 Although it may be considered internal, the class hierarchy does matter
5754 for both users and programmer. CPAN.pm deals with above mentioned four
5755 classes, and all those classes share a set of methods. A classical
5756 single polymorphism is in effect. A metaclass object registers all
5757 objects of all kinds and indexes them with a string. The strings
5758 referencing objects have a separated namespace (well, not completely
5763 words containing a "/" (slash) Distribution
5764 words starting with Bundle:: Bundle
5765 everything else Module or Author
5767 Modules know their associated Distribution objects. They always refer
5768 to the most recent official release. Developers may mark their releases
5769 as unstable development versions (by inserting an underbar into the
5770 visible version number), so the really hottest and newest distribution
5771 file is not always the default. If a module Foo circulates on CPAN in
5772 both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
5773 install version 1.23 by saying
5777 This would install the complete distribution file (say
5778 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
5779 like to install version 1.23_90, you need to know where the
5780 distribution file resides on CPAN relative to the authors/id/
5781 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
5782 so you would have to say
5784 install BAR/Foo-1.23_90.tar.gz
5786 The first example will be driven by an object of the class
5787 CPAN::Module, the second by an object of class CPAN::Distribution.
5789 =head2 Programmer's interface
5791 If you do not enter the shell, the available shell commands are both
5792 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
5793 functions in the calling package (C<install(...)>).
5795 There's currently only one class that has a stable interface -
5796 CPAN::Shell. All commands that are available in the CPAN shell are
5797 methods of the class CPAN::Shell. Each of the commands that produce
5798 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
5799 the IDs of all modules within the list.
5803 =item expand($type,@things)
5805 The IDs of all objects available within a program are strings that can
5806 be expanded to the corresponding real objects with the
5807 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
5808 list of CPAN::Module objects according to the C<@things> arguments
5809 given. In scalar context it only returns the first element of the
5812 =item Programming Examples
5814 This enables the programmer to do operations that combine
5815 functionalities that are available in the shell.
5817 # install everything that is outdated on my disk:
5818 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
5820 # install my favorite programs if necessary:
5821 for $mod (qw(Net::FTP MD5 Data::Dumper)){
5822 my $obj = CPAN::Shell->expand('Module',$mod);
5826 # list all modules on my disk that have no VERSION number
5827 for $mod (CPAN::Shell->expand("Module","/./")){
5828 next unless $mod->inst_file;
5829 # MakeMaker convention for undefined $VERSION:
5830 next unless $mod->inst_version eq "undef";
5831 print "No VERSION in ", $mod->id, "\n";
5834 # find out which distribution on CPAN contains a module:
5835 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
5837 Or if you want to write a cronjob to watch The CPAN, you could list
5838 all modules that need updating. First a quick and dirty way:
5840 perl -e 'use CPAN; CPAN::Shell->r;'
5842 If you don't want to get any output in the case that all modules are
5843 up to date, you can parse the output of above command for the regular
5844 expression //modules are up to date// and decide to mail the output
5845 only if it doesn't match. Ick?
5847 If you prefer to do it more in a programmer style in one single
5848 process, maybe something like this suits you better:
5850 # list all modules on my disk that have newer versions on CPAN
5851 for $mod (CPAN::Shell->expand("Module","/./")){
5852 next unless $mod->inst_file;
5853 next if $mod->uptodate;
5854 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
5855 $mod->id, $mod->inst_version, $mod->cpan_version;
5858 If that gives you too much output every day, you maybe only want to
5859 watch for three modules. You can write
5861 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
5863 as the first line instead. Or you can combine some of the above
5866 # watch only for a new mod_perl module
5867 $mod = CPAN::Shell->expand("Module","mod_perl");
5868 exit if $mod->uptodate;
5869 # new mod_perl arrived, let me know all update recommendations
5874 =head2 Methods in the four Classes
5876 =head2 Cache Manager
5878 Currently the cache manager only keeps track of the build directory
5879 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
5880 deletes complete directories below C<build_dir> as soon as the size of
5881 all directories there gets bigger than $CPAN::Config->{build_cache}
5882 (in MB). The contents of this cache may be used for later
5883 re-installations that you intend to do manually, but will never be
5884 trusted by CPAN itself. This is due to the fact that the user might
5885 use these directories for building modules on different architectures.
5887 There is another directory ($CPAN::Config->{keep_source_where}) where
5888 the original distribution files are kept. This directory is not
5889 covered by the cache manager and must be controlled by the user. If
5890 you choose to have the same directory as build_dir and as
5891 keep_source_where directory, then your sources will be deleted with
5892 the same fifo mechanism.
5896 A bundle is just a perl module in the namespace Bundle:: that does not
5897 define any functions or methods. It usually only contains documentation.
5899 It starts like a perl module with a package declaration and a $VERSION
5900 variable. After that the pod section looks like any other pod with the
5901 only difference being that I<one special pod section> exists starting with
5906 In this pod section each line obeys the format
5908 Module_Name [Version_String] [- optional text]
5910 The only required part is the first field, the name of a module
5911 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
5912 of the line is optional. The comment part is delimited by a dash just
5913 as in the man page header.
5915 The distribution of a bundle should follow the same convention as
5916 other distributions.
5918 Bundles are treated specially in the CPAN package. If you say 'install
5919 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
5920 the modules in the CONTENTS section of the pod. You can install your
5921 own Bundles locally by placing a conformant Bundle file somewhere into
5922 your @INC path. The autobundle() command which is available in the
5923 shell interface does that for you by including all currently installed
5924 modules in a snapshot bundle file.
5926 =head2 Prerequisites
5928 If you have a local mirror of CPAN and can access all files with
5929 "file:" URLs, then you only need a perl better than perl5.003 to run
5930 this module. Otherwise Net::FTP is strongly recommended. LWP may be
5931 required for non-UNIX systems or if your nearest CPAN site is
5932 associated with an URL that is not C<ftp:>.
5934 If you have neither Net::FTP nor LWP, there is a fallback mechanism
5935 implemented for an external ftp command or for an external lynx
5938 =head2 Finding packages and VERSION
5940 This module presumes that all packages on CPAN
5946 declare their $VERSION variable in an easy to parse manner. This
5947 prerequisite can hardly be relaxed because it consumes far too much
5948 memory to load all packages into the running program just to determine
5949 the $VERSION variable. Currently all programs that are dealing with
5950 version use something like this
5952 perl -MExtUtils::MakeMaker -le \
5953 'print MM->parse_version(shift)' filename
5955 If you are author of a package and wonder if your $VERSION can be
5956 parsed, please try the above method.
5960 come as compressed or gzipped tarfiles or as zip files and contain a
5961 Makefile.PL (well, we try to handle a bit more, but without much
5968 The debugging of this module is a bit complex, because we have
5969 interferences of the software producing the indices on CPAN, of the
5970 mirroring process on CPAN, of packaging, of configuration, of
5971 synchronicity, and of bugs within CPAN.pm.
5973 For code debugging in interactive mode you can try "o debug" which
5974 will list options for debugging the various parts of the code. You
5975 should know that "o debug" has built-in completion support.
5977 For data debugging there is the C<dump> command which takes the same
5978 arguments as make/test/install and outputs the object's Data::Dumper
5981 =head2 Floppy, Zip, Offline Mode
5983 CPAN.pm works nicely without network too. If you maintain machines
5984 that are not networked at all, you should consider working with file:
5985 URLs. Of course, you have to collect your modules somewhere first. So
5986 you might use CPAN.pm to put together all you need on a networked
5987 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
5988 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
5989 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
5990 with this floppy. See also below the paragraph about CD-ROM support.
5992 =head1 CONFIGURATION
5994 When the CPAN module is installed, a site wide configuration file is
5995 created as CPAN/Config.pm. The default values defined there can be
5996 overridden in another configuration file: CPAN/MyConfig.pm. You can
5997 store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
5998 $HOME/.cpan is added to the search path of the CPAN module before the
5999 use() or require() statements.
6001 Currently the following keys in the hash reference $CPAN::Config are
6004 build_cache size of cache for directories to build modules
6005 build_dir locally accessible directory to build modules
6006 index_expire after this many days refetch index files
6007 cache_metadata use serializer to cache metadata
6008 cpan_home local directory reserved for this package
6009 dontload_hash anonymous hash: modules in the keys will not be
6010 loaded by the CPAN::has_inst() routine
6011 gzip location of external program gzip
6012 inactivity_timeout breaks interactive Makefile.PLs after this
6013 many seconds inactivity. Set to 0 to never break.
6014 inhibit_startup_message
6015 if true, does not print the startup message
6016 keep_source_where directory in which to keep the source (if we do)
6017 make location of external make program
6018 make_arg arguments that should always be passed to 'make'
6019 make_install_arg same as make_arg for 'make install'
6020 makepl_arg arguments passed to 'perl Makefile.PL'
6021 pager location of external program more (or any pager)
6022 prerequisites_policy
6023 what to do if you are missing module prerequisites
6024 ('follow' automatically, 'ask' me, or 'ignore')
6025 scan_cache controls scanning of cache ('atstart' or 'never')
6026 tar location of external program tar
6027 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6028 (and nonsense for characters outside latin range)
6029 unzip location of external program unzip
6030 urllist arrayref to nearby CPAN sites (or equivalent locations)
6031 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6032 ftp_proxy, } the three usual variables for configuring
6033 http_proxy, } proxy requests. Both as CPAN::Config variables
6034 no_proxy } and as environment variables configurable.
6036 You can set and query each of these options interactively in the cpan
6037 shell with the command set defined within the C<o conf> command:
6041 =item C<o conf E<lt>scalar optionE<gt>>
6043 prints the current value of the I<scalar option>
6045 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6047 Sets the value of the I<scalar option> to I<value>
6049 =item C<o conf E<lt>list optionE<gt>>
6051 prints the current value of the I<list option> in MakeMaker's
6054 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6056 shifts or pops the array in the I<list option> variable
6058 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6060 works like the corresponding perl commands.
6064 =head2 Note on urllist parameter's format
6066 urllist parameters are URLs according to RFC 1738. We do a little
6067 guessing if your URL is not compliant, but if you have problems with
6068 file URLs, please try the correct format. Either:
6070 file://localhost/whatever/ftp/pub/CPAN/
6074 file:///home/ftp/pub/CPAN/
6076 =head2 urllist parameter has CD-ROM support
6078 The C<urllist> parameter of the configuration table contains a list of
6079 URLs that are to be used for downloading. If the list contains any
6080 C<file> URLs, CPAN always tries to get files from there first. This
6081 feature is disabled for index files. So the recommendation for the
6082 owner of a CD-ROM with CPAN contents is: include your local, possibly
6083 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6085 o conf urllist push file://localhost/CDROM/CPAN
6087 CPAN.pm will then fetch the index files from one of the CPAN sites
6088 that come at the beginning of urllist. It will later check for each
6089 module if there is a local copy of the most recent version.
6091 Another peculiarity of urllist is that the site that we could
6092 successfully fetch the last file from automatically gets a preference
6093 token and is tried as the first site for the next request. So if you
6094 add a new site at runtime it may happen that the previously preferred
6095 site will be tried another time. This means that if you want to disallow
6096 a site for the next transfer, it must be explicitly removed from
6101 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6102 install foreign, unmasked, unsigned code on your machine. We compare
6103 to a checksum that comes from the net just as the distribution file
6104 itself. If somebody has managed to tamper with the distribution file,
6105 they may have as well tampered with the CHECKSUMS file. Future
6106 development will go towards strong authentication.
6110 Most functions in package CPAN are exported per default. The reason
6111 for this is that the primary use is intended for the cpan shell or for
6114 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6116 Populating a freshly installed perl with your favorite modules is pretty
6117 easy if you maintain a private bundle definition file. To get a useful
6118 blueprint of a bundle definition file, the command autobundle can be used
6119 on the CPAN shell command line. This command writes a bundle definition
6120 file for all modules that are installed for the currently running perl
6121 interpreter. It's recommended to run this command only once and from then
6122 on maintain the file manually under a private name, say
6123 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6125 cpan> install Bundle::my_bundle
6127 then answer a few questions and then go out for a coffee.
6129 Maintaining a bundle definition file means keeping track of two
6130 things: dependencies and interactivity. CPAN.pm sometimes fails on
6131 calculating dependencies because not all modules define all MakeMaker
6132 attributes correctly, so a bundle definition file should specify
6133 prerequisites as early as possible. On the other hand, it's a bit
6134 annoying that many distributions need some interactive configuring. So
6135 what I try to accomplish in my private bundle file is to have the
6136 packages that need to be configured early in the file and the gentle
6137 ones later, so I can go out after a few minutes and leave CPAN.pm
6140 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6142 Thanks to Graham Barr for contributing the following paragraphs about
6143 the interaction between perl, and various firewall configurations. For
6144 further informations on firewalls, it is recommended to consult the
6145 documentation that comes with the ncftp program. If you are unable to
6146 go through the firewall with a simple Perl setup, it is very likely
6147 that you can configure ncftp so that it works for your firewall.
6149 =head2 Three basic types of firewalls
6151 Firewalls can be categorized into three basic types.
6157 This is where the firewall machine runs a web server and to access the
6158 outside world you must do it via the web server. If you set environment
6159 variables like http_proxy or ftp_proxy to a values beginning with http://
6160 or in your web browser you have to set proxy information then you know
6161 you are running a http firewall.
6163 To access servers outside these types of firewalls with perl (even for
6164 ftp) you will need to use LWP.
6168 This where the firewall machine runs a ftp server. This kind of
6169 firewall will only let you access ftp servers outside the firewall.
6170 This is usually done by connecting to the firewall with ftp, then
6171 entering a username like "user@outside.host.com"
6173 To access servers outside these type of firewalls with perl you
6174 will need to use Net::FTP.
6176 =item One way visibility
6178 I say one way visibility as these firewalls try to make themselve look
6179 invisible to the users inside the firewall. An FTP data connection is
6180 normally created by sending the remote server your IP address and then
6181 listening for the connection. But the remote server will not be able to
6182 connect to you because of the firewall. So for these types of firewall
6183 FTP connections need to be done in a passive mode.
6185 There are two that I can think off.
6191 If you are using a SOCKS firewall you will need to compile perl and link
6192 it with the SOCKS library, this is what is normally called a 'socksified'
6193 perl. With this executable you will be able to connect to servers outside
6194 the firewall as if it is not there.
6198 This is the firewall implemented in the Linux kernel, it allows you to
6199 hide a complete network behind one IP address. With this firewall no
6200 special compiling is need as you can access hosts directly.
6206 =head2 Configuring lynx or ncftp for going through a firewall
6208 If you can go through your firewall with e.g. lynx, presumably with a
6211 /usr/local/bin/lynx -pscott:tiger
6213 then you would configure CPAN.pm with the command
6215 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6217 That's all. Similarly for ncftp or ftp, you would configure something
6220 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6222 Your milage may vary...
6228 =item 1) I installed a new version of module X but CPAN keeps saying,
6229 I have the old version installed
6231 Most probably you B<do> have the old version installed. This can
6232 happen if a module installs itself into a different directory in the
6233 @INC path than it was previously installed. This is not really a
6234 CPAN.pm problem, you would have the same problem when installing the
6235 module manually. The easiest way to prevent this behaviour is to add
6236 the argument C<UNINST=1> to the C<make install> call, and that is why
6237 many people add this argument permanently by configuring
6239 o conf make_install_arg UNINST=1
6241 =item 2) So why is UNINST=1 not the default?
6243 Because there are people who have their precise expectations about who
6244 may install where in the @INC path and who uses which @INC array. In
6245 fine tuned environments C<UNINST=1> can cause damage.
6247 =item 3) I want to clean up my mess, and install a new perl along with
6248 all modules I have. How do I go about it?
6250 Run the autobundle command for your old perl and optionally rename the
6251 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6252 with the Configure option prefix, e.g.
6254 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6256 Install the bundle file you produced in the first step with something like
6258 cpan> install Bundle::mybundle
6262 =item 4) When I install bundles or multiple modules with one command
6263 there is too much output to keep track of
6265 You may want to configure something like
6267 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6268 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6270 so that STDOUT is captured in a file for later inspection.
6273 =item 5) I am not root, how can I install a module in a personal
6276 You will most probably like something like this:
6278 o conf makepl_arg "LIB=~/myperl/lib \
6279 INSTALLMAN1DIR=~/myperl/man/man1 \
6280 INSTALLMAN3DIR=~/myperl/man/man3"
6281 install Sybase::Sybperl
6283 You can make this setting permanent like all C<o conf> settings with
6286 You will have to add ~/myperl/man to the MANPATH environment variable
6287 and also tell your perl programs to look into ~/myperl/lib, e.g. by
6290 use lib "$ENV{HOME}/myperl/lib";
6292 or setting the PERL5LIB environment variable.
6294 Another thing you should bear in mind is that the UNINST parameter
6295 should never be set if you are not root.
6297 =item 6) How to get a package, unwrap it, and make a change before
6300 look Sybase::Sybperl
6302 =item 7) I installed a Bundle and had a couple of fails. When I
6303 retried, everything resolved nicely. Can this be fixed to work
6306 The reason for this is that CPAN does not know the dependencies of all
6307 modules when it starts out. To decide about the additional items to
6308 install, it just uses data found in the generated Makefile. An
6309 undetected missing piece breaks the process. But it may well be that
6310 your Bundle installs some prerequisite later than some depending item
6311 and thus your second try is able to resolve everything. Please note,
6312 CPAN.pm does not know the dependency tree in advance and cannot sort
6313 the queue of things to install in a topologically correct order. It
6314 resolves perfectly well IFF all modules declare the prerequisites
6315 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6316 fail and you need to install often, it is recommended sort the Bundle
6317 definition file manually. It is planned to improve the metadata
6318 situation for dependencies on CPAN in general, but this will still
6321 =item 8) In our intranet we have many modules for internal use. How
6322 can I integrate these modules with CPAN.pm but without uploading
6323 the modules to CPAN?
6325 Have a look at the CPAN::Site module.
6327 =item 9) When I run CPAN's shell, I get error msg about line 1 to 4,
6328 setting meta input/output via the /etc/inputrc file.
6330 Some versions of readline are picky about capitalization in the
6331 /etc/inputrc file and specifically RedHat 6.2 comes with a
6332 /etc/inputrc that contains the word C<on> in lowercase. Change the
6333 occurrences of C<on> to C<On> and the bug should disappear.
6335 =item 10) Some authors have strange characters in their names.
6337 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
6338 expecting ISO-8859-1 charset, a converter can be activated by setting
6339 term_is_latin to a true value in your config file. One way of doing so
6342 cpan> ! $CPAN::Config->{term_is_latin}=1
6344 Extended support for converters will be made available as soon as perl
6345 becomes stable with regard to charset issues.
6351 We should give coverage for B<all> of the CPAN and not just the PAUSE
6352 part, right? In this discussion CPAN and PAUSE have become equal --
6353 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
6354 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
6356 Future development should be directed towards a better integration of
6359 If a Makefile.PL requires special customization of libraries, prompts
6360 the user for special input, etc. then you may find CPAN is not able to
6361 build the distribution. In that case, you should attempt the
6362 traditional method of building a Perl module package from a shell.
6366 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
6370 perl(1), CPAN::Nox(3)