1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 # $Id: CPAN.pm,v 1.409 2003/07/28 22:07:23 k Exp $
6 # only used during development:
8 # $Revision = "[".substr(q$Revision: 1.409 $, 10)."]";
15 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
16 use File::Basename ();
22 use Text::ParseWords ();
26 no lib "."; # we need to run chdir all over and we would get at wrong
29 require Mac::BuildTools if $^O eq 'MacOS';
31 END { $End++; &cleanup; }
54 $CPAN::Frontend ||= "CPAN::Shell";
55 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
60 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
61 $Revision $Signal $End $Suppress_readline $Frontend
62 $Defaultsite $Have_warned);
64 @CPAN::ISA = qw(CPAN::Debug Exporter);
67 autobundle bundle expand force get cvs_import
68 install make readme recompile shell test clean
71 #-> sub CPAN::AUTOLOAD ;
76 @EXPORT{@EXPORT} = '';
77 CPAN::Config->load unless $CPAN::Config_loaded++;
78 if (exists $EXPORT{$l}){
81 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
90 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
91 CPAN::Config->load unless $CPAN::Config_loaded++;
93 my $oprompt = shift || "cpan> ";
94 my $prompt = $oprompt;
95 my $commandline = shift || "";
98 unless ($Suppress_readline) {
99 require Term::ReadLine;
102 $term->ReadLine eq "Term::ReadLine::Stub"
104 $term = Term::ReadLine->new('CPAN Monitor');
106 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
107 my $attribs = $term->Attribs;
108 $attribs->{attempted_completion_function} = sub {
109 &CPAN::Complete::gnu_cpl;
112 $readline::rl_completion_function =
113 $readline::rl_completion_function = 'CPAN::Complete::cpl';
115 if (my $histfile = $CPAN::Config->{'histfile'}) {{
116 unless ($term->can("AddHistory")) {
117 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
120 my($fh) = FileHandle->new;
121 open $fh, "<$histfile" or last;
125 $term->AddHistory($_);
129 # $term->OUT is autoflushed anyway
130 my $odef = select STDERR;
137 # no strict; # I do not recall why no strict was here (2000-09-03)
139 my $cwd = CPAN::anycwd();
140 my $try_detect_readline;
141 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
142 my $rl_avail = $Suppress_readline ? "suppressed" :
143 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
144 "available (try 'install Bundle::CPAN')";
146 $CPAN::Frontend->myprint(
148 cpan shell -- CPAN exploration and modules installation (v%s%s)
156 unless $CPAN::Config->{'inhibit_startup_message'} ;
157 my($continuation) = "";
158 SHELLCOMMAND: while () {
159 if ($Suppress_readline) {
161 last SHELLCOMMAND unless defined ($_ = <> );
164 last SHELLCOMMAND unless
165 defined ($_ = $term->readline($prompt, $commandline));
167 $_ = "$continuation$_" if $continuation;
169 next SHELLCOMMAND if /^$/;
170 $_ = 'h' if /^\s*\?/;
171 if (/^(?:q(?:uit)?|bye|exit)$/i) {
181 use vars qw($import_done);
182 CPAN->import(':DEFAULT') unless $import_done++;
183 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
190 if ($] < 5.00322) { # parsewords had a bug until recently
193 eval { @line = Text::ParseWords::shellwords($_) };
194 warn($@), next SHELLCOMMAND if $@;
195 warn("Text::Parsewords could not parse the line [$_]"),
196 next SHELLCOMMAND unless @line;
198 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
199 my $command = shift @line;
200 eval { CPAN::Shell->$command(@line) };
202 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
203 $CPAN::Frontend->myprint("\n");
208 $commandline = ""; # I do want to be able to pass a default to
209 # shell, but on the second command I see no
212 CPAN::Queue->nullify_queue;
213 if ($try_detect_readline) {
214 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
216 $CPAN::META->has_inst("Term::ReadLine::Perl")
218 delete $INC{"Term/ReadLine.pm"};
220 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
221 require Term::ReadLine;
222 $CPAN::Frontend->myprint("\n$redef subroutines in ".
223 "Term::ReadLine redefined\n");
229 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
232 package CPAN::CacheMgr;
233 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
236 package CPAN::Config;
237 use vars qw(%can $dot_cpan);
240 'commit' => "Commit changes to disk",
241 'defaults' => "Reload defaults from disk",
242 'init' => "Interactive setting of all options",
246 use vars qw($Ua $Thesite $Themethod);
247 @CPAN::FTP::ISA = qw(CPAN::Debug);
249 package CPAN::LWP::UserAgent;
250 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
251 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
253 package CPAN::Complete;
254 @CPAN::Complete::ISA = qw(CPAN::Debug);
255 @CPAN::Complete::COMMANDS = sort qw(
256 ! a b d h i m o q r u autobundle clean dump
257 make test install force readme reload look
259 ) unless @CPAN::Complete::COMMANDS;
262 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
263 @CPAN::Index::ISA = qw(CPAN::Debug);
266 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
269 package CPAN::InfoObj;
270 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
272 package CPAN::Author;
273 @CPAN::Author::ISA = qw(CPAN::InfoObj);
275 package CPAN::Distribution;
276 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
278 package CPAN::Bundle;
279 @CPAN::Bundle::ISA = qw(CPAN::Module);
281 package CPAN::Module;
282 @CPAN::Module::ISA = qw(CPAN::InfoObj);
284 package CPAN::Exception::RecursiveDependency;
285 use overload '""' => "as_string";
292 for my $dep (@$deps) {
294 last if $seen{$dep}++;
296 bless { deps => \@deps }, $class;
301 "\nRecursive dependency detected:\n " .
302 join("\n => ", @{$self->{deps}}) .
303 ".\nCannot continue.\n";
307 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
308 @CPAN::Shell::ISA = qw(CPAN::Debug);
309 $COLOR_REGISTERED ||= 0;
310 $PRINT_ORNAMENTING ||= 0;
312 #-> sub CPAN::Shell::AUTOLOAD ;
314 my($autoload) = $AUTOLOAD;
315 my $class = shift(@_);
316 # warn "autoload[$autoload] class[$class]";
317 $autoload =~ s/.*:://;
318 if ($autoload =~ /^w/) {
319 if ($CPAN::META->has_inst('CPAN::WAIT')) {
320 CPAN::WAIT->$autoload(@_);
322 $CPAN::Frontend->mywarn(qq{
323 Commands starting with "w" require CPAN::WAIT to be installed.
324 Please consider installing CPAN::WAIT to use the fulltext index.
325 For this you just need to type
330 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
336 package CPAN::Tarzip;
337 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
338 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
339 $BUGHUNTING = 0; # released code must have turned off
343 # One use of the queue is to determine if we should or shouldn't
344 # announce the availability of a new CPAN module
346 # Now we try to use it for dependency tracking. For that to happen
347 # we need to draw a dependency tree and do the leaves first. This can
348 # easily be reached by running CPAN.pm recursively, but we don't want
349 # to waste memory and run into deep recursion. So what we can do is
352 # CPAN::Queue is the package where the queue is maintained. Dependencies
353 # often have high priority and must be brought to the head of the queue,
354 # possibly by jumping the queue if they are already there. My first code
355 # attempt tried to be extremely correct. Whenever a module needed
356 # immediate treatment, I either unshifted it to the front of the queue,
357 # or, if it was already in the queue, I spliced and let it bypass the
358 # others. This became a too correct model that made it impossible to put
359 # an item more than once into the queue. Why would you need that? Well,
360 # you need temporary duplicates as the manager of the queue is a loop
363 # (1) looks at the first item in the queue without shifting it off
365 # (2) cares for the item
367 # (3) removes the item from the queue, *even if its agenda failed and
368 # even if the item isn't the first in the queue anymore* (that way
369 # protecting against never ending queues)
371 # So if an item has prerequisites, the installation fails now, but we
372 # want to retry later. That's easy if we have it twice in the queue.
374 # I also expect insane dependency situations where an item gets more
375 # than two lives in the queue. Simplest example is triggered by 'install
376 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
377 # get in the way. I wanted the queue manager to be a dumb servant, not
378 # one that knows everything.
380 # Who would I tell in this model that the user wants to be asked before
381 # processing? I can't attach that information to the module object,
382 # because not modules are installed but distributions. So I'd have to
383 # tell the distribution object that it should ask the user before
384 # processing. Where would the question be triggered then? Most probably
385 # in CPAN::Distribution::rematein.
386 # Hope that makes sense, my head is a bit off:-) -- AK
393 my $self = bless { qmod => $s }, $class;
398 # CPAN::Queue::first ;
404 # CPAN::Queue::delete_first ;
406 my($class,$what) = @_;
408 for my $i (0..$#All) {
409 if ( $All[$i]->{qmod} eq $what ) {
416 # CPAN::Queue::jumpqueue ;
420 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
421 join(",",map {$_->{qmod}} @All),
424 WHAT: for my $what (reverse @what) {
426 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
427 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
428 if ($All[$i]->{qmod} eq $what){
430 if ($jumped > 100) { # one's OK if e.g. just
431 # processing now; more are OK if
432 # user typed it several times
433 $CPAN::Frontend->mywarn(
434 qq{Object [$what] queued more than 100 times, ignoring}
440 my $obj = bless { qmod => $what }, $class;
443 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
444 join(",",map {$_->{qmod}} @All),
449 # CPAN::Queue::exists ;
451 my($self,$what) = @_;
452 my @all = map { $_->{qmod} } @All;
453 my $exists = grep { $_->{qmod} eq $what } @All;
454 # warn "in exists what[$what] all[@all] exists[$exists]";
458 # CPAN::Queue::delete ;
461 @All = grep { $_->{qmod} ne $mod } @All;
464 # CPAN::Queue::nullify_queue ;
473 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
475 # from here on only subs.
476 ################################################################################
478 #-> sub CPAN::all_objects ;
480 my($mgr,$class) = @_;
481 CPAN::Config->load unless $CPAN::Config_loaded++;
482 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
484 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
486 *all = \&all_objects;
488 # Called by shell, not in batch mode. In batch mode I see no risk in
489 # having many processes updating something as installations are
490 # continually checked at runtime. In shell mode I suspect it is
491 # unintentional to open more than one shell at a time
493 #-> sub CPAN::checklock ;
496 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
497 if (-f $lockfile && -M _ > 0) {
498 my $fh = FileHandle->new($lockfile) or
499 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
500 my $otherpid = <$fh>;
501 my $otherhost = <$fh>;
503 if (defined $otherpid && $otherpid) {
506 if (defined $otherhost && $otherhost) {
509 my $thishost = hostname();
510 if (defined $otherhost && defined $thishost &&
511 $otherhost ne '' && $thishost ne '' &&
512 $otherhost ne $thishost) {
513 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
514 "reports other host $otherhost and other process $otherpid.\n".
515 "Cannot proceed.\n"));
517 elsif (defined $otherpid && $otherpid) {
518 return if $$ == $otherpid; # should never happen
519 $CPAN::Frontend->mywarn(
521 There seems to be running another CPAN process (pid $otherpid). Contacting...
523 if (kill 0, $otherpid) {
524 $CPAN::Frontend->mydie(qq{Other job is running.
525 You may want to kill it and delete the lockfile, maybe. On UNIX try:
529 } elsif (-w $lockfile) {
531 ExtUtils::MakeMaker::prompt
532 (qq{Other job not responding. Shall I overwrite }.
533 qq{the lockfile? (Y/N)},"y");
534 $CPAN::Frontend->myexit("Ok, bye\n")
535 unless $ans =~ /^y/i;
538 qq{Lockfile $lockfile not writeable by you. }.
539 qq{Cannot proceed.\n}.
542 qq{ and then rerun us.\n}
546 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
547 "reports other process with ID ".
548 "$otherpid. Cannot proceed.\n"));
551 my $dotcpan = $CPAN::Config->{cpan_home};
552 eval { File::Path::mkpath($dotcpan);};
554 # A special case at least for Jarkko.
559 $symlinkcpan = readlink $dotcpan;
560 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
561 eval { File::Path::mkpath($symlinkcpan); };
565 $CPAN::Frontend->mywarn(qq{
566 Working directory $symlinkcpan created.
570 unless (-d $dotcpan) {
572 Your configuration suggests "$dotcpan" as your
573 CPAN.pm working directory. I could not create this directory due
574 to this error: $firsterror\n};
576 As "$dotcpan" is a symlink to "$symlinkcpan",
577 I tried to create that, but I failed with this error: $seconderror
580 Please make sure the directory exists and is writable.
582 $CPAN::Frontend->mydie($diemess);
586 unless ($fh = FileHandle->new(">$lockfile")) {
587 if ($! =~ /Permission/) {
588 my $incc = $INC{'CPAN/Config.pm'};
589 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
590 $CPAN::Frontend->myprint(qq{
592 Your configuration suggests that CPAN.pm should use a working
594 $CPAN::Config->{cpan_home}
595 Unfortunately we could not create the lock file
597 due to permission problems.
599 Please make sure that the configuration variable
600 \$CPAN::Config->{cpan_home}
601 points to a directory where you can write a .lock file. You can set
602 this variable in either
609 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
611 $fh->print($$, "\n");
612 $fh->print(hostname(), "\n");
613 $self->{LOCK} = $lockfile;
617 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
622 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
623 print "Caught SIGINT\n";
627 # From: Larry Wall <larry@wall.org>
628 # Subject: Re: deprecating SIGDIE
629 # To: perl5-porters@perl.org
630 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
632 # The original intent of __DIE__ was only to allow you to substitute one
633 # kind of death for another on an application-wide basis without respect
634 # to whether you were in an eval or not. As a global backstop, it should
635 # not be used any more lightly (or any more heavily :-) than class
636 # UNIVERSAL. Any attempt to build a general exception model on it should
637 # be politely squashed. Any bug that causes every eval {} to have to be
638 # modified should be not so politely squashed.
640 # Those are my current opinions. It is also my optinion that polite
641 # arguments degenerate to personal arguments far too frequently, and that
642 # when they do, it's because both people wanted it to, or at least didn't
643 # sufficiently want it not to.
647 # global backstop to cleanup if we should really die
648 $SIG{__DIE__} = \&cleanup;
649 $self->debug("Signal handler set.") if $CPAN::DEBUG;
652 #-> sub CPAN::DESTROY ;
654 &cleanup; # need an eval?
657 #-> sub CPAN::anycwd ;
660 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
665 sub cwd {Cwd::cwd();}
667 #-> sub CPAN::getcwd ;
668 sub getcwd {Cwd::getcwd();}
670 #-> sub CPAN::exists ;
672 my($mgr,$class,$id) = @_;
673 CPAN::Config->load unless $CPAN::Config_loaded++;
675 ### Carp::croak "exists called without class argument" unless $class;
677 exists $META->{readonly}{$class}{$id} or
678 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
681 #-> sub CPAN::delete ;
683 my($mgr,$class,$id) = @_;
684 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
685 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
688 #-> sub CPAN::has_usable
689 # has_inst is sometimes too optimistic, we should replace it with this
690 # has_usable whenever a case is given
692 my($self,$mod,$message) = @_;
693 return 1 if $HAS_USABLE->{$mod};
694 my $has_inst = $self->has_inst($mod,$message);
695 return unless $has_inst;
698 LWP => [ # we frequently had "Can't locate object
699 # method "new" via package "LWP::UserAgent" at
700 # (eval 69) line 2006
702 sub {require LWP::UserAgent},
703 sub {require HTTP::Request},
704 sub {require URI::URL},
707 sub {require Net::FTP},
708 sub {require Net::Config},
711 if ($usable->{$mod}) {
712 for my $c (0..$#{$usable->{$mod}}) {
713 my $code = $usable->{$mod}[$c];
714 my $ret = eval { &$code() };
716 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
721 return $HAS_USABLE->{$mod} = 1;
724 #-> sub CPAN::has_inst
726 my($self,$mod,$message) = @_;
727 Carp::croak("CPAN->has_inst() called without an argument")
729 if (defined $message && $message eq "no"
731 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
733 exists $CPAN::Config->{dontload_hash}{$mod}
735 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
741 $file =~ s|/|\\|g if $^O eq 'MSWin32';
744 # checking %INC is wrong, because $INC{LWP} may be true
745 # although $INC{"URI/URL.pm"} may have failed. But as
746 # I really want to say "bla loaded OK", I have to somehow
748 ### warn "$file in %INC"; #debug
750 } elsif (eval { require $file }) {
751 # eval is good: if we haven't yet read the database it's
752 # perfect and if we have installed the module in the meantime,
753 # it tries again. The second require is only a NOOP returning
754 # 1 if we had success, otherwise it's retrying
756 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
757 if ($mod eq "CPAN::WAIT") {
758 push @CPAN::Shell::ISA, CPAN::WAIT;
761 } elsif ($mod eq "Net::FTP") {
762 $CPAN::Frontend->mywarn(qq{
763 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
765 install Bundle::libnet
767 }) unless $Have_warned->{"Net::FTP"}++;
769 } elsif ($mod eq "Digest::MD5"){
770 $CPAN::Frontend->myprint(qq{
771 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
772 Please consider installing the Digest::MD5 module.
776 } elsif ($mod eq "Module::Signature"){
777 # No point in complaining unless the user can reasonably install it.
778 if (eval { require Crypt::OpenPGP; 1 } or
779 defined $CPAN::Config->{'gpg'}) {
780 $CPAN::Frontend->myprint(qq{
781 CPAN: Module::Signature security checks disabled because Module::Signature
782 not installed. Please consider installing the Module::Signature module.
787 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
792 #-> sub CPAN::instance ;
794 my($mgr,$class,$id) = @_;
797 # unsafe meta access, ok?
798 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
799 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
807 #-> sub CPAN::cleanup ;
809 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
810 local $SIG{__DIE__} = '';
815 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
817 $subroutine eq '(eval)';
819 return if $ineval && !$End;
820 return unless defined $META->{LOCK};
821 return unless -f $META->{LOCK};
823 unlink $META->{LOCK};
825 # Carp::cluck("DEBUGGING");
826 $CPAN::Frontend->mywarn("Lockfile removed.\n");
829 #-> sub CPAN::savehist
832 my($histfile,$histsize);
833 unless ($histfile = $CPAN::Config->{'histfile'}){
834 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
837 $histsize = $CPAN::Config->{'histsize'} || 100;
839 unless ($CPAN::term->can("GetHistory")) {
840 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
846 my @h = $CPAN::term->GetHistory;
847 splice @h, 0, @h-$histsize if @h>$histsize;
848 my($fh) = FileHandle->new;
849 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
850 local $\ = local $, = "\n";
856 my($self,$what) = @_;
857 $self->{is_tested}{$what} = 1;
861 my($self,$what) = @_;
862 delete $self->{is_tested}{$what};
867 $self->{is_tested} ||= {};
868 return unless %{$self->{is_tested}};
869 my $env = $ENV{PERL5LIB};
870 $env = $ENV{PERLLIB} unless defined $env;
872 push @env, $env if defined $env and length $env;
873 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
874 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
875 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
878 package CPAN::CacheMgr;
880 #-> sub CPAN::CacheMgr::as_string ;
882 eval { require Data::Dumper };
884 return shift->SUPER::as_string;
886 return Data::Dumper::Dumper(shift);
890 #-> sub CPAN::CacheMgr::cachesize ;
895 #-> sub CPAN::CacheMgr::tidyup ;
898 return unless -d $self->{ID};
899 while ($self->{DU} > $self->{'MAX'} ) {
900 my($toremove) = shift @{$self->{FIFO}};
901 $CPAN::Frontend->myprint(sprintf(
902 "Deleting from cache".
903 ": $toremove (%.1f>%.1f MB)\n",
904 $self->{DU}, $self->{'MAX'})
906 return if $CPAN::Signal;
907 $self->force_clean_cache($toremove);
908 return if $CPAN::Signal;
912 #-> sub CPAN::CacheMgr::dir ;
917 #-> sub CPAN::CacheMgr::entries ;
920 return unless defined $dir;
921 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
922 $dir ||= $self->{ID};
923 my($cwd) = CPAN::anycwd();
924 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
925 my $dh = DirHandle->new(File::Spec->curdir)
926 or Carp::croak("Couldn't opendir $dir: $!");
929 next if $_ eq "." || $_ eq "..";
931 push @entries, File::Spec->catfile($dir,$_);
933 push @entries, File::Spec->catdir($dir,$_);
935 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
938 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
939 sort { -M $b <=> -M $a} @entries;
942 #-> sub CPAN::CacheMgr::disk_usage ;
945 return if exists $self->{SIZE}{$dir};
946 return if $CPAN::Signal;
950 $File::Find::prune++ if $CPAN::Signal;
952 if ($^O eq 'MacOS') {
954 my $cat = Mac::Files::FSpGetCatInfo($_);
955 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
962 return if $CPAN::Signal;
963 $self->{SIZE}{$dir} = $Du/1024/1024;
964 push @{$self->{FIFO}}, $dir;
965 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
966 $self->{DU} += $Du/1024/1024;
970 #-> sub CPAN::CacheMgr::force_clean_cache ;
971 sub force_clean_cache {
973 return unless -e $dir;
974 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
976 File::Path::rmtree($dir);
977 $self->{DU} -= $self->{SIZE}{$dir};
978 delete $self->{SIZE}{$dir};
981 #-> sub CPAN::CacheMgr::new ;
988 ID => $CPAN::Config->{'build_dir'},
989 MAX => $CPAN::Config->{'build_cache'},
990 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
993 File::Path::mkpath($self->{ID});
994 my $dh = DirHandle->new($self->{ID});
998 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1000 CPAN->debug($debug) if $CPAN::DEBUG;
1004 #-> sub CPAN::CacheMgr::scan_cache ;
1007 return if $self->{SCAN} eq 'never';
1008 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1009 unless $self->{SCAN} eq 'atstart';
1010 $CPAN::Frontend->myprint(
1011 sprintf("Scanning cache %s for sizes\n",
1014 for $e ($self->entries($self->{ID})) {
1015 next if $e eq ".." || $e eq ".";
1016 $self->disk_usage($e);
1017 return if $CPAN::Signal;
1022 package CPAN::Debug;
1024 #-> sub CPAN::Debug::debug ;
1026 my($self,$arg) = @_;
1027 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
1028 # Complete, caller(1)
1030 ($caller) = caller(0);
1031 $caller =~ s/.*:://;
1032 $arg = "" unless defined $arg;
1033 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
1034 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
1035 if ($arg and ref $arg) {
1036 eval { require Data::Dumper };
1038 $CPAN::Frontend->myprint($arg->as_string);
1040 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
1043 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
1048 package CPAN::Config;
1050 #-> sub CPAN::Config::edit ;
1051 # returns true on successful action
1053 my($self,@args) = @_;
1054 return unless @args;
1055 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
1056 my($o,$str,$func,$args,$key_exists);
1062 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1063 if ($o =~ /list$/) {
1064 $func = shift @args;
1066 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1068 # Let's avoid eval, it's easier to comprehend without.
1069 if ($func eq "push") {
1070 push @{$CPAN::Config->{$o}}, @args;
1072 } elsif ($func eq "pop") {
1073 pop @{$CPAN::Config->{$o}};
1075 } elsif ($func eq "shift") {
1076 shift @{$CPAN::Config->{$o}};
1078 } elsif ($func eq "unshift") {
1079 unshift @{$CPAN::Config->{$o}}, @args;
1081 } elsif ($func eq "splice") {
1082 splice @{$CPAN::Config->{$o}}, @args;
1085 $CPAN::Config->{$o} = [@args];
1088 $self->prettyprint($o);
1090 if ($o eq "urllist" && $changed) {
1091 # reset the cached values
1092 undef $CPAN::FTP::Thesite;
1093 undef $CPAN::FTP::Themethod;
1097 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1098 $self->prettyprint($o);
1105 my $v = $CPAN::Config->{$k};
1107 my(@report) = ref $v eq "ARRAY" ?
1109 map { sprintf(" %-18s => %s\n",
1111 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1113 $CPAN::Frontend->myprint(
1120 map {"\t$_\n"} @report
1123 } elsif (defined $v) {
1124 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1126 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1130 #-> sub CPAN::Config::commit ;
1132 my($self,$configpm) = @_;
1133 unless (defined $configpm){
1134 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1135 $configpm ||= $INC{"CPAN/Config.pm"};
1136 $configpm || Carp::confess(q{
1137 CPAN::Config::commit called without an argument.
1138 Please specify a filename where to save the configuration or try
1139 "o conf init" to have an interactive course through configing.
1144 $mode = (stat $configpm)[2];
1145 if ($mode && ! -w _) {
1146 Carp::confess("$configpm is not writable");
1151 $msg = <<EOF unless $configpm =~ /MyConfig/;
1153 # This is CPAN.pm's systemwide configuration file. This file provides
1154 # defaults for users, and the values can be changed in a per-user
1155 # configuration file. The user-config file is being looked for as
1156 # ~/.cpan/CPAN/MyConfig.pm.
1160 my($fh) = FileHandle->new;
1161 rename $configpm, "$configpm~" if -f $configpm;
1162 open $fh, ">$configpm" or
1163 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1164 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1165 foreach (sort keys %$CPAN::Config) {
1168 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1173 $fh->print("};\n1;\n__END__\n");
1176 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1177 #chmod $mode, $configpm;
1178 ###why was that so? $self->defaults;
1179 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1183 *default = \&defaults;
1184 #-> sub CPAN::Config::defaults ;
1194 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1203 # This is a piece of repeated code that is abstracted here for
1204 # maintainability. RMB
1207 my($configpmdir, $configpmtest) = @_;
1208 if (-w $configpmtest) {
1209 return $configpmtest;
1210 } elsif (-w $configpmdir) {
1211 #_#_# following code dumped core on me with 5.003_11, a.k.
1212 my $configpm_bak = "$configpmtest.bak";
1213 unlink $configpm_bak if -f $configpm_bak;
1214 if( -f $configpmtest ) {
1215 if( rename $configpmtest, $configpm_bak ) {
1216 $CPAN::Frontend->mywarn(<<END)
1217 Old configuration file $configpmtest
1218 moved to $configpm_bak
1222 my $fh = FileHandle->new;
1223 if ($fh->open(">$configpmtest")) {
1225 return $configpmtest;
1227 # Should never happen
1228 Carp::confess("Cannot open >$configpmtest");
1233 #-> sub CPAN::Config::load ;
1238 eval {require CPAN::Config;}; # We eval because of some
1239 # MakeMaker problems
1240 unless ($dot_cpan++){
1241 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1242 eval {require CPAN::MyConfig;}; # where you can override
1243 # system wide settings
1246 return unless @miss = $self->missing_config_data;
1248 require CPAN::FirstTime;
1249 my($configpm,$fh,$redo,$theycalled);
1251 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1252 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1253 $configpm = $INC{"CPAN/Config.pm"};
1255 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1256 $configpm = $INC{"CPAN/MyConfig.pm"};
1259 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1260 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1261 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1262 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1263 $configpm = _configpmtest($configpmdir,$configpmtest);
1265 unless ($configpm) {
1266 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1267 File::Path::mkpath($configpmdir);
1268 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1269 $configpm = _configpmtest($configpmdir,$configpmtest);
1270 unless ($configpm) {
1271 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1272 qq{create a configuration file.});
1277 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1278 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1282 $CPAN::Frontend->myprint(qq{
1283 $configpm initialized.
1286 CPAN::FirstTime::init($configpm);
1289 #-> sub CPAN::Config::missing_config_data ;
1290 sub missing_config_data {
1293 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1294 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1296 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1297 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1298 "prerequisites_policy",
1301 push @miss, $_ unless defined $CPAN::Config->{$_};
1306 #-> sub CPAN::Config::unload ;
1308 delete $INC{'CPAN/MyConfig.pm'};
1309 delete $INC{'CPAN/Config.pm'};
1312 #-> sub CPAN::Config::help ;
1314 $CPAN::Frontend->myprint(q[
1316 defaults reload default config values from disk
1317 commit commit session changes to disk
1318 init go through a dialog to set all parameters
1320 You may edit key values in the follow fashion (the "o" is a literal
1323 o conf build_cache 15
1325 o conf build_dir "/foo/bar"
1327 o conf urllist shift
1329 o conf urllist unshift ftp://ftp.foo.bar/
1332 undef; #don't reprint CPAN::Config
1335 #-> sub CPAN::Config::cpl ;
1337 my($word,$line,$pos) = @_;
1339 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1340 my(@words) = split " ", substr($line,0,$pos+1);
1345 $words[2] =~ /list$/ && @words == 3
1347 $words[2] =~ /list$/ && @words == 4 && length($word)
1350 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1351 } elsif (@words >= 4) {
1354 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1355 return grep /^\Q$word\E/, @o_conf;
1358 package CPAN::Shell;
1360 #-> sub CPAN::Shell::h ;
1362 my($class,$about) = @_;
1363 if (defined $about) {
1364 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1366 $CPAN::Frontend->myprint(q{
1368 command argument description
1369 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1370 i WORD or /REGEXP/ about anything of above
1371 r NONE reinstall recommendations
1372 ls AUTHOR about files in the author's directory
1374 Download, Test, Make, Install...
1376 make make (implies get)
1377 test MODULES, make test (implies make)
1378 install DISTS, BUNDLES make install (implies test)
1380 look open subshell in these dists' directories
1381 readme display these dists' README files
1384 h,? display this menu ! perl-code eval a perl command
1385 o conf [opt] set and query options q quit the cpan shell
1386 reload cpan load CPAN.pm again reload index load newer indices
1387 autobundle Snapshot force cmd unconditionally do cmd});
1393 #-> sub CPAN::Shell::a ;
1395 my($self,@arg) = @_;
1396 # authors are always UPPERCASE
1398 $_ = uc $_ unless /=/;
1400 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1403 #-> sub CPAN::Shell::ls ;
1405 my($self,@arg) = @_;
1408 unless (/^[A-Z\-]+$/i) {
1409 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1412 push @accept, uc $_;
1414 for my $a (@accept){
1415 my $author = $self->expand('Author',$a) or die "No author found for $a";
1420 #-> sub CPAN::Shell::local_bundles ;
1422 my($self,@which) = @_;
1423 my($incdir,$bdir,$dh);
1424 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1425 my @bbase = "Bundle";
1426 while (my $bbase = shift @bbase) {
1427 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1428 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1429 if ($dh = DirHandle->new($bdir)) { # may fail
1431 for $entry ($dh->read) {
1432 next if $entry =~ /^\./;
1433 if (-d File::Spec->catdir($bdir,$entry)){
1434 push @bbase, "$bbase\::$entry";
1436 next unless $entry =~ s/\.pm(?!\n)\Z//;
1437 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1445 #-> sub CPAN::Shell::b ;
1447 my($self,@which) = @_;
1448 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1449 $self->local_bundles;
1450 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1453 #-> sub CPAN::Shell::d ;
1454 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1456 #-> sub CPAN::Shell::m ;
1457 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1459 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1462 #-> sub CPAN::Shell::i ;
1467 @type = qw/Author Bundle Distribution Module/;
1468 @args = '/./' unless @args;
1471 push @result, $self->expand($type,@args);
1473 my $result = @result == 1 ?
1474 $result[0]->as_string :
1476 "No objects found of any type for argument @args\n" :
1478 (map {$_->as_glimpse} @result),
1479 scalar @result, " items found\n",
1481 $CPAN::Frontend->myprint($result);
1484 #-> sub CPAN::Shell::o ;
1486 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1487 # should have been called set and 'o debug' maybe 'set debug'
1489 my($self,$o_type,@o_what) = @_;
1491 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1492 if ($o_type eq 'conf') {
1493 shift @o_what if @o_what && $o_what[0] eq 'help';
1494 if (!@o_what) { # print all things, "o conf"
1496 $CPAN::Frontend->myprint("CPAN::Config options");
1497 if (exists $INC{'CPAN/Config.pm'}) {
1498 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1500 if (exists $INC{'CPAN/MyConfig.pm'}) {
1501 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1503 $CPAN::Frontend->myprint(":\n");
1504 for $k (sort keys %CPAN::Config::can) {
1505 $v = $CPAN::Config::can{$k};
1506 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1508 $CPAN::Frontend->myprint("\n");
1509 for $k (sort keys %$CPAN::Config) {
1510 CPAN::Config->prettyprint($k);
1512 $CPAN::Frontend->myprint("\n");
1513 } elsif (!CPAN::Config->edit(@o_what)) {
1514 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1515 qq{edit options\n\n});
1517 } elsif ($o_type eq 'debug') {
1519 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1522 my($what) = shift @o_what;
1523 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1524 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1527 if ( exists $CPAN::DEBUG{$what} ) {
1528 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1529 } elsif ($what =~ /^\d/) {
1530 $CPAN::DEBUG = $what;
1531 } elsif (lc $what eq 'all') {
1533 for (values %CPAN::DEBUG) {
1536 $CPAN::DEBUG = $max;
1539 for (keys %CPAN::DEBUG) {
1540 next unless lc($_) eq lc($what);
1541 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1544 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1549 my $raw = "Valid options for debug are ".
1550 join(", ",sort(keys %CPAN::DEBUG), 'all').
1551 qq{ or a number. Completion works on the options. }.
1552 qq{Case is ignored.};
1554 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1555 $CPAN::Frontend->myprint("\n\n");
1558 $CPAN::Frontend->myprint("Options set for debugging:\n");
1560 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1561 $v = $CPAN::DEBUG{$k};
1562 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1563 if $v & $CPAN::DEBUG;
1566 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1569 $CPAN::Frontend->myprint(qq{
1571 conf set or get configuration variables
1572 debug set or get debugging options
1577 sub paintdots_onreload {
1580 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1584 # $CPAN::Frontend->myprint(".($subr)");
1585 $CPAN::Frontend->myprint(".");
1592 #-> sub CPAN::Shell::reload ;
1594 my($self,$command,@arg) = @_;
1596 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1597 if ($command =~ /cpan/i) {
1598 for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1599 next unless $INC{$f};
1600 CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
1601 my $fh = FileHandle->new($INC{$f});
1604 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1607 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1609 } elsif ($command =~ /index/) {
1610 CPAN::Index->force_reload;
1612 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1613 index re-reads the index files\n});
1617 #-> sub CPAN::Shell::_binary_extensions ;
1618 sub _binary_extensions {
1619 my($self) = shift @_;
1620 my(@result,$module,%seen,%need,$headerdone);
1621 for $module ($self->expand('Module','/./')) {
1622 my $file = $module->cpan_file;
1623 next if $file eq "N/A";
1624 next if $file =~ /^Contact Author/;
1625 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1626 next if $dist->isa_perl;
1627 next unless $module->xs_file;
1629 $CPAN::Frontend->myprint(".");
1630 push @result, $module;
1632 # print join " | ", @result;
1633 $CPAN::Frontend->myprint("\n");
1637 #-> sub CPAN::Shell::recompile ;
1639 my($self) = shift @_;
1640 my($module,@module,$cpan_file,%dist);
1641 @module = $self->_binary_extensions();
1642 for $module (@module){ # we force now and compile later, so we
1644 $cpan_file = $module->cpan_file;
1645 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1647 $dist{$cpan_file}++;
1649 for $cpan_file (sort keys %dist) {
1650 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1651 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1653 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1654 # stop a package from recompiling,
1655 # e.g. IO-1.12 when we have perl5.003_10
1659 #-> sub CPAN::Shell::_u_r_common ;
1661 my($self) = shift @_;
1662 my($what) = shift @_;
1663 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1664 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1665 $what && $what =~ /^[aru]$/;
1667 @args = '/./' unless @args;
1668 my(@result,$module,%seen,%need,$headerdone,
1669 $version_undefs,$version_zeroes);
1670 $version_undefs = $version_zeroes = 0;
1671 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1672 my @expand = $self->expand('Module',@args);
1673 my $expand = scalar @expand;
1674 if (0) { # Looks like noise to me, was very useful for debugging
1675 # for metadata cache
1676 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1678 for $module (@expand) {
1679 my $file = $module->cpan_file;
1680 next unless defined $file; # ??
1681 my($latest) = $module->cpan_version;
1682 my($inst_file) = $module->inst_file;
1684 return if $CPAN::Signal;
1687 $have = $module->inst_version;
1688 } elsif ($what eq "r") {
1689 $have = $module->inst_version;
1691 if ($have eq "undef"){
1693 } elsif ($have == 0){
1696 next unless CPAN::Version->vgt($latest, $have);
1697 # to be pedantic we should probably say:
1698 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1699 # to catch the case where CPAN has a version 0 and we have a version undef
1700 } elsif ($what eq "u") {
1706 } elsif ($what eq "r") {
1708 } elsif ($what eq "u") {
1712 return if $CPAN::Signal; # this is sometimes lengthy
1715 push @result, sprintf "%s %s\n", $module->id, $have;
1716 } elsif ($what eq "r") {
1717 push @result, $module->id;
1718 next if $seen{$file}++;
1719 } elsif ($what eq "u") {
1720 push @result, $module->id;
1721 next if $seen{$file}++;
1722 next if $file =~ /^Contact/;
1724 unless ($headerdone++){
1725 $CPAN::Frontend->myprint("\n");
1726 $CPAN::Frontend->myprint(sprintf(
1729 "Package namespace",
1741 $CPAN::META->has_inst("Term::ANSIColor")
1743 $module->{RO}{description}
1745 $color_on = Term::ANSIColor::color("green");
1746 $color_off = Term::ANSIColor::color("reset");
1748 $CPAN::Frontend->myprint(sprintf $sprintf,
1755 $need{$module->id}++;
1759 $CPAN::Frontend->myprint("No modules found for @args\n");
1760 } elsif ($what eq "r") {
1761 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1765 if ($version_zeroes) {
1766 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1767 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1768 qq{a version number of 0\n});
1770 if ($version_undefs) {
1771 my $s_has = $version_undefs > 1 ? "s have" : " has";
1772 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1773 qq{parseable version number\n});
1779 #-> sub CPAN::Shell::r ;
1781 shift->_u_r_common("r",@_);
1784 #-> sub CPAN::Shell::u ;
1786 shift->_u_r_common("u",@_);
1789 #-> sub CPAN::Shell::autobundle ;
1792 CPAN::Config->load unless $CPAN::Config_loaded++;
1793 my(@bundle) = $self->_u_r_common("a",@_);
1794 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1795 File::Path::mkpath($todir);
1796 unless (-d $todir) {
1797 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1800 my($y,$m,$d) = (localtime)[5,4,3];
1804 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1805 my($to) = File::Spec->catfile($todir,"$me.pm");
1807 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1808 $to = File::Spec->catfile($todir,"$me.pm");
1810 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1812 "package Bundle::$me;\n\n",
1813 "\$VERSION = '0.01';\n\n",
1817 "Bundle::$me - Snapshot of installation on ",
1818 $Config::Config{'myhostname'},
1821 "\n\n=head1 SYNOPSIS\n\n",
1822 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1823 "=head1 CONTENTS\n\n",
1824 join("\n", @bundle),
1825 "\n\n=head1 CONFIGURATION\n\n",
1827 "\n\n=head1 AUTHOR\n\n",
1828 "This Bundle has been generated automatically ",
1829 "by the autobundle routine in CPAN.pm.\n",
1832 $CPAN::Frontend->myprint("\nWrote bundle file
1836 #-> sub CPAN::Shell::expandany ;
1839 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1840 if ($s =~ m|/|) { # looks like a file
1841 $s = CPAN::Distribution->normalize($s);
1842 return $CPAN::META->instance('CPAN::Distribution',$s);
1843 # Distributions spring into existence, not expand
1844 } elsif ($s =~ m|^Bundle::|) {
1845 $self->local_bundles; # scanning so late for bundles seems
1846 # both attractive and crumpy: always
1847 # current state but easy to forget
1849 return $self->expand('Bundle',$s);
1851 return $self->expand('Module',$s)
1852 if $CPAN::META->exists('CPAN::Module',$s);
1857 #-> sub CPAN::Shell::expand ;
1860 my($type,@args) = @_;
1862 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1864 my($regex,$command);
1865 if ($arg =~ m|^/(.*)/$|) {
1867 } elsif ($arg =~ m/=/) {
1870 my $class = "CPAN::$type";
1872 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1874 defined $regex ? $regex : "UNDEFINED",
1875 $command || "UNDEFINED",
1877 if (defined $regex) {
1881 $CPAN::META->all_objects($class)
1884 # BUG, we got an empty object somewhere
1885 require Data::Dumper;
1886 CPAN->debug(sprintf(
1887 "Bug in CPAN: Empty id on obj[%s][%s]",
1889 Data::Dumper::Dumper($obj)
1894 if $obj->id =~ /$regex/i
1898 $] < 5.00303 ### provide sort of
1899 ### compatibility with 5.003
1904 $obj->name =~ /$regex/i
1907 } elsif ($command) {
1908 die "equal sign in command disabled (immature interface), ".
1910 ! \$CPAN::Shell::ADVANCED_QUERY=1
1911 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1912 that may go away anytime.\n"
1913 unless $ADVANCED_QUERY;
1914 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1915 my($matchcrit) = $criterion =~ m/^~(.+)/;
1919 $CPAN::META->all_objects($class)
1921 my $lhs = $self->$method() or next; # () for 5.00503
1923 push @m, $self if $lhs =~ m/$matchcrit/;
1925 push @m, $self if $lhs eq $criterion;
1930 if ( $type eq 'Bundle' ) {
1931 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1932 } elsif ($type eq "Distribution") {
1933 $xarg = CPAN::Distribution->normalize($arg);
1935 if ($CPAN::META->exists($class,$xarg)) {
1936 $obj = $CPAN::META->instance($class,$xarg);
1937 } elsif ($CPAN::META->exists($class,$arg)) {
1938 $obj = $CPAN::META->instance($class,$arg);
1945 return wantarray ? @m : $m[0];
1948 #-> sub CPAN::Shell::format_result ;
1951 my($type,@args) = @_;
1952 @args = '/./' unless @args;
1953 my(@result) = $self->expand($type,@args);
1954 my $result = @result == 1 ?
1955 $result[0]->as_string :
1957 "No objects of type $type found for argument @args\n" :
1959 (map {$_->as_glimpse} @result),
1960 scalar @result, " items found\n",
1965 # The only reason for this method is currently to have a reliable
1966 # debugging utility that reveals which output is going through which
1967 # channel. No, I don't like the colors ;-)
1969 #-> sub CPAN::Shell::print_ornameted ;
1970 sub print_ornamented {
1971 my($self,$what,$ornament) = @_;
1973 return unless defined $what;
1975 if ($CPAN::Config->{term_is_latin}){
1978 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1980 if ($PRINT_ORNAMENTING) {
1981 unless (defined &color) {
1982 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1983 import Term::ANSIColor "color";
1985 *color = sub { return "" };
1989 for $line (split /\n/, $what) {
1990 $longest = length($line) if length($line) > $longest;
1992 my $sprintf = "%-" . $longest . "s";
1994 $what =~ s/(.*\n?)//m;
1997 my($nl) = chomp $line ? "\n" : "";
1998 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1999 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
2003 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
2009 my($self,$what) = @_;
2011 $self->print_ornamented($what, 'bold blue on_yellow');
2015 my($self,$what) = @_;
2016 $self->myprint($what);
2021 my($self,$what) = @_;
2022 $self->print_ornamented($what, 'bold red on_yellow');
2026 my($self,$what) = @_;
2027 $self->print_ornamented($what, 'bold red on_white');
2028 Carp::confess "died";
2032 my($self,$what) = @_;
2033 $self->print_ornamented($what, 'bold red on_white');
2038 return if -t STDOUT;
2039 my $odef = select STDERR;
2046 #-> sub CPAN::Shell::rematein ;
2047 # RE-adme||MA-ke||TE-st||IN-stall
2050 my($meth,@some) = @_;
2052 if ($meth eq 'force') {
2054 $meth = shift @some;
2057 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
2059 # Here is the place to set "test_count" on all involved parties to
2060 # 0. We then can pass this counter on to the involved
2061 # distributions and those can refuse to test if test_count > X. In
2062 # the first stab at it we could use a 1 for "X".
2064 # But when do I reset the distributions to start with 0 again?
2065 # Jost suggested to have a random or cycling interaction ID that
2066 # we pass through. But the ID is something that is just left lying
2067 # around in addition to the counter, so I'd prefer to set the
2068 # counter to 0 now, and repeat at the end of the loop. But what
2069 # about dependencies? They appear later and are not reset, they
2070 # enter the queue but not its copy. How do they get a sensible
2073 # construct the queue
2075 foreach $s (@some) {
2078 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2080 } elsif ($s =~ m|^/|) { # looks like a regexp
2081 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2086 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2087 $obj = CPAN::Shell->expandany($s);
2090 $obj->color_cmd_tmps(0,1);
2091 CPAN::Queue->new($obj->id);
2093 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2094 $obj = $CPAN::META->instance('CPAN::Author',$s);
2095 if ($meth =~ /^(dump|ls)$/) {
2098 $CPAN::Frontend->myprint(
2100 "Don't be silly, you can't $meth ",
2108 ->myprint(qq{Warning: Cannot $meth $s, }.
2109 qq{don\'t know what it is.
2114 to find objects with matching identifiers.
2120 # queuerunner (please be warned: when I started to change the
2121 # queue to hold objects instead of names, I made one or two
2122 # mistakes and never found which. I reverted back instead)
2123 while ($s = CPAN::Queue->first) {
2126 $obj = $s; # I do not believe, we would survive if this happened
2128 $obj = CPAN::Shell->expandany($s);
2132 ($] < 5.00303 || $obj->can($pragma))){
2133 ### compatibility with 5.003
2134 $obj->$pragma($meth); # the pragma "force" in
2135 # "CPAN::Distribution" must know
2136 # what we are intending
2138 if ($]>=5.00303 && $obj->can('called_for')) {
2139 $obj->called_for($s);
2142 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2148 CPAN::Queue->delete($s);
2150 CPAN->debug("failed");
2154 CPAN::Queue->delete_first($s);
2156 for my $obj (@qcopy) {
2157 $obj->color_cmd_tmps(0,0);
2161 #-> sub CPAN::Shell::dump ;
2162 sub dump { shift->rematein('dump',@_); }
2163 #-> sub CPAN::Shell::force ;
2164 sub force { shift->rematein('force',@_); }
2165 #-> sub CPAN::Shell::get ;
2166 sub get { shift->rematein('get',@_); }
2167 #-> sub CPAN::Shell::readme ;
2168 sub readme { shift->rematein('readme',@_); }
2169 #-> sub CPAN::Shell::make ;
2170 sub make { shift->rematein('make',@_); }
2171 #-> sub CPAN::Shell::test ;
2172 sub test { shift->rematein('test',@_); }
2173 #-> sub CPAN::Shell::install ;
2174 sub install { shift->rematein('install',@_); }
2175 #-> sub CPAN::Shell::clean ;
2176 sub clean { shift->rematein('clean',@_); }
2177 #-> sub CPAN::Shell::look ;
2178 sub look { shift->rematein('look',@_); }
2179 #-> sub CPAN::Shell::cvs_import ;
2180 sub cvs_import { shift->rematein('cvs_import',@_); }
2182 package CPAN::LWP::UserAgent;
2185 return if $SETUPDONE;
2186 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2187 require LWP::UserAgent;
2188 @ISA = qw(Exporter LWP::UserAgent);
2191 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2195 sub get_basic_credentials {
2196 my($self, $realm, $uri, $proxy) = @_;
2197 return unless $proxy;
2198 if ($USER && $PASSWD) {
2199 } elsif (defined $CPAN::Config->{proxy_user} &&
2200 defined $CPAN::Config->{proxy_pass}) {
2201 $USER = $CPAN::Config->{proxy_user};
2202 $PASSWD = $CPAN::Config->{proxy_pass};
2204 require ExtUtils::MakeMaker;
2205 ExtUtils::MakeMaker->import(qw(prompt));
2206 $USER = prompt("Proxy authentication needed!
2207 (Note: to permanently configure username and password run
2208 o conf proxy_user your_username
2209 o conf proxy_pass your_password
2211 if ($CPAN::META->has_inst("Term::ReadKey")) {
2212 Term::ReadKey::ReadMode("noecho");
2214 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2216 $PASSWD = prompt("Password:");
2217 if ($CPAN::META->has_inst("Term::ReadKey")) {
2218 Term::ReadKey::ReadMode("restore");
2220 $CPAN::Frontend->myprint("\n\n");
2222 return($USER,$PASSWD);
2226 my($self,$url,$aslocal) = @_;
2227 my $result = $self->SUPER::mirror($url,$aslocal);
2228 if ($result->code == 407) {
2231 $result = $self->SUPER::mirror($url,$aslocal);
2238 #-> sub CPAN::FTP::ftp_get ;
2240 my($class,$host,$dir,$file,$target) = @_;
2242 qq[Going to fetch file [$file] from dir [$dir]
2243 on host [$host] as local [$target]\n]
2245 my $ftp = Net::FTP->new($host);
2246 return 0 unless defined $ftp;
2247 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2248 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2249 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2250 warn "Couldn't login on $host";
2253 unless ( $ftp->cwd($dir) ){
2254 warn "Couldn't cwd $dir";
2258 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2259 unless ( $ftp->get($file,$target) ){
2260 warn "Couldn't fetch $file from $host\n";
2263 $ftp->quit; # it's ok if this fails
2267 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2269 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2270 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2272 # > *** 1562,1567 ****
2273 # > --- 1562,1580 ----
2274 # > return 1 if substr($url,0,4) eq "file";
2275 # > return 1 unless $url =~ m|://([^/]+)|;
2277 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2279 # > + $proxy =~ m|://([^/:]+)|;
2281 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2282 # > + if ($noproxy) {
2283 # > + if ($host !~ /$noproxy$/) {
2284 # > + $host = $proxy;
2287 # > + $host = $proxy;
2290 # > require Net::Ping;
2291 # > return 1 unless $Net::Ping::VERSION >= 2;
2295 #-> sub CPAN::FTP::localize ;
2297 my($self,$file,$aslocal,$force) = @_;
2299 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2300 unless defined $aslocal;
2301 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2304 if ($^O eq 'MacOS') {
2305 # Comment by AK on 2000-09-03: Uniq short filenames would be
2306 # available in CHECKSUMS file
2307 my($name, $path) = File::Basename::fileparse($aslocal, '');
2308 if (length($name) > 31) {
2319 my $size = 31 - length($suf);
2320 while (length($name) > $size) {
2324 $aslocal = File::Spec->catfile($path, $name);
2328 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2331 rename $aslocal, "$aslocal.bak";
2335 my($aslocal_dir) = File::Basename::dirname($aslocal);
2336 File::Path::mkpath($aslocal_dir);
2337 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2338 qq{directory "$aslocal_dir".
2339 I\'ll continue, but if you encounter problems, they may be due
2340 to insufficient permissions.\n}) unless -w $aslocal_dir;
2342 # Inheritance is not easier to manage than a few if/else branches
2343 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2345 CPAN::LWP::UserAgent->config;
2346 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2348 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2352 $Ua->proxy('ftp', $var)
2353 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2354 $Ua->proxy('http', $var)
2355 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2358 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2360 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2361 # > use ones that require basic autorization.
2363 # > Example of when I use it manually in my own stuff:
2365 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2366 # > $req->proxy_authorization_basic("username","password");
2367 # > $res = $ua->request($req);
2371 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2375 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2376 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2379 # Try the list of urls for each single object. We keep a record
2380 # where we did get a file from
2381 my(@reordered,$last);
2382 $CPAN::Config->{urllist} ||= [];
2383 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2384 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2386 $last = $#{$CPAN::Config->{urllist}};
2387 if ($force & 2) { # local cpans probably out of date, don't reorder
2388 @reordered = (0..$last);
2392 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2394 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2405 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2407 @levels = qw/easy hard hardest/;
2409 @levels = qw/easy/ if $^O eq 'MacOS';
2411 for $levelno (0..$#levels) {
2412 my $level = $levels[$levelno];
2413 my $method = "host$level";
2414 my @host_seq = $level eq "easy" ?
2415 @reordered : 0..$last; # reordered has CDROM up front
2416 @host_seq = (0) unless @host_seq;
2417 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2419 $Themethod = $level;
2421 # utime $now, $now, $aslocal; # too bad, if we do that, we
2422 # might alter a local mirror
2423 $self->debug("level[$level]") if $CPAN::DEBUG;
2427 last if $CPAN::Signal; # need to cleanup
2430 unless ($CPAN::Signal) {
2433 qq{Please check, if the URLs I found in your configuration file \(}.
2434 join(", ", @{$CPAN::Config->{urllist}}).
2435 qq{\) are valid. The urllist can be edited.},
2436 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2437 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2439 $CPAN::Frontend->myprint("Could not fetch $file\n");
2442 rename "$aslocal.bak", $aslocal;
2443 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2444 $self->ls($aslocal));
2451 my($self,$host_seq,$file,$aslocal) = @_;
2453 HOSTEASY: for $i (@$host_seq) {
2454 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2455 $url .= "/" unless substr($url,-1) eq "/";
2457 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2458 if ($url =~ /^file:/) {
2460 if ($CPAN::META->has_inst('URI::URL')) {
2461 my $u = URI::URL->new($url);
2463 } else { # works only on Unix, is poorly constructed, but
2464 # hopefully better than nothing.
2465 # RFC 1738 says fileurl BNF is
2466 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2467 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2469 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2470 $l =~ s|^file:||; # assume they
2473 $l =~ s|^/||s unless -f $l; # e.g. /P:
2474 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2476 if ( -f $l && -r _) {
2480 # Maybe mirror has compressed it?
2482 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2483 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2490 if ($CPAN::META->has_usable('LWP')) {
2491 $CPAN::Frontend->myprint("Fetching with LWP:
2495 CPAN::LWP::UserAgent->config;
2496 eval { $Ua = CPAN::LWP::UserAgent->new; };
2498 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2501 my $res = $Ua->mirror($url, $aslocal);
2502 if ($res->is_success) {
2505 utime $now, $now, $aslocal; # download time is more
2506 # important than upload time
2508 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2509 my $gzurl = "$url.gz";
2510 $CPAN::Frontend->myprint("Fetching with LWP:
2513 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2514 if ($res->is_success &&
2515 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2521 $CPAN::Frontend->myprint(sprintf(
2522 "LWP failed with code[%s] message[%s]\n",
2526 # Alan Burlison informed me that in firewall environments
2527 # Net::FTP can still succeed where LWP fails. So we do not
2528 # skip Net::FTP anymore when LWP is available.
2531 $CPAN::Frontend->myprint("LWP not available\n");
2533 return if $CPAN::Signal;
2534 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2535 # that's the nice and easy way thanks to Graham
2536 my($host,$dir,$getfile) = ($1,$2,$3);
2537 if ($CPAN::META->has_usable('Net::FTP')) {
2539 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2542 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2543 "aslocal[$aslocal]") if $CPAN::DEBUG;
2544 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2548 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2549 my $gz = "$aslocal.gz";
2550 $CPAN::Frontend->myprint("Fetching with Net::FTP
2553 if (CPAN::FTP->ftp_get($host,
2557 CPAN::Tarzip->gunzip($gz,$aslocal)
2566 return if $CPAN::Signal;
2571 my($self,$host_seq,$file,$aslocal) = @_;
2573 # Came back if Net::FTP couldn't establish connection (or
2574 # failed otherwise) Maybe they are behind a firewall, but they
2575 # gave us a socksified (or other) ftp program...
2578 my($devnull) = $CPAN::Config->{devnull} || "";
2580 my($aslocal_dir) = File::Basename::dirname($aslocal);
2581 File::Path::mkpath($aslocal_dir);
2582 HOSTHARD: for $i (@$host_seq) {
2583 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2584 $url .= "/" unless substr($url,-1) eq "/";
2586 my($proto,$host,$dir,$getfile);
2588 # Courtesy Mark Conty mark_conty@cargill.com change from
2589 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2591 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2592 # proto not yet used
2593 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2595 next HOSTHARD; # who said, we could ftp anything except ftp?
2597 next HOSTHARD if $proto eq "file"; # file URLs would have had
2598 # success above. Likely a bogus URL
2600 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2602 for $f ('lynx','ncftpget','ncftp','wget') {
2603 next unless exists $CPAN::Config->{$f};
2604 $funkyftp = $CPAN::Config->{$f};
2605 next unless defined $funkyftp;
2606 next if $funkyftp =~ /^\s*$/;
2607 my($asl_ungz, $asl_gz);
2608 ($asl_ungz = $aslocal) =~ s/\.gz//;
2609 $asl_gz = "$asl_ungz.gz";
2610 my($src_switch) = "";
2612 $src_switch = " -source";
2613 } elsif ($f eq "ncftp"){
2614 $src_switch = " -c";
2615 } elsif ($f eq "wget"){
2616 $src_switch = " -O -";
2619 my($stdout_redir) = " > $asl_ungz";
2620 if ($f eq "ncftpget"){
2621 $chdir = "cd $aslocal_dir && ";
2624 $CPAN::Frontend->myprint(
2626 Trying with "$funkyftp$src_switch" to get
2630 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2631 $self->debug("system[$system]") if $CPAN::DEBUG;
2633 if (($wstatus = system($system)) == 0
2636 -s $asl_ungz # lynx returns 0 when it fails somewhere
2642 } elsif ($asl_ungz ne $aslocal) {
2643 # test gzip integrity
2644 if (CPAN::Tarzip->gtest($asl_ungz)) {
2645 # e.g. foo.tar is gzipped --> foo.tar.gz
2646 rename $asl_ungz, $aslocal;
2648 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2653 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2655 -f $asl_ungz && -s _ == 0;
2656 my $gz = "$aslocal.gz";
2657 my $gzurl = "$url.gz";
2658 $CPAN::Frontend->myprint(
2660 Trying with "$funkyftp$src_switch" to get
2663 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2664 $self->debug("system[$system]") if $CPAN::DEBUG;
2666 if (($wstatus = system($system)) == 0
2670 # test gzip integrity
2671 if (CPAN::Tarzip->gtest($asl_gz)) {
2672 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2674 # somebody uncompressed file for us?
2675 rename $asl_ungz, $aslocal;
2680 unlink $asl_gz if -f $asl_gz;
2683 my $estatus = $wstatus >> 8;
2684 my $size = -f $aslocal ?
2685 ", left\n$aslocal with size ".-s _ :
2686 "\nWarning: expected file [$aslocal] doesn't exist";
2687 $CPAN::Frontend->myprint(qq{
2688 System call "$system"
2689 returned status $estatus (wstat $wstatus)$size
2692 return if $CPAN::Signal;
2693 } # lynx,ncftpget,ncftp
2698 my($self,$host_seq,$file,$aslocal) = @_;
2701 my($aslocal_dir) = File::Basename::dirname($aslocal);
2702 File::Path::mkpath($aslocal_dir);
2703 my $ftpbin = $CPAN::Config->{ftp};
2704 HOSTHARDEST: for $i (@$host_seq) {
2705 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2706 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2709 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2710 $url .= "/" unless substr($url,-1) eq "/";
2712 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2713 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2716 my($host,$dir,$getfile) = ($1,$2,$3);
2718 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2719 $ctime,$blksize,$blocks) = stat($aslocal);
2720 $timestamp = $mtime ||= 0;
2721 my($netrc) = CPAN::FTP::netrc->new;
2722 my($netrcfile) = $netrc->netrc;
2723 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2724 my $targetfile = File::Basename::basename($aslocal);
2730 map("cd $_", split /\//, $dir), # RFC 1738
2732 "get $getfile $targetfile",
2736 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2737 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2738 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2740 $netrc->contains($host))) if $CPAN::DEBUG;
2741 if ($netrc->protected) {
2742 $CPAN::Frontend->myprint(qq{
2743 Trying with external ftp to get
2745 As this requires some features that are not thoroughly tested, we\'re
2746 not sure, that we get it right....
2750 $self->talk_ftp("$ftpbin$verbose $host",
2752 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2753 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2755 if ($mtime > $timestamp) {
2756 $CPAN::Frontend->myprint("GOT $aslocal\n");
2760 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2762 return if $CPAN::Signal;
2764 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2765 qq{correctly protected.\n});
2768 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2769 nor does it have a default entry\n");
2772 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2773 # then and login manually to host, using e-mail as
2775 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2779 "user anonymous $Config::Config{'cf_email'}"
2781 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2782 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2783 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2785 if ($mtime > $timestamp) {
2786 $CPAN::Frontend->myprint("GOT $aslocal\n");
2790 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2792 return if $CPAN::Signal;
2793 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2799 my($self,$command,@dialog) = @_;
2800 my $fh = FileHandle->new;
2801 $fh->open("|$command") or die "Couldn't open ftp: $!";
2802 foreach (@dialog) { $fh->print("$_\n") }
2803 $fh->close; # Wait for process to complete
2805 my $estatus = $wstatus >> 8;
2806 $CPAN::Frontend->myprint(qq{
2807 Subprocess "|$command"
2808 returned status $estatus (wstat $wstatus)
2812 # find2perl needs modularization, too, all the following is stolen
2816 my($self,$name) = @_;
2817 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2818 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2820 my($perms,%user,%group);
2824 $blocks = int(($blocks + 1) / 2);
2827 $blocks = int(($sizemm + 1023) / 1024);
2830 if (-f _) { $perms = '-'; }
2831 elsif (-d _) { $perms = 'd'; }
2832 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2833 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2834 elsif (-p _) { $perms = 'p'; }
2835 elsif (-S _) { $perms = 's'; }
2836 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2838 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2839 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2840 my $tmpmode = $mode;
2841 my $tmp = $rwx[$tmpmode & 7];
2843 $tmp = $rwx[$tmpmode & 7] . $tmp;
2845 $tmp = $rwx[$tmpmode & 7] . $tmp;
2846 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2847 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2848 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2851 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2852 my $group = $group{$gid} || $gid;
2854 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2856 my($moname) = $moname[$mon];
2857 if (-M _ > 365.25 / 2) {
2858 $timeyear = $year + 1900;
2861 $timeyear = sprintf("%02d:%02d", $hour, $min);
2864 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2878 package CPAN::FTP::netrc;
2882 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2884 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2885 $atime,$mtime,$ctime,$blksize,$blocks)
2890 my($fh,@machines,$hasdefault);
2892 $fh = FileHandle->new or die "Could not create a filehandle";
2894 if($fh->open($file)){
2895 $protected = ($mode & 077) == 0;
2897 NETRC: while (<$fh>) {
2898 my(@tokens) = split " ", $_;
2899 TOKEN: while (@tokens) {
2900 my($t) = shift @tokens;
2901 if ($t eq "default"){
2905 last TOKEN if $t eq "macdef";
2906 if ($t eq "machine") {
2907 push @machines, shift @tokens;
2912 $file = $hasdefault = $protected = "";
2916 'mach' => [@machines],
2918 'hasdefault' => $hasdefault,
2919 'protected' => $protected,
2923 # CPAN::FTP::hasdefault;
2924 sub hasdefault { shift->{'hasdefault'} }
2925 sub netrc { shift->{'netrc'} }
2926 sub protected { shift->{'protected'} }
2928 my($self,$mach) = @_;
2929 for ( @{$self->{'mach'}} ) {
2930 return 1 if $_ eq $mach;
2935 package CPAN::Complete;
2938 my($text, $line, $start, $end) = @_;
2939 my(@perlret) = cpl($text, $line, $start);
2940 # find longest common match. Can anybody show me how to peruse
2941 # T::R::Gnu to have this done automatically? Seems expensive.
2942 return () unless @perlret;
2943 my($newtext) = $text;
2944 for (my $i = length($text)+1;;$i++) {
2945 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2946 my $try = substr($perlret[0],0,$i);
2947 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2948 # warn "try[$try]tries[@tries]";
2949 if (@tries == @perlret) {
2955 ($newtext,@perlret);
2958 #-> sub CPAN::Complete::cpl ;
2960 my($word,$line,$pos) = @_;
2964 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2966 if ($line =~ s/^(force\s*)//) {
2971 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2972 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2974 } elsif ($line =~ /^(a|ls)\s/) {
2975 @return = cplx('CPAN::Author',uc($word));
2976 } elsif ($line =~ /^b\s/) {
2977 CPAN::Shell->local_bundles;
2978 @return = cplx('CPAN::Bundle',$word);
2979 } elsif ($line =~ /^d\s/) {
2980 @return = cplx('CPAN::Distribution',$word);
2981 } elsif ($line =~ m/^(
2982 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2984 if ($word =~ /^Bundle::/) {
2985 CPAN::Shell->local_bundles;
2987 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2988 } elsif ($line =~ /^i\s/) {
2989 @return = cpl_any($word);
2990 } elsif ($line =~ /^reload\s/) {
2991 @return = cpl_reload($word,$line,$pos);
2992 } elsif ($line =~ /^o\s/) {
2993 @return = cpl_option($word,$line,$pos);
2994 } elsif ($line =~ m/^\S+\s/ ) {
2995 # fallback for future commands and what we have forgotten above
2996 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3003 #-> sub CPAN::Complete::cplx ;
3005 my($class, $word) = @_;
3006 # I believed for many years that this was sorted, today I
3007 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3008 # make it sorted again. Maybe sort was dropped when GNU-readline
3009 # support came in? The RCS file is difficult to read on that:-(
3010 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3013 #-> sub CPAN::Complete::cpl_any ;
3017 cplx('CPAN::Author',$word),
3018 cplx('CPAN::Bundle',$word),
3019 cplx('CPAN::Distribution',$word),
3020 cplx('CPAN::Module',$word),
3024 #-> sub CPAN::Complete::cpl_reload ;
3026 my($word,$line,$pos) = @_;
3028 my(@words) = split " ", $line;
3029 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3030 my(@ok) = qw(cpan index);
3031 return @ok if @words == 1;
3032 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3035 #-> sub CPAN::Complete::cpl_option ;
3037 my($word,$line,$pos) = @_;
3039 my(@words) = split " ", $line;
3040 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3041 my(@ok) = qw(conf debug);
3042 return @ok if @words == 1;
3043 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3045 } elsif ($words[1] eq 'index') {
3047 } elsif ($words[1] eq 'conf') {
3048 return CPAN::Config::cpl(@_);
3049 } elsif ($words[1] eq 'debug') {
3050 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
3054 package CPAN::Index;
3056 #-> sub CPAN::Index::force_reload ;
3059 $CPAN::Index::LAST_TIME = 0;
3063 #-> sub CPAN::Index::reload ;
3065 my($cl,$force) = @_;
3068 # XXX check if a newer one is available. (We currently read it
3069 # from time to time)
3070 for ($CPAN::Config->{index_expire}) {
3071 $_ = 0.001 unless $_ && $_ > 0.001;
3073 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3074 # debug here when CPAN doesn't seem to read the Metadata
3076 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3078 unless ($CPAN::META->{PROTOCOL}) {
3079 $cl->read_metadata_cache;
3080 $CPAN::META->{PROTOCOL} ||= "1.0";
3082 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3083 # warn "Setting last_time to 0";
3084 $LAST_TIME = 0; # No warning necessary
3086 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3089 # IFF we are developing, it helps to wipe out the memory
3090 # between reloads, otherwise it is not what a user expects.
3091 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3092 $CPAN::META = CPAN->new;
3096 local $LAST_TIME = $time;
3097 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3099 my $needshort = $^O eq "dos";
3101 $cl->rd_authindex($cl
3103 "authors/01mailrc.txt.gz",
3105 File::Spec->catfile('authors', '01mailrc.gz') :
3106 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3109 $debug = "timing reading 01[".($t2 - $time)."]";
3111 return if $CPAN::Signal; # this is sometimes lengthy
3112 $cl->rd_modpacks($cl
3114 "modules/02packages.details.txt.gz",
3116 File::Spec->catfile('modules', '02packag.gz') :
3117 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3120 $debug .= "02[".($t2 - $time)."]";
3122 return if $CPAN::Signal; # this is sometimes lengthy
3125 "modules/03modlist.data.gz",
3127 File::Spec->catfile('modules', '03mlist.gz') :
3128 File::Spec->catfile('modules', '03modlist.data.gz'),
3130 $cl->write_metadata_cache;
3132 $debug .= "03[".($t2 - $time)."]";
3134 CPAN->debug($debug) if $CPAN::DEBUG;
3137 $CPAN::META->{PROTOCOL} = PROTOCOL;
3140 #-> sub CPAN::Index::reload_x ;
3142 my($cl,$wanted,$localname,$force) = @_;
3143 $force |= 2; # means we're dealing with an index here
3144 CPAN::Config->load; # we should guarantee loading wherever we rely
3146 $localname ||= $wanted;
3147 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3151 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3154 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3155 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3156 qq{day$s. I\'ll use that.});
3159 $force |= 1; # means we're quite serious about it.
3161 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3164 #-> sub CPAN::Index::rd_authindex ;
3166 my($cl, $index_target) = @_;
3168 return unless defined $index_target;
3169 $CPAN::Frontend->myprint("Going to read $index_target\n");
3171 tie *FH, CPAN::Tarzip, $index_target;
3173 push @lines, split /\012/ while <FH>;
3175 my($userid,$fullname,$email) =
3176 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3177 next unless $userid && $fullname && $email;
3179 # instantiate an author object
3180 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3181 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3182 return if $CPAN::Signal;
3187 my($self,$dist) = @_;
3188 $dist = $self->{'id'} unless defined $dist;
3189 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3193 #-> sub CPAN::Index::rd_modpacks ;
3195 my($self, $index_target) = @_;
3197 return unless defined $index_target;
3198 $CPAN::Frontend->myprint("Going to read $index_target\n");
3199 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3201 while ($_ = $fh->READLINE) {
3203 my @ls = map {"$_\n"} split /\n/, $_;
3204 unshift @ls, "\n" x length($1) if /^(\n+)/;
3208 my($line_count,$last_updated);
3210 my $shift = shift(@lines);
3211 last if $shift =~ /^\s*$/;
3212 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3213 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3215 if (not defined $line_count) {
3217 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3218 Please check the validity of the index file by comparing it to more
3219 than one CPAN mirror. I'll continue but problems seem likely to
3224 } elsif ($line_count != scalar @lines) {
3226 warn sprintf qq{Warning: Your %s
3227 contains a Line-Count header of %d but I see %d lines there. Please
3228 check the validity of the index file by comparing it to more than one
3229 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3230 $index_target, $line_count, scalar(@lines);
3233 if (not defined $last_updated) {
3235 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3236 Please check the validity of the index file by comparing it to more
3237 than one CPAN mirror. I'll continue but problems seem likely to
3245 ->myprint(sprintf qq{ Database was generated on %s\n},
3247 $DATE_OF_02 = $last_updated;
3249 if ($CPAN::META->has_inst(HTTP::Date)) {
3251 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3256 qq{Warning: This index file is %d days old.
3257 Please check the host you chose as your CPAN mirror for staleness.
3258 I'll continue but problems seem likely to happen.\a\n},
3263 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3268 # A necessity since we have metadata_cache: delete what isn't
3270 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3271 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3275 # before 1.56 we split into 3 and discarded the rest. From
3276 # 1.57 we assign remaining text to $comment thus allowing to
3277 # influence isa_perl
3278 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3279 my($bundle,$id,$userid);
3281 if ($mod eq 'CPAN' &&
3283 CPAN::Queue->exists('Bundle::CPAN') ||
3284 CPAN::Queue->exists('CPAN')
3288 if ($version > $CPAN::VERSION){
3289 $CPAN::Frontend->myprint(qq{
3290 There's a new CPAN.pm version (v$version) available!
3291 [Current version is v$CPAN::VERSION]
3292 You might want to try
3293 install Bundle::CPAN
3295 without quitting the current session. It should be a seamless upgrade
3296 while we are running...
3299 $CPAN::Frontend->myprint(qq{\n});
3301 last if $CPAN::Signal;
3302 } elsif ($mod =~ /^Bundle::(.*)/) {
3307 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3308 # Let's make it a module too, because bundles have so much
3309 # in common with modules.
3311 # Changed in 1.57_63: seems like memory bloat now without
3312 # any value, so commented out
3314 # $CPAN::META->instance('CPAN::Module',$mod);
3318 # instantiate a module object
3319 $id = $CPAN::META->instance('CPAN::Module',$mod);
3323 if ($id->cpan_file ne $dist){ # update only if file is
3324 # different. CPAN prohibits same
3325 # name with different version
3326 $userid = $id->userid || $self->userid($dist);
3328 'CPAN_USERID' => $userid,
3329 'CPAN_VERSION' => $version,
3330 'CPAN_FILE' => $dist,
3334 # instantiate a distribution object
3335 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3336 # we do not need CONTAINSMODS unless we do something with
3337 # this dist, so we better produce it on demand.
3339 ## my $obj = $CPAN::META->instance(
3340 ## 'CPAN::Distribution' => $dist
3342 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3344 $CPAN::META->instance(
3345 'CPAN::Distribution' => $dist
3347 'CPAN_USERID' => $userid,
3348 'CPAN_COMMENT' => $comment,
3352 for my $name ($mod,$dist) {
3353 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3354 $exists{$name} = undef;
3357 return if $CPAN::Signal;
3361 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3362 for my $o ($CPAN::META->all_objects($class)) {
3363 next if exists $exists{$o->{ID}};
3364 $CPAN::META->delete($class,$o->{ID});
3365 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3372 #-> sub CPAN::Index::rd_modlist ;
3374 my($cl,$index_target) = @_;
3375 return unless defined $index_target;
3376 $CPAN::Frontend->myprint("Going to read $index_target\n");
3377 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3380 while ($_ = $fh->READLINE) {
3382 my @ls = map {"$_\n"} split /\n/, $_;
3383 unshift @ls, "\n" x length($1) if /^(\n+)/;
3387 my $shift = shift(@eval);
3388 if ($shift =~ /^Date:\s+(.*)/){
3389 return if $DATE_OF_03 eq $1;
3392 last if $shift =~ /^\s*$/;
3395 push @eval, q{CPAN::Modulelist->data;};
3397 my($comp) = Safe->new("CPAN::Safe1");
3398 my($eval) = join("", @eval);
3399 my $ret = $comp->reval($eval);
3400 Carp::confess($@) if $@;
3401 return if $CPAN::Signal;
3403 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3404 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3405 $obj->set(%{$ret->{$_}});
3406 return if $CPAN::Signal;
3410 #-> sub CPAN::Index::write_metadata_cache ;
3411 sub write_metadata_cache {
3413 return unless $CPAN::Config->{'cache_metadata'};
3414 return unless $CPAN::META->has_usable("Storable");
3416 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3417 CPAN::Distribution)) {
3418 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3420 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3421 $cache->{last_time} = $LAST_TIME;
3422 $cache->{DATE_OF_02} = $DATE_OF_02;
3423 $cache->{PROTOCOL} = PROTOCOL;
3424 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3425 eval { Storable::nstore($cache, $metadata_file) };
3426 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3429 #-> sub CPAN::Index::read_metadata_cache ;
3430 sub read_metadata_cache {
3432 return unless $CPAN::Config->{'cache_metadata'};
3433 return unless $CPAN::META->has_usable("Storable");
3434 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3435 return unless -r $metadata_file and -f $metadata_file;
3436 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3438 eval { $cache = Storable::retrieve($metadata_file) };
3439 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3440 if (!$cache || ref $cache ne 'HASH'){
3444 if (exists $cache->{PROTOCOL}) {
3445 if (PROTOCOL > $cache->{PROTOCOL}) {
3446 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3447 "with protocol v%s, requiring v%s\n",
3454 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3455 "with protocol v1.0\n");
3460 while(my($class,$v) = each %$cache) {
3461 next unless $class =~ /^CPAN::/;
3462 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3463 while (my($id,$ro) = each %$v) {
3464 $CPAN::META->{readwrite}{$class}{$id} ||=
3465 $class->new(ID=>$id, RO=>$ro);
3470 unless ($clcnt) { # sanity check
3471 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3474 if ($idcnt < 1000) {
3475 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3476 "in $metadata_file\n");
3479 $CPAN::META->{PROTOCOL} ||=
3480 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3481 # does initialize to some protocol
3482 $LAST_TIME = $cache->{last_time};
3483 $DATE_OF_02 = $cache->{DATE_OF_02};
3484 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3485 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3489 package CPAN::InfoObj;
3494 $self->{RO}{CPAN_USERID}
3497 sub id { shift->{ID}; }
3499 #-> sub CPAN::InfoObj::new ;
3501 my $this = bless {}, shift;
3506 # The set method may only be used by code that reads index data or
3507 # otherwise "objective" data from the outside world. All session
3508 # related material may do anything else with instance variables but
3509 # must not touch the hash under the RO attribute. The reason is that
3510 # the RO hash gets written to Metadata file and is thus persistent.
3512 #-> sub CPAN::InfoObj::set ;
3514 my($self,%att) = @_;
3515 my $class = ref $self;
3517 # This must be ||=, not ||, because only if we write an empty
3518 # reference, only then the set method will write into the readonly
3519 # area. But for Distributions that spring into existence, maybe
3520 # because of a typo, we do not like it that they are written into
3521 # the readonly area and made permanent (at least for a while) and
3522 # that is why we do not "allow" other places to call ->set.
3523 unless ($self->id) {
3524 CPAN->debug("Bug? Empty ID, rejecting");
3527 my $ro = $self->{RO} =
3528 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3530 while (my($k,$v) = each %att) {
3535 #-> sub CPAN::InfoObj::as_glimpse ;
3539 my $class = ref($self);
3540 $class =~ s/^CPAN:://;
3541 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3545 #-> sub CPAN::InfoObj::as_string ;
3549 my $class = ref($self);
3550 $class =~ s/^CPAN:://;
3551 push @m, $class, " id = $self->{ID}\n";
3552 for (sort keys %{$self->{RO}}) {
3553 # next if m/^(ID|RO)$/;
3555 if ($_ eq "CPAN_USERID") {
3556 $extra .= " (".$self->author;
3557 my $email; # old perls!
3558 if ($email = $CPAN::META->instance("CPAN::Author",
3561 $extra .= " <$email>";
3563 $extra .= " <no email>";
3566 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3567 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3570 next unless defined $self->{RO}{$_};
3571 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3573 for (sort keys %$self) {
3574 next if m/^(ID|RO)$/;
3575 if (ref($self->{$_}) eq "ARRAY") {
3576 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3577 } elsif (ref($self->{$_}) eq "HASH") {
3581 join(" ",keys %{$self->{$_}}),
3584 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3590 #-> sub CPAN::InfoObj::author ;
3593 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3596 #-> sub CPAN::InfoObj::dump ;
3599 require Data::Dumper;
3600 print Data::Dumper::Dumper($self);
3603 package CPAN::Author;
3605 #-> sub CPAN::Author::id
3608 my $id = $self->{ID};
3609 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3613 #-> sub CPAN::Author::as_glimpse ;
3617 my $class = ref($self);
3618 $class =~ s/^CPAN:://;
3619 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3627 #-> sub CPAN::Author::fullname ;
3629 shift->{RO}{FULLNAME};
3633 #-> sub CPAN::Author::email ;
3634 sub email { shift->{RO}{EMAIL}; }
3636 #-> sub CPAN::Author::ls ;
3641 # adapted from CPAN::Distribution::verifyMD5 ;
3642 my(@csf); # chksumfile
3643 @csf = $self->id =~ /(.)(.)(.*)/;
3644 $csf[1] = join "", @csf[0,1];
3645 $csf[2] = join "", @csf[1,2];
3647 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3648 unless (grep {$_->[2] eq $csf[1]} @dl) {
3649 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3652 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3653 unless (grep {$_->[2] eq $csf[2]} @dl) {
3654 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3657 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3658 $CPAN::Frontend->myprint(join "", map {
3659 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3660 } sort { $a->[2] cmp $b->[2] } @dl);
3663 # returns an array of arrays, the latter contain (size,mtime,filename)
3664 #-> sub CPAN::Author::dir_listing ;
3667 my $chksumfile = shift;
3668 my $recursive = shift;
3670 File::Spec->catfile($CPAN::Config->{keep_source_where},
3671 "authors", "id", @$chksumfile);
3675 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
3676 # hazard. (Without GPG installed they are not that much better,
3678 $fh = FileHandle->new;
3679 if (open($fh, $lc_want)) {
3680 my $line = <$fh>; close $fh;
3681 unlink($lc_want) unless $line =~ /PGP/;
3685 # connect "force" argument with "index_expire".
3687 if (my @stat = stat $lc_want) {
3688 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3690 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3693 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3694 $chksumfile->[-1] .= ".gz";
3695 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3698 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3699 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3705 # adapted from CPAN::Distribution::MD5_check_file ;
3706 $fh = FileHandle->new;
3708 if (open $fh, $lc_file){
3711 $eval =~ s/\015?\012/\n/g;
3713 my($comp) = Safe->new();
3714 $cksum = $comp->reval($eval);
3716 rename $lc_file, "$lc_file.bad";
3717 Carp::confess($@) if $@;
3720 Carp::carp "Could not open $lc_file for reading";
3723 for $f (sort keys %$cksum) {
3724 if (exists $cksum->{$f}{isdir}) {
3726 my(@dir) = @$chksumfile;
3728 push @dir, $f, "CHECKSUMS";
3730 [$_->[0], $_->[1], "$f/$_->[2]"]
3731 } $self->dir_listing(\@dir,1);
3733 push @result, [ 0, "-", $f ];
3737 ($cksum->{$f}{"size"}||0),
3738 $cksum->{$f}{"mtime"}||"---",
3746 package CPAN::Distribution;
3749 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3753 delete $self->{later};
3756 # CPAN::Distribution::normalize
3759 $s = $self->id unless defined $s;
3763 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3765 return $s if $s =~ m:^N/A|^Contact Author: ;
3766 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3767 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3768 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3773 #-> sub CPAN::Distribution::color_cmd_tmps ;
3774 sub color_cmd_tmps {
3776 my($depth) = shift || 0;
3777 my($color) = shift || 0;
3778 my($ancestors) = shift || [];
3779 # a distribution needs to recurse into its prereq_pms
3781 return if exists $self->{incommandcolor}
3782 && $self->{incommandcolor}==$color;
3784 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3786 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3787 my $prereq_pm = $self->prereq_pm;
3788 if (defined $prereq_pm) {
3789 for my $pre (keys %$prereq_pm) {
3790 my $premo = CPAN::Shell->expand("Module",$pre);
3791 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3795 delete $self->{sponsored_mods};
3796 delete $self->{badtestcnt};
3798 $self->{incommandcolor} = $color;
3801 #-> sub CPAN::Distribution::as_string ;
3804 $self->containsmods;
3805 $self->SUPER::as_string(@_);
3808 #-> sub CPAN::Distribution::containsmods ;
3811 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3812 my $dist_id = $self->{ID};
3813 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3814 my $mod_file = $mod->cpan_file or next;
3815 my $mod_id = $mod->{ID} or next;
3816 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3818 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3820 keys %{$self->{CONTAINSMODS}};
3823 #-> sub CPAN::Distribution::uptodate ;
3827 foreach $c ($self->containsmods) {
3828 my $obj = CPAN::Shell->expandany($c);
3829 return 0 unless $obj->uptodate;
3834 #-> sub CPAN::Distribution::called_for ;
3837 $self->{CALLED_FOR} = $id if defined $id;
3838 return $self->{CALLED_FOR};
3841 #-> sub CPAN::Distribution::safe_chdir ;
3843 my($self,$todir) = @_;
3844 # we die if we cannot chdir and we are debuggable
3845 Carp::confess("safe_chdir called without todir argument")
3846 unless defined $todir and length $todir;
3848 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3851 my $cwd = CPAN::anycwd();
3852 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3853 qq{to todir[$todir]: $!});
3857 #-> sub CPAN::Distribution::get ;
3862 exists $self->{'build_dir'} and push @e,
3863 "Is already unwrapped into directory $self->{'build_dir'}";
3864 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3866 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3869 # Get the file on local disk
3874 File::Spec->catfile(
3875 $CPAN::Config->{keep_source_where},
3878 split(/\//,$self->id)
3881 $self->debug("Doing localize") if $CPAN::DEBUG;
3882 unless ($local_file =
3883 CPAN::FTP->localize("authors/id/$self->{ID}",
3886 if ($CPAN::Index::DATE_OF_02) {
3887 $note = "Note: Current database in memory was generated ".
3888 "on $CPAN::Index::DATE_OF_02\n";
3890 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3892 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3893 $self->{localfile} = $local_file;
3894 return if $CPAN::Signal;
3899 if ($CPAN::META->has_inst("Digest::MD5")) {
3900 $self->debug("Digest::MD5 is installed, verifying");
3903 $self->debug("Digest::MD5 is NOT installed");
3905 return if $CPAN::Signal;
3908 # Create a clean room and go there
3910 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3911 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3912 $self->safe_chdir($builddir);
3913 $self->debug("Removing tmp") if $CPAN::DEBUG;
3914 File::Path::rmtree("tmp");
3915 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3917 $self->safe_chdir($sub_wd);
3920 $self->safe_chdir("tmp");
3925 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3926 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3927 $self->untar_me($local_file);
3928 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3929 $self->unzip_me($local_file);
3930 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3931 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3932 $self->pm2dir_me($local_file);
3934 $self->{archived} = "NO";
3935 $self->safe_chdir($sub_wd);
3939 # we are still in the tmp directory!
3940 # Let's check if the package has its own directory.
3941 my $dh = DirHandle->new(File::Spec->curdir)
3942 or Carp::croak("Couldn't opendir .: $!");
3943 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3945 my ($distdir,$packagedir);
3946 if (@readdir == 1 && -d $readdir[0]) {
3947 $distdir = $readdir[0];
3948 $packagedir = File::Spec->catdir($builddir,$distdir);
3949 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3951 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3953 File::Path::rmtree($packagedir);
3954 rename($distdir,$packagedir) or
3955 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3956 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3963 my $userid = $self->cpan_userid;
3965 CPAN->debug("no userid? self[$self]");
3968 my $pragmatic_dir = $userid . '000';
3969 $pragmatic_dir =~ s/\W_//g;
3970 $pragmatic_dir++ while -d "../$pragmatic_dir";
3971 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3972 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3973 File::Path::mkpath($packagedir);
3975 for $f (@readdir) { # is already without "." and ".."
3976 my $to = File::Spec->catdir($packagedir,$f);
3977 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3981 $self->safe_chdir($sub_wd);
3985 $self->{'build_dir'} = $packagedir;
3986 $self->safe_chdir($builddir);
3987 File::Path::rmtree("tmp");
3989 $self->safe_chdir($packagedir);
3990 if ($CPAN::META->has_inst("Module::Signature")) {
3991 if (-f "SIGNATURE") {
3992 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
3993 my $rv = Module::Signature::verify();
3994 if ($rv != Module::Signature::SIGNATURE_OK() and
3995 $rv != Module::Signature::SIGNATURE_MISSING()) {
3996 $CPAN::Frontend->myprint(
3997 qq{\nSignature invalid for }.
3998 qq{distribution file. }.
3999 qq{Please investigate.\n\n}.
4001 $CPAN::META->instance(
4007 my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
4008 is invalid. Maybe you have configured your 'urllist' with
4009 a bad URL. Please check this array with 'o conf urllist', and
4011 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4014 $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
4017 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4019 $self->safe_chdir($builddir);
4020 return if $CPAN::Signal;
4024 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4025 my($mpl_exists) = -f $mpl;
4026 unless ($mpl_exists) {
4027 # NFS has been reported to have racing problems after the
4028 # renaming of a directory in some environments.
4031 my $mpldh = DirHandle->new($packagedir)
4032 or Carp::croak("Couldn't opendir $packagedir: $!");
4033 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4036 unless ($mpl_exists) {
4037 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4041 my($configure) = File::Spec->catfile($packagedir,"Configure");
4042 if (-f $configure) {
4043 # do we have anything to do?
4044 $self->{'configure'} = $configure;
4045 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4046 $CPAN::Frontend->myprint(qq{
4047 Package comes with a Makefile and without a Makefile.PL.
4048 We\'ll try to build it with that Makefile then.
4050 $self->{writemakefile} = "YES";
4053 my $cf = $self->called_for || "unknown";
4058 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4059 $cf = "unknown" unless length($cf);
4060 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4061 (The test -f "$mpl" returned false.)
4062 Writing one on our own (setting NAME to $cf)\a\n});
4063 $self->{had_no_makefile_pl}++;
4066 # Writing our own Makefile.PL
4068 my $fh = FileHandle->new;
4070 or Carp::croak("Could not open >$mpl: $!");
4072 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4073 # because there was no Makefile.PL supplied.
4074 # Autogenerated on: }.scalar localtime().qq{
4076 use ExtUtils::MakeMaker;
4077 WriteMakefile(NAME => q[$cf]);
4087 # CPAN::Distribution::untar_me ;
4089 my($self,$local_file) = @_;
4090 $self->{archived} = "tar";
4091 if (CPAN::Tarzip->untar($local_file)) {
4092 $self->{unwrapped} = "YES";
4094 $self->{unwrapped} = "NO";
4098 # CPAN::Distribution::unzip_me ;
4100 my($self,$local_file) = @_;
4101 $self->{archived} = "zip";
4102 if (CPAN::Tarzip->unzip($local_file)) {
4103 $self->{unwrapped} = "YES";
4105 $self->{unwrapped} = "NO";
4111 my($self,$local_file) = @_;
4112 $self->{archived} = "pm";
4113 my $to = File::Basename::basename($local_file);
4114 $to =~ s/\.(gz|Z)(?!\n)\Z//;
4115 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4116 $self->{unwrapped} = "YES";
4118 $self->{unwrapped} = "NO";
4122 #-> sub CPAN::Distribution::new ;
4124 my($class,%att) = @_;
4126 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4128 my $this = { %att };
4129 return bless $this, $class;
4132 #-> sub CPAN::Distribution::look ;
4136 if ($^O eq 'MacOS') {
4137 $self->Mac::BuildTools::look;
4141 if ( $CPAN::Config->{'shell'} ) {
4142 $CPAN::Frontend->myprint(qq{
4143 Trying to open a subshell in the build directory...
4146 $CPAN::Frontend->myprint(qq{
4147 Your configuration does not define a value for subshells.
4148 Please define it with "o conf shell <your shell>"
4152 my $dist = $self->id;
4154 unless ($dir = $self->dir) {
4157 unless ($dir ||= $self->dir) {
4158 $CPAN::Frontend->mywarn(qq{
4159 Could not determine which directory to use for looking at $dist.
4163 my $pwd = CPAN::anycwd();
4164 $self->safe_chdir($dir);
4165 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4166 unless (system($CPAN::Config->{'shell'}) == 0) {
4168 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4170 $self->safe_chdir($pwd);
4173 # CPAN::Distribution::cvs_import ;
4177 my $dir = $self->dir;
4179 my $package = $self->called_for;
4180 my $module = $CPAN::META->instance('CPAN::Module', $package);
4181 my $version = $module->cpan_version;
4183 my $userid = $self->cpan_userid;
4185 my $cvs_dir = (split /\//, $dir)[-1];
4186 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4188 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4190 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4191 if ($cvs_site_perl) {
4192 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4194 my $cvs_log = qq{"imported $package $version sources"};
4195 $version =~ s/\./_/g;
4196 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4197 "$cvs_dir", $userid, "v$version");
4199 my $pwd = CPAN::anycwd();
4200 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4202 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4204 $CPAN::Frontend->myprint(qq{@cmd\n});
4205 system(@cmd) == 0 or
4206 $CPAN::Frontend->mydie("cvs import failed");
4207 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4210 #-> sub CPAN::Distribution::readme ;
4213 my($dist) = $self->id;
4214 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4215 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4218 File::Spec->catfile(
4219 $CPAN::Config->{keep_source_where},
4222 split(/\//,"$sans.readme"),
4224 $self->debug("Doing localize") if $CPAN::DEBUG;
4225 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4227 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4229 if ($^O eq 'MacOS') {
4230 Mac::BuildTools::launch_file($local_file);
4234 my $fh_pager = FileHandle->new;
4235 local($SIG{PIPE}) = "IGNORE";
4236 $fh_pager->open("|$CPAN::Config->{'pager'}")
4237 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4238 my $fh_readme = FileHandle->new;
4239 $fh_readme->open($local_file)
4240 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4241 $CPAN::Frontend->myprint(qq{
4244 with pager "$CPAN::Config->{'pager'}"
4247 $fh_pager->print(<$fh_readme>);
4250 #-> sub CPAN::Distribution::verifyMD5 ;
4255 $self->{MD5_STATUS} ||= "";
4256 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4257 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4259 my($lc_want,$lc_file,@local,$basename);
4260 @local = split(/\//,$self->id);
4262 push @local, "CHECKSUMS";
4264 File::Spec->catfile($CPAN::Config->{keep_source_where},
4265 "authors", "id", @local);
4270 $self->MD5_check_file($lc_want)
4272 return $self->{MD5_STATUS} = "OK";
4274 $lc_file = CPAN::FTP->localize("authors/id/@local",
4277 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4278 $local[-1] .= ".gz";
4279 $lc_file = CPAN::FTP->localize("authors/id/@local",
4282 $lc_file =~ s/\.gz(?!\n)\Z//;
4283 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4288 $self->MD5_check_file($lc_file);
4291 sub SIG_check_file {
4292 my($self,$chk_file) = @_;
4293 my $rv = eval { Module::Signature::_verify($chk_file) };
4295 if ($rv == Module::Signature::SIGNATURE_OK()) {
4296 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
4297 return $self->{SIG_STATUS} = "OK";
4299 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
4300 qq{distribution file. }.
4301 qq{Please investigate.\n\n}.
4303 $CPAN::META->instance(
4308 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
4309 is invalid. Maybe you have configured your 'urllist' with
4310 a bad URL. Please check this array with 'o conf urllist', and
4313 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4317 #-> sub CPAN::Distribution::MD5_check_file ;
4318 sub MD5_check_file {
4319 my($self,$chk_file) = @_;
4320 my($cksum,$file,$basename);
4322 if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
4323 $self->debug("Module::Signature is installed, verifying");
4324 $self->SIG_check_file($chk_file);
4326 $self->debug("Module::Signature is NOT installed");
4329 $file = $self->{localfile};
4330 $basename = File::Basename::basename($file);
4331 my $fh = FileHandle->new;
4332 if (open $fh, $chk_file){
4335 $eval =~ s/\015?\012/\n/g;
4337 my($comp) = Safe->new();
4338 $cksum = $comp->reval($eval);
4340 rename $chk_file, "$chk_file.bad";
4341 Carp::confess($@) if $@;
4344 Carp::carp "Could not open $chk_file for reading";
4347 if (exists $cksum->{$basename}{md5}) {
4348 $self->debug("Found checksum for $basename:" .
4349 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4353 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4355 $fh = CPAN::Tarzip->TIEHANDLE($file);
4358 # had to inline it, when I tied it, the tiedness got lost on
4359 # the call to eq_MD5. (Jan 1998)
4360 my $md5 = Digest::MD5->new;
4363 while ($fh->READ($ref, 4096) > 0){
4366 my $hexdigest = $md5->hexdigest;
4367 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4371 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4372 return $self->{MD5_STATUS} = "OK";
4374 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4375 qq{distribution file. }.
4376 qq{Please investigate.\n\n}.
4378 $CPAN::META->instance(
4383 my $wrap = qq{I\'d recommend removing $file. Its MD5
4384 checksum is incorrect. Maybe you have configured your 'urllist' with
4385 a bad URL. Please check this array with 'o conf urllist', and
4388 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4390 # former versions just returned here but this seems a
4391 # serious threat that deserves a die
4393 # $CPAN::Frontend->myprint("\n\n");
4397 # close $fh if fileno($fh);
4399 $self->{MD5_STATUS} ||= "";
4400 if ($self->{MD5_STATUS} eq "NIL") {
4401 $CPAN::Frontend->mywarn(qq{
4402 Warning: No md5 checksum for $basename in $chk_file.
4404 The cause for this may be that the file is very new and the checksum
4405 has not yet been calculated, but it may also be that something is
4406 going awry right now.
4408 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4409 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4411 $self->{MD5_STATUS} = "NIL";
4416 #-> sub CPAN::Distribution::eq_MD5 ;
4418 my($self,$fh,$expectMD5) = @_;
4419 my $md5 = Digest::MD5->new;
4421 while (read($fh, $data, 4096)){
4424 # $md5->addfile($fh);
4425 my $hexdigest = $md5->hexdigest;
4426 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4427 $hexdigest eq $expectMD5;
4430 #-> sub CPAN::Distribution::force ;
4432 # Both modules and distributions know if "force" is in effect by
4433 # autoinspection, not by inspecting a global variable. One of the
4434 # reason why this was chosen to work that way was the treatment of
4435 # dependencies. They should not autpomatically inherit the force
4436 # status. But this has the downside that ^C and die() will return to
4437 # the prompt but will not be able to reset the force_update
4438 # attributes. We try to correct for it currently in the read_metadata
4439 # routine, and immediately before we check for a Signal. I hope this
4440 # works out in one of v1.57_53ff
4443 my($self, $method) = @_;
4445 MD5_STATUS archived build_dir localfile make install unwrapped
4448 delete $self->{$att};
4450 if ($method && $method eq "install") {
4451 $self->{"force_update"}++; # name should probably have been force_install
4455 #-> sub CPAN::Distribution::unforce ;
4458 delete $self->{'force_update'};
4461 #-> sub CPAN::Distribution::isa_perl ;
4464 my $file = File::Basename::basename($self->id);
4465 if ($file =~ m{ ^ perl
4478 } elsif ($self->cpan_comment
4480 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4485 #-> sub CPAN::Distribution::perl ;
4488 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4489 my $pwd = CPAN::anycwd();
4490 my $candidate = File::Spec->catfile($pwd,$^X);
4491 $perl ||= $candidate if MM->maybe_command($candidate);
4493 my ($component,$perl_name);
4494 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4495 PATH_COMPONENT: foreach $component (File::Spec->path(),
4496 $Config::Config{'binexp'}) {
4497 next unless defined($component) && $component;
4498 my($abs) = File::Spec->catfile($component,$perl_name);
4499 if (MM->maybe_command($abs)) {
4509 #-> sub CPAN::Distribution::make ;
4512 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4513 # Emergency brake if they said install Pippi and get newest perl
4514 if ($self->isa_perl) {
4516 $self->called_for ne $self->id &&
4517 ! $self->{force_update}
4519 # if we die here, we break bundles
4520 $CPAN::Frontend->mywarn(sprintf qq{
4521 The most recent version "%s" of the module "%s"
4522 comes with the current version of perl (%s).
4523 I\'ll build that only if you ask for something like
4528 $CPAN::META->instance(
4542 $self->{archived} eq "NO" and push @e,
4543 "Is neither a tar nor a zip archive.";
4545 $self->{unwrapped} eq "NO" and push @e,
4546 "had problems unarchiving. Please build manually";
4548 exists $self->{writemakefile} &&
4549 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4550 $1 || "Had some problem writing Makefile";
4552 defined $self->{'make'} and push @e,
4553 "Has already been processed within this session";
4555 exists $self->{later} and length($self->{later}) and
4556 push @e, $self->{later};
4558 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4560 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4561 my $builddir = $self->dir;
4562 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4563 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4565 if ($^O eq 'MacOS') {
4566 Mac::BuildTools::make($self);
4571 if ($self->{'configure'}) {
4572 $system = $self->{'configure'};
4574 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4576 # This needs a handler that can be turned on or off:
4577 # $switch = "-MExtUtils::MakeMaker ".
4578 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4580 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4582 unless (exists $self->{writemakefile}) {
4583 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4586 if ($CPAN::Config->{inactivity_timeout}) {
4588 alarm $CPAN::Config->{inactivity_timeout};
4589 local $SIG{CHLD}; # = sub { wait };
4590 if (defined($pid = fork)) {
4595 # note, this exec isn't necessary if
4596 # inactivity_timeout is 0. On the Mac I'd
4597 # suggest, we set it always to 0.
4601 $CPAN::Frontend->myprint("Cannot fork: $!");
4609 $CPAN::Frontend->myprint($@);
4610 $self->{writemakefile} = "NO $@";
4615 $ret = system($system);
4617 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4621 if (-f "Makefile") {
4622 $self->{writemakefile} = "YES";
4623 delete $self->{make_clean}; # if cleaned before, enable next
4625 $self->{writemakefile} =
4626 qq{NO Makefile.PL refused to write a Makefile.};
4627 # It's probably worth it to record the reason, so let's retry
4629 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4630 # $self->{writemakefile} .= <$fh>;
4634 delete $self->{force_update};
4637 if (my @prereq = $self->unsat_prereq){
4638 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4640 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4641 if (system($system) == 0) {
4642 $CPAN::Frontend->myprint(" $system -- OK\n");
4643 $self->{'make'} = "YES";
4645 $self->{writemakefile} ||= "YES";
4646 $self->{'make'} = "NO";
4647 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4651 sub follow_prereqs {
4655 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4656 "during [$id] -----\n");
4658 for my $p (@prereq) {
4659 $CPAN::Frontend->myprint(" $p\n");
4662 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4664 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4665 require ExtUtils::MakeMaker;
4666 my $answer = ExtUtils::MakeMaker::prompt(
4667 "Shall I follow them and prepend them to the queue
4668 of modules we are processing right now?", "yes");
4669 $follow = $answer =~ /^\s*y/i;
4673 myprint(" Ignoring dependencies on modules @prereq\n");
4676 # color them as dirty
4677 for my $p (@prereq) {
4678 # warn "calling color_cmd_tmps(0,1)";
4679 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4681 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4682 $self->{later} = "Delayed until after prerequisites";
4683 return 1; # signal success to the queuerunner
4687 #-> sub CPAN::Distribution::unsat_prereq ;
4690 my $prereq_pm = $self->prereq_pm or return;
4692 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4693 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4694 # we were too demanding:
4695 next if $nmo->uptodate;
4697 # if they have not specified a version, we accept any installed one
4698 if (not defined $need_version or
4699 $need_version == 0 or
4700 $need_version eq "undef") {
4701 next if defined $nmo->inst_file;
4704 # We only want to install prereqs if either they're not installed
4705 # or if the installed version is too old. We cannot omit this
4706 # check, because if 'force' is in effect, nobody else will check.
4710 defined $nmo->inst_file &&
4711 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4713 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4717 CPAN::Version->readable($need_version)
4723 if ($self->{sponsored_mods}{$need_module}++){
4724 # We have already sponsored it and for some reason it's still
4725 # not available. So we do nothing. Or what should we do?
4726 # if we push it again, we have a potential infinite loop
4729 push @need, $need_module;
4734 #-> sub CPAN::Distribution::prereq_pm ;
4737 return $self->{prereq_pm} if
4738 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4739 return unless $self->{writemakefile}; # no need to have succeeded
4740 # but we must have run it
4741 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4742 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4747 $fh = FileHandle->new("<$makefile\0")) {
4751 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4753 last if /MakeMaker post_initialize section/;
4755 \s+PREREQ_PM\s+=>\s+(.+)
4758 # warn "Found prereq expr[$p]";
4760 # Regexp modified by A.Speer to remember actual version of file
4761 # PREREQ_PM hash key wants, then add to
4762 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4763 # In case a prereq is mentioned twice, complain.
4764 if ( defined $p{$1} ) {
4765 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4772 $self->{prereq_pm_detected}++;
4773 return $self->{prereq_pm} = \%p;
4776 #-> sub CPAN::Distribution::test ;
4781 delete $self->{force_update};
4784 $CPAN::Frontend->myprint("Running make test\n");
4785 if (my @prereq = $self->unsat_prereq){
4786 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4790 exists $self->{make} or exists $self->{later} or push @e,
4791 "Make had some problems, maybe interrupted? Won't test";
4793 exists $self->{'make'} and
4794 $self->{'make'} eq 'NO' and
4795 push @e, "Can't test without successful make";
4797 exists $self->{build_dir} or push @e, "Has no own directory";
4798 $self->{badtestcnt} ||= 0;
4799 $self->{badtestcnt} > 0 and
4800 push @e, "Won't repeat unsuccessful test during this command";
4802 exists $self->{later} and length($self->{later}) and
4803 push @e, $self->{later};
4805 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4807 chdir $self->{'build_dir'} or
4808 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4809 $self->debug("Changed directory to $self->{'build_dir'}")
4812 if ($^O eq 'MacOS') {
4813 Mac::BuildTools::make_test($self);
4817 local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4818 $CPAN::META->set_perl5lib;
4819 my $system = join " ", $CPAN::Config->{'make'}, "test";
4820 if (system($system) == 0) {
4821 $CPAN::Frontend->myprint(" $system -- OK\n");
4822 $CPAN::META->is_tested($self->{'build_dir'});
4823 $self->{make_test} = "YES";
4825 $self->{make_test} = "NO";
4826 $self->{badtestcnt}++;
4827 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4831 #-> sub CPAN::Distribution::clean ;
4834 $CPAN::Frontend->myprint("Running make clean\n");
4837 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4838 push @e, "make clean already called once";
4839 exists $self->{build_dir} or push @e, "Has no own directory";
4840 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4842 chdir $self->{'build_dir'} or
4843 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4844 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4846 if ($^O eq 'MacOS') {
4847 Mac::BuildTools::make_clean($self);
4851 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4852 if (system($system) == 0) {
4853 $CPAN::Frontend->myprint(" $system -- OK\n");
4857 # Jost Krieger pointed out that this "force" was wrong because
4858 # it has the effect that the next "install" on this distribution
4859 # will untar everything again. Instead we should bring the
4860 # object's state back to where it is after untarring.
4862 delete $self->{force_update};
4863 delete $self->{install};
4864 delete $self->{writemakefile};
4865 delete $self->{make};
4866 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4867 $self->{make_clean} = "YES";
4870 # Hmmm, what to do if make clean failed?
4872 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4874 make clean did not succeed, marking directory as unusable for further work.
4876 $self->force("make"); # so that this directory won't be used again
4881 #-> sub CPAN::Distribution::install ;
4886 delete $self->{force_update};
4889 $CPAN::Frontend->myprint("Running make install\n");
4892 exists $self->{build_dir} or push @e, "Has no own directory";
4894 exists $self->{make} or exists $self->{later} or push @e,
4895 "Make had some problems, maybe interrupted? Won't install";
4897 exists $self->{'make'} and
4898 $self->{'make'} eq 'NO' and
4899 push @e, "make had returned bad status, install seems impossible";
4901 push @e, "make test had returned bad status, ".
4902 "won't install without force"
4903 if exists $self->{'make_test'} and
4904 $self->{'make_test'} eq 'NO' and
4905 ! $self->{'force_update'};
4907 exists $self->{'install'} and push @e,
4908 $self->{'install'} eq "YES" ?
4909 "Already done" : "Already tried without success";
4911 exists $self->{later} and length($self->{later}) and
4912 push @e, $self->{later};
4914 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4916 chdir $self->{'build_dir'} or
4917 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4918 $self->debug("Changed directory to $self->{'build_dir'}")
4921 if ($^O eq 'MacOS') {
4922 Mac::BuildTools::make_install($self);
4926 my $system = join(" ", $CPAN::Config->{'make'},
4927 "install", $CPAN::Config->{make_install_arg});
4928 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4929 my($pipe) = FileHandle->new("$system $stderr |");
4932 $CPAN::Frontend->myprint($_);
4937 $CPAN::Frontend->myprint(" $system -- OK\n");
4938 $CPAN::META->is_installed($self->{'build_dir'});
4939 return $self->{'install'} = "YES";
4941 $self->{'install'} = "NO";
4942 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4943 if ($makeout =~ /permission/s && $> > 0) {
4944 $CPAN::Frontend->myprint(qq{ You may have to su }.
4945 qq{to root to install the package\n});
4948 delete $self->{force_update};
4951 #-> sub CPAN::Distribution::dir ;
4953 shift->{'build_dir'};
4956 package CPAN::Bundle;
4960 $CPAN::Frontend->myprint($self->as_string);
4965 delete $self->{later};
4966 for my $c ( $self->contains ) {
4967 my $obj = CPAN::Shell->expandany($c) or next;
4972 #-> sub CPAN::Bundle::color_cmd_tmps ;
4973 sub color_cmd_tmps {
4975 my($depth) = shift || 0;
4976 my($color) = shift || 0;
4977 my($ancestors) = shift || [];
4978 # a module needs to recurse to its cpan_file, a distribution needs
4979 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4981 return if exists $self->{incommandcolor}
4982 && $self->{incommandcolor}==$color;
4984 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4986 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4988 for my $c ( $self->contains ) {
4989 my $obj = CPAN::Shell->expandany($c) or next;
4990 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4991 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4994 delete $self->{badtestcnt};
4996 $self->{incommandcolor} = $color;
4999 #-> sub CPAN::Bundle::as_string ;
5003 # following line must be "=", not "||=" because we have a moving target
5004 $self->{INST_VERSION} = $self->inst_version;
5005 return $self->SUPER::as_string;
5008 #-> sub CPAN::Bundle::contains ;
5011 my($inst_file) = $self->inst_file || "";
5012 my($id) = $self->id;
5013 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
5014 unless ($inst_file) {
5015 # Try to get at it in the cpan directory
5016 $self->debug("no inst_file") if $CPAN::DEBUG;
5018 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
5019 $cpan_file = $self->cpan_file;
5020 if ($cpan_file eq "N/A") {
5021 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
5022 Maybe stale symlink? Maybe removed during session? Giving up.\n");
5024 my $dist = $CPAN::META->instance('CPAN::Distribution',
5027 $self->debug($dist->as_string) if $CPAN::DEBUG;
5028 my($todir) = $CPAN::Config->{'cpan_home'};
5029 my(@me,$from,$to,$me);
5030 @me = split /::/, $self->id;
5032 $me = File::Spec->catfile(@me);
5033 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5034 $to = File::Spec->catfile($todir,$me);
5035 File::Path::mkpath(File::Basename::dirname($to));
5036 File::Copy::copy($from, $to)
5037 or Carp::confess("Couldn't copy $from to $to: $!");
5041 my $fh = FileHandle->new;
5043 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
5045 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
5047 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
5048 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
5049 next unless $in_cont;
5054 push @result, (split " ", $_, 2)[0];
5057 delete $self->{STATUS};
5058 $self->{CONTAINS} = \@result;
5059 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5061 $CPAN::Frontend->mywarn(qq{
5062 The bundle file "$inst_file" may be a broken
5063 bundlefile. It seems not to contain any bundle definition.
5064 Please check the file and if it is bogus, please delete it.
5065 Sorry for the inconvenience.
5071 #-> sub CPAN::Bundle::find_bundle_file
5072 sub find_bundle_file {
5073 my($self,$where,$what) = @_;
5074 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5075 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5076 ### my $bu = File::Spec->catfile($where,$what);
5077 ### return $bu if -f $bu;
5078 my $manifest = File::Spec->catfile($where,"MANIFEST");
5079 unless (-f $manifest) {
5080 require ExtUtils::Manifest;
5081 my $cwd = CPAN::anycwd();
5082 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5083 ExtUtils::Manifest::mkmanifest();
5084 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5086 my $fh = FileHandle->new($manifest)
5087 or Carp::croak("Couldn't open $manifest: $!");
5090 if ($^O eq 'MacOS') {
5093 $what2 =~ s/:Bundle://;
5096 $what2 =~ s|Bundle[/\\]||;
5101 my($file) = /(\S+)/;
5102 if ($file =~ m|\Q$what\E$|) {
5104 # return File::Spec->catfile($where,$bu); # bad
5107 # retry if she managed to
5108 # have no Bundle directory
5109 $bu = $file if $file =~ m|\Q$what2\E$|;
5111 $bu =~ tr|/|:| if $^O eq 'MacOS';
5112 return File::Spec->catfile($where, $bu) if $bu;
5113 Carp::croak("Couldn't find a Bundle file in $where");
5116 # needs to work quite differently from Module::inst_file because of
5117 # cpan_home/Bundle/ directory and the possibility that we have
5118 # shadowing effect. As it makes no sense to take the first in @INC for
5119 # Bundles, we parse them all for $VERSION and take the newest.
5121 #-> sub CPAN::Bundle::inst_file ;
5126 @me = split /::/, $self->id;
5129 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5130 my $bfile = File::Spec->catfile($incdir, @me);
5131 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5132 next unless -f $bfile;
5133 my $foundv = MM->parse_version($bfile);
5134 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5135 $self->{INST_FILE} = $bfile;
5136 $self->{INST_VERSION} = $bestv = $foundv;
5142 #-> sub CPAN::Bundle::inst_version ;
5145 $self->inst_file; # finds INST_VERSION as side effect
5146 $self->{INST_VERSION};
5149 #-> sub CPAN::Bundle::rematein ;
5151 my($self,$meth) = @_;
5152 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5153 my($id) = $self->id;
5154 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5155 unless $self->inst_file || $self->cpan_file;
5157 for $s ($self->contains) {
5158 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5159 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5160 if ($type eq 'CPAN::Distribution') {
5161 $CPAN::Frontend->mywarn(qq{
5162 The Bundle }.$self->id.qq{ contains
5163 explicitly a file $s.
5167 # possibly noisy action:
5168 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5169 my $obj = $CPAN::META->instance($type,$s);
5171 if ($obj->isa(CPAN::Bundle)
5173 exists $obj->{install_failed}
5175 ref($obj->{install_failed}) eq "HASH"
5177 for (keys %{$obj->{install_failed}}) {
5178 $self->{install_failed}{$_} = undef; # propagate faiure up
5181 $fail{$s} = 1; # the bundle itself may have succeeded but
5186 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5187 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5189 delete $self->{install_failed}{$s};
5196 # recap with less noise
5197 if ( $meth eq "install" ) {
5200 my $raw = sprintf(qq{Bundle summary:
5201 The following items in bundle %s had installation problems:},
5204 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5205 $CPAN::Frontend->myprint("\n");
5208 for $s ($self->contains) {
5210 $paragraph .= "$s ";
5211 $self->{install_failed}{$s} = undef;
5212 $reported{$s} = undef;
5215 my $report_propagated;
5216 for $s (sort keys %{$self->{install_failed}}) {
5217 next if exists $reported{$s};
5218 $paragraph .= "and the following items had problems
5219 during recursive bundle calls: " unless $report_propagated++;
5220 $paragraph .= "$s ";
5222 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5223 $CPAN::Frontend->myprint("\n");
5225 $self->{'install'} = 'YES';
5230 #sub CPAN::Bundle::xs_file
5232 # If a bundle contains another that contains an xs_file we have
5233 # here, we just don't bother I suppose
5237 #-> sub CPAN::Bundle::force ;
5238 sub force { shift->rematein('force',@_); }
5239 #-> sub CPAN::Bundle::get ;
5240 sub get { shift->rematein('get',@_); }
5241 #-> sub CPAN::Bundle::make ;
5242 sub make { shift->rematein('make',@_); }
5243 #-> sub CPAN::Bundle::test ;
5246 $self->{badtestcnt} ||= 0;
5247 $self->rematein('test',@_);
5249 #-> sub CPAN::Bundle::install ;
5252 $self->rematein('install',@_);
5254 #-> sub CPAN::Bundle::clean ;
5255 sub clean { shift->rematein('clean',@_); }
5257 #-> sub CPAN::Bundle::uptodate ;
5260 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5262 foreach $c ($self->contains) {
5263 my $obj = CPAN::Shell->expandany($c);
5264 return 0 unless $obj->uptodate;
5269 #-> sub CPAN::Bundle::readme ;
5272 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5273 No File found for bundle } . $self->id . qq{\n}), return;
5274 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5275 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5278 package CPAN::Module;
5281 # sub CPAN::Module::userid
5284 return unless exists $self->{RO}; # should never happen
5285 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5287 # sub CPAN::Module::description
5288 sub description { shift->{RO}{description} }
5292 delete $self->{later};
5293 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5298 #-> sub CPAN::Module::color_cmd_tmps ;
5299 sub color_cmd_tmps {
5301 my($depth) = shift || 0;
5302 my($color) = shift || 0;
5303 my($ancestors) = shift || [];
5304 # a module needs to recurse to its cpan_file
5306 return if exists $self->{incommandcolor}
5307 && $self->{incommandcolor}==$color;
5309 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5311 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5313 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5314 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5317 delete $self->{badtestcnt};
5319 $self->{incommandcolor} = $color;
5322 #-> sub CPAN::Module::as_glimpse ;
5326 my $class = ref($self);
5327 $class =~ s/^CPAN:://;
5331 $CPAN::Shell::COLOR_REGISTERED
5333 $CPAN::META->has_inst("Term::ANSIColor")
5335 $self->{RO}{description}
5337 $color_on = Term::ANSIColor::color("green");
5338 $color_off = Term::ANSIColor::color("reset");
5340 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5349 #-> sub CPAN::Module::as_string ;
5353 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5354 my $class = ref($self);
5355 $class =~ s/^CPAN:://;
5357 push @m, $class, " id = $self->{ID}\n";
5358 my $sprintf = " %-12s %s\n";
5359 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5360 if $self->description;
5361 my $sprintf2 = " %-12s %s (%s)\n";
5363 $userid = $self->userid;
5366 if ($author = CPAN::Shell->expand('Author',$userid)) {
5369 if ($m = $author->email) {
5376 $author->fullname . $email
5380 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5381 if $self->cpan_version;
5382 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5383 if $self->cpan_file;
5384 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5385 my(%statd,%stats,%statl,%stati);
5386 @statd{qw,? i c a b R M S,} = qw,unknown idea
5387 pre-alpha alpha beta released mature standard,;
5388 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5389 developer comp.lang.perl.* none abandoned,;
5390 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5391 @stati{qw,? f r O h,} = qw,unknown functions
5392 references+ties object-oriented hybrid,;
5393 $statd{' '} = 'unknown';
5394 $stats{' '} = 'unknown';
5395 $statl{' '} = 'unknown';
5396 $stati{' '} = 'unknown';
5404 $statd{$self->{RO}{statd}},
5405 $stats{$self->{RO}{stats}},
5406 $statl{$self->{RO}{statl}},
5407 $stati{$self->{RO}{stati}}
5408 ) if $self->{RO}{statd};
5409 my $local_file = $self->inst_file;
5410 unless ($self->{MANPAGE}) {
5412 $self->{MANPAGE} = $self->manpage_headline($local_file);
5414 # If we have already untarred it, we should look there
5415 my $dist = $CPAN::META->instance('CPAN::Distribution',
5417 # warn "dist[$dist]";
5418 # mff=manifest file; mfh=manifest handle
5423 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5425 $mfh = FileHandle->new($mff)
5427 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5428 my $lfre = $self->id; # local file RE
5431 my($lfl); # local file file
5433 my(@mflines) = <$mfh>;
5438 while (length($lfre)>5 and !$lfl) {
5439 ($lfl) = grep /$lfre/, @mflines;
5440 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5443 $lfl =~ s/\s.*//; # remove comments
5444 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5445 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5446 # warn "lfl_abs[$lfl_abs]";
5448 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5454 for $item (qw/MANPAGE/) {
5455 push @m, sprintf($sprintf, $item, $self->{$item})
5456 if exists $self->{$item};
5458 for $item (qw/CONTAINS/) {
5459 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5460 if exists $self->{$item} && @{$self->{$item}};
5462 push @m, sprintf($sprintf, 'INST_FILE',
5463 $local_file || "(not installed)");
5464 push @m, sprintf($sprintf, 'INST_VERSION',
5465 $self->inst_version) if $local_file;
5469 sub manpage_headline {
5470 my($self,$local_file) = @_;
5471 my(@local_file) = $local_file;
5472 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5473 push @local_file, $local_file;
5475 for $locf (@local_file) {
5476 next unless -f $locf;
5477 my $fh = FileHandle->new($locf)
5478 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5482 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5483 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5496 #-> sub CPAN::Module::cpan_file ;
5497 # Note: also inherited by CPAN::Bundle
5500 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5501 unless (defined $self->{RO}{CPAN_FILE}) {
5502 CPAN::Index->reload;
5504 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5505 return $self->{RO}{CPAN_FILE};
5507 my $userid = $self->userid;
5509 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5510 my $author = $CPAN::META->instance("CPAN::Author",
5512 my $fullname = $author->fullname;
5513 my $email = $author->email;
5514 unless (defined $fullname && defined $email) {
5515 return sprintf("Contact Author %s",
5519 return "Contact Author $fullname <$email>";
5521 return "UserID $userid";
5529 #-> sub CPAN::Module::cpan_version ;
5533 $self->{RO}{CPAN_VERSION} = 'undef'
5534 unless defined $self->{RO}{CPAN_VERSION};
5535 # I believe this is always a bug in the index and should be reported
5536 # as such, but usually I find out such an error and do not want to
5537 # provoke too many bugreports
5539 $self->{RO}{CPAN_VERSION};
5542 #-> sub CPAN::Module::force ;
5545 $self->{'force_update'}++;
5548 #-> sub CPAN::Module::rematein ;
5550 my($self,$meth) = @_;
5551 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5554 my $cpan_file = $self->cpan_file;
5555 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5556 $CPAN::Frontend->mywarn(sprintf qq{
5557 The module %s isn\'t available on CPAN.
5559 Either the module has not yet been uploaded to CPAN, or it is
5560 temporary unavailable. Please contact the author to find out
5561 more about the status. Try 'i %s'.
5568 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5569 $pack->called_for($self->id);
5570 $pack->force($meth) if exists $self->{'force_update'};
5572 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5573 delete $self->{'force_update'};
5576 #-> sub CPAN::Module::readme ;
5577 sub readme { shift->rematein('readme') }
5578 #-> sub CPAN::Module::look ;
5579 sub look { shift->rematein('look') }
5580 #-> sub CPAN::Module::cvs_import ;
5581 sub cvs_import { shift->rematein('cvs_import') }
5582 #-> sub CPAN::Module::get ;
5583 sub get { shift->rematein('get',@_); }
5584 #-> sub CPAN::Module::make ;
5587 $self->rematein('make');
5589 #-> sub CPAN::Module::test ;
5592 $self->{badtestcnt} ||= 0;
5593 $self->rematein('test',@_);
5595 #-> sub CPAN::Module::uptodate ;
5598 my($latest) = $self->cpan_version;
5600 my($inst_file) = $self->inst_file;
5602 if (defined $inst_file) {
5603 $have = $self->inst_version;
5608 ! CPAN::Version->vgt($latest, $have)
5610 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5611 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5616 #-> sub CPAN::Module::install ;
5622 not exists $self->{'force_update'}
5624 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5628 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
5629 $CPAN::Frontend->mywarn(qq{
5630 \n\n\n ***WARNING***
5631 The module $self->{ID} has no active maintainer.\n\n\n
5635 $self->rematein('install') if $doit;
5637 #-> sub CPAN::Module::clean ;
5638 sub clean { shift->rematein('clean') }
5640 #-> sub CPAN::Module::inst_file ;
5644 @packpath = split /::/, $self->{ID};
5645 $packpath[-1] .= ".pm";
5646 foreach $dir (@INC) {
5647 my $pmfile = File::Spec->catfile($dir,@packpath);
5655 #-> sub CPAN::Module::xs_file ;
5659 @packpath = split /::/, $self->{ID};
5660 push @packpath, $packpath[-1];
5661 $packpath[-1] .= "." . $Config::Config{'dlext'};
5662 foreach $dir (@INC) {
5663 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5671 #-> sub CPAN::Module::inst_version ;
5674 my $parsefile = $self->inst_file or return;
5675 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5678 # there was a bug in 5.6.0 that let lots of unini warnings out of
5679 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5680 # the following workaround after 5.6.1 is out.
5681 local($SIG{__WARN__}) = sub { my $w = shift;
5682 return if $w =~ /uninitialized/i;
5686 $have = MM->parse_version($parsefile) || "undef";
5687 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5688 $have =~ s/ $//; # trailing whitespace happens all the time
5690 # My thoughts about why %vd processing should happen here
5692 # Alt1 maintain it as string with leading v:
5693 # read index files do nothing
5694 # compare it use utility for compare
5695 # print it do nothing
5697 # Alt2 maintain it as what it is
5698 # read index files convert
5699 # compare it use utility because there's still a ">" vs "gt" issue
5700 # print it use CPAN::Version for print
5702 # Seems cleaner to hold it in memory as a string starting with a "v"
5704 # If the author of this module made a mistake and wrote a quoted
5705 # "v1.13" instead of v1.13, we simply leave it at that with the
5706 # effect that *we* will treat it like a v-tring while the rest of
5707 # perl won't. Seems sensible when we consider that any action we
5708 # could take now would just add complexity.
5710 $have = CPAN::Version->readable($have);
5712 $have =~ s/\s*//g; # stringify to float around floating point issues
5713 $have; # no stringify needed, \s* above matches always
5716 package CPAN::Tarzip;
5718 # CPAN::Tarzip::gzip
5720 my($class,$read,$write) = @_;
5721 if ($CPAN::META->has_inst("Compress::Zlib")) {
5723 $fhw = FileHandle->new($read)
5724 or $CPAN::Frontend->mydie("Could not open $read: $!");
5725 my $gz = Compress::Zlib::gzopen($write, "wb")
5726 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5727 $gz->gzwrite($buffer)
5728 while read($fhw,$buffer,4096) > 0 ;
5733 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5738 # CPAN::Tarzip::gunzip
5740 my($class,$read,$write) = @_;
5741 if ($CPAN::META->has_inst("Compress::Zlib")) {
5743 $fhw = FileHandle->new(">$write")
5744 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5745 my $gz = Compress::Zlib::gzopen($read, "rb")
5746 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5747 $fhw->print($buffer)
5748 while $gz->gzread($buffer) > 0 ;
5749 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5750 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5755 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5760 # CPAN::Tarzip::gtest
5762 my($class,$read) = @_;
5763 # After I had reread the documentation in zlib.h, I discovered that
5764 # uncompressed files do not lead to an gzerror (anymore?).
5765 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5768 my $gz = Compress::Zlib::gzopen($read, "rb")
5769 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5771 $Compress::Zlib::gzerrno));
5772 while ($gz->gzread($buffer) > 0 ){
5773 $len += length($buffer);
5776 my $err = $gz->gzerror;
5777 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5778 if ($len == -s $read){
5780 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5783 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5786 return system("$CPAN::Config->{gzip} -dt $read")==0;
5791 # CPAN::Tarzip::TIEHANDLE
5793 my($class,$file) = @_;
5795 $class->debug("file[$file]");
5796 if ($CPAN::META->has_inst("Compress::Zlib")) {
5797 my $gz = Compress::Zlib::gzopen($file,"rb") or
5798 die "Could not gzopen $file";
5799 $ret = bless {GZ => $gz}, $class;
5801 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5802 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5804 $ret = bless {FH => $fh}, $class;
5810 # CPAN::Tarzip::READLINE
5813 if (exists $self->{GZ}) {
5814 my $gz = $self->{GZ};
5815 my($line,$bytesread);
5816 $bytesread = $gz->gzreadline($line);
5817 return undef if $bytesread <= 0;
5820 my $fh = $self->{FH};
5821 return scalar <$fh>;
5826 # CPAN::Tarzip::READ
5828 my($self,$ref,$length,$offset) = @_;
5829 die "read with offset not implemented" if defined $offset;
5830 if (exists $self->{GZ}) {
5831 my $gz = $self->{GZ};
5832 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5835 my $fh = $self->{FH};
5836 return read($fh,$$ref,$length);
5841 # CPAN::Tarzip::DESTROY
5844 if (exists $self->{GZ}) {
5845 my $gz = $self->{GZ};
5846 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5847 # to be undef ever. AK, 2000-09
5849 my $fh = $self->{FH};
5850 $fh->close if defined $fh;
5856 # CPAN::Tarzip::untar
5858 my($class,$file) = @_;
5861 if (0) { # makes changing order easier
5862 } elsif ($BUGHUNTING){
5864 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5866 MM->maybe_command($CPAN::Config->{'tar'})) {
5867 # should be default until Archive::Tar is fixed
5870 $CPAN::META->has_inst("Archive::Tar")
5872 $CPAN::META->has_inst("Compress::Zlib") ) {
5875 $CPAN::Frontend->mydie(qq{
5876 CPAN.pm needs either both external programs tar and gzip installed or
5877 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5878 is available. Can\'t continue.
5881 if ($prefer==1) { # 1 => external gzip+tar
5883 my $is_compressed = $class->gtest($file);
5884 if ($is_compressed) {
5885 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5886 "< $file | $CPAN::Config->{tar} xvf -";
5888 $system = "$CPAN::Config->{tar} xvf $file";
5890 if (system($system) != 0) {
5891 # people find the most curious tar binaries that cannot handle
5893 if ($is_compressed) {
5894 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5895 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5896 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5898 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5902 $system = "$CPAN::Config->{tar} xvf $file";
5903 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5904 if (system($system)==0) {
5905 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5907 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5913 } elsif ($prefer==2) { # 2 => modules
5914 my $tar = Archive::Tar->new($file,1);
5915 my $af; # archive file
5918 # RCS 1.337 had this code, it turned out unacceptable slow but
5919 # it revealed a bug in Archive::Tar. Code is only here to hunt
5920 # the bug again. It should never be enabled in published code.
5921 # GDGraph3d-0.53 was an interesting case according to Larry
5923 warn(">>>Bughunting code enabled<<< " x 20);
5924 for $af ($tar->list_files) {
5925 if ($af =~ m!^(/|\.\./)!) {
5926 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5927 "illegal member [$af]");
5929 $CPAN::Frontend->myprint("$af\n");
5930 $tar->extract($af); # slow but effective for finding the bug
5931 return if $CPAN::Signal;
5934 for $af ($tar->list_files) {
5935 if ($af =~ m!^(/|\.\./)!) {
5936 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5937 "illegal member [$af]");
5939 $CPAN::Frontend->myprint("$af\n");
5941 return if $CPAN::Signal;
5946 Mac::BuildTools::convert_files([$tar->list_files], 1)
5947 if ($^O eq 'MacOS');
5954 my($class,$file) = @_;
5955 if ($CPAN::META->has_inst("Archive::Zip")) {
5956 # blueprint of the code from Archive::Zip::Tree::extractTree();
5957 my $zip = Archive::Zip->new();
5959 $status = $zip->read($file);
5960 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5961 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5962 my @members = $zip->members();
5963 for my $member ( @members ) {
5964 my $af = $member->fileName();
5965 if ($af =~ m!^(/|\.\./)!) {
5966 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5967 "illegal member [$af]");
5969 my $status = $member->extractToFileNamed( $af );
5970 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5971 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5972 $status != Archive::Zip::AZ_OK();
5973 return if $CPAN::Signal;
5977 my $unzip = $CPAN::Config->{unzip} or
5978 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5979 my @system = ($unzip, $file);
5980 return system(@system) == 0;
5985 package CPAN::Version;
5986 # CPAN::Version::vcmp courtesy Jost Krieger
5988 my($self,$l,$r) = @_;
5990 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5992 return 0 if $l eq $r; # short circuit for quicker success
5994 if ($l=~/^v/ <=> $r=~/^v/) {
5997 $_ = $self->float2vv($_);
6002 ($l ne "undef") <=> ($r ne "undef") ||
6006 $self->vstring($l) cmp $self->vstring($r)) ||
6012 my($self,$l,$r) = @_;
6013 $self->vcmp($l,$r) > 0;
6018 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
6019 pack "U*", split /\./, $n;
6022 # vv => visible vstring
6027 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
6028 # architecture influence
6030 $mantissa .= "0" while length($mantissa)%3;
6031 my $ret = "v" . $rev;
6033 $mantissa =~ s/(\d{1,3})// or
6034 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
6035 $ret .= ".".int($1);
6037 # warn "n[$n]ret[$ret]";
6043 $n =~ /^([\w\-\+\.]+)/;
6045 return $1 if defined $1 && length($1)>0;
6046 # if the first user reaches version v43, he will be treated as "+".
6047 # We'll have to decide about a new rule here then, depending on what
6048 # will be the prevailing versioning behavior then.
6050 if ($] < 5.006) { # or whenever v-strings were introduced
6051 # we get them wrong anyway, whatever we do, because 5.005 will
6052 # have already interpreted 0.2.4 to be "0.24". So even if he
6053 # indexer sends us something like "v0.2.4" we compare wrongly.
6055 # And if they say v1.2, then the old perl takes it as "v12"
6057 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
6060 my $better = sprintf "v%vd", $n;
6061 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
6073 CPAN - query, download and build perl modules from CPAN sites
6079 perl -MCPAN -e shell;
6085 autobundle, clean, install, make, recompile, test
6089 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6090 of a modern rewrite from ground up with greater extensibility and more
6091 features but no full compatibility. If you're new to CPAN.pm, you
6092 probably should investigate if CPANPLUS is the better choice for you.
6093 If you're already used to CPAN.pm you're welcome to continue using it,
6094 if you accept that its development is mostly (though not completely)
6099 The CPAN module is designed to automate the make and install of perl
6100 modules and extensions. It includes some primitive searching capabilities and
6101 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6102 to fetch the raw data from the net.
6104 Modules are fetched from one or more of the mirrored CPAN
6105 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6108 The CPAN module also supports the concept of named and versioned
6109 I<bundles> of modules. Bundles simplify the handling of sets of
6110 related modules. See Bundles below.
6112 The package contains a session manager and a cache manager. There is
6113 no status retained between sessions. The session manager keeps track
6114 of what has been fetched, built and installed in the current
6115 session. The cache manager keeps track of the disk space occupied by
6116 the make processes and deletes excess space according to a simple FIFO
6119 For extended searching capabilities there's a plugin for CPAN available,
6120 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6121 that indexes all documents available in CPAN authors directories. If
6122 C<CPAN::WAIT> is installed on your system, the interactive shell of
6123 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6124 which send queries to the WAIT server that has been configured for your
6127 All other methods provided are accessible in a programmer style and in an
6128 interactive shell style.
6130 =head2 Interactive Mode
6132 The interactive mode is entered by running
6134 perl -MCPAN -e shell
6136 which puts you into a readline interface. You will have the most fun if
6137 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6140 Once you are on the command line, type 'h' and the rest should be
6143 The function call C<shell> takes two optional arguments, one is the
6144 prompt, the second is the default initial command line (the latter
6145 only works if a real ReadLine interface module is installed).
6147 The most common uses of the interactive modes are
6151 =item Searching for authors, bundles, distribution files and modules
6153 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6154 for each of the four categories and another, C<i> for any of the
6155 mentioned four. Each of the four entities is implemented as a class
6156 with slightly differing methods for displaying an object.
6158 Arguments you pass to these commands are either strings exactly matching
6159 the identification string of an object or regular expressions that are
6160 then matched case-insensitively against various attributes of the
6161 objects. The parser recognizes a regular expression only if you
6162 enclose it between two slashes.
6164 The principle is that the number of found objects influences how an
6165 item is displayed. If the search finds one item, the result is
6166 displayed with the rather verbose method C<as_string>, but if we find
6167 more than one, we display each object with the terse method
6170 =item make, test, install, clean modules or distributions
6172 These commands take any number of arguments and investigate what is
6173 necessary to perform the action. If the argument is a distribution
6174 file name (recognized by embedded slashes), it is processed. If it is
6175 a module, CPAN determines the distribution file in which this module
6176 is included and processes that, following any dependencies named in
6177 the module's Makefile.PL (this behavior is controlled by
6178 I<prerequisites_policy>.)
6180 Any C<make> or C<test> are run unconditionally. An
6182 install <distribution_file>
6184 also is run unconditionally. But for
6188 CPAN checks if an install is actually needed for it and prints
6189 I<module up to date> in the case that the distribution file containing
6190 the module doesn't need to be updated.
6192 CPAN also keeps track of what it has done within the current session
6193 and doesn't try to build a package a second time regardless if it
6194 succeeded or not. The C<force> command takes as a first argument the
6195 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6196 command from scratch.
6200 cpan> install OpenGL
6201 OpenGL is up to date.
6202 cpan> force install OpenGL
6205 OpenGL-0.4/COPYRIGHT
6208 A C<clean> command results in a
6212 being executed within the distribution file's working directory.
6214 =item get, readme, look module or distribution
6216 C<get> downloads a distribution file without further action. C<readme>
6217 displays the README file of the associated distribution. C<Look> gets
6218 and untars (if not yet done) the distribution file, changes to the
6219 appropriate directory and opens a subshell process in that directory.
6223 C<ls> lists all distribution files in and below an author's CPAN
6224 directory. Only those files that contain modules are listed and if
6225 there is more than one for any given module, only the most recent one
6230 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6231 in the cpan-shell it is intended that you can press C<^C> anytime and
6232 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6233 to clean up and leave the shell loop. You can emulate the effect of a
6234 SIGTERM by sending two consecutive SIGINTs, which usually means by
6235 pressing C<^C> twice.
6237 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6238 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6244 The commands that are available in the shell interface are methods in
6245 the package CPAN::Shell. If you enter the shell command, all your
6246 input is split by the Text::ParseWords::shellwords() routine which
6247 acts like most shells do. The first word is being interpreted as the
6248 method to be called and the rest of the words are treated as arguments
6249 to this method. Continuation lines are supported if a line ends with a
6254 C<autobundle> writes a bundle file into the
6255 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6256 a list of all modules that are both available from CPAN and currently
6257 installed within @INC. The name of the bundle file is based on the
6258 current date and a counter.
6262 recompile() is a very special command in that it takes no argument and
6263 runs the make/test/install cycle with brute force over all installed
6264 dynamically loadable extensions (aka XS modules) with 'force' in
6265 effect. The primary purpose of this command is to finish a network
6266 installation. Imagine, you have a common source tree for two different
6267 architectures. You decide to do a completely independent fresh
6268 installation. You start on one architecture with the help of a Bundle
6269 file produced earlier. CPAN installs the whole Bundle for you, but
6270 when you try to repeat the job on the second architecture, CPAN
6271 responds with a C<"Foo up to date"> message for all modules. So you
6272 invoke CPAN's recompile on the second architecture and you're done.
6274 Another popular use for C<recompile> is to act as a rescue in case your
6275 perl breaks binary compatibility. If one of the modules that CPAN uses
6276 is in turn depending on binary compatibility (so you cannot run CPAN
6277 commands), then you should try the CPAN::Nox module for recovery.
6279 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6281 Although it may be considered internal, the class hierarchy does matter
6282 for both users and programmer. CPAN.pm deals with above mentioned four
6283 classes, and all those classes share a set of methods. A classical
6284 single polymorphism is in effect. A metaclass object registers all
6285 objects of all kinds and indexes them with a string. The strings
6286 referencing objects have a separated namespace (well, not completely
6291 words containing a "/" (slash) Distribution
6292 words starting with Bundle:: Bundle
6293 everything else Module or Author
6295 Modules know their associated Distribution objects. They always refer
6296 to the most recent official release. Developers may mark their releases
6297 as unstable development versions (by inserting an underbar into the
6298 module version number which will also be reflected in the distribution
6299 name when you run 'make dist'), so the really hottest and newest
6300 distribution is not always the default. If a module Foo circulates
6301 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6302 way to install version 1.23 by saying
6306 This would install the complete distribution file (say
6307 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6308 like to install version 1.23_90, you need to know where the
6309 distribution file resides on CPAN relative to the authors/id/
6310 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6311 so you would have to say
6313 install BAR/Foo-1.23_90.tar.gz
6315 The first example will be driven by an object of the class
6316 CPAN::Module, the second by an object of class CPAN::Distribution.
6318 =head2 Programmer's interface
6320 If you do not enter the shell, the available shell commands are both
6321 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6322 functions in the calling package (C<install(...)>).
6324 There's currently only one class that has a stable interface -
6325 CPAN::Shell. All commands that are available in the CPAN shell are
6326 methods of the class CPAN::Shell. Each of the commands that produce
6327 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6328 the IDs of all modules within the list.
6332 =item expand($type,@things)
6334 The IDs of all objects available within a program are strings that can
6335 be expanded to the corresponding real objects with the
6336 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6337 list of CPAN::Module objects according to the C<@things> arguments
6338 given. In scalar context it only returns the first element of the
6341 =item expandany(@things)
6343 Like expand, but returns objects of the appropriate type, i.e.
6344 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6345 CPAN::Distribution objects fro distributions.
6347 =item Programming Examples
6349 This enables the programmer to do operations that combine
6350 functionalities that are available in the shell.
6352 # install everything that is outdated on my disk:
6353 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6355 # install my favorite programs if necessary:
6356 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6357 my $obj = CPAN::Shell->expand('Module',$mod);
6361 # list all modules on my disk that have no VERSION number
6362 for $mod (CPAN::Shell->expand("Module","/./")){
6363 next unless $mod->inst_file;
6364 # MakeMaker convention for undefined $VERSION:
6365 next unless $mod->inst_version eq "undef";
6366 print "No VERSION in ", $mod->id, "\n";
6369 # find out which distribution on CPAN contains a module:
6370 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6372 Or if you want to write a cronjob to watch The CPAN, you could list
6373 all modules that need updating. First a quick and dirty way:
6375 perl -e 'use CPAN; CPAN::Shell->r;'
6377 If you don't want to get any output in the case that all modules are
6378 up to date, you can parse the output of above command for the regular
6379 expression //modules are up to date// and decide to mail the output
6380 only if it doesn't match. Ick?
6382 If you prefer to do it more in a programmer style in one single
6383 process, maybe something like this suits you better:
6385 # list all modules on my disk that have newer versions on CPAN
6386 for $mod (CPAN::Shell->expand("Module","/./")){
6387 next unless $mod->inst_file;
6388 next if $mod->uptodate;
6389 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6390 $mod->id, $mod->inst_version, $mod->cpan_version;
6393 If that gives you too much output every day, you maybe only want to
6394 watch for three modules. You can write
6396 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6398 as the first line instead. Or you can combine some of the above
6401 # watch only for a new mod_perl module
6402 $mod = CPAN::Shell->expand("Module","mod_perl");
6403 exit if $mod->uptodate;
6404 # new mod_perl arrived, let me know all update recommendations
6409 =head2 Methods in the other Classes
6411 The programming interface for the classes CPAN::Module,
6412 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6413 beta and partially even alpha. In the following paragraphs only those
6414 methods are documented that have proven useful over a longer time and
6415 thus are unlikely to change.
6419 =item CPAN::Author::as_glimpse()
6421 Returns a one-line description of the author
6423 =item CPAN::Author::as_string()
6425 Returns a multi-line description of the author
6427 =item CPAN::Author::email()
6429 Returns the author's email address
6431 =item CPAN::Author::fullname()
6433 Returns the author's name
6435 =item CPAN::Author::name()
6437 An alias for fullname
6439 =item CPAN::Bundle::as_glimpse()
6441 Returns a one-line description of the bundle
6443 =item CPAN::Bundle::as_string()
6445 Returns a multi-line description of the bundle
6447 =item CPAN::Bundle::clean()
6449 Recursively runs the C<clean> method on all items contained in the bundle.
6451 =item CPAN::Bundle::contains()
6453 Returns a list of objects' IDs contained in a bundle. The associated
6454 objects may be bundles, modules or distributions.
6456 =item CPAN::Bundle::force($method,@args)
6458 Forces CPAN to perform a task that normally would have failed. Force
6459 takes as arguments a method name to be called and any number of
6460 additional arguments that should be passed to the called method. The
6461 internals of the object get the needed changes so that CPAN.pm does
6462 not refuse to take the action. The C<force> is passed recursively to
6463 all contained objects.
6465 =item CPAN::Bundle::get()
6467 Recursively runs the C<get> method on all items contained in the bundle
6469 =item CPAN::Bundle::inst_file()
6471 Returns the highest installed version of the bundle in either @INC or
6472 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6473 CPAN::Module::inst_file.
6475 =item CPAN::Bundle::inst_version()
6477 Like CPAN::Bundle::inst_file, but returns the $VERSION
6479 =item CPAN::Bundle::uptodate()
6481 Returns 1 if the bundle itself and all its members are uptodate.
6483 =item CPAN::Bundle::install()
6485 Recursively runs the C<install> method on all items contained in the bundle
6487 =item CPAN::Bundle::make()
6489 Recursively runs the C<make> method on all items contained in the bundle
6491 =item CPAN::Bundle::readme()
6493 Recursively runs the C<readme> method on all items contained in the bundle
6495 =item CPAN::Bundle::test()
6497 Recursively runs the C<test> method on all items contained in the bundle
6499 =item CPAN::Distribution::as_glimpse()
6501 Returns a one-line description of the distribution
6503 =item CPAN::Distribution::as_string()
6505 Returns a multi-line description of the distribution
6507 =item CPAN::Distribution::clean()
6509 Changes to the directory where the distribution has been unpacked and
6510 runs C<make clean> there.
6512 =item CPAN::Distribution::containsmods()
6514 Returns a list of IDs of modules contained in a distribution file.
6515 Only works for distributions listed in the 02packages.details.txt.gz
6516 file. This typically means that only the most recent version of a
6517 distribution is covered.
6519 =item CPAN::Distribution::cvs_import()
6521 Changes to the directory where the distribution has been unpacked and
6524 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6528 =item CPAN::Distribution::dir()
6530 Returns the directory into which this distribution has been unpacked.
6532 =item CPAN::Distribution::force($method,@args)
6534 Forces CPAN to perform a task that normally would have failed. Force
6535 takes as arguments a method name to be called and any number of
6536 additional arguments that should be passed to the called method. The
6537 internals of the object get the needed changes so that CPAN.pm does
6538 not refuse to take the action.
6540 =item CPAN::Distribution::get()
6542 Downloads the distribution from CPAN and unpacks it. Does nothing if
6543 the distribution has already been downloaded and unpacked within the
6546 =item CPAN::Distribution::install()
6548 Changes to the directory where the distribution has been unpacked and
6549 runs the external command C<make install> there. If C<make> has not
6550 yet been run, it will be run first. A C<make test> will be issued in
6551 any case and if this fails, the install will be canceled. The
6552 cancellation can be avoided by letting C<force> run the C<install> for
6555 =item CPAN::Distribution::isa_perl()
6557 Returns 1 if this distribution file seems to be a perl distribution.
6558 Normally this is derived from the file name only, but the index from
6559 CPAN can contain a hint to achieve a return value of true for other
6562 =item CPAN::Distribution::look()
6564 Changes to the directory where the distribution has been unpacked and
6565 opens a subshell there. Exiting the subshell returns.
6567 =item CPAN::Distribution::make()
6569 First runs the C<get> method to make sure the distribution is
6570 downloaded and unpacked. Changes to the directory where the
6571 distribution has been unpacked and runs the external commands C<perl
6572 Makefile.PL> and C<make> there.
6574 =item CPAN::Distribution::prereq_pm()
6576 Returns the hash reference that has been announced by a distribution
6577 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6578 attempt has been made to C<make> the distribution. Returns undef
6581 =item CPAN::Distribution::readme()
6583 Downloads the README file associated with a distribution and runs it
6584 through the pager specified in C<$CPAN::Config->{pager}>.
6586 =item CPAN::Distribution::test()
6588 Changes to the directory where the distribution has been unpacked and
6589 runs C<make test> there.
6591 =item CPAN::Distribution::uptodate()
6593 Returns 1 if all the modules contained in the distribution are
6594 uptodate. Relies on containsmods.
6596 =item CPAN::Index::force_reload()
6598 Forces a reload of all indices.
6600 =item CPAN::Index::reload()
6602 Reloads all indices if they have been read more than
6603 C<$CPAN::Config->{index_expire}> days.
6605 =item CPAN::InfoObj::dump()
6607 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6608 inherit this method. It prints the data structure associated with an
6609 object. Useful for debugging. Note: the data structure is considered
6610 internal and thus subject to change without notice.
6612 =item CPAN::Module::as_glimpse()
6614 Returns a one-line description of the module
6616 =item CPAN::Module::as_string()
6618 Returns a multi-line description of the module
6620 =item CPAN::Module::clean()
6622 Runs a clean on the distribution associated with this module.
6624 =item CPAN::Module::cpan_file()
6626 Returns the filename on CPAN that is associated with the module.
6628 =item CPAN::Module::cpan_version()
6630 Returns the latest version of this module available on CPAN.
6632 =item CPAN::Module::cvs_import()
6634 Runs a cvs_import on the distribution associated with this module.
6636 =item CPAN::Module::description()
6638 Returns a 44 character description of this module. Only available for
6639 modules listed in The Module List (CPAN/modules/00modlist.long.html
6640 or 00modlist.long.txt.gz)
6642 =item CPAN::Module::force($method,@args)
6644 Forces CPAN to perform a task that normally would have failed. Force
6645 takes as arguments a method name to be called and any number of
6646 additional arguments that should be passed to the called method. The
6647 internals of the object get the needed changes so that CPAN.pm does
6648 not refuse to take the action.
6650 =item CPAN::Module::get()
6652 Runs a get on the distribution associated with this module.
6654 =item CPAN::Module::inst_file()
6656 Returns the filename of the module found in @INC. The first file found
6657 is reported just like perl itself stops searching @INC when it finds a
6660 =item CPAN::Module::inst_version()
6662 Returns the version number of the module in readable format.
6664 =item CPAN::Module::install()
6666 Runs an C<install> on the distribution associated with this module.
6668 =item CPAN::Module::look()
6670 Changes to the directory where the distribution associated with this
6671 module has been unpacked and opens a subshell there. Exiting the
6674 =item CPAN::Module::make()
6676 Runs a C<make> on the distribution associated with this module.
6678 =item CPAN::Module::manpage_headline()
6680 If module is installed, peeks into the module's manpage, reads the
6681 headline and returns it. Moreover, if the module has been downloaded
6682 within this session, does the equivalent on the downloaded module even
6683 if it is not installed.
6685 =item CPAN::Module::readme()
6687 Runs a C<readme> on the distribution associated with this module.
6689 =item CPAN::Module::test()
6691 Runs a C<test> on the distribution associated with this module.
6693 =item CPAN::Module::uptodate()
6695 Returns 1 if the module is installed and up-to-date.
6697 =item CPAN::Module::userid()
6699 Returns the author's ID of the module.
6703 =head2 Cache Manager
6705 Currently the cache manager only keeps track of the build directory
6706 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6707 deletes complete directories below C<build_dir> as soon as the size of
6708 all directories there gets bigger than $CPAN::Config->{build_cache}
6709 (in MB). The contents of this cache may be used for later
6710 re-installations that you intend to do manually, but will never be
6711 trusted by CPAN itself. This is due to the fact that the user might
6712 use these directories for building modules on different architectures.
6714 There is another directory ($CPAN::Config->{keep_source_where}) where
6715 the original distribution files are kept. This directory is not
6716 covered by the cache manager and must be controlled by the user. If
6717 you choose to have the same directory as build_dir and as
6718 keep_source_where directory, then your sources will be deleted with
6719 the same fifo mechanism.
6723 A bundle is just a perl module in the namespace Bundle:: that does not
6724 define any functions or methods. It usually only contains documentation.
6726 It starts like a perl module with a package declaration and a $VERSION
6727 variable. After that the pod section looks like any other pod with the
6728 only difference being that I<one special pod section> exists starting with
6733 In this pod section each line obeys the format
6735 Module_Name [Version_String] [- optional text]
6737 The only required part is the first field, the name of a module
6738 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6739 of the line is optional. The comment part is delimited by a dash just
6740 as in the man page header.
6742 The distribution of a bundle should follow the same convention as
6743 other distributions.
6745 Bundles are treated specially in the CPAN package. If you say 'install
6746 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6747 the modules in the CONTENTS section of the pod. You can install your
6748 own Bundles locally by placing a conformant Bundle file somewhere into
6749 your @INC path. The autobundle() command which is available in the
6750 shell interface does that for you by including all currently installed
6751 modules in a snapshot bundle file.
6753 =head2 Prerequisites
6755 If you have a local mirror of CPAN and can access all files with
6756 "file:" URLs, then you only need a perl better than perl5.003 to run
6757 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6758 required for non-UNIX systems or if your nearest CPAN site is
6759 associated with a URL that is not C<ftp:>.
6761 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6762 implemented for an external ftp command or for an external lynx
6765 =head2 Finding packages and VERSION
6767 This module presumes that all packages on CPAN
6773 declare their $VERSION variable in an easy to parse manner. This
6774 prerequisite can hardly be relaxed because it consumes far too much
6775 memory to load all packages into the running program just to determine
6776 the $VERSION variable. Currently all programs that are dealing with
6777 version use something like this
6779 perl -MExtUtils::MakeMaker -le \
6780 'print MM->parse_version(shift)' filename
6782 If you are author of a package and wonder if your $VERSION can be
6783 parsed, please try the above method.
6787 come as compressed or gzipped tarfiles or as zip files and contain a
6788 Makefile.PL (well, we try to handle a bit more, but without much
6795 The debugging of this module is a bit complex, because we have
6796 interferences of the software producing the indices on CPAN, of the
6797 mirroring process on CPAN, of packaging, of configuration, of
6798 synchronicity, and of bugs within CPAN.pm.
6800 For code debugging in interactive mode you can try "o debug" which
6801 will list options for debugging the various parts of the code. You
6802 should know that "o debug" has built-in completion support.
6804 For data debugging there is the C<dump> command which takes the same
6805 arguments as make/test/install and outputs the object's Data::Dumper
6808 =head2 Floppy, Zip, Offline Mode
6810 CPAN.pm works nicely without network too. If you maintain machines
6811 that are not networked at all, you should consider working with file:
6812 URLs. Of course, you have to collect your modules somewhere first. So
6813 you might use CPAN.pm to put together all you need on a networked
6814 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6815 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6816 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6817 with this floppy. See also below the paragraph about CD-ROM support.
6819 =head1 CONFIGURATION
6821 When the CPAN module is used for the first time, a configuration
6822 dialog tries to determine a couple of site specific options. The
6823 result of the dialog is stored in a hash reference C< $CPAN::Config >
6824 in a file CPAN/Config.pm.
6826 The default values defined in the CPAN/Config.pm file can be
6827 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6828 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6829 added to the search path of the CPAN module before the use() or
6830 require() statements.
6832 The configuration dialog can be started any time later again by
6833 issueing the command C< o conf init > in the CPAN shell.
6835 Currently the following keys in the hash reference $CPAN::Config are
6838 build_cache size of cache for directories to build modules
6839 build_dir locally accessible directory to build modules
6840 index_expire after this many days refetch index files
6841 cache_metadata use serializer to cache metadata
6842 cpan_home local directory reserved for this package
6843 dontload_hash anonymous hash: modules in the keys will not be
6844 loaded by the CPAN::has_inst() routine
6845 gzip location of external program gzip
6846 histfile file to maintain history between sessions
6847 histsize maximum number of lines to keep in histfile
6848 inactivity_timeout breaks interactive Makefile.PLs after this
6849 many seconds inactivity. Set to 0 to never break.
6850 inhibit_startup_message
6851 if true, does not print the startup message
6852 keep_source_where directory in which to keep the source (if we do)
6853 make location of external make program
6854 make_arg arguments that should always be passed to 'make'
6855 make_install_arg same as make_arg for 'make install'
6856 makepl_arg arguments passed to 'perl Makefile.PL'
6857 pager location of external program more (or any pager)
6858 prerequisites_policy
6859 what to do if you are missing module prerequisites
6860 ('follow' automatically, 'ask' me, or 'ignore')
6861 proxy_user username for accessing an authenticating proxy
6862 proxy_pass password for accessing an authenticating proxy
6863 scan_cache controls scanning of cache ('atstart' or 'never')
6864 tar location of external program tar
6865 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6866 (and nonsense for characters outside latin range)
6867 unzip location of external program unzip
6868 urllist arrayref to nearby CPAN sites (or equivalent locations)
6869 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6870 ftp_proxy, } the three usual variables for configuring
6871 http_proxy, } proxy requests. Both as CPAN::Config variables
6872 no_proxy } and as environment variables configurable.
6874 You can set and query each of these options interactively in the cpan
6875 shell with the command set defined within the C<o conf> command:
6879 =item C<o conf E<lt>scalar optionE<gt>>
6881 prints the current value of the I<scalar option>
6883 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6885 Sets the value of the I<scalar option> to I<value>
6887 =item C<o conf E<lt>list optionE<gt>>
6889 prints the current value of the I<list option> in MakeMaker's
6892 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6894 shifts or pops the array in the I<list option> variable
6896 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6898 works like the corresponding perl commands.
6902 =head2 Note on urllist parameter's format
6904 urllist parameters are URLs according to RFC 1738. We do a little
6905 guessing if your URL is not compliant, but if you have problems with
6906 file URLs, please try the correct format. Either:
6908 file://localhost/whatever/ftp/pub/CPAN/
6912 file:///home/ftp/pub/CPAN/
6914 =head2 urllist parameter has CD-ROM support
6916 The C<urllist> parameter of the configuration table contains a list of
6917 URLs that are to be used for downloading. If the list contains any
6918 C<file> URLs, CPAN always tries to get files from there first. This
6919 feature is disabled for index files. So the recommendation for the
6920 owner of a CD-ROM with CPAN contents is: include your local, possibly
6921 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6923 o conf urllist push file://localhost/CDROM/CPAN
6925 CPAN.pm will then fetch the index files from one of the CPAN sites
6926 that come at the beginning of urllist. It will later check for each
6927 module if there is a local copy of the most recent version.
6929 Another peculiarity of urllist is that the site that we could
6930 successfully fetch the last file from automatically gets a preference
6931 token and is tried as the first site for the next request. So if you
6932 add a new site at runtime it may happen that the previously preferred
6933 site will be tried another time. This means that if you want to disallow
6934 a site for the next transfer, it must be explicitly removed from
6939 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6940 install foreign, unmasked, unsigned code on your machine. We compare
6941 to a checksum that comes from the net just as the distribution file
6942 itself. If somebody has managed to tamper with the distribution file,
6943 they may have as well tampered with the CHECKSUMS file. Future
6944 development will go towards strong authentication.
6948 Most functions in package CPAN are exported per default. The reason
6949 for this is that the primary use is intended for the cpan shell or for
6952 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6954 Populating a freshly installed perl with my favorite modules is pretty
6955 easy if you maintain a private bundle definition file. To get a useful
6956 blueprint of a bundle definition file, the command autobundle can be used
6957 on the CPAN shell command line. This command writes a bundle definition
6958 file for all modules that are installed for the currently running perl
6959 interpreter. It's recommended to run this command only once and from then
6960 on maintain the file manually under a private name, say
6961 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6963 cpan> install Bundle::my_bundle
6965 then answer a few questions and then go out for a coffee.
6967 Maintaining a bundle definition file means keeping track of two
6968 things: dependencies and interactivity. CPAN.pm sometimes fails on
6969 calculating dependencies because not all modules define all MakeMaker
6970 attributes correctly, so a bundle definition file should specify
6971 prerequisites as early as possible. On the other hand, it's a bit
6972 annoying that many distributions need some interactive configuring. So
6973 what I try to accomplish in my private bundle file is to have the
6974 packages that need to be configured early in the file and the gentle
6975 ones later, so I can go out after a few minutes and leave CPAN.pm
6978 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6980 Thanks to Graham Barr for contributing the following paragraphs about
6981 the interaction between perl, and various firewall configurations. For
6982 further informations on firewalls, it is recommended to consult the
6983 documentation that comes with the ncftp program. If you are unable to
6984 go through the firewall with a simple Perl setup, it is very likely
6985 that you can configure ncftp so that it works for your firewall.
6987 =head2 Three basic types of firewalls
6989 Firewalls can be categorized into three basic types.
6995 This is where the firewall machine runs a web server and to access the
6996 outside world you must do it via the web server. If you set environment
6997 variables like http_proxy or ftp_proxy to a values beginning with http://
6998 or in your web browser you have to set proxy information then you know
6999 you are running an http firewall.
7001 To access servers outside these types of firewalls with perl (even for
7002 ftp) you will need to use LWP.
7006 This where the firewall machine runs an ftp server. This kind of
7007 firewall will only let you access ftp servers outside the firewall.
7008 This is usually done by connecting to the firewall with ftp, then
7009 entering a username like "user@outside.host.com"
7011 To access servers outside these type of firewalls with perl you
7012 will need to use Net::FTP.
7014 =item One way visibility
7016 I say one way visibility as these firewalls try to make themselves look
7017 invisible to the users inside the firewall. An FTP data connection is
7018 normally created by sending the remote server your IP address and then
7019 listening for the connection. But the remote server will not be able to
7020 connect to you because of the firewall. So for these types of firewall
7021 FTP connections need to be done in a passive mode.
7023 There are two that I can think off.
7029 If you are using a SOCKS firewall you will need to compile perl and link
7030 it with the SOCKS library, this is what is normally called a 'socksified'
7031 perl. With this executable you will be able to connect to servers outside
7032 the firewall as if it is not there.
7036 This is the firewall implemented in the Linux kernel, it allows you to
7037 hide a complete network behind one IP address. With this firewall no
7038 special compiling is needed as you can access hosts directly.
7040 For accessing ftp servers behind such firewalls you may need to set
7041 the environment variable C<FTP_PASSIVE> to a true value, e.g.
7043 env FTP_PASSIVE=1 perl -MCPAN -eshell
7047 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
7054 =head2 Configuring lynx or ncftp for going through a firewall
7056 If you can go through your firewall with e.g. lynx, presumably with a
7059 /usr/local/bin/lynx -pscott:tiger
7061 then you would configure CPAN.pm with the command
7063 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7065 That's all. Similarly for ncftp or ftp, you would configure something
7068 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7070 Your mileage may vary...
7078 I installed a new version of module X but CPAN keeps saying,
7079 I have the old version installed
7081 Most probably you B<do> have the old version installed. This can
7082 happen if a module installs itself into a different directory in the
7083 @INC path than it was previously installed. This is not really a
7084 CPAN.pm problem, you would have the same problem when installing the
7085 module manually. The easiest way to prevent this behaviour is to add
7086 the argument C<UNINST=1> to the C<make install> call, and that is why
7087 many people add this argument permanently by configuring
7089 o conf make_install_arg UNINST=1
7093 So why is UNINST=1 not the default?
7095 Because there are people who have their precise expectations about who
7096 may install where in the @INC path and who uses which @INC array. In
7097 fine tuned environments C<UNINST=1> can cause damage.
7101 I want to clean up my mess, and install a new perl along with
7102 all modules I have. How do I go about it?
7104 Run the autobundle command for your old perl and optionally rename the
7105 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7106 with the Configure option prefix, e.g.
7108 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7110 Install the bundle file you produced in the first step with something like
7112 cpan> install Bundle::mybundle
7118 When I install bundles or multiple modules with one command
7119 there is too much output to keep track of.
7121 You may want to configure something like
7123 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7124 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7126 so that STDOUT is captured in a file for later inspection.
7131 I am not root, how can I install a module in a personal directory?
7133 You will most probably like something like this:
7135 o conf makepl_arg "LIB=~/myperl/lib \
7136 INSTALLMAN1DIR=~/myperl/man/man1 \
7137 INSTALLMAN3DIR=~/myperl/man/man3"
7138 install Sybase::Sybperl
7140 You can make this setting permanent like all C<o conf> settings with
7143 You will have to add ~/myperl/man to the MANPATH environment variable
7144 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7147 use lib "$ENV{HOME}/myperl/lib";
7149 or setting the PERL5LIB environment variable.
7151 Another thing you should bear in mind is that the UNINST parameter
7152 should never be set if you are not root.
7156 How to get a package, unwrap it, and make a change before building it?
7158 look Sybase::Sybperl
7162 I installed a Bundle and had a couple of fails. When I
7163 retried, everything resolved nicely. Can this be fixed to work
7166 The reason for this is that CPAN does not know the dependencies of all
7167 modules when it starts out. To decide about the additional items to
7168 install, it just uses data found in the generated Makefile. An
7169 undetected missing piece breaks the process. But it may well be that
7170 your Bundle installs some prerequisite later than some depending item
7171 and thus your second try is able to resolve everything. Please note,
7172 CPAN.pm does not know the dependency tree in advance and cannot sort
7173 the queue of things to install in a topologically correct order. It
7174 resolves perfectly well IFF all modules declare the prerequisites
7175 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7176 fail and you need to install often, it is recommended sort the Bundle
7177 definition file manually. It is planned to improve the metadata
7178 situation for dependencies on CPAN in general, but this will still
7183 In our intranet we have many modules for internal use. How
7184 can I integrate these modules with CPAN.pm but without uploading
7185 the modules to CPAN?
7187 Have a look at the CPAN::Site module.
7191 When I run CPAN's shell, I get error msg about line 1 to 4,
7192 setting meta input/output via the /etc/inputrc file.
7194 Some versions of readline are picky about capitalization in the
7195 /etc/inputrc file and specifically RedHat 6.2 comes with a
7196 /etc/inputrc that contains the word C<on> in lowercase. Change the
7197 occurrences of C<on> to C<On> and the bug should disappear.
7201 Some authors have strange characters in their names.
7203 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7204 expecting ISO-8859-1 charset, a converter can be activated by setting
7205 term_is_latin to a true value in your config file. One way of doing so
7208 cpan> ! $CPAN::Config->{term_is_latin}=1
7210 Extended support for converters will be made available as soon as perl
7211 becomes stable with regard to charset issues.
7217 We should give coverage for B<all> of the CPAN and not just the PAUSE
7218 part, right? In this discussion CPAN and PAUSE have become equal --
7219 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7220 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7222 Future development should be directed towards a better integration of
7225 If a Makefile.PL requires special customization of libraries, prompts
7226 the user for special input, etc. then you may find CPAN is not able to
7227 build the distribution. In that case, you should attempt the
7228 traditional method of building a Perl module package from a shell.
7232 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7236 Kawai,Takanori provides a Japanese translation of this manpage at
7237 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7241 perl(1), CPAN::Nox(3)