1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $VERSION = eval $VERSION;
7 use CPAN::HandleConfig;
16 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
17 use File::Basename ();
25 use Sys::Hostname qw(hostname);
26 use Text::ParseWords ();
28 no lib "."; # we need to run chdir all over and we would get at wrong
31 require Mac::BuildTools if $^O eq 'MacOS';
33 END { $CPAN::End++; &cleanup; }
36 $CPAN::Frontend ||= "CPAN::Shell";
37 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
38 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
39 $CPAN::Perl ||= CPAN::find_perl();
40 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
41 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
47 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
48 $Signal $Suppress_readline $Frontend
49 $Defaultsite $Have_warned $Defaultdocs $Defaultrecent
52 @CPAN::ISA = qw(CPAN::Debug Exporter);
55 autobundle bundle expand force notest get cvs_import
56 install make readme recompile shell test clean
60 sub soft_chdir_with_alternatives ($);
62 #-> sub CPAN::AUTOLOAD ;
67 @EXPORT{@EXPORT} = '';
68 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
69 if (exists $EXPORT{$l}){
72 $CPAN::Frontend->mywarn(qq{Unknown CPAN command "$AUTOLOAD". }.
81 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
82 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
84 my $oprompt = shift || "cpan> ";
85 my $prompt = $oprompt;
86 my $commandline = shift || "";
89 unless ($Suppress_readline) {
90 require Term::ReadLine;
93 $term->ReadLine eq "Term::ReadLine::Stub"
95 $term = Term::ReadLine->new('CPAN Monitor');
97 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
98 my $attribs = $term->Attribs;
99 $attribs->{attempted_completion_function} = sub {
100 &CPAN::Complete::gnu_cpl;
103 $readline::rl_completion_function =
104 $readline::rl_completion_function = 'CPAN::Complete::cpl';
106 if (my $histfile = $CPAN::Config->{'histfile'}) {{
107 unless ($term->can("AddHistory")) {
108 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
111 my($fh) = FileHandle->new;
112 open $fh, "<$histfile" or last;
116 $term->AddHistory($_);
120 # $term->OUT is autoflushed anyway
121 my $odef = select STDERR;
128 # no strict; # I do not recall why no strict was here (2000-09-03)
130 my @cwd = (CPAN::anycwd(),File::Spec->tmpdir(),File::Spec->rootdir());
131 my $try_detect_readline;
132 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
133 my $rl_avail = $Suppress_readline ? "suppressed" :
134 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
135 "available (try 'install Bundle::CPAN')";
137 $CPAN::Frontend->myprint(
139 cpan shell -- CPAN exploration and modules installation (v%s)
146 unless $CPAN::Config->{'inhibit_startup_message'} ;
147 my($continuation) = "";
148 SHELLCOMMAND: while () {
149 if ($Suppress_readline) {
151 last SHELLCOMMAND unless defined ($_ = <> );
154 last SHELLCOMMAND unless
155 defined ($_ = $term->readline($prompt, $commandline));
157 $_ = "$continuation$_" if $continuation;
159 next SHELLCOMMAND if /^$/;
160 $_ = 'h' if /^\s*\?/;
161 if (/^(?:q(?:uit)?|bye|exit)$/i) {
172 use vars qw($import_done);
173 CPAN->import(':DEFAULT') unless $import_done++;
174 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
181 if ($] < 5.00322) { # parsewords had a bug until recently
184 eval { @line = Text::ParseWords::shellwords($_) };
185 warn($@), next SHELLCOMMAND if $@;
186 warn("Text::Parsewords could not parse the line [$_]"),
187 next SHELLCOMMAND unless @line;
189 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
190 my $command = shift @line;
191 eval { CPAN::Shell->$command(@line) };
193 soft_chdir_with_alternatives(\@cwd);
194 $CPAN::Frontend->myprint("\n");
199 $commandline = ""; # I do want to be able to pass a default to
200 # shell, but on the second command I see no
203 CPAN::Queue->nullify_queue;
204 if ($try_detect_readline) {
205 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
207 $CPAN::META->has_inst("Term::ReadLine::Perl")
209 delete $INC{"Term/ReadLine.pm"};
211 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
212 require Term::ReadLine;
213 $CPAN::Frontend->myprint("\n$redef subroutines in ".
214 "Term::ReadLine redefined\n");
220 soft_chdir_with_alternatives(\@cwd);
223 sub soft_chdir_with_alternatives ($) {
225 while (not chdir $cwd->[0]) {
227 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
228 Trying to chdir to "$cwd->[1]" instead.
232 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
236 package CPAN::CacheMgr;
238 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
243 use vars qw($Ua $Thesite $Themethod);
244 @CPAN::FTP::ISA = qw(CPAN::Debug);
246 package CPAN::LWP::UserAgent;
248 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
249 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
251 package CPAN::Complete;
253 @CPAN::Complete::ISA = qw(CPAN::Debug);
254 @CPAN::Complete::COMMANDS = sort qw(
255 ! a b d h i m o q r u
274 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
275 @CPAN::Index::ISA = qw(CPAN::Debug);
278 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
281 package CPAN::InfoObj;
283 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
285 package CPAN::Author;
287 @CPAN::Author::ISA = qw(CPAN::InfoObj);
289 package CPAN::Distribution;
291 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
293 package CPAN::Bundle;
295 @CPAN::Bundle::ISA = qw(CPAN::Module);
297 package CPAN::Module;
299 @CPAN::Module::ISA = qw(CPAN::InfoObj);
301 package CPAN::Exception::RecursiveDependency;
303 use overload '""' => "as_string";
310 for my $dep (@$deps) {
312 last if $seen{$dep}++;
314 bless { deps => \@deps }, $class;
319 "\nRecursive dependency detected:\n " .
320 join("\n => ", @{$self->{deps}}) .
321 ".\nCannot continue.\n";
326 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
327 @CPAN::Shell::ISA = qw(CPAN::Debug);
328 $COLOR_REGISTERED ||= 0;
329 $PRINT_ORNAMENTING ||= 0;
331 #-> sub CPAN::Shell::AUTOLOAD ;
333 my($autoload) = $AUTOLOAD;
334 my $class = shift(@_);
335 # warn "autoload[$autoload] class[$class]";
336 $autoload =~ s/.*:://;
337 if ($autoload =~ /^w/) {
338 if ($CPAN::META->has_inst('CPAN::WAIT')) {
339 CPAN::WAIT->$autoload(@_);
341 $CPAN::Frontend->mywarn(qq{
342 Commands starting with "w" require CPAN::WAIT to be installed.
343 Please consider installing CPAN::WAIT to use the fulltext index.
344 For this you just need to type
349 $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload'. }.
358 # One use of the queue is to determine if we should or shouldn't
359 # announce the availability of a new CPAN module
361 # Now we try to use it for dependency tracking. For that to happen
362 # we need to draw a dependency tree and do the leaves first. This can
363 # easily be reached by running CPAN.pm recursively, but we don't want
364 # to waste memory and run into deep recursion. So what we can do is
367 # CPAN::Queue is the package where the queue is maintained. Dependencies
368 # often have high priority and must be brought to the head of the queue,
369 # possibly by jumping the queue if they are already there. My first code
370 # attempt tried to be extremely correct. Whenever a module needed
371 # immediate treatment, I either unshifted it to the front of the queue,
372 # or, if it was already in the queue, I spliced and let it bypass the
373 # others. This became a too correct model that made it impossible to put
374 # an item more than once into the queue. Why would you need that? Well,
375 # you need temporary duplicates as the manager of the queue is a loop
378 # (1) looks at the first item in the queue without shifting it off
380 # (2) cares for the item
382 # (3) removes the item from the queue, *even if its agenda failed and
383 # even if the item isn't the first in the queue anymore* (that way
384 # protecting against never ending queues)
386 # So if an item has prerequisites, the installation fails now, but we
387 # want to retry later. That's easy if we have it twice in the queue.
389 # I also expect insane dependency situations where an item gets more
390 # than two lives in the queue. Simplest example is triggered by 'install
391 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
392 # get in the way. I wanted the queue manager to be a dumb servant, not
393 # one that knows everything.
395 # Who would I tell in this model that the user wants to be asked before
396 # processing? I can't attach that information to the module object,
397 # because not modules are installed but distributions. So I'd have to
398 # tell the distribution object that it should ask the user before
399 # processing. Where would the question be triggered then? Most probably
400 # in CPAN::Distribution::rematein.
401 # Hope that makes sense, my head is a bit off:-) -- AK
408 my $self = bless { qmod => $s }, $class;
413 # CPAN::Queue::first ;
419 # CPAN::Queue::delete_first ;
421 my($class,$what) = @_;
423 for my $i (0..$#All) {
424 if ( $All[$i]->{qmod} eq $what ) {
431 # CPAN::Queue::jumpqueue ;
435 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
436 join(",",map {$_->{qmod}} @All),
439 WHAT: for my $what (reverse @what) {
441 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
442 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
443 if ($All[$i]->{qmod} eq $what){
445 if ($jumped > 100) { # one's OK if e.g. just
446 # processing now; more are OK if
447 # user typed it several times
448 $CPAN::Frontend->mywarn(
449 qq{Object [$what] queued more than 100 times, ignoring}
455 my $obj = bless { qmod => $what }, $class;
458 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
459 join(",",map {$_->{qmod}} @All),
464 # CPAN::Queue::exists ;
466 my($self,$what) = @_;
467 my @all = map { $_->{qmod} } @All;
468 my $exists = grep { $_->{qmod} eq $what } @All;
469 # warn "in exists what[$what] all[@all] exists[$exists]";
473 # CPAN::Queue::delete ;
476 @All = grep { $_->{qmod} ne $mod } @All;
479 # CPAN::Queue::nullify_queue ;
489 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
491 # from here on only subs.
492 ################################################################################
494 #-> sub CPAN::all_objects ;
496 my($mgr,$class) = @_;
497 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
498 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
500 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
502 *all = \&all_objects;
504 # Called by shell, not in batch mode. In batch mode I see no risk in
505 # having many processes updating something as installations are
506 # continually checked at runtime. In shell mode I suspect it is
507 # unintentional to open more than one shell at a time
509 #-> sub CPAN::checklock ;
512 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
513 if (-f $lockfile && -M _ > 0) {
514 my $fh = FileHandle->new($lockfile) or
515 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
516 my $otherpid = <$fh>;
517 my $otherhost = <$fh>;
519 if (defined $otherpid && $otherpid) {
522 if (defined $otherhost && $otherhost) {
525 my $thishost = hostname();
526 if (defined $otherhost && defined $thishost &&
527 $otherhost ne '' && $thishost ne '' &&
528 $otherhost ne $thishost) {
529 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
530 "reports other host $otherhost and other process $otherpid.\n".
531 "Cannot proceed.\n"));
533 elsif (defined $otherpid && $otherpid) {
534 return if $$ == $otherpid; # should never happen
535 $CPAN::Frontend->mywarn(
537 There seems to be running another CPAN process (pid $otherpid). Contacting...
539 if (kill 0, $otherpid) {
540 $CPAN::Frontend->mydie(qq{Other job is running.
541 You may want to kill it and delete the lockfile, maybe. On UNIX try:
545 } elsif (-w $lockfile) {
547 ExtUtils::MakeMaker::prompt
548 (qq{Other job not responding. Shall I overwrite }.
549 qq{the lockfile? (Y/N)},"y");
550 $CPAN::Frontend->myexit("Ok, bye\n")
551 unless $ans =~ /^y/i;
554 qq{Lockfile $lockfile not writeable by you. }.
555 qq{Cannot proceed.\n}.
558 qq{ and then rerun us.\n}
562 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
563 "reports other process with ID ".
564 "$otherpid. Cannot proceed.\n"));
567 my $dotcpan = $CPAN::Config->{cpan_home};
568 eval { File::Path::mkpath($dotcpan);};
570 # A special case at least for Jarkko.
575 $symlinkcpan = readlink $dotcpan;
576 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
577 eval { File::Path::mkpath($symlinkcpan); };
581 $CPAN::Frontend->mywarn(qq{
582 Working directory $symlinkcpan created.
586 unless (-d $dotcpan) {
588 Your configuration suggests "$dotcpan" as your
589 CPAN.pm working directory. I could not create this directory due
590 to this error: $firsterror\n};
592 As "$dotcpan" is a symlink to "$symlinkcpan",
593 I tried to create that, but I failed with this error: $seconderror
596 Please make sure the directory exists and is writable.
598 $CPAN::Frontend->mydie($diemess);
602 unless ($fh = FileHandle->new(">$lockfile")) {
603 if ($! =~ /Permission/) {
604 my $incc = $INC{'CPAN/Config.pm'};
605 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
606 $CPAN::Frontend->myprint(qq{
608 Your configuration suggests that CPAN.pm should use a working
610 $CPAN::Config->{cpan_home}
611 Unfortunately we could not create the lock file
613 due to permission problems.
615 Please make sure that the configuration variable
616 \$CPAN::Config->{cpan_home}
617 points to a directory where you can write a .lock file. You can set
618 this variable in either
625 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
627 $fh->print($$, "\n");
628 $fh->print(hostname(), "\n");
629 $self->{LOCK} = $lockfile;
633 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
638 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
639 print "Caught SIGINT\n";
643 # From: Larry Wall <larry@wall.org>
644 # Subject: Re: deprecating SIGDIE
645 # To: perl5-porters@perl.org
646 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
648 # The original intent of __DIE__ was only to allow you to substitute one
649 # kind of death for another on an application-wide basis without respect
650 # to whether you were in an eval or not. As a global backstop, it should
651 # not be used any more lightly (or any more heavily :-) than class
652 # UNIVERSAL. Any attempt to build a general exception model on it should
653 # be politely squashed. Any bug that causes every eval {} to have to be
654 # modified should be not so politely squashed.
656 # Those are my current opinions. It is also my optinion that polite
657 # arguments degenerate to personal arguments far too frequently, and that
658 # when they do, it's because both people wanted it to, or at least didn't
659 # sufficiently want it not to.
663 # global backstop to cleanup if we should really die
664 $SIG{__DIE__} = \&cleanup;
665 $self->debug("Signal handler set.") if $CPAN::DEBUG;
668 #-> sub CPAN::DESTROY ;
670 &cleanup; # need an eval?
673 #-> sub CPAN::anycwd ;
676 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
681 sub cwd {Cwd::cwd();}
683 #-> sub CPAN::getcwd ;
684 sub getcwd {Cwd::getcwd();}
686 #-> sub CPAN::find_perl ;
688 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
689 my $pwd = $CPAN::iCwd = CPAN::anycwd();
690 my $candidate = File::Spec->catfile($pwd,$^X);
691 $perl ||= $candidate if MM->maybe_command($candidate);
694 my ($component,$perl_name);
695 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
696 PATH_COMPONENT: foreach $component (File::Spec->path(),
697 $Config::Config{'binexp'}) {
698 next unless defined($component) && $component;
699 my($abs) = File::Spec->catfile($component,$perl_name);
700 if (MM->maybe_command($abs)) {
712 #-> sub CPAN::exists ;
714 my($mgr,$class,$id) = @_;
715 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
717 ### Carp::croak "exists called without class argument" unless $class;
719 $id =~ s/:+/::/g if $class eq "CPAN::Module";
720 exists $META->{readonly}{$class}{$id} or
721 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
724 #-> sub CPAN::delete ;
726 my($mgr,$class,$id) = @_;
727 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
728 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
731 #-> sub CPAN::has_usable
732 # has_inst is sometimes too optimistic, we should replace it with this
733 # has_usable whenever a case is given
735 my($self,$mod,$message) = @_;
736 return 1 if $HAS_USABLE->{$mod};
737 my $has_inst = $self->has_inst($mod,$message);
738 return unless $has_inst;
741 LWP => [ # we frequently had "Can't locate object
742 # method "new" via package "LWP::UserAgent" at
743 # (eval 69) line 2006
745 sub {require LWP::UserAgent},
746 sub {require HTTP::Request},
747 sub {require URI::URL},
750 sub {require Net::FTP},
751 sub {require Net::Config},
754 if ($usable->{$mod}) {
755 for my $c (0..$#{$usable->{$mod}}) {
756 my $code = $usable->{$mod}[$c];
757 my $ret = eval { &$code() };
759 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
764 return $HAS_USABLE->{$mod} = 1;
767 #-> sub CPAN::has_inst
769 my($self,$mod,$message) = @_;
770 Carp::croak("CPAN->has_inst() called without an argument")
772 if (defined $message && $message eq "no"
774 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
776 exists $CPAN::Config->{dontload_hash}{$mod}
778 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
786 # checking %INC is wrong, because $INC{LWP} may be true
787 # although $INC{"URI/URL.pm"} may have failed. But as
788 # I really want to say "bla loaded OK", I have to somehow
790 ### warn "$file in %INC"; #debug
792 } elsif (eval { require $file }) {
793 # eval is good: if we haven't yet read the database it's
794 # perfect and if we have installed the module in the meantime,
795 # it tries again. The second require is only a NOOP returning
796 # 1 if we had success, otherwise it's retrying
798 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
799 if ($mod eq "CPAN::WAIT") {
800 push @CPAN::Shell::ISA, 'CPAN::WAIT';
803 } elsif ($mod eq "Net::FTP") {
804 $CPAN::Frontend->mywarn(qq{
805 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
807 install Bundle::libnet
809 }) unless $Have_warned->{"Net::FTP"}++;
811 } elsif ($mod eq "Digest::SHA"){
812 $CPAN::Frontend->myprint(qq{
813 CPAN: checksum security checks disabled because Digest::SHA not installed.
814 Please consider installing the Digest::SHA module.
818 } elsif ($mod eq "Module::Signature"){
819 unless ($Have_warned->{"Module::Signature"}++) {
820 # No point in complaining unless the user can
821 # reasonably install and use it.
822 if (eval { require Crypt::OpenPGP; 1 } ||
823 defined $CPAN::Config->{'gpg'}) {
824 $CPAN::Frontend->myprint(qq{
825 CPAN: Module::Signature security checks disabled because Module::Signature
826 not installed. Please consider installing the Module::Signature module.
827 You may also need to be able to connect over the Internet to the public
828 keyservers like pgp.mit.edu (port 11371).
835 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
840 #-> sub CPAN::instance ;
842 my($mgr,$class,$id) = @_;
845 # unsafe meta access, ok?
846 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
847 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
855 #-> sub CPAN::cleanup ;
857 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
858 local $SIG{__DIE__} = '';
863 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
865 $subroutine eq '(eval)';
867 return if $ineval && !$CPAN::End;
868 return unless defined $META->{LOCK};
869 return unless -f $META->{LOCK};
871 unlink $META->{LOCK};
873 # Carp::cluck("DEBUGGING");
874 $CPAN::Frontend->mywarn("Lockfile removed.\n");
877 #-> sub CPAN::savehist
880 my($histfile,$histsize);
881 unless ($histfile = $CPAN::Config->{'histfile'}){
882 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
885 $histsize = $CPAN::Config->{'histsize'} || 100;
887 unless ($CPAN::term->can("GetHistory")) {
888 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
894 my @h = $CPAN::term->GetHistory;
895 splice @h, 0, @h-$histsize if @h>$histsize;
896 my($fh) = FileHandle->new;
897 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
898 local $\ = local $, = "\n";
904 my($self,$what) = @_;
905 $self->{is_tested}{$what} = 1;
909 my($self,$what) = @_;
910 delete $self->{is_tested}{$what};
915 $self->{is_tested} ||= {};
916 return unless %{$self->{is_tested}};
917 my $env = $ENV{PERL5LIB};
918 $env = $ENV{PERLLIB} unless defined $env;
920 push @env, $env if defined $env and length $env;
921 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
922 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
923 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
926 package CPAN::CacheMgr;
929 #-> sub CPAN::CacheMgr::as_string ;
931 eval { require Data::Dumper };
933 return shift->SUPER::as_string;
935 return Data::Dumper::Dumper(shift);
939 #-> sub CPAN::CacheMgr::cachesize ;
944 #-> sub CPAN::CacheMgr::tidyup ;
947 return unless -d $self->{ID};
948 while ($self->{DU} > $self->{'MAX'} ) {
949 my($toremove) = shift @{$self->{FIFO}};
950 $CPAN::Frontend->myprint(sprintf(
951 "Deleting from cache".
952 ": $toremove (%.1f>%.1f MB)\n",
953 $self->{DU}, $self->{'MAX'})
955 return if $CPAN::Signal;
956 $self->force_clean_cache($toremove);
957 return if $CPAN::Signal;
961 #-> sub CPAN::CacheMgr::dir ;
966 #-> sub CPAN::CacheMgr::entries ;
969 return unless defined $dir;
970 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
971 $dir ||= $self->{ID};
972 my($cwd) = CPAN::anycwd();
973 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
974 my $dh = DirHandle->new(File::Spec->curdir)
975 or Carp::croak("Couldn't opendir $dir: $!");
978 next if $_ eq "." || $_ eq "..";
980 push @entries, File::Spec->catfile($dir,$_);
982 push @entries, File::Spec->catdir($dir,$_);
984 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
987 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
988 sort { -M $b <=> -M $a} @entries;
991 #-> sub CPAN::CacheMgr::disk_usage ;
994 return if exists $self->{SIZE}{$dir};
995 return if $CPAN::Signal;
998 unless (chmod 0755, $dir) {
999 $CPAN::Frontend->mywarn("I have neither the -x permission nor the permission ".
1000 "to change the permission; cannot estimate disk usage ".
1008 $File::Find::prune++ if $CPAN::Signal;
1010 if ($^O eq 'MacOS') {
1012 my $cat = Mac::Files::FSpGetCatInfo($_);
1013 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1017 unless (chmod 0755, $_) {
1018 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1019 "the permission to change the permission; ".
1020 "can only partially estimate disk usage ".
1033 return if $CPAN::Signal;
1034 $self->{SIZE}{$dir} = $Du/1024/1024;
1035 push @{$self->{FIFO}}, $dir;
1036 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1037 $self->{DU} += $Du/1024/1024;
1041 #-> sub CPAN::CacheMgr::force_clean_cache ;
1042 sub force_clean_cache {
1043 my($self,$dir) = @_;
1044 return unless -e $dir;
1045 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1047 File::Path::rmtree($dir);
1048 $self->{DU} -= $self->{SIZE}{$dir};
1049 delete $self->{SIZE}{$dir};
1052 #-> sub CPAN::CacheMgr::new ;
1059 ID => $CPAN::Config->{'build_dir'},
1060 MAX => $CPAN::Config->{'build_cache'},
1061 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1064 File::Path::mkpath($self->{ID});
1065 my $dh = DirHandle->new($self->{ID});
1066 bless $self, $class;
1069 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1071 CPAN->debug($debug) if $CPAN::DEBUG;
1075 #-> sub CPAN::CacheMgr::scan_cache ;
1078 return if $self->{SCAN} eq 'never';
1079 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1080 unless $self->{SCAN} eq 'atstart';
1081 $CPAN::Frontend->myprint(
1082 sprintf("Scanning cache %s for sizes\n",
1085 for $e ($self->entries($self->{ID})) {
1086 next if $e eq ".." || $e eq ".";
1087 $self->disk_usage($e);
1088 return if $CPAN::Signal;
1093 package CPAN::Shell;
1096 #-> sub CPAN::Shell::h ;
1098 my($class,$about) = @_;
1099 if (defined $about) {
1100 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1102 $CPAN::Frontend->myprint(q{
1104 command argument description
1105 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1106 i WORD or /REGEXP/ about any of the above
1107 r NONE report updatable modules
1108 ls AUTHOR or GLOB about files in the author's directory
1109 (with WORD being a module, bundle or author name or a distribution
1110 name of the form AUTHOR/DISTRIBUTION)
1112 Download, Test, Make, Install...
1113 get download clean make clean
1114 make make (implies get) look open subshell in dist directory
1115 test make test (implies make) readme display these README files
1116 install make install (implies test) perldoc display POD documentation
1119 force COMMAND unconditionally do command
1120 notest COMMAND skip testing
1123 h,? display this menu ! perl-code eval a perl command
1124 o conf [opt] set and query options q quit the cpan shell
1125 reload cpan load CPAN.pm again reload index load newer indices
1126 autobundle Snapshot recent latest CPAN uploads});
1132 #-> sub CPAN::Shell::a ;
1134 my($self,@arg) = @_;
1135 # authors are always UPPERCASE
1137 $_ = uc $_ unless /=/;
1139 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1143 my($self,$pragma,$s) = @_;
1144 # ls is really very different, but we had it once as an ordinary
1145 # command in the Shell (upto rev. 321) and we could not handle
1147 my(@accept,@preexpand);
1148 if ($s =~ /[\*\?\/]/) {
1149 if ($CPAN::META->has_inst("Text::Glob")) {
1150 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1151 my $rau = Text::Glob::glob_to_regex(uc $au);
1152 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1154 push @preexpand, map { $_->id . "/" . $pathglob }
1155 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1157 my $rau = Text::Glob::glob_to_regex(uc $s);
1158 push @preexpand, map { $_->id }
1159 CPAN::Shell->expand_by_method('CPAN::Author',
1164 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1167 push @preexpand, uc $s;
1170 unless (/^[A-Z0-9\-]+(\/|$)/i) {
1171 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1176 my $silent = @accept>1;
1177 my $last_alpha = "";
1178 for my $a (@accept){
1179 my($author,$pathglob);
1180 if ($a =~ m|(.*?)/(.*)|) {
1183 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1185 $a2) or die "No author found for $a2";
1187 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1189 $a) or die "No author found for $a";
1192 my $alpha = substr $author->id, 0, 1;
1194 if ($alpha eq $last_alpha) {
1198 $last_alpha = $alpha;
1200 $CPAN::Frontend->myprint($ad);
1202 $author->ls($pathglob,$silent); # silent if more than one author
1206 #-> sub CPAN::Shell::local_bundles ;
1208 my($self,@which) = @_;
1209 my($incdir,$bdir,$dh);
1210 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1211 my @bbase = "Bundle";
1212 while (my $bbase = shift @bbase) {
1213 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1214 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1215 if ($dh = DirHandle->new($bdir)) { # may fail
1217 for $entry ($dh->read) {
1218 next if $entry =~ /^\./;
1219 if (-d File::Spec->catdir($bdir,$entry)){
1220 push @bbase, "$bbase\::$entry";
1222 next unless $entry =~ s/\.pm(?!\n)\Z//;
1223 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1231 #-> sub CPAN::Shell::b ;
1233 my($self,@which) = @_;
1234 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1235 $self->local_bundles;
1236 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1239 #-> sub CPAN::Shell::d ;
1240 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1242 #-> sub CPAN::Shell::m ;
1243 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1245 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1248 #-> sub CPAN::Shell::i ;
1252 @args = '/./' unless @args;
1254 for my $type (qw/Bundle Distribution Module/) {
1255 push @result, $self->expand($type,@args);
1257 # Authors are always uppercase.
1258 push @result, $self->expand("Author", map { uc $_ } @args);
1260 my $result = @result == 1 ?
1261 $result[0]->as_string :
1263 "No objects found of any type for argument @args\n" :
1265 (map {$_->as_glimpse} @result),
1266 scalar @result, " items found\n",
1268 $CPAN::Frontend->myprint($result);
1271 #-> sub CPAN::Shell::o ;
1273 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1274 # should have been called set and 'o debug' maybe 'set debug'
1276 my($self,$o_type,@o_what) = @_;
1278 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1279 if ($o_type eq 'conf') {
1280 shift @o_what if @o_what && $o_what[0] eq 'help';
1281 if (!@o_what) { # print all things, "o conf"
1283 $CPAN::Frontend->myprint("CPAN::Config options");
1284 if (exists $INC{'CPAN/Config.pm'}) {
1285 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1287 if (exists $INC{'CPAN/MyConfig.pm'}) {
1288 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1290 $CPAN::Frontend->myprint(":\n");
1291 for $k (sort keys %CPAN::HandleConfig::can) {
1292 $v = $CPAN::HandleConfig::can{$k};
1293 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1295 $CPAN::Frontend->myprint("\n");
1296 for $k (sort keys %$CPAN::Config) {
1297 CPAN::HandleConfig->prettyprint($k);
1299 $CPAN::Frontend->myprint("\n");
1300 } elsif (!CPAN::HandleConfig->edit(@o_what)) {
1301 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1304 } elsif ($o_type eq 'debug') {
1306 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1309 my($what) = shift @o_what;
1310 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1311 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1314 if ( exists $CPAN::DEBUG{$what} ) {
1315 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1316 } elsif ($what =~ /^\d/) {
1317 $CPAN::DEBUG = $what;
1318 } elsif (lc $what eq 'all') {
1320 for (values %CPAN::DEBUG) {
1323 $CPAN::DEBUG = $max;
1326 for (keys %CPAN::DEBUG) {
1327 next unless lc($_) eq lc($what);
1328 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1331 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1336 my $raw = "Valid options for debug are ".
1337 join(", ",sort(keys %CPAN::DEBUG), 'all').
1338 qq{ or a number. Completion works on the options. }.
1339 qq{Case is ignored.};
1341 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1342 $CPAN::Frontend->myprint("\n\n");
1345 $CPAN::Frontend->myprint("Options set for debugging:\n");
1347 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1348 $v = $CPAN::DEBUG{$k};
1349 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1350 if $v & $CPAN::DEBUG;
1353 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1356 $CPAN::Frontend->myprint(qq{
1358 conf set or get configuration variables
1359 debug set or get debugging options
1364 sub paintdots_onreload {
1367 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1371 # $CPAN::Frontend->myprint(".($subr)");
1372 $CPAN::Frontend->myprint(".");
1379 #-> sub CPAN::Shell::reload ;
1381 my($self,$command,@arg) = @_;
1383 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1384 if ($command =~ /cpan/i) {
1386 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1388 MFILE: for my $f (qw(CPAN.pm CPAN/HandleConfig.pm CPAN/FirstTime.pm CPAN/Tarzip.pm
1389 CPAN/Debug.pm CPAN/Version.pm)) {
1390 next unless $INC{$f};
1391 my $pwd = CPAN::anycwd();
1392 CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
1395 for my $inc (@INC) {
1396 $read = File::Spec->catfile($inc,split /\//, $f);
1401 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1404 my $fh = FileHandle->new($read) or
1405 $CPAN::Frontend->mydie("Could not open $read: $!");
1408 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1410 CPAN->debug(sprintf("evaling [%s...]\n",substr($eval,0,64)))
1418 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1419 $failed++ unless $redef;
1421 $CPAN::Frontend->mywarn("\n$failed errors during reload. You better quit ".
1424 } elsif ($command =~ /index/) {
1425 CPAN::Index->force_reload;
1427 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1428 index re-reads the index files\n});
1432 #-> sub CPAN::Shell::_binary_extensions ;
1433 sub _binary_extensions {
1434 my($self) = shift @_;
1435 my(@result,$module,%seen,%need,$headerdone);
1436 for $module ($self->expand('Module','/./')) {
1437 my $file = $module->cpan_file;
1438 next if $file eq "N/A";
1439 next if $file =~ /^Contact Author/;
1440 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1441 next if $dist->isa_perl;
1442 next unless $module->xs_file;
1444 $CPAN::Frontend->myprint(".");
1445 push @result, $module;
1447 # print join " | ", @result;
1448 $CPAN::Frontend->myprint("\n");
1452 #-> sub CPAN::Shell::recompile ;
1454 my($self) = shift @_;
1455 my($module,@module,$cpan_file,%dist);
1456 @module = $self->_binary_extensions();
1457 for $module (@module){ # we force now and compile later, so we
1459 $cpan_file = $module->cpan_file;
1460 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1462 $dist{$cpan_file}++;
1464 for $cpan_file (sort keys %dist) {
1465 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1466 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1468 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1469 # stop a package from recompiling,
1470 # e.g. IO-1.12 when we have perl5.003_10
1474 #-> sub CPAN::Shell::_u_r_common ;
1476 my($self) = shift @_;
1477 my($what) = shift @_;
1478 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1479 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1480 $what && $what =~ /^[aru]$/;
1482 @args = '/./' unless @args;
1483 my(@result,$module,%seen,%need,$headerdone,
1484 $version_undefs,$version_zeroes);
1485 $version_undefs = $version_zeroes = 0;
1486 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1487 my @expand = $self->expand('Module',@args);
1488 my $expand = scalar @expand;
1489 if (0) { # Looks like noise to me, was very useful for debugging
1490 # for metadata cache
1491 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1493 MODULE: for $module (@expand) {
1494 my $file = $module->cpan_file;
1495 next MODULE unless defined $file; # ??
1496 $file =~ s|^./../||;
1497 my($latest) = $module->cpan_version;
1498 my($inst_file) = $module->inst_file;
1500 return if $CPAN::Signal;
1503 $have = $module->inst_version;
1504 } elsif ($what eq "r") {
1505 $have = $module->inst_version;
1507 if ($have eq "undef"){
1509 } elsif ($have == 0){
1512 next MODULE unless CPAN::Version->vgt($latest, $have);
1513 # to be pedantic we should probably say:
1514 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1515 # to catch the case where CPAN has a version 0 and we have a version undef
1516 } elsif ($what eq "u") {
1522 } elsif ($what eq "r") {
1524 } elsif ($what eq "u") {
1528 return if $CPAN::Signal; # this is sometimes lengthy
1531 push @result, sprintf "%s %s\n", $module->id, $have;
1532 } elsif ($what eq "r") {
1533 push @result, $module->id;
1534 next MODULE if $seen{$file}++;
1535 } elsif ($what eq "u") {
1536 push @result, $module->id;
1537 next MODULE if $seen{$file}++;
1538 next MODULE if $file =~ /^Contact/;
1540 unless ($headerdone++){
1541 $CPAN::Frontend->myprint("\n");
1542 $CPAN::Frontend->myprint(sprintf(
1545 "Package namespace",
1557 $CPAN::META->has_inst("Term::ANSIColor")
1559 $module->description
1561 $color_on = Term::ANSIColor::color("green");
1562 $color_off = Term::ANSIColor::color("reset");
1564 $CPAN::Frontend->myprint(sprintf $sprintf,
1571 $need{$module->id}++;
1575 $CPAN::Frontend->myprint("No modules found for @args\n");
1576 } elsif ($what eq "r") {
1577 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1581 if ($version_zeroes) {
1582 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1583 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1584 qq{a version number of 0\n});
1586 if ($version_undefs) {
1587 my $s_has = $version_undefs > 1 ? "s have" : " has";
1588 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1589 qq{parseable version number\n});
1595 #-> sub CPAN::Shell::r ;
1597 shift->_u_r_common("r",@_);
1600 #-> sub CPAN::Shell::u ;
1602 shift->_u_r_common("u",@_);
1605 # XXX intentionally undocumented because not considered enough
1606 #-> sub CPAN::Shell::failed ;
1610 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1612 for my $nosayer (qw(make make_test make_install)) {
1613 next unless exists $d->{$nosayer};
1614 next unless substr($d->{$nosayer},0,2) eq "NO";
1618 next DIST unless $failed;
1621 $print .= sprintf " %-45s: %s %s\n", $id, $failed, $d->{$failed};
1624 $CPAN::Frontend->myprint("Failed installations in this session:\n$print");
1626 $CPAN::Frontend->myprint("No installations failed in this session\n");
1630 # XXX intentionally undocumented because not considered enough
1631 #-> sub CPAN::Shell::status ;
1634 require Devel::Size;
1635 my $ps = FileHandle->new;
1636 open $ps, "/proc/$$/status";
1639 next unless /VmSize:\s+(\d+)/;
1643 $CPAN::Frontend->mywarn(sprintf(
1644 "%-27s %6d\n%-27s %6d\n",
1648 Devel::Size::total_size($CPAN::META)/1024,
1650 for my $k (sort keys %$CPAN::META) {
1651 next unless substr($k,0,4) eq "read";
1652 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
1653 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
1654 warn sprintf " %-25s %6d %6d\n",
1656 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
1657 scalar keys %{$CPAN::META->{$k}{$k2}};
1662 #-> sub CPAN::Shell::autobundle ;
1665 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1666 my(@bundle) = $self->_u_r_common("a",@_);
1667 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1668 File::Path::mkpath($todir);
1669 unless (-d $todir) {
1670 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1673 my($y,$m,$d) = (localtime)[5,4,3];
1677 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1678 my($to) = File::Spec->catfile($todir,"$me.pm");
1680 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1681 $to = File::Spec->catfile($todir,"$me.pm");
1683 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1685 "package Bundle::$me;\n\n",
1686 "\$VERSION = '0.01';\n\n",
1690 "Bundle::$me - Snapshot of installation on ",
1691 $Config::Config{'myhostname'},
1694 "\n\n=head1 SYNOPSIS\n\n",
1695 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1696 "=head1 CONTENTS\n\n",
1697 join("\n", @bundle),
1698 "\n\n=head1 CONFIGURATION\n\n",
1700 "\n\n=head1 AUTHOR\n\n",
1701 "This Bundle has been generated automatically ",
1702 "by the autobundle routine in CPAN.pm.\n",
1705 $CPAN::Frontend->myprint("\nWrote bundle file
1709 #-> sub CPAN::Shell::expandany ;
1712 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1713 if ($s =~ m|/|) { # looks like a file
1714 $s = CPAN::Distribution->normalize($s);
1715 return $CPAN::META->instance('CPAN::Distribution',$s);
1716 # Distributions spring into existence, not expand
1717 } elsif ($s =~ m|^Bundle::|) {
1718 $self->local_bundles; # scanning so late for bundles seems
1719 # both attractive and crumpy: always
1720 # current state but easy to forget
1722 return $self->expand('Bundle',$s);
1724 return $self->expand('Module',$s)
1725 if $CPAN::META->exists('CPAN::Module',$s);
1730 #-> sub CPAN::Shell::expand ;
1733 my($type,@args) = @_;
1734 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1735 my $class = "CPAN::$type";
1736 my $methods = ['id'];
1737 for my $meth (qw(name)) {
1738 next if $] < 5.00303; # no "can"
1739 next unless $class->can($meth);
1740 push @$methods, $meth;
1742 $self->expand_by_method($class,$methods,@args);
1745 sub expand_by_method {
1747 my($class,$methods,@args) = @_;
1750 my($regex,$command);
1751 if ($arg =~ m|^/(.*)/$|) {
1753 } elsif ($arg =~ m/=/) {
1757 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1759 defined $regex ? $regex : "UNDEFINED",
1760 defined $command ? $command : "UNDEFINED",
1762 if (defined $regex) {
1764 $CPAN::META->all_objects($class)
1767 # BUG, we got an empty object somewhere
1768 require Data::Dumper;
1769 CPAN->debug(sprintf(
1770 "Bug in CPAN: Empty id on obj[%s][%s]",
1772 Data::Dumper::Dumper($obj)
1776 for my $method (@$methods) {
1777 if ($obj->$method() =~ /$regex/i) {
1783 } elsif ($command) {
1784 die "equal sign in command disabled (immature interface), ".
1786 ! \$CPAN::Shell::ADVANCED_QUERY=1
1787 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1788 that may go away anytime.\n"
1789 unless $ADVANCED_QUERY;
1790 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1791 my($matchcrit) = $criterion =~ m/^~(.+)/;
1795 $CPAN::META->all_objects($class)
1797 my $lhs = $self->$method() or next; # () for 5.00503
1799 push @m, $self if $lhs =~ m/$matchcrit/;
1801 push @m, $self if $lhs eq $criterion;
1806 if ( $class eq 'CPAN::Bundle' ) {
1807 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1808 } elsif ($class eq "CPAN::Distribution") {
1809 $xarg = CPAN::Distribution->normalize($arg);
1813 if ($CPAN::META->exists($class,$xarg)) {
1814 $obj = $CPAN::META->instance($class,$xarg);
1815 } elsif ($CPAN::META->exists($class,$arg)) {
1816 $obj = $CPAN::META->instance($class,$arg);
1823 @m = sort {$a->id cmp $b->id} @m;
1824 if ( $CPAN::DEBUG ) {
1825 my $wantarray = wantarray;
1826 my $join_m = join ",", map {$_->id} @m;
1827 $self->debug("wantarray[$wantarray]join_m[$join_m]");
1829 return wantarray ? @m : $m[0];
1832 #-> sub CPAN::Shell::format_result ;
1835 my($type,@args) = @_;
1836 @args = '/./' unless @args;
1837 my(@result) = $self->expand($type,@args);
1838 my $result = @result == 1 ?
1839 $result[0]->as_string :
1841 "No objects of type $type found for argument @args\n" :
1843 (map {$_->as_glimpse} @result),
1844 scalar @result, " items found\n",
1849 #-> sub CPAN::Shell::report_fh ;
1851 my $installation_report_fh;
1852 my $previously_noticed = 0;
1855 return $installation_report_fh if $installation_report_fh;
1856 $installation_report_fh = File::Temp->new(
1857 template => 'cpan_install_XXXX',
1861 unless ( $installation_report_fh ) {
1862 warn("Couldn't open installation report file; " .
1863 "no report file will be generated."
1864 ) unless $previously_noticed++;
1870 # The only reason for this method is currently to have a reliable
1871 # debugging utility that reveals which output is going through which
1872 # channel. No, I don't like the colors ;-)
1874 #-> sub CPAN::Shell::print_ornameted ;
1875 sub print_ornamented {
1876 my($self,$what,$ornament) = @_;
1878 return unless defined $what;
1880 local $| = 1; # Flush immediately
1881 if ( $CPAN::Be_Silent ) {
1882 print {report_fh()} $what;
1886 if ($CPAN::Config->{term_is_latin}){
1889 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1891 if ($PRINT_ORNAMENTING) {
1892 unless (defined &color) {
1893 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1894 import Term::ANSIColor "color";
1896 *color = sub { return "" };
1900 for $line (split /\n/, $what) {
1901 $longest = length($line) if length($line) > $longest;
1903 my $sprintf = "%-" . $longest . "s";
1905 $what =~ s/(.*\n?)//m;
1908 my($nl) = chomp $line ? "\n" : "";
1909 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1910 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1914 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
1920 my($self,$what) = @_;
1922 $self->print_ornamented($what, 'bold blue on_yellow');
1926 my($self,$what) = @_;
1927 $self->myprint($what);
1932 my($self,$what) = @_;
1933 $self->print_ornamented($what, 'bold red on_yellow');
1937 my($self,$what) = @_;
1938 $self->print_ornamented($what, 'bold red on_white');
1939 Carp::confess "died";
1943 my($self,$what) = @_;
1944 $self->print_ornamented($what, 'bold red on_white');
1949 return if -t STDOUT;
1950 my $odef = select STDERR;
1957 #-> sub CPAN::Shell::rematein ;
1958 # RE-adme||MA-ke||TE-st||IN-stall
1961 my($meth,@some) = @_;
1963 while($meth =~ /^(force|notest)$/) {
1964 push @pragma, $meth;
1965 $meth = shift @some or
1966 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
1970 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
1972 # Here is the place to set "test_count" on all involved parties to
1973 # 0. We then can pass this counter on to the involved
1974 # distributions and those can refuse to test if test_count > X. In
1975 # the first stab at it we could use a 1 for "X".
1977 # But when do I reset the distributions to start with 0 again?
1978 # Jost suggested to have a random or cycling interaction ID that
1979 # we pass through. But the ID is something that is just left lying
1980 # around in addition to the counter, so I'd prefer to set the
1981 # counter to 0 now, and repeat at the end of the loop. But what
1982 # about dependencies? They appear later and are not reset, they
1983 # enter the queue but not its copy. How do they get a sensible
1986 # construct the queue
1988 STHING: foreach $s (@some) {
1991 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
1993 } elsif ($s =~ m|^/|) { # looks like a regexp
1994 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
1998 } elsif ($meth eq "ls") {
1999 $self->handle_ls(\@pragma,$s);
2002 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2003 $obj = CPAN::Shell->expandany($s);
2006 $obj->color_cmd_tmps(0,1);
2007 CPAN::Queue->new($obj->id);
2009 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2010 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2011 if ($meth =~ /^(dump|ls)$/) {
2014 $CPAN::Frontend->myprint(
2016 "Don't be silly, you can't $meth ",
2024 ->myprint(qq{Warning: Cannot $meth $s, }.
2025 qq{don\'t know what it is.
2030 to find objects with matching identifiers.
2036 # queuerunner (please be warned: when I started to change the
2037 # queue to hold objects instead of names, I made one or two
2038 # mistakes and never found which. I reverted back instead)
2039 while ($s = CPAN::Queue->first) {
2042 $obj = $s; # I do not believe, we would survive if this happened
2044 $obj = CPAN::Shell->expandany($s);
2046 for my $pragma (@pragma) {
2049 ($] < 5.00303 || $obj->can($pragma))){
2050 ### compatibility with 5.003
2051 $obj->$pragma($meth); # the pragma "force" in
2052 # "CPAN::Distribution" must know
2053 # what we are intending
2056 if ($]>=5.00303 && $obj->can('called_for')) {
2057 $obj->called_for($s);
2060 qq{pragma[@pragma]meth[$meth]obj[$obj]as_string\[}.
2066 CPAN::Queue->delete($s);
2068 CPAN->debug("failed");
2072 CPAN::Queue->delete_first($s);
2074 for my $obj (@qcopy) {
2075 $obj->color_cmd_tmps(0,0);
2076 delete $obj->{incommandcolor};
2080 #-> sub CPAN::Shell::recent ;
2084 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2089 # set up the dispatching methods
2091 for my $command (qw(
2106 *$command = sub { shift->rematein($command, @_); };
2110 package CPAN::LWP::UserAgent;
2114 return if $SETUPDONE;
2115 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2116 require LWP::UserAgent;
2117 @ISA = qw(Exporter LWP::UserAgent);
2120 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2124 sub get_basic_credentials {
2125 my($self, $realm, $uri, $proxy) = @_;
2126 return unless $proxy;
2127 if ($USER && $PASSWD) {
2128 } elsif (defined $CPAN::Config->{proxy_user} &&
2129 defined $CPAN::Config->{proxy_pass}) {
2130 $USER = $CPAN::Config->{proxy_user};
2131 $PASSWD = $CPAN::Config->{proxy_pass};
2133 require ExtUtils::MakeMaker;
2134 ExtUtils::MakeMaker->import(qw(prompt));
2135 $USER = prompt("Proxy authentication needed!
2136 (Note: to permanently configure username and password run
2137 o conf proxy_user your_username
2138 o conf proxy_pass your_password
2140 if ($CPAN::META->has_inst("Term::ReadKey")) {
2141 Term::ReadKey::ReadMode("noecho");
2143 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2145 $PASSWD = prompt("Password:");
2146 if ($CPAN::META->has_inst("Term::ReadKey")) {
2147 Term::ReadKey::ReadMode("restore");
2149 $CPAN::Frontend->myprint("\n\n");
2151 return($USER,$PASSWD);
2154 # mirror(): Its purpose is to deal with proxy authentication. When we
2155 # call SUPER::mirror, we relly call the mirror method in
2156 # LWP::UserAgent. LWP::UserAgent will then call
2157 # $self->get_basic_credentials or some equivalent and this will be
2158 # $self->dispatched to our own get_basic_credentials method.
2160 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2162 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2163 # although we have gone through our get_basic_credentials, the proxy
2164 # server refuses to connect. This could be a case where the username or
2165 # password has changed in the meantime, so I'm trying once again without
2166 # $USER and $PASSWD to give the get_basic_credentials routine another
2167 # chance to set $USER and $PASSWD.
2169 # mirror(): Its purpose is to deal with proxy authentication. When we
2170 # call SUPER::mirror, we relly call the mirror method in
2171 # LWP::UserAgent. LWP::UserAgent will then call
2172 # $self->get_basic_credentials or some equivalent and this will be
2173 # $self->dispatched to our own get_basic_credentials method.
2175 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2177 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2178 # although we have gone through our get_basic_credentials, the proxy
2179 # server refuses to connect. This could be a case where the username or
2180 # password has changed in the meantime, so I'm trying once again without
2181 # $USER and $PASSWD to give the get_basic_credentials routine another
2182 # chance to set $USER and $PASSWD.
2185 my($self,$url,$aslocal) = @_;
2186 my $result = $self->SUPER::mirror($url,$aslocal);
2187 if ($result->code == 407) {
2190 $result = $self->SUPER::mirror($url,$aslocal);
2198 #-> sub CPAN::FTP::ftp_get ;
2200 my($class,$host,$dir,$file,$target) = @_;
2202 qq[Going to fetch file [$file] from dir [$dir]
2203 on host [$host] as local [$target]\n]
2205 my $ftp = Net::FTP->new($host);
2206 return 0 unless defined $ftp;
2207 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2208 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2209 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2210 warn "Couldn't login on $host";
2213 unless ( $ftp->cwd($dir) ){
2214 warn "Couldn't cwd $dir";
2218 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2219 unless ( $ftp->get($file,$target) ){
2220 warn "Couldn't fetch $file from $host\n";
2223 $ftp->quit; # it's ok if this fails
2227 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2229 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2230 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2232 # > *** 1562,1567 ****
2233 # > --- 1562,1580 ----
2234 # > return 1 if substr($url,0,4) eq "file";
2235 # > return 1 unless $url =~ m|://([^/]+)|;
2237 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2239 # > + $proxy =~ m|://([^/:]+)|;
2241 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2242 # > + if ($noproxy) {
2243 # > + if ($host !~ /$noproxy$/) {
2244 # > + $host = $proxy;
2247 # > + $host = $proxy;
2250 # > require Net::Ping;
2251 # > return 1 unless $Net::Ping::VERSION >= 2;
2255 #-> sub CPAN::FTP::localize ;
2257 my($self,$file,$aslocal,$force) = @_;
2259 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2260 unless defined $aslocal;
2261 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2264 if ($^O eq 'MacOS') {
2265 # Comment by AK on 2000-09-03: Uniq short filenames would be
2266 # available in CHECKSUMS file
2267 my($name, $path) = File::Basename::fileparse($aslocal, '');
2268 if (length($name) > 31) {
2279 my $size = 31 - length($suf);
2280 while (length($name) > $size) {
2284 $aslocal = File::Spec->catfile($path, $name);
2288 if (-f $aslocal && -r _ && !($force & 1)){
2292 # empty file from a previous unsuccessful attempt to download it
2294 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I could not remove.");
2299 rename $aslocal, "$aslocal.bak";
2303 my($aslocal_dir) = File::Basename::dirname($aslocal);
2304 File::Path::mkpath($aslocal_dir);
2305 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2306 qq{directory "$aslocal_dir".
2307 I\'ll continue, but if you encounter problems, they may be due
2308 to insufficient permissions.\n}) unless -w $aslocal_dir;
2310 # Inheritance is not easier to manage than a few if/else branches
2311 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2313 CPAN::LWP::UserAgent->config;
2314 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2316 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2320 $Ua->proxy('ftp', $var)
2321 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2322 $Ua->proxy('http', $var)
2323 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2326 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2328 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2329 # > use ones that require basic autorization.
2331 # > Example of when I use it manually in my own stuff:
2333 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2334 # > $req->proxy_authorization_basic("username","password");
2335 # > $res = $ua->request($req);
2339 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2343 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2344 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2347 # Try the list of urls for each single object. We keep a record
2348 # where we did get a file from
2349 my(@reordered,$last);
2350 $CPAN::Config->{urllist} ||= [];
2351 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2352 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2354 $last = $#{$CPAN::Config->{urllist}};
2355 if ($force & 2) { # local cpans probably out of date, don't reorder
2356 @reordered = (0..$last);
2360 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2362 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2373 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2375 @levels = qw/easy hard hardest/;
2377 @levels = qw/easy/ if $^O eq 'MacOS';
2379 for $levelno (0..$#levels) {
2380 my $level = $levels[$levelno];
2381 my $method = "host$level";
2382 my @host_seq = $level eq "easy" ?
2383 @reordered : 0..$last; # reordered has CDROM up front
2384 @host_seq = (0) unless @host_seq;
2385 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2387 $Themethod = $level;
2389 # utime $now, $now, $aslocal; # too bad, if we do that, we
2390 # might alter a local mirror
2391 $self->debug("level[$level]") if $CPAN::DEBUG;
2395 last if $CPAN::Signal; # need to cleanup
2398 unless ($CPAN::Signal) {
2401 qq{Please check, if the URLs I found in your configuration file \(}.
2402 join(", ", @{$CPAN::Config->{urllist}}).
2403 qq{\) are valid. The urllist can be edited.},
2404 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2405 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2407 $CPAN::Frontend->myprint("Could not fetch $file\n");
2410 rename "$aslocal.bak", $aslocal;
2411 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2412 $self->ls($aslocal));
2419 my($self,$host_seq,$file,$aslocal) = @_;
2421 HOSTEASY: for $i (@$host_seq) {
2422 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2423 $url .= "/" unless substr($url,-1) eq "/";
2425 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2426 if ($url =~ /^file:/) {
2428 if ($CPAN::META->has_inst('URI::URL')) {
2429 my $u = URI::URL->new($url);
2431 } else { # works only on Unix, is poorly constructed, but
2432 # hopefully better than nothing.
2433 # RFC 1738 says fileurl BNF is
2434 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2435 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2437 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2438 $l =~ s|^file:||; # assume they
2441 $l =~ s|^/||s unless -f $l; # e.g. /P:
2442 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2444 if ( -f $l && -r _) {
2448 # Maybe mirror has compressed it?
2450 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2451 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
2458 if ($CPAN::META->has_usable('LWP')) {
2459 $CPAN::Frontend->myprint("Fetching with LWP:
2463 CPAN::LWP::UserAgent->config;
2464 eval { $Ua = CPAN::LWP::UserAgent->new; };
2466 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2469 my $res = $Ua->mirror($url, $aslocal);
2470 if ($res->is_success) {
2473 utime $now, $now, $aslocal; # download time is more
2474 # important than upload time
2476 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2477 my $gzurl = "$url.gz";
2478 $CPAN::Frontend->myprint("Fetching with LWP:
2481 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2482 if ($res->is_success &&
2483 CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
2489 $CPAN::Frontend->myprint(sprintf(
2490 "LWP failed with code[%s] message[%s]\n",
2494 # Alan Burlison informed me that in firewall environments
2495 # Net::FTP can still succeed where LWP fails. So we do not
2496 # skip Net::FTP anymore when LWP is available.
2499 $CPAN::Frontend->myprint("LWP not available\n");
2501 return if $CPAN::Signal;
2502 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2503 # that's the nice and easy way thanks to Graham
2504 my($host,$dir,$getfile) = ($1,$2,$3);
2505 if ($CPAN::META->has_usable('Net::FTP')) {
2507 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2510 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2511 "aslocal[$aslocal]") if $CPAN::DEBUG;
2512 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2516 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2517 my $gz = "$aslocal.gz";
2518 $CPAN::Frontend->myprint("Fetching with Net::FTP
2521 if (CPAN::FTP->ftp_get($host,
2525 CPAN::Tarzip->new($gz)->gunzip($aslocal)
2534 return if $CPAN::Signal;
2539 my($self,$host_seq,$file,$aslocal) = @_;
2541 # Came back if Net::FTP couldn't establish connection (or
2542 # failed otherwise) Maybe they are behind a firewall, but they
2543 # gave us a socksified (or other) ftp program...
2546 my($devnull) = $CPAN::Config->{devnull} || "";
2548 my($aslocal_dir) = File::Basename::dirname($aslocal);
2549 File::Path::mkpath($aslocal_dir);
2550 HOSTHARD: for $i (@$host_seq) {
2551 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2552 $url .= "/" unless substr($url,-1) eq "/";
2554 my($proto,$host,$dir,$getfile);
2556 # Courtesy Mark Conty mark_conty@cargill.com change from
2557 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2559 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2560 # proto not yet used
2561 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2563 next HOSTHARD; # who said, we could ftp anything except ftp?
2565 next HOSTHARD if $proto eq "file"; # file URLs would have had
2566 # success above. Likely a bogus URL
2568 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2570 # Try the most capable first and leave ncftp* for last as it only
2572 for my $f (qw(curl wget lynx ncftpget ncftp)) {
2573 my $funkyftp = $CPAN::Config->{$f};
2574 next unless defined $funkyftp;
2575 next if $funkyftp =~ /^\s*$/;
2577 my($asl_ungz, $asl_gz);
2578 ($asl_ungz = $aslocal) =~ s/\.gz//;
2579 $asl_gz = "$asl_ungz.gz";
2581 my($src_switch) = "";
2583 my($stdout_redir) = " > $asl_ungz";
2585 $src_switch = " -source";
2586 } elsif ($f eq "ncftp"){
2587 $src_switch = " -c";
2588 } elsif ($f eq "wget"){
2589 $src_switch = " -O $asl_ungz";
2591 } elsif ($f eq 'curl'){
2592 $src_switch = ' -L';
2595 if ($f eq "ncftpget"){
2596 $chdir = "cd $aslocal_dir && ";
2599 $CPAN::Frontend->myprint(
2601 Trying with "$funkyftp$src_switch" to get
2605 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2606 $self->debug("system[$system]") if $CPAN::DEBUG;
2608 if (($wstatus = system($system)) == 0
2611 -s $asl_ungz # lynx returns 0 when it fails somewhere
2617 } elsif ($asl_ungz ne $aslocal) {
2618 # test gzip integrity
2619 if (CPAN::Tarzip->new($asl_ungz)->gtest) {
2620 # e.g. foo.tar is gzipped --> foo.tar.gz
2621 rename $asl_ungz, $aslocal;
2623 CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
2628 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2630 -f $asl_ungz && -s _ == 0;
2631 my $gz = "$aslocal.gz";
2632 my $gzurl = "$url.gz";
2633 $CPAN::Frontend->myprint(
2635 Trying with "$funkyftp$src_switch" to get
2638 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2639 $self->debug("system[$system]") if $CPAN::DEBUG;
2641 if (($wstatus = system($system)) == 0
2645 # test gzip integrity
2646 my $ct = CPAN::Tarzip->new($asl_gz);
2648 $ct->gunzip($aslocal);
2650 # somebody uncompressed file for us?
2651 rename $asl_ungz, $aslocal;
2656 unlink $asl_gz if -f $asl_gz;
2659 my $estatus = $wstatus >> 8;
2660 my $size = -f $aslocal ?
2661 ", left\n$aslocal with size ".-s _ :
2662 "\nWarning: expected file [$aslocal] doesn't exist";
2663 $CPAN::Frontend->myprint(qq{
2664 System call "$system"
2665 returned status $estatus (wstat $wstatus)$size
2668 return if $CPAN::Signal;
2669 } # transfer programs
2674 my($self,$host_seq,$file,$aslocal) = @_;
2677 my($aslocal_dir) = File::Basename::dirname($aslocal);
2678 File::Path::mkpath($aslocal_dir);
2679 my $ftpbin = $CPAN::Config->{ftp};
2680 HOSTHARDEST: for $i (@$host_seq) {
2681 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2682 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2685 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2686 $url .= "/" unless substr($url,-1) eq "/";
2688 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2689 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2692 my($host,$dir,$getfile) = ($1,$2,$3);
2694 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2695 $ctime,$blksize,$blocks) = stat($aslocal);
2696 $timestamp = $mtime ||= 0;
2697 my($netrc) = CPAN::FTP::netrc->new;
2698 my($netrcfile) = $netrc->netrc;
2699 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2700 my $targetfile = File::Basename::basename($aslocal);
2706 map("cd $_", split /\//, $dir), # RFC 1738
2708 "get $getfile $targetfile",
2712 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2713 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2714 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2716 $netrc->contains($host))) if $CPAN::DEBUG;
2717 if ($netrc->protected) {
2718 $CPAN::Frontend->myprint(qq{
2719 Trying with external ftp to get
2721 As this requires some features that are not thoroughly tested, we\'re
2722 not sure, that we get it right....
2726 $self->talk_ftp("$ftpbin$verbose $host",
2728 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2729 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2731 if ($mtime > $timestamp) {
2732 $CPAN::Frontend->myprint("GOT $aslocal\n");
2736 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2738 return if $CPAN::Signal;
2740 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2741 qq{correctly protected.\n});
2744 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2745 nor does it have a default entry\n");
2748 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2749 # then and login manually to host, using e-mail as
2751 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2755 "user anonymous $Config::Config{'cf_email'}"
2757 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2758 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2759 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2761 if ($mtime > $timestamp) {
2762 $CPAN::Frontend->myprint("GOT $aslocal\n");
2766 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2768 return if $CPAN::Signal;
2769 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2775 my($self,$command,@dialog) = @_;
2776 my $fh = FileHandle->new;
2777 $fh->open("|$command") or die "Couldn't open ftp: $!";
2778 foreach (@dialog) { $fh->print("$_\n") }
2779 $fh->close; # Wait for process to complete
2781 my $estatus = $wstatus >> 8;
2782 $CPAN::Frontend->myprint(qq{
2783 Subprocess "|$command"
2784 returned status $estatus (wstat $wstatus)
2788 # find2perl needs modularization, too, all the following is stolen
2792 my($self,$name) = @_;
2793 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2794 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2796 my($perms,%user,%group);
2800 $blocks = int(($blocks + 1) / 2);
2803 $blocks = int(($sizemm + 1023) / 1024);
2806 if (-f _) { $perms = '-'; }
2807 elsif (-d _) { $perms = 'd'; }
2808 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2809 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2810 elsif (-p _) { $perms = 'p'; }
2811 elsif (-S _) { $perms = 's'; }
2812 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2814 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2815 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2816 my $tmpmode = $mode;
2817 my $tmp = $rwx[$tmpmode & 7];
2819 $tmp = $rwx[$tmpmode & 7] . $tmp;
2821 $tmp = $rwx[$tmpmode & 7] . $tmp;
2822 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2823 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2824 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2827 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2828 my $group = $group{$gid} || $gid;
2830 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2832 my($moname) = $moname[$mon];
2833 if (-M _ > 365.25 / 2) {
2834 $timeyear = $year + 1900;
2837 $timeyear = sprintf("%02d:%02d", $hour, $min);
2840 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2854 package CPAN::FTP::netrc;
2859 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2861 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2862 $atime,$mtime,$ctime,$blksize,$blocks)
2867 my($fh,@machines,$hasdefault);
2869 $fh = FileHandle->new or die "Could not create a filehandle";
2871 if($fh->open($file)){
2872 $protected = ($mode & 077) == 0;
2874 NETRC: while (<$fh>) {
2875 my(@tokens) = split " ", $_;
2876 TOKEN: while (@tokens) {
2877 my($t) = shift @tokens;
2878 if ($t eq "default"){
2882 last TOKEN if $t eq "macdef";
2883 if ($t eq "machine") {
2884 push @machines, shift @tokens;
2889 $file = $hasdefault = $protected = "";
2893 'mach' => [@machines],
2895 'hasdefault' => $hasdefault,
2896 'protected' => $protected,
2900 # CPAN::FTP::hasdefault;
2901 sub hasdefault { shift->{'hasdefault'} }
2902 sub netrc { shift->{'netrc'} }
2903 sub protected { shift->{'protected'} }
2905 my($self,$mach) = @_;
2906 for ( @{$self->{'mach'}} ) {
2907 return 1 if $_ eq $mach;
2912 package CPAN::Complete;
2916 my($text, $line, $start, $end) = @_;
2917 my(@perlret) = cpl($text, $line, $start);
2918 # find longest common match. Can anybody show me how to peruse
2919 # T::R::Gnu to have this done automatically? Seems expensive.
2920 return () unless @perlret;
2921 my($newtext) = $text;
2922 for (my $i = length($text)+1;;$i++) {
2923 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2924 my $try = substr($perlret[0],0,$i);
2925 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2926 # warn "try[$try]tries[@tries]";
2927 if (@tries == @perlret) {
2933 ($newtext,@perlret);
2936 #-> sub CPAN::Complete::cpl ;
2938 my($word,$line,$pos) = @_;
2942 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2944 if ($line =~ s/^(force\s*)//) {
2949 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2950 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2952 } elsif ($line =~ /^(a|ls)\s/) {
2953 @return = cplx('CPAN::Author',uc($word));
2954 } elsif ($line =~ /^b\s/) {
2955 CPAN::Shell->local_bundles;
2956 @return = cplx('CPAN::Bundle',$word);
2957 } elsif ($line =~ /^d\s/) {
2958 @return = cplx('CPAN::Distribution',$word);
2959 } elsif ($line =~ m/^(
2960 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
2962 if ($word =~ /^Bundle::/) {
2963 CPAN::Shell->local_bundles;
2965 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2966 } elsif ($line =~ /^i\s/) {
2967 @return = cpl_any($word);
2968 } elsif ($line =~ /^reload\s/) {
2969 @return = cpl_reload($word,$line,$pos);
2970 } elsif ($line =~ /^o\s/) {
2971 @return = cpl_option($word,$line,$pos);
2972 } elsif ($line =~ m/^\S+\s/ ) {
2973 # fallback for future commands and what we have forgotten above
2974 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2981 #-> sub CPAN::Complete::cplx ;
2983 my($class, $word) = @_;
2984 # I believed for many years that this was sorted, today I
2985 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2986 # make it sorted again. Maybe sort was dropped when GNU-readline
2987 # support came in? The RCS file is difficult to read on that:-(
2988 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2991 #-> sub CPAN::Complete::cpl_any ;
2995 cplx('CPAN::Author',$word),
2996 cplx('CPAN::Bundle',$word),
2997 cplx('CPAN::Distribution',$word),
2998 cplx('CPAN::Module',$word),
3002 #-> sub CPAN::Complete::cpl_reload ;
3004 my($word,$line,$pos) = @_;
3006 my(@words) = split " ", $line;
3007 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3008 my(@ok) = qw(cpan index);
3009 return @ok if @words == 1;
3010 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3013 #-> sub CPAN::Complete::cpl_option ;
3015 my($word,$line,$pos) = @_;
3017 my(@words) = split " ", $line;
3018 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3019 my(@ok) = qw(conf debug);
3020 return @ok if @words == 1;
3021 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3023 } elsif ($words[1] eq 'index') {
3025 } elsif ($words[1] eq 'conf') {
3026 return CPAN::HandleConfig::cpl(@_);
3027 } elsif ($words[1] eq 'debug') {
3028 return sort grep /^\Q$word\E/i,
3029 sort keys %CPAN::DEBUG, 'all';
3033 package CPAN::Index;
3036 #-> sub CPAN::Index::force_reload ;
3039 $CPAN::Index::LAST_TIME = 0;
3043 #-> sub CPAN::Index::reload ;
3045 my($cl,$force) = @_;
3048 # XXX check if a newer one is available. (We currently read it
3049 # from time to time)
3050 for ($CPAN::Config->{index_expire}) {
3051 $_ = 0.001 unless $_ && $_ > 0.001;
3053 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3054 # debug here when CPAN doesn't seem to read the Metadata
3056 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3058 unless ($CPAN::META->{PROTOCOL}) {
3059 $cl->read_metadata_cache;
3060 $CPAN::META->{PROTOCOL} ||= "1.0";
3062 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3063 # warn "Setting last_time to 0";
3064 $LAST_TIME = 0; # No warning necessary
3066 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3069 # IFF we are developing, it helps to wipe out the memory
3070 # between reloads, otherwise it is not what a user expects.
3071 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3072 $CPAN::META = CPAN->new;
3076 local $LAST_TIME = $time;
3077 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3079 my $needshort = $^O eq "dos";
3081 $cl->rd_authindex($cl
3083 "authors/01mailrc.txt.gz",
3085 File::Spec->catfile('authors', '01mailrc.gz') :
3086 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3089 $debug = "timing reading 01[".($t2 - $time)."]";
3091 return if $CPAN::Signal; # this is sometimes lengthy
3092 $cl->rd_modpacks($cl
3094 "modules/02packages.details.txt.gz",
3096 File::Spec->catfile('modules', '02packag.gz') :
3097 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3100 $debug .= "02[".($t2 - $time)."]";
3102 return if $CPAN::Signal; # this is sometimes lengthy
3105 "modules/03modlist.data.gz",
3107 File::Spec->catfile('modules', '03mlist.gz') :
3108 File::Spec->catfile('modules', '03modlist.data.gz'),
3110 $cl->write_metadata_cache;
3112 $debug .= "03[".($t2 - $time)."]";
3114 CPAN->debug($debug) if $CPAN::DEBUG;
3117 $CPAN::META->{PROTOCOL} = PROTOCOL;
3120 #-> sub CPAN::Index::reload_x ;
3122 my($cl,$wanted,$localname,$force) = @_;
3123 $force |= 2; # means we're dealing with an index here
3124 CPAN::HandleConfig->load; # we should guarantee loading wherever we rely
3126 $localname ||= $wanted;
3127 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3131 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3134 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3135 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3136 qq{day$s. I\'ll use that.});
3139 $force |= 1; # means we're quite serious about it.
3141 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3144 #-> sub CPAN::Index::rd_authindex ;
3146 my($cl, $index_target) = @_;
3148 return unless defined $index_target;
3149 $CPAN::Frontend->myprint("Going to read $index_target\n");
3151 tie *FH, 'CPAN::Tarzip', $index_target;
3154 push @lines, split /\012/ while <FH>;
3156 my($userid,$fullname,$email) =
3157 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3158 next unless $userid && $fullname && $email;
3160 # instantiate an author object
3161 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3162 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3163 return if $CPAN::Signal;
3168 my($self,$dist) = @_;
3169 $dist = $self->{'id'} unless defined $dist;
3170 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3174 #-> sub CPAN::Index::rd_modpacks ;
3176 my($self, $index_target) = @_;
3178 return unless defined $index_target;
3179 $CPAN::Frontend->myprint("Going to read $index_target\n");
3180 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3183 while ($_ = $fh->READLINE) {
3185 my @ls = map {"$_\n"} split /\n/, $_;
3186 unshift @ls, "\n" x length($1) if /^(\n+)/;
3190 my($line_count,$last_updated);
3192 my $shift = shift(@lines);
3193 last if $shift =~ /^\s*$/;
3194 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3195 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3197 if (not defined $line_count) {
3199 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3200 Please check the validity of the index file by comparing it to more
3201 than one CPAN mirror. I'll continue but problems seem likely to
3206 } elsif ($line_count != scalar @lines) {
3208 warn sprintf qq{Warning: Your %s
3209 contains a Line-Count header of %d but I see %d lines there. Please
3210 check the validity of the index file by comparing it to more than one
3211 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3212 $index_target, $line_count, scalar(@lines);
3215 if (not defined $last_updated) {
3217 warn qq{Warning: Your $index_target does not contain a Last-Updated 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
3227 ->myprint(sprintf qq{ Database was generated on %s\n},
3229 $DATE_OF_02 = $last_updated;
3231 if ($CPAN::META->has_inst('HTTP::Date')) {
3233 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3238 qq{Warning: This index file is %d days old.
3239 Please check the host you chose as your CPAN mirror for staleness.
3240 I'll continue but problems seem likely to happen.\a\n},
3245 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3250 # A necessity since we have metadata_cache: delete what isn't
3252 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3253 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3257 # before 1.56 we split into 3 and discarded the rest. From
3258 # 1.57 we assign remaining text to $comment thus allowing to
3259 # influence isa_perl
3260 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3261 my($bundle,$id,$userid);
3263 if ($mod eq 'CPAN' &&
3265 CPAN::Queue->exists('Bundle::CPAN') ||
3266 CPAN::Queue->exists('CPAN')
3270 if ($version > $CPAN::VERSION){
3271 $CPAN::Frontend->myprint(qq{
3272 There's a new CPAN.pm version (v$version) available!
3273 [Current version is v$CPAN::VERSION]
3274 You might want to try
3275 install Bundle::CPAN
3277 without quitting the current session. It should be a seamless upgrade
3278 while we are running...
3281 $CPAN::Frontend->myprint(qq{\n});
3283 last if $CPAN::Signal;
3284 } elsif ($mod =~ /^Bundle::(.*)/) {
3289 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3290 # Let's make it a module too, because bundles have so much
3291 # in common with modules.
3293 # Changed in 1.57_63: seems like memory bloat now without
3294 # any value, so commented out
3296 # $CPAN::META->instance('CPAN::Module',$mod);
3300 # instantiate a module object
3301 $id = $CPAN::META->instance('CPAN::Module',$mod);
3305 # Although CPAN prohibits same name with different version the
3306 # indexer may have changed the version for the same distro
3307 # since the last time ("Force Reindexing" feature)
3308 if ($id->cpan_file ne $dist
3310 $id->cpan_version ne $version
3312 $userid = $id->userid || $self->userid($dist);
3314 'CPAN_USERID' => $userid,
3315 'CPAN_VERSION' => $version,
3316 'CPAN_FILE' => $dist,
3320 # instantiate a distribution object
3321 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3322 # we do not need CONTAINSMODS unless we do something with
3323 # this dist, so we better produce it on demand.
3325 ## my $obj = $CPAN::META->instance(
3326 ## 'CPAN::Distribution' => $dist
3328 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3330 $CPAN::META->instance(
3331 'CPAN::Distribution' => $dist
3333 'CPAN_USERID' => $userid,
3334 'CPAN_COMMENT' => $comment,
3338 for my $name ($mod,$dist) {
3339 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3340 $exists{$name} = undef;
3343 return if $CPAN::Signal;
3347 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3348 for my $o ($CPAN::META->all_objects($class)) {
3349 next if exists $exists{$o->{ID}};
3350 $CPAN::META->delete($class,$o->{ID});
3351 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3358 #-> sub CPAN::Index::rd_modlist ;
3360 my($cl,$index_target) = @_;
3361 return unless defined $index_target;
3362 $CPAN::Frontend->myprint("Going to read $index_target\n");
3363 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3367 while ($_ = $fh->READLINE) {
3369 my @ls = map {"$_\n"} split /\n/, $_;
3370 unshift @ls, "\n" x length($1) if /^(\n+)/;
3374 my $shift = shift(@eval);
3375 if ($shift =~ /^Date:\s+(.*)/){
3376 return if $DATE_OF_03 eq $1;
3379 last if $shift =~ /^\s*$/;
3382 push @eval, q{CPAN::Modulelist->data;};
3384 my($comp) = Safe->new("CPAN::Safe1");
3385 my($eval) = join("", @eval);
3386 my $ret = $comp->reval($eval);
3387 Carp::confess($@) if $@;
3388 return if $CPAN::Signal;
3390 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3391 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3392 $obj->set(%{$ret->{$_}});
3393 return if $CPAN::Signal;
3397 #-> sub CPAN::Index::write_metadata_cache ;
3398 sub write_metadata_cache {
3400 return unless $CPAN::Config->{'cache_metadata'};
3401 return unless $CPAN::META->has_usable("Storable");
3403 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3404 CPAN::Distribution)) {
3405 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3407 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3408 $cache->{last_time} = $LAST_TIME;
3409 $cache->{DATE_OF_02} = $DATE_OF_02;
3410 $cache->{PROTOCOL} = PROTOCOL;
3411 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3412 eval { Storable::nstore($cache, $metadata_file) };
3413 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3416 #-> sub CPAN::Index::read_metadata_cache ;
3417 sub read_metadata_cache {
3419 return unless $CPAN::Config->{'cache_metadata'};
3420 return unless $CPAN::META->has_usable("Storable");
3421 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3422 return unless -r $metadata_file and -f $metadata_file;
3423 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3425 eval { $cache = Storable::retrieve($metadata_file) };
3426 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3427 if (!$cache || ref $cache ne 'HASH'){
3431 if (exists $cache->{PROTOCOL}) {
3432 if (PROTOCOL > $cache->{PROTOCOL}) {
3433 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3434 "with protocol v%s, requiring v%s\n",
3441 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3442 "with protocol v1.0\n");
3447 while(my($class,$v) = each %$cache) {
3448 next unless $class =~ /^CPAN::/;
3449 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3450 while (my($id,$ro) = each %$v) {
3451 $CPAN::META->{readwrite}{$class}{$id} ||=
3452 $class->new(ID=>$id, RO=>$ro);
3457 unless ($clcnt) { # sanity check
3458 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3461 if ($idcnt < 1000) {
3462 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3463 "in $metadata_file\n");
3466 $CPAN::META->{PROTOCOL} ||=
3467 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3468 # does initialize to some protocol
3469 $LAST_TIME = $cache->{last_time};
3470 $DATE_OF_02 = $cache->{DATE_OF_02};
3471 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3472 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3476 package CPAN::InfoObj;
3481 exists $self->{RO} and return $self->{RO};
3486 my $ro = $self->ro or return;
3487 return $ro->{CPAN_USERID};
3490 sub id { shift->{ID}; }
3492 #-> sub CPAN::InfoObj::new ;
3494 my $this = bless {}, shift;
3499 # The set method may only be used by code that reads index data or
3500 # otherwise "objective" data from the outside world. All session
3501 # related material may do anything else with instance variables but
3502 # must not touch the hash under the RO attribute. The reason is that
3503 # the RO hash gets written to Metadata file and is thus persistent.
3505 #-> sub CPAN::InfoObj::set ;
3507 my($self,%att) = @_;
3508 my $class = ref $self;
3510 # This must be ||=, not ||, because only if we write an empty
3511 # reference, only then the set method will write into the readonly
3512 # area. But for Distributions that spring into existence, maybe
3513 # because of a typo, we do not like it that they are written into
3514 # the readonly area and made permanent (at least for a while) and
3515 # that is why we do not "allow" other places to call ->set.
3516 unless ($self->id) {
3517 CPAN->debug("Bug? Empty ID, rejecting");
3520 my $ro = $self->{RO} =
3521 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3523 while (my($k,$v) = each %att) {
3528 #-> sub CPAN::InfoObj::as_glimpse ;
3532 my $class = ref($self);
3533 $class =~ s/^CPAN:://;
3534 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3538 #-> sub CPAN::InfoObj::as_string ;
3542 my $class = ref($self);
3543 $class =~ s/^CPAN:://;
3544 push @m, $class, " id = $self->{ID}\n";
3546 for (sort keys %$ro) {
3547 # next if m/^(ID|RO)$/;
3549 if ($_ eq "CPAN_USERID") {
3550 $extra .= " (".$self->author;
3551 my $email; # old perls!
3552 if ($email = $CPAN::META->instance("CPAN::Author",
3555 $extra .= " <$email>";
3557 $extra .= " <no email>";
3560 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3561 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3564 next unless defined $ro->{$_};
3565 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
3567 for (sort keys %$self) {
3568 next if m/^(ID|RO)$/;
3569 if (ref($self->{$_}) eq "ARRAY") {
3570 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3571 } elsif (ref($self->{$_}) eq "HASH") {
3575 join(" ",keys %{$self->{$_}}),
3578 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3584 #-> sub CPAN::InfoObj::author ;
3587 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3590 #-> sub CPAN::InfoObj::dump ;
3593 require Data::Dumper;
3594 print Data::Dumper::Dumper($self);
3597 package CPAN::Author;
3600 #-> sub CPAN::Author::id
3603 my $id = $self->{ID};
3604 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3608 #-> sub CPAN::Author::as_glimpse ;
3612 my $class = ref($self);
3613 $class =~ s/^CPAN:://;
3614 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3622 #-> sub CPAN::Author::fullname ;
3624 shift->ro->{FULLNAME};
3628 #-> sub CPAN::Author::email ;
3629 sub email { shift->ro->{EMAIL}; }
3631 #-> sub CPAN::Author::ls ;
3634 my $glob = shift || "";
3635 my $silent = shift || 0;
3638 # adapted from CPAN::Distribution::verifyCHECKSUM ;
3639 my(@csf); # chksumfile
3640 @csf = $self->id =~ /(.)(.)(.*)/;
3641 $csf[1] = join "", @csf[0,1];
3642 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
3644 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
3645 unless (grep {$_->[2] eq $csf[1]} @dl) {
3646 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
3649 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
3650 unless (grep {$_->[2] eq $csf[2]} @dl) {
3651 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
3654 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
3656 my $rglob = Text::Glob::glob_to_regex($glob);
3657 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
3659 $CPAN::Frontend->myprint(join "", map {
3660 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3661 } sort { $a->[2] cmp $b->[2] } @dl);
3664 # returns an array of arrays, the latter contain (size,mtime,filename)
3665 #-> sub CPAN::Author::dir_listing ;
3668 my $chksumfile = shift;
3669 my $recursive = shift;
3670 my $may_ftp = shift;
3672 File::Spec->catfile($CPAN::Config->{keep_source_where},
3673 "authors", "id", @$chksumfile);
3677 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
3678 # hazard. (Without GPG installed they are not that much better,
3680 $fh = FileHandle->new;
3681 if (open($fh, $lc_want)) {
3682 my $line = <$fh>; close $fh;
3683 unlink($lc_want) unless $line =~ /PGP/;
3687 # connect "force" argument with "index_expire".
3689 if (my @stat = stat $lc_want) {
3690 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3694 $lc_file = CPAN::FTP->localize(
3695 "authors/id/@$chksumfile",
3700 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3701 $chksumfile->[-1] .= ".gz";
3702 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3705 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3706 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
3712 $lc_file = $lc_want;
3713 # we *could* second-guess and if the user has a file: URL,
3714 # then we could look there. But on the other hand, if they do
3715 # have a file: URL, wy did they choose to set
3716 # $CPAN::Config->{show_upload_date} to false?
3719 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
3720 $fh = FileHandle->new;
3722 if (open $fh, $lc_file){
3725 $eval =~ s/\015?\012/\n/g;
3727 my($comp) = Safe->new();
3728 $cksum = $comp->reval($eval);
3730 rename $lc_file, "$lc_file.bad";
3731 Carp::confess($@) if $@;
3733 } elsif ($may_ftp) {
3734 Carp::carp "Could not open $lc_file for reading.";
3736 # Maybe should warn: "You may want to set show_upload_date to a true value"
3740 for $f (sort keys %$cksum) {
3741 if (exists $cksum->{$f}{isdir}) {
3743 my(@dir) = @$chksumfile;
3745 push @dir, $f, "CHECKSUMS";
3747 [$_->[0], $_->[1], "$f/$_->[2]"]
3748 } $self->dir_listing(\@dir,1,$may_ftp);
3750 push @result, [ 0, "-", $f ];
3754 ($cksum->{$f}{"size"}||0),
3755 $cksum->{$f}{"mtime"}||"---",
3763 package CPAN::Distribution;
3769 my $ro = $self->ro or return;
3775 delete $self->{later};
3778 # add the A/AN/ stuff
3779 # CPAN::Distribution::normalize
3782 $s = $self->id unless defined $s;
3786 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3788 return $s if $s =~ m:^N/A|^Contact Author: ;
3789 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3790 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3791 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3799 return $id unless $id =~ m|^./../|;
3803 # mark as dirty/clean
3804 #-> sub CPAN::Distribution::color_cmd_tmps ;
3805 sub color_cmd_tmps {
3807 my($depth) = shift || 0;
3808 my($color) = shift || 0;
3809 my($ancestors) = shift || [];
3810 # a distribution needs to recurse into its prereq_pms
3812 return if exists $self->{incommandcolor}
3813 && $self->{incommandcolor}==$color;
3815 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3817 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3818 my $prereq_pm = $self->prereq_pm;
3819 if (defined $prereq_pm) {
3820 for my $pre (keys %$prereq_pm) {
3821 my $premo = CPAN::Shell->expand("Module",$pre);
3822 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3826 delete $self->{sponsored_mods};
3827 delete $self->{badtestcnt};
3829 $self->{incommandcolor} = $color;
3832 #-> sub CPAN::Distribution::as_string ;
3835 $self->containsmods;
3837 $self->SUPER::as_string(@_);
3840 #-> sub CPAN::Distribution::containsmods ;
3843 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3844 my $dist_id = $self->{ID};
3845 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3846 my $mod_file = $mod->cpan_file or next;
3847 my $mod_id = $mod->{ID} or next;
3848 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3850 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3852 keys %{$self->{CONTAINSMODS}};
3855 #-> sub CPAN::Distribution::upload_date ;
3858 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
3859 my(@local_wanted) = split(/\//,$self->id);
3860 my $filename = pop @local_wanted;
3861 push @local_wanted, "CHECKSUMS";
3862 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
3863 return unless $author;
3864 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
3866 my($dirent) = grep { $_->[2] eq $filename } @dl;
3867 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
3868 return unless $dirent->[1];
3869 return $self->{UPLOAD_DATE} = $dirent->[1];
3872 #-> sub CPAN::Distribution::uptodate ;
3876 foreach $c ($self->containsmods) {
3877 my $obj = CPAN::Shell->expandany($c);
3878 return 0 unless $obj->uptodate;
3883 #-> sub CPAN::Distribution::called_for ;
3886 $self->{CALLED_FOR} = $id if defined $id;
3887 return $self->{CALLED_FOR};
3890 #-> sub CPAN::Distribution::safe_chdir ;
3892 my($self,$todir) = @_;
3893 # we die if we cannot chdir and we are debuggable
3894 Carp::confess("safe_chdir called without todir argument")
3895 unless defined $todir and length $todir;
3897 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3900 unless (-x $todir) {
3901 unless (chmod 0755, $todir) {
3902 my $cwd = CPAN::anycwd();
3903 $CPAN::Frontend->mywarn("I have neither the -x permission nor the permission ".
3904 "to change the permission; cannot chdir ".
3907 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3908 qq{to todir[$todir]: $!});
3912 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3915 my $cwd = CPAN::anycwd();
3916 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3917 qq{to todir[$todir] (a chmod has been issued): $!});
3922 #-> sub CPAN::Distribution::get ;
3927 exists $self->{'build_dir'} and push @e,
3928 "Is already unwrapped into directory $self->{'build_dir'}";
3929 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3931 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3934 # Get the file on local disk
3939 File::Spec->catfile(
3940 $CPAN::Config->{keep_source_where},
3943 split(/\//,$self->id)
3946 $self->debug("Doing localize") if $CPAN::DEBUG;
3947 unless ($local_file =
3948 CPAN::FTP->localize("authors/id/$self->{ID}",
3951 if ($CPAN::Index::DATE_OF_02) {
3952 $note = "Note: Current database in memory was generated ".
3953 "on $CPAN::Index::DATE_OF_02\n";
3955 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3957 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3958 $self->{localfile} = $local_file;
3959 return if $CPAN::Signal;
3964 if ($CPAN::META->has_inst("Digest::SHA")) {
3965 $self->debug("Digest::SHA is installed, verifying");
3966 $self->verifyCHECKSUM;
3968 $self->debug("Digest::SHA is NOT installed");
3970 return if $CPAN::Signal;
3973 # Create a clean room and go there
3975 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3976 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3977 $self->safe_chdir($builddir);
3978 $self->debug("Removing tmp") if $CPAN::DEBUG;
3979 File::Path::rmtree("tmp");
3980 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3982 $self->safe_chdir($sub_wd);
3985 $self->safe_chdir("tmp");
3990 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3991 my $ct = CPAN::Tarzip->new($local_file);
3992 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
3993 $self->{was_uncompressed}++ unless $ct->gtest();
3994 $self->untar_me($ct);
3995 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3996 $self->unzip_me($ct);
3997 } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
3998 $self->{was_uncompressed}++ unless $ct->gtest();
3999 $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
4000 $self->pm2dir_me($local_file);
4002 $self->{archived} = "NO";
4003 $self->safe_chdir($sub_wd);
4007 # we are still in the tmp directory!
4008 # Let's check if the package has its own directory.
4009 my $dh = DirHandle->new(File::Spec->curdir)
4010 or Carp::croak("Couldn't opendir .: $!");
4011 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4013 my ($distdir,$packagedir);
4014 if (@readdir == 1 && -d $readdir[0]) {
4015 $distdir = $readdir[0];
4016 $packagedir = File::Spec->catdir($builddir,$distdir);
4017 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4019 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4021 File::Path::rmtree($packagedir);
4022 File::Copy::move($distdir,$packagedir) or
4023 Carp::confess("Couldn't move $distdir to $packagedir: $!");
4024 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4031 my $userid = $self->cpan_userid;
4033 CPAN->debug("no userid? self[$self]");
4036 my $pragmatic_dir = $userid . '000';
4037 $pragmatic_dir =~ s/\W_//g;
4038 $pragmatic_dir++ while -d "../$pragmatic_dir";
4039 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4040 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4041 File::Path::mkpath($packagedir);
4043 for $f (@readdir) { # is already without "." and ".."
4044 my $to = File::Spec->catdir($packagedir,$f);
4045 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4049 $self->safe_chdir($sub_wd);
4053 $self->{'build_dir'} = $packagedir;
4054 $self->safe_chdir($builddir);
4055 File::Path::rmtree("tmp");
4057 $self->safe_chdir($packagedir);
4058 if ($CPAN::META->has_inst("Module::Signature")) {
4059 if (-f "SIGNATURE") {
4060 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4061 my $rv = Module::Signature::verify();
4062 if ($rv != Module::Signature::SIGNATURE_OK() and
4063 $rv != Module::Signature::SIGNATURE_MISSING()) {
4064 $CPAN::Frontend->myprint(
4065 qq{\nSignature invalid for }.
4066 qq{distribution file. }.
4067 qq{Please investigate.\n\n}.
4069 $CPAN::META->instance(
4076 sprintf(qq{I\'d recommend removing %s. Its signature
4077 is invalid. Maybe you have configured your 'urllist' with
4078 a bad URL. Please check this array with 'o conf urllist', and
4079 retry. For more information, try opening a subshell with
4086 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4089 $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
4092 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4094 $self->safe_chdir($builddir);
4095 return if $CPAN::Signal;
4098 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4099 my($mpl_exists) = -f $mpl;
4100 unless ($mpl_exists) {
4101 # NFS has been reported to have racing problems after the
4102 # renaming of a directory in some environments.
4105 my $mpldh = DirHandle->new($packagedir)
4106 or Carp::croak("Couldn't opendir $packagedir: $!");
4107 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4110 my $prefer_installer = "eumm"; # eumm|mb
4111 if (-f File::Spec->catfile($packagedir,"Build.PL")) {
4112 if ($mpl_exists) { # they *can* choose
4113 if ($CPAN::META->has_inst("Module::Build")) {
4114 $prefer_installer = $CPAN::Config->{prefer_installer};
4117 $prefer_installer = "mb";
4120 if (lc($prefer_installer) eq "mb") {
4121 $self->{modulebuild} = "YES";
4122 } elsif (! $mpl_exists) {
4123 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4127 my($configure) = File::Spec->catfile($packagedir,"Configure");
4128 if (-f $configure) {
4129 # do we have anything to do?
4130 $self->{'configure'} = $configure;
4131 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4132 $CPAN::Frontend->myprint(qq{
4133 Package comes with a Makefile and without a Makefile.PL.
4134 We\'ll try to build it with that Makefile then.
4136 $self->{writemakefile} = "YES";
4139 my $cf = $self->called_for || "unknown";
4144 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4145 $cf = "unknown" unless length($cf);
4146 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4147 (The test -f "$mpl" returned false.)
4148 Writing one on our own (setting NAME to $cf)\a\n});
4149 $self->{had_no_makefile_pl}++;
4152 # Writing our own Makefile.PL
4154 my $fh = FileHandle->new;
4156 or Carp::croak("Could not open >$mpl: $!");
4158 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4159 # because there was no Makefile.PL supplied.
4160 # Autogenerated on: }.scalar localtime().qq{
4162 use ExtUtils::MakeMaker;
4163 WriteMakefile(NAME => q[$cf]);
4173 # CPAN::Distribution::untar_me ;
4176 $self->{archived} = "tar";
4178 $self->{unwrapped} = "YES";
4180 $self->{unwrapped} = "NO";
4184 # CPAN::Distribution::unzip_me ;
4187 $self->{archived} = "zip";
4189 $self->{unwrapped} = "YES";
4191 $self->{unwrapped} = "NO";
4197 my($self,$local_file) = @_;
4198 $self->{archived} = "pm";
4199 my $to = File::Basename::basename($local_file);
4200 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4201 if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
4202 $self->{unwrapped} = "YES";
4204 $self->{unwrapped} = "NO";
4207 File::Copy::cp($local_file,".");
4208 $self->{unwrapped} = "YES";
4212 #-> sub CPAN::Distribution::new ;
4214 my($class,%att) = @_;
4216 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4218 my $this = { %att };
4219 return bless $this, $class;
4222 #-> sub CPAN::Distribution::look ;
4226 if ($^O eq 'MacOS') {
4227 $self->Mac::BuildTools::look;
4231 if ( $CPAN::Config->{'shell'} ) {
4232 $CPAN::Frontend->myprint(qq{
4233 Trying to open a subshell in the build directory...
4236 $CPAN::Frontend->myprint(qq{
4237 Your configuration does not define a value for subshells.
4238 Please define it with "o conf shell <your shell>"
4242 my $dist = $self->id;
4244 unless ($dir = $self->dir) {
4247 unless ($dir ||= $self->dir) {
4248 $CPAN::Frontend->mywarn(qq{
4249 Could not determine which directory to use for looking at $dist.
4253 my $pwd = CPAN::anycwd();
4254 $self->safe_chdir($dir);
4255 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4256 unless (system($CPAN::Config->{'shell'}) == 0) {
4258 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4260 $self->safe_chdir($pwd);
4263 # CPAN::Distribution::cvs_import ;
4267 my $dir = $self->dir;
4269 my $package = $self->called_for;
4270 my $module = $CPAN::META->instance('CPAN::Module', $package);
4271 my $version = $module->cpan_version;
4273 my $userid = $self->cpan_userid;
4275 my $cvs_dir = (split /\//, $dir)[-1];
4276 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4278 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4280 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4281 if ($cvs_site_perl) {
4282 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4284 my $cvs_log = qq{"imported $package $version sources"};
4285 $version =~ s/\./_/g;
4286 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4287 "$cvs_dir", $userid, "v$version");
4289 my $pwd = CPAN::anycwd();
4290 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4292 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4294 $CPAN::Frontend->myprint(qq{@cmd\n});
4295 system(@cmd) == 0 or
4296 $CPAN::Frontend->mydie("cvs import failed");
4297 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4300 #-> sub CPAN::Distribution::readme ;
4303 my($dist) = $self->id;
4304 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4305 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4308 File::Spec->catfile(
4309 $CPAN::Config->{keep_source_where},
4312 split(/\//,"$sans.readme"),
4314 $self->debug("Doing localize") if $CPAN::DEBUG;
4315 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4317 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4319 if ($^O eq 'MacOS') {
4320 Mac::BuildTools::launch_file($local_file);
4324 my $fh_pager = FileHandle->new;
4325 local($SIG{PIPE}) = "IGNORE";
4326 $fh_pager->open("|$CPAN::Config->{'pager'}")
4327 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4328 my $fh_readme = FileHandle->new;
4329 $fh_readme->open($local_file)
4330 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4331 $CPAN::Frontend->myprint(qq{
4334 with pager "$CPAN::Config->{'pager'}"
4337 $fh_pager->print(<$fh_readme>);
4341 #-> sub CPAN::Distribution::verifyCHECKSUM ;
4342 sub verifyCHECKSUM {
4346 $self->{CHECKSUM_STATUS} ||= "";
4347 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
4348 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4350 my($lc_want,$lc_file,@local,$basename);
4351 @local = split(/\//,$self->id);
4353 push @local, "CHECKSUMS";
4355 File::Spec->catfile($CPAN::Config->{keep_source_where},
4356 "authors", "id", @local);
4361 $self->CHECKSUM_check_file($lc_want)
4363 return $self->{CHECKSUM_STATUS} = "OK";
4365 $lc_file = CPAN::FTP->localize("authors/id/@local",
4368 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4369 $local[-1] .= ".gz";
4370 $lc_file = CPAN::FTP->localize("authors/id/@local",
4373 $lc_file =~ s/\.gz(?!\n)\Z//;
4374 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4379 $self->CHECKSUM_check_file($lc_file);
4382 sub SIG_check_file {
4383 my($self,$chk_file) = @_;
4384 my $rv = eval { Module::Signature::_verify($chk_file) };
4386 if ($rv == Module::Signature::SIGNATURE_OK()) {
4387 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
4388 return $self->{SIG_STATUS} = "OK";
4390 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
4391 qq{distribution file. }.
4392 qq{Please investigate.\n\n}.
4394 $CPAN::META->instance(
4399 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
4400 is invalid. Maybe you have configured your 'urllist' with
4401 a bad URL. Please check this array with 'o conf urllist', and
4404 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4408 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
4409 sub CHECKSUM_check_file {
4410 my($self,$chk_file) = @_;
4411 my($cksum,$file,$basename);
4413 if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
4414 $self->debug("Module::Signature is installed, verifying");
4415 $self->SIG_check_file($chk_file);
4417 $self->debug("Module::Signature is NOT installed");
4420 $file = $self->{localfile};
4421 $basename = File::Basename::basename($file);
4422 my $fh = FileHandle->new;
4423 if (open $fh, $chk_file){
4426 $eval =~ s/\015?\012/\n/g;
4428 my($comp) = Safe->new();
4429 $cksum = $comp->reval($eval);
4431 rename $chk_file, "$chk_file.bad";
4432 Carp::confess($@) if $@;
4435 Carp::carp "Could not open $chk_file for reading";
4438 if (exists $cksum->{$basename}{sha256}) {
4439 $self->debug("Found checksum for $basename:" .
4440 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
4444 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
4446 $fh = CPAN::Tarzip->TIEHANDLE($file);
4449 my $dg = Digest::SHA->new(256);
4452 while ($fh->READ($ref, 4096) > 0){
4455 my $hexdigest = $dg->hexdigest;
4456 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
4460 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4461 return $self->{CHECKSUM_STATUS} = "OK";
4463 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4464 qq{distribution file. }.
4465 qq{Please investigate.\n\n}.
4467 $CPAN::META->instance(
4472 my $wrap = qq{I\'d recommend removing $file. Its
4473 checksum is incorrect. Maybe you have configured your 'urllist' with
4474 a bad URL. Please check this array with 'o conf urllist', and
4477 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4479 # former versions just returned here but this seems a
4480 # serious threat that deserves a die
4482 # $CPAN::Frontend->myprint("\n\n");
4486 # close $fh if fileno($fh);
4488 $self->{CHECKSUM_STATUS} ||= "";
4489 if ($self->{CHECKSUM_STATUS} eq "NIL") {
4490 $CPAN::Frontend->mywarn(qq{
4491 Warning: No checksum for $basename in $chk_file.
4493 The cause for this may be that the file is very new and the checksum
4494 has not yet been calculated, but it may also be that something is
4495 going awry right now.
4497 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4498 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4500 $self->{CHECKSUM_STATUS} = "NIL";
4505 #-> sub CPAN::Distribution::eq_CHECKSUM ;
4507 my($self,$fh,$expect) = @_;
4508 my $dg = Digest::SHA->new(256);
4510 while (read($fh, $data, 4096)){
4513 my $hexdigest = $dg->hexdigest;
4514 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4515 $hexdigest eq $expect;
4518 #-> sub CPAN::Distribution::force ;
4520 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
4521 # effect by autoinspection, not by inspecting a global variable. One
4522 # of the reason why this was chosen to work that way was the treatment
4523 # of dependencies. They should not automatically inherit the force
4524 # status. But this has the downside that ^C and die() will return to
4525 # the prompt but will not be able to reset the force_update
4526 # attributes. We try to correct for it currently in the read_metadata
4527 # routine, and immediately before we check for a Signal. I hope this
4528 # works out in one of v1.57_53ff
4531 my($self, $method) = @_;
4533 CHECKSUM_STATUS archived build_dir localfile make install unwrapped
4536 delete $self->{$att};
4538 if ($method && $method eq "install") {
4539 $self->{"force_update"}++; # name should probably have been force_install
4544 my($self, $method) = @_;
4545 # warn "XDEBUG: set notest for $self $method";
4546 $self->{"notest"}++; # name should probably have been force_install
4551 # warn "XDEBUG: deleting notest";
4552 delete $self->{'notest'};
4555 #-> sub CPAN::Distribution::unforce ;
4558 delete $self->{'force_update'};
4561 #-> sub CPAN::Distribution::isa_perl ;
4564 my $file = File::Basename::basename($self->id);
4565 if ($file =~ m{ ^ perl
4578 } elsif ($self->cpan_comment
4580 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4586 #-> sub CPAN::Distribution::perl ;
4592 #-> sub CPAN::Distribution::make ;
4595 my $make = $self->{modulebuild} ? "Build" : "make";
4596 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
4597 # Emergency brake if they said install Pippi and get newest perl
4598 if ($self->isa_perl) {
4600 $self->called_for ne $self->id &&
4601 ! $self->{force_update}
4603 # if we die here, we break bundles
4604 $CPAN::Frontend->mywarn(sprintf qq{
4605 The most recent version "%s" of the module "%s"
4606 comes with the current version of perl (%s).
4607 I\'ll build that only if you ask for something like
4612 $CPAN::META->instance(
4626 !$self->{archived} || $self->{archived} eq "NO" and push @e,
4627 "Is neither a tar nor a zip archive.";
4629 !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
4630 "had problems unarchiving. Please build manually";
4632 exists $self->{writemakefile} &&
4633 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4634 $1 || "Had some problem writing Makefile";
4636 defined $self->{'make'} and push @e,
4637 "Has already been processed within this session";
4639 exists $self->{later} and length($self->{later}) and
4640 push @e, $self->{later};
4642 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4644 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4645 my $builddir = $self->dir or
4646 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory");
4647 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4648 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4650 if ($^O eq 'MacOS') {
4651 Mac::BuildTools::make($self);
4656 if ($self->{'configure'}) {
4657 $system = $self->{'configure'};
4658 } elsif ($self->{modulebuild}) {
4659 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4660 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
4662 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4664 # This needs a handler that can be turned on or off:
4665 # $switch = "-MExtUtils::MakeMaker ".
4666 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4668 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4670 unless (exists $self->{writemakefile}) {
4671 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4674 if ($CPAN::Config->{inactivity_timeout}) {
4676 alarm $CPAN::Config->{inactivity_timeout};
4677 local $SIG{CHLD}; # = sub { wait };
4678 if (defined($pid = fork)) {
4683 # note, this exec isn't necessary if
4684 # inactivity_timeout is 0. On the Mac I'd
4685 # suggest, we set it always to 0.
4689 $CPAN::Frontend->myprint("Cannot fork: $!");
4697 $CPAN::Frontend->myprint($@);
4698 $self->{writemakefile} = "NO $@";
4703 $ret = system($system);
4705 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4709 if (-f "Makefile" || -f "Build") {
4710 $self->{writemakefile} = "YES";
4711 delete $self->{make_clean}; # if cleaned before, enable next
4713 $self->{writemakefile} =
4714 qq{NO Makefile.PL refused to write a Makefile.};
4715 # It's probably worth it to record the reason, so let's retry
4717 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4718 # $self->{writemakefile} .= <$fh>;
4722 delete $self->{force_update};
4725 if (my @prereq = $self->unsat_prereq){
4726 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4728 if ($self->{modulebuild}) {
4729 $system = "./Build $CPAN::Config->{mbuild_arg}";
4731 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4733 if (system($system) == 0) {
4734 $CPAN::Frontend->myprint(" $system -- OK\n");
4735 $self->{'make'} = "YES";
4737 $self->{writemakefile} ||= "YES";
4738 $self->{'make'} = "NO";
4739 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4743 sub follow_prereqs {
4745 my(@prereq) = grep {$_ ne "perl"} @_;
4746 return unless @prereq;
4748 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4749 "during [$id] -----\n");
4751 for my $p (@prereq) {
4752 $CPAN::Frontend->myprint(" $p\n");
4755 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4757 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4758 require ExtUtils::MakeMaker;
4759 my $answer = ExtUtils::MakeMaker::prompt(
4760 "Shall I follow them and prepend them to the queue
4761 of modules we are processing right now?", "yes");
4762 $follow = $answer =~ /^\s*y/i;
4766 myprint(" Ignoring dependencies on modules @prereq\n");
4769 # color them as dirty
4770 for my $p (@prereq) {
4771 # warn "calling color_cmd_tmps(0,1)";
4772 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4774 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4775 $self->{later} = "Delayed until after prerequisites";
4776 return 1; # signal success to the queuerunner
4780 #-> sub CPAN::Distribution::unsat_prereq ;
4783 my $prereq_pm = $self->prereq_pm or return;
4785 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4786 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4787 # we were too demanding:
4788 next if $nmo->uptodate;
4790 # if they have not specified a version, we accept any installed one
4791 if (not defined $need_version or
4792 $need_version eq "0" or
4793 $need_version eq "undef") {
4794 next if defined $nmo->inst_file;
4797 # We only want to install prereqs if either they're not installed
4798 # or if the installed version is too old. We cannot omit this
4799 # check, because if 'force' is in effect, nobody else will check.
4800 if (defined $nmo->inst_file) {
4801 my(@all_requirements) = split /\s*,\s*/, $need_version;
4804 RQ: for my $rq (@all_requirements) {
4805 if ($rq =~ s|>=\s*||) {
4806 } elsif ($rq =~ s|>\s*||) {
4808 if (CPAN::Version->vgt($nmo->inst_version,$rq)){
4812 } elsif ($rq =~ s|!=\s*||) {
4814 if (CPAN::Version->vcmp($nmo->inst_version,$rq)){
4820 } elsif ($rq =~ m|<=?\s*|) {
4822 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
4826 if (! CPAN::Version->vgt($rq, $nmo->inst_version)){
4829 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]rq[%s]ok[%d]",
4833 CPAN::Version->readable($rq),
4837 next NEED if $ok == @all_requirements;
4840 if ($self->{sponsored_mods}{$need_module}++){
4841 # We have already sponsored it and for some reason it's still
4842 # not available. So we do nothing. Or what should we do?
4843 # if we push it again, we have a potential infinite loop
4846 push @need, $need_module;
4851 #-> sub CPAN::Distribution::read_yaml ;
4854 return $self->{yaml_content} if exists $self->{yaml_content};
4855 my $build_dir = $self->{build_dir};
4856 my $yaml = File::Spec->catfile($build_dir,"META.yml");
4857 return unless -f $yaml;
4858 if ($CPAN::META->has_inst("YAML")) {
4859 eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
4861 $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
4865 return $self->{yaml_content};
4868 #-> sub CPAN::Distribution::prereq_pm ;
4871 return $self->{prereq_pm} if
4872 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4873 return unless $self->{writemakefile} # no need to have succeeded
4874 # but we must have run it
4875 || $self->{mudulebuild};
4877 if (my $yaml = $self->read_yaml) {
4878 $req = $yaml->{requires};
4879 undef $req unless ref $req eq "HASH" && %$req;
4881 if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
4882 my $eummv = do { local $^W = 0; $1+0; };
4883 if ($eummv < 6.2501) {
4884 # thanks to Slaven for digging that out: MM before
4885 # that could be wrong because it could reflect a
4892 while (my($k,$v) = each %{$req||{}}) {
4895 } elsif ($k =~ /[A-Za-z]/ &&
4897 $CPAN::META->exists("Module",$v)
4899 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
4900 "requires hash: $k => $v; I'll take both ".
4901 "key and value as a module name\n");
4908 $req = $areq if $do_replace;
4911 delete $req->{perl};
4915 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4916 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4920 $fh = FileHandle->new("<$makefile\0")) {
4923 last if /MakeMaker post_initialize section/;
4925 \s+PREREQ_PM\s+=>\s+(.+)
4928 # warn "Found prereq expr[$p]";
4930 # Regexp modified by A.Speer to remember actual version of file
4931 # PREREQ_PM hash key wants, then add to
4932 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4933 # In case a prereq is mentioned twice, complain.
4934 if ( defined $req->{$1} ) {
4935 warn "Warning: PREREQ_PM mentions $1 more than once, ".
4936 "last mention wins";
4944 $self->{prereq_pm_detected}++;
4945 return $self->{prereq_pm} = $req;
4948 #-> sub CPAN::Distribution::test ;
4953 delete $self->{force_update};
4956 # warn "XDEBUG: checking for notest: $self->{notest} $self";
4957 if ($self->{notest}) {
4958 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
4962 my $make = $self->{modulebuild} ? "Build" : "make";
4963 $CPAN::Frontend->myprint("Running $make test\n");
4964 if (my @prereq = $self->unsat_prereq){
4965 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4969 exists $self->{make} or exists $self->{later} or push @e,
4970 "Make had some problems, maybe interrupted? Won't test";
4972 exists $self->{'make'} and
4973 $self->{'make'} eq 'NO' and
4974 push @e, "Can't test without successful make";
4976 exists $self->{build_dir} or push @e, "Has no own directory";
4977 $self->{badtestcnt} ||= 0;
4978 $self->{badtestcnt} > 0 and
4979 push @e, "Won't repeat unsuccessful test during this command";
4981 exists $self->{later} and length($self->{later}) and
4982 push @e, $self->{later};
4984 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4986 chdir $self->{'build_dir'} or
4987 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4988 $self->debug("Changed directory to $self->{'build_dir'}")
4991 if ($^O eq 'MacOS') {
4992 Mac::BuildTools::make_test($self);
4996 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
4998 : ($ENV{PERLLIB} || "");
5000 $CPAN::META->set_perl5lib;
5002 if ($self->{modulebuild}) {
5003 $system = "./Build test";
5005 $system = join " ", $CPAN::Config->{'make'}, "test";
5007 if (system($system) == 0) {
5008 $CPAN::Frontend->myprint(" $system -- OK\n");
5009 $CPAN::META->is_tested($self->{'build_dir'});
5010 $self->{make_test} = "YES";
5012 $self->{make_test} = "NO";
5013 $self->{badtestcnt}++;
5014 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
5018 #-> sub CPAN::Distribution::clean ;
5021 my $make = $self->{modulebuild} ? "Build" : "make";
5022 $CPAN::Frontend->myprint("Running $make clean\n");
5023 unless (exists $self->{build_dir}) {
5024 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
5029 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
5030 push @e, "make clean already called once";
5031 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5033 chdir $self->{'build_dir'} or
5034 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5035 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
5037 if ($^O eq 'MacOS') {
5038 Mac::BuildTools::make_clean($self);
5043 if ($self->{modulebuild}) {
5044 $system = "./Build clean";
5046 $system = join " ", $CPAN::Config->{'make'}, "clean";
5048 if (system($system) == 0) {
5049 $CPAN::Frontend->myprint(" $system -- OK\n");
5053 # Jost Krieger pointed out that this "force" was wrong because
5054 # it has the effect that the next "install" on this distribution
5055 # will untar everything again. Instead we should bring the
5056 # object's state back to where it is after untarring.
5067 $self->{make_clean} = "YES";
5070 # Hmmm, what to do if make clean failed?
5072 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
5074 make clean did not succeed, marking directory as unusable for further work.
5076 $self->force("make"); # so that this directory won't be used again
5081 #-> sub CPAN::Distribution::install ;
5086 delete $self->{force_update};
5089 my $make = $self->{modulebuild} ? "Build" : "make";
5090 $CPAN::Frontend->myprint("Running $make install\n");
5093 exists $self->{build_dir} or push @e, "Has no own directory";
5095 exists $self->{make} or exists $self->{later} or push @e,
5096 "Make had some problems, maybe interrupted? Won't install";
5098 exists $self->{'make'} and
5099 $self->{'make'} eq 'NO' and
5100 push @e, "make had returned bad status, install seems impossible";
5102 push @e, "make test had returned bad status, ".
5103 "won't install without force"
5104 if exists $self->{'make_test'} and
5105 $self->{'make_test'} eq 'NO' and
5106 ! $self->{'force_update'};
5108 exists $self->{'install'} and push @e,
5109 $self->{'install'} eq "YES" ?
5110 "Already done" : "Already tried without success";
5112 exists $self->{later} and length($self->{later}) and
5113 push @e, $self->{later};
5115 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5117 chdir $self->{'build_dir'} or
5118 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5119 $self->debug("Changed directory to $self->{'build_dir'}")
5122 if ($^O eq 'MacOS') {
5123 Mac::BuildTools::make_install($self);
5128 if ($self->{modulebuild}) {
5129 my($mbuild_install_build_command) = $CPAN::Config->{'mbuild_install_build_command'} ||
5132 $mbuild_install_build_command,
5134 $CPAN::Config->{mbuild_install_arg},
5137 my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
5138 $CPAN::Config->{'make'};
5140 $make_install_make_command,
5142 $CPAN::Config->{make_install_arg},
5146 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
5147 my($pipe) = FileHandle->new("$system $stderr |");
5150 $CPAN::Frontend->myprint($_);
5155 $CPAN::Frontend->myprint(" $system -- OK\n");
5156 $CPAN::META->is_installed($self->{'build_dir'});
5157 return $self->{'install'} = "YES";
5159 $self->{'install'} = "NO";
5160 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
5162 $makeout =~ /permission/s
5165 ! $CPAN::Config->{make_install_make_command}
5166 || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
5169 $CPAN::Frontend->myprint(
5171 qq{ You may have to su }.
5172 qq{to root to install the package\n}.
5173 qq{ (Or you may want to run something like\n}.
5174 qq{ o conf make_install_make_command 'sudo make'\n}.
5175 qq{ to raise your permissions.}
5179 delete $self->{force_update};
5182 #-> sub CPAN::Distribution::dir ;
5184 shift->{'build_dir'};
5187 #-> sub CPAN::Distribution::perldoc ;
5191 my($dist) = $self->id;
5192 my $package = $self->called_for;
5194 $self->_display_url( $CPAN::Defaultdocs . $package );
5197 #-> sub CPAN::Distribution::_check_binary ;
5199 my ($dist,$shell,$binary) = @_;
5200 my ($pid,$readme,$out);
5202 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
5205 $pid = open $readme, "which $binary|"
5206 or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
5210 close $readme or die "Could not run 'which $binary': $!";
5212 $CPAN::Frontend->myprint(qq{ + $out \n})
5213 if $CPAN::DEBUG && $out;
5218 #-> sub CPAN::Distribution::_display_url ;
5220 my($self,$url) = @_;
5221 my($res,$saved_file,$pid,$readme,$out);
5223 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
5226 # should we define it in the config instead?
5227 my $html_converter = "html2text";
5229 my $web_browser = $CPAN::Config->{'lynx'} || undef;
5230 my $web_browser_out = $web_browser
5231 ? CPAN::Distribution->_check_binary($self,$web_browser)
5234 my ($tmpout,$tmperr);
5235 if (not $web_browser_out) {
5236 # web browser not found, let's try text only
5237 my $html_converter_out =
5238 CPAN::Distribution->_check_binary($self,$html_converter);
5240 if ($html_converter_out ) {
5241 # html2text found, run it
5242 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
5243 $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
5244 unless defined($saved_file);
5246 $pid = open $readme, "$html_converter $saved_file |"
5247 or $CPAN::Frontend->mydie(qq{
5248 Could not fork '$html_converter $saved_file': $!});
5249 my $fh = File::Temp->new(
5250 template => 'cpan_htmlconvert_XXXX',
5258 or $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
5259 my $tmpin = $fh->filename;
5260 $CPAN::Frontend->myprint(sprintf(qq{
5262 saved output to %s\n},
5267 close $fh; undef $fh;
5269 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
5270 my $fh_pager = FileHandle->new;
5271 local($SIG{PIPE}) = "IGNORE";
5272 $fh_pager->open("|$CPAN::Config->{'pager'}")
5273 or $CPAN::Frontend->mydie(qq{
5274 Could not open pager $CPAN::Config->{'pager'}: $!});
5275 $CPAN::Frontend->myprint(qq{
5278 with pager "$CPAN::Config->{'pager'}"
5281 $fh_pager->print(<$fh>);
5284 # coldn't find the web browser or html converter
5285 $CPAN::Frontend->myprint(qq{
5286 You need to install lynx or $html_converter to use this feature.});
5289 # web browser found, run the action
5290 my $browser = $CPAN::Config->{'lynx'};
5291 $CPAN::Frontend->myprint(qq{system[$browser $url]})
5293 $CPAN::Frontend->myprint(qq{
5296 with browser $browser
5299 system("$browser $url");
5300 if ($saved_file) { 1 while unlink($saved_file) }
5304 #-> sub CPAN::Distribution::_getsave_url ;
5306 my($dist, $shell, $url) = @_;
5308 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
5311 my $fh = File::Temp->new(
5312 template => "cpan_getsave_url_XXXX",
5316 my $tmpin = $fh->filename;
5317 if ($CPAN::META->has_usable('LWP')) {
5318 $CPAN::Frontend->myprint("Fetching with LWP:
5322 CPAN::LWP::UserAgent->config;
5323 eval { $Ua = CPAN::LWP::UserAgent->new; };
5325 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
5329 $Ua->proxy('http', $var)
5330 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
5332 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
5335 my $req = HTTP::Request->new(GET => $url);
5336 $req->header('Accept' => 'text/html');
5337 my $res = $Ua->request($req);
5338 if ($res->is_success) {
5339 $CPAN::Frontend->myprint(" + request successful.\n")
5341 print $fh $res->content;
5343 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
5347 $CPAN::Frontend->myprint(sprintf(
5348 "LWP failed with code[%s], message[%s]\n",
5355 $CPAN::Frontend->myprint("LWP not available\n");
5360 package CPAN::Bundle;
5365 $CPAN::Frontend->myprint($self->as_string);
5370 delete $self->{later};
5371 for my $c ( $self->contains ) {
5372 my $obj = CPAN::Shell->expandany($c) or next;
5377 # mark as dirty/clean
5378 #-> sub CPAN::Bundle::color_cmd_tmps ;
5379 sub color_cmd_tmps {
5381 my($depth) = shift || 0;
5382 my($color) = shift || 0;
5383 my($ancestors) = shift || [];
5384 # a module needs to recurse to its cpan_file, a distribution needs
5385 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
5387 return if exists $self->{incommandcolor}
5388 && $self->{incommandcolor}==$color;
5390 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5392 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5394 for my $c ( $self->contains ) {
5395 my $obj = CPAN::Shell->expandany($c) or next;
5396 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
5397 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5400 delete $self->{badtestcnt};
5402 $self->{incommandcolor} = $color;
5405 #-> sub CPAN::Bundle::as_string ;
5409 # following line must be "=", not "||=" because we have a moving target
5410 $self->{INST_VERSION} = $self->inst_version;
5411 return $self->SUPER::as_string;
5414 #-> sub CPAN::Bundle::contains ;
5417 my($inst_file) = $self->inst_file || "";
5418 my($id) = $self->id;
5419 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
5420 unless ($inst_file) {
5421 # Try to get at it in the cpan directory
5422 $self->debug("no inst_file") if $CPAN::DEBUG;
5424 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
5425 $cpan_file = $self->cpan_file;
5426 if ($cpan_file eq "N/A") {
5427 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
5428 Maybe stale symlink? Maybe removed during session? Giving up.\n");
5430 my $dist = $CPAN::META->instance('CPAN::Distribution',
5433 $self->debug($dist->as_string) if $CPAN::DEBUG;
5434 my($todir) = $CPAN::Config->{'cpan_home'};
5435 my(@me,$from,$to,$me);
5436 @me = split /::/, $self->id;
5438 $me = File::Spec->catfile(@me);
5439 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5440 $to = File::Spec->catfile($todir,$me);
5441 File::Path::mkpath(File::Basename::dirname($to));
5442 File::Copy::copy($from, $to)
5443 or Carp::confess("Couldn't copy $from to $to: $!");
5447 my $fh = FileHandle->new;
5449 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
5451 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
5453 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
5454 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
5455 next unless $in_cont;
5460 push @result, (split " ", $_, 2)[0];
5463 delete $self->{STATUS};
5464 $self->{CONTAINS} = \@result;
5465 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5467 $CPAN::Frontend->mywarn(qq{
5468 The bundle file "$inst_file" may be a broken
5469 bundlefile. It seems not to contain any bundle definition.
5470 Please check the file and if it is bogus, please delete it.
5471 Sorry for the inconvenience.
5477 #-> sub CPAN::Bundle::find_bundle_file
5478 sub find_bundle_file {
5479 my($self,$where,$what) = @_;
5480 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5481 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5482 ### my $bu = File::Spec->catfile($where,$what);
5483 ### return $bu if -f $bu;
5484 my $manifest = File::Spec->catfile($where,"MANIFEST");
5485 unless (-f $manifest) {
5486 require ExtUtils::Manifest;
5487 my $cwd = CPAN::anycwd();
5488 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5489 ExtUtils::Manifest::mkmanifest();
5490 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5492 my $fh = FileHandle->new($manifest)
5493 or Carp::croak("Couldn't open $manifest: $!");
5496 if ($^O eq 'MacOS') {
5499 $what2 =~ s/:Bundle://;
5502 $what2 =~ s|Bundle[/\\]||;
5507 my($file) = /(\S+)/;
5508 if ($file =~ m|\Q$what\E$|) {
5510 # return File::Spec->catfile($where,$bu); # bad
5513 # retry if she managed to
5514 # have no Bundle directory
5515 $bu = $file if $file =~ m|\Q$what2\E$|;
5517 $bu =~ tr|/|:| if $^O eq 'MacOS';
5518 return File::Spec->catfile($where, $bu) if $bu;
5519 Carp::croak("Couldn't find a Bundle file in $where");
5522 # needs to work quite differently from Module::inst_file because of
5523 # cpan_home/Bundle/ directory and the possibility that we have
5524 # shadowing effect. As it makes no sense to take the first in @INC for
5525 # Bundles, we parse them all for $VERSION and take the newest.
5527 #-> sub CPAN::Bundle::inst_file ;
5532 @me = split /::/, $self->id;
5535 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5536 my $bfile = File::Spec->catfile($incdir, @me);
5537 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5538 next unless -f $bfile;
5539 my $foundv = MM->parse_version($bfile);
5540 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5541 $self->{INST_FILE} = $bfile;
5542 $self->{INST_VERSION} = $bestv = $foundv;
5548 #-> sub CPAN::Bundle::inst_version ;
5551 $self->inst_file; # finds INST_VERSION as side effect
5552 $self->{INST_VERSION};
5555 #-> sub CPAN::Bundle::rematein ;
5557 my($self,$meth) = @_;
5558 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5559 my($id) = $self->id;
5560 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5561 unless $self->inst_file || $self->cpan_file;
5563 for $s ($self->contains) {
5564 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5565 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5566 if ($type eq 'CPAN::Distribution') {
5567 $CPAN::Frontend->mywarn(qq{
5568 The Bundle }.$self->id.qq{ contains
5569 explicitly a file $s.
5573 # possibly noisy action:
5574 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5575 my $obj = $CPAN::META->instance($type,$s);
5577 if ($obj->isa('CPAN::Bundle')
5579 exists $obj->{install_failed}
5581 ref($obj->{install_failed}) eq "HASH"
5583 for (keys %{$obj->{install_failed}}) {
5584 $self->{install_failed}{$_} = undef; # propagate faiure up
5587 $fail{$s} = 1; # the bundle itself may have succeeded but
5592 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5593 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5595 delete $self->{install_failed}{$s};
5602 # recap with less noise
5603 if ( $meth eq "install" ) {
5606 my $raw = sprintf(qq{Bundle summary:
5607 The following items in bundle %s had installation problems:},
5610 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5611 $CPAN::Frontend->myprint("\n");
5614 for $s ($self->contains) {
5616 $paragraph .= "$s ";
5617 $self->{install_failed}{$s} = undef;
5618 $reported{$s} = undef;
5621 my $report_propagated;
5622 for $s (sort keys %{$self->{install_failed}}) {
5623 next if exists $reported{$s};
5624 $paragraph .= "and the following items had problems
5625 during recursive bundle calls: " unless $report_propagated++;
5626 $paragraph .= "$s ";
5628 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5629 $CPAN::Frontend->myprint("\n");
5631 $self->{'install'} = 'YES';
5636 #sub CPAN::Bundle::xs_file
5638 # If a bundle contains another that contains an xs_file we have
5639 # here, we just don't bother I suppose
5643 #-> sub CPAN::Bundle::force ;
5644 sub force { shift->rematein('force',@_); }
5645 #-> sub CPAN::Bundle::notest ;
5646 sub notest { shift->rematein('notest',@_); }
5647 #-> sub CPAN::Bundle::get ;
5648 sub get { shift->rematein('get',@_); }
5649 #-> sub CPAN::Bundle::make ;
5650 sub make { shift->rematein('make',@_); }
5651 #-> sub CPAN::Bundle::test ;
5654 $self->{badtestcnt} ||= 0;
5655 $self->rematein('test',@_);
5657 #-> sub CPAN::Bundle::install ;
5660 $self->rematein('install',@_);
5662 #-> sub CPAN::Bundle::clean ;
5663 sub clean { shift->rematein('clean',@_); }
5665 #-> sub CPAN::Bundle::uptodate ;
5668 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5670 foreach $c ($self->contains) {
5671 my $obj = CPAN::Shell->expandany($c);
5672 return 0 unless $obj->uptodate;
5677 #-> sub CPAN::Bundle::readme ;
5680 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5681 No File found for bundle } . $self->id . qq{\n}), return;
5682 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5683 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5686 package CPAN::Module;
5690 # sub CPAN::Module::userid
5695 return $ro->{userid} || $ro->{CPAN_USERID};
5697 # sub CPAN::Module::description
5698 sub description { shift->ro->{description} }
5702 delete $self->{later};
5703 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5708 # mark as dirty/clean
5709 #-> sub CPAN::Module::color_cmd_tmps ;
5710 sub color_cmd_tmps {
5712 my($depth) = shift || 0;
5713 my($color) = shift || 0;
5714 my($ancestors) = shift || [];
5715 # a module needs to recurse to its cpan_file
5717 return if exists $self->{incommandcolor}
5718 && $self->{incommandcolor}==$color;
5719 return if $depth>=1 && $self->uptodate;
5721 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5723 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5725 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5726 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5729 delete $self->{badtestcnt};
5731 $self->{incommandcolor} = $color;
5734 #-> sub CPAN::Module::as_glimpse ;
5738 my $class = ref($self);
5739 $class =~ s/^CPAN:://;
5743 $CPAN::Shell::COLOR_REGISTERED
5745 $CPAN::META->has_inst("Term::ANSIColor")
5749 $color_on = Term::ANSIColor::color("green");
5750 $color_off = Term::ANSIColor::color("reset");
5752 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5761 #-> sub CPAN::Module::as_string ;
5765 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5766 my $class = ref($self);
5767 $class =~ s/^CPAN:://;
5769 push @m, $class, " id = $self->{ID}\n";
5770 my $sprintf = " %-12s %s\n";
5771 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5772 if $self->description;
5773 my $sprintf2 = " %-12s %s (%s)\n";
5775 $userid = $self->userid;
5778 if ($author = CPAN::Shell->expand('Author',$userid)) {
5781 if ($m = $author->email) {
5788 $author->fullname . $email
5792 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5793 if $self->cpan_version;
5794 if (my $cpan_file = $self->cpan_file){
5795 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
5796 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
5797 my $upload_date = $dist->upload_date;
5799 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
5803 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5804 my(%statd,%stats,%statl,%stati);
5805 @statd{qw,? i c a b R M S,} = qw,unknown idea
5806 pre-alpha alpha beta released mature standard,;
5807 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5808 developer comp.lang.perl.* none abandoned,;
5809 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5810 @stati{qw,? f r O h,} = qw,unknown functions
5811 references+ties object-oriented hybrid,;
5812 $statd{' '} = 'unknown';
5813 $stats{' '} = 'unknown';
5814 $statl{' '} = 'unknown';
5815 $stati{' '} = 'unknown';
5824 $statd{$ro->{statd}},
5825 $stats{$ro->{stats}},
5826 $statl{$ro->{statl}},
5827 $stati{$ro->{stati}}
5829 my $local_file = $self->inst_file;
5830 unless ($self->{MANPAGE}) {
5832 $self->{MANPAGE} = $self->manpage_headline($local_file);
5834 # If we have already untarred it, we should look there
5835 my $dist = $CPAN::META->instance('CPAN::Distribution',
5837 # warn "dist[$dist]";
5838 # mff=manifest file; mfh=manifest handle
5843 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5845 $mfh = FileHandle->new($mff)
5847 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5848 my $lfre = $self->id; # local file RE
5851 my($lfl); # local file file
5853 my(@mflines) = <$mfh>;
5858 while (length($lfre)>5 and !$lfl) {
5859 ($lfl) = grep /$lfre/, @mflines;
5860 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5863 $lfl =~ s/\s.*//; # remove comments
5864 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5865 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5866 # warn "lfl_abs[$lfl_abs]";
5868 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5874 for $item (qw/MANPAGE/) {
5875 push @m, sprintf($sprintf, $item, $self->{$item})
5876 if exists $self->{$item};
5878 for $item (qw/CONTAINS/) {
5879 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5880 if exists $self->{$item} && @{$self->{$item}};
5882 push @m, sprintf($sprintf, 'INST_FILE',
5883 $local_file || "(not installed)");
5884 push @m, sprintf($sprintf, 'INST_VERSION',
5885 $self->inst_version) if $local_file;
5889 sub manpage_headline {
5890 my($self,$local_file) = @_;
5891 my(@local_file) = $local_file;
5892 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5893 push @local_file, $local_file;
5895 for $locf (@local_file) {
5896 next unless -f $locf;
5897 my $fh = FileHandle->new($locf)
5898 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5902 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5903 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5916 #-> sub CPAN::Module::cpan_file ;
5917 # Note: also inherited by CPAN::Bundle
5920 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5921 unless ($self->ro) {
5922 CPAN::Index->reload;
5925 if ($ro && defined $ro->{CPAN_FILE}){
5926 return $ro->{CPAN_FILE};
5928 my $userid = $self->userid;
5930 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5931 my $author = $CPAN::META->instance("CPAN::Author",
5933 my $fullname = $author->fullname;
5934 my $email = $author->email;
5935 unless (defined $fullname && defined $email) {
5936 return sprintf("Contact Author %s",
5940 return "Contact Author $fullname <$email>";
5942 return "Contact Author $userid (Email address not available)";
5950 #-> sub CPAN::Module::cpan_version ;
5956 # Can happen with modules that are not on CPAN
5959 $ro->{CPAN_VERSION} = 'undef'
5960 unless defined $ro->{CPAN_VERSION};
5961 $ro->{CPAN_VERSION};
5964 #-> sub CPAN::Module::force ;
5967 $self->{'force_update'}++;
5972 # warn "XDEBUG: set notest for Module";
5973 $self->{'notest'}++;
5976 #-> sub CPAN::Module::rematein ;
5978 my($self,$meth) = @_;
5979 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5982 my $cpan_file = $self->cpan_file;
5983 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5984 $CPAN::Frontend->mywarn(sprintf qq{
5985 The module %s isn\'t available on CPAN.
5987 Either the module has not yet been uploaded to CPAN, or it is
5988 temporary unavailable. Please contact the author to find out
5989 more about the status. Try 'i %s'.
5996 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5997 $pack->called_for($self->id);
5998 $pack->force($meth) if exists $self->{'force_update'};
5999 $pack->notest($meth) if exists $self->{'notest'};
6004 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
6005 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
6006 delete $self->{'force_update'};
6007 delete $self->{'notest'};
6013 #-> sub CPAN::Module::perldoc ;
6014 sub perldoc { shift->rematein('perldoc') }
6015 #-> sub CPAN::Module::readme ;
6016 sub readme { shift->rematein('readme') }
6017 #-> sub CPAN::Module::look ;
6018 sub look { shift->rematein('look') }
6019 #-> sub CPAN::Module::cvs_import ;
6020 sub cvs_import { shift->rematein('cvs_import') }
6021 #-> sub CPAN::Module::get ;
6022 sub get { shift->rematein('get',@_) }
6023 #-> sub CPAN::Module::make ;
6024 sub make { shift->rematein('make') }
6025 #-> sub CPAN::Module::test ;
6028 $self->{badtestcnt} ||= 0;
6029 $self->rematein('test',@_);
6031 #-> sub CPAN::Module::uptodate ;
6034 my($latest) = $self->cpan_version;
6036 my($inst_file) = $self->inst_file;
6038 if (defined $inst_file) {
6039 $have = $self->inst_version;
6044 ! CPAN::Version->vgt($latest, $have)
6046 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
6047 "latest[$latest] have[$have]") if $CPAN::DEBUG;
6052 #-> sub CPAN::Module::install ;
6058 not exists $self->{'force_update'}
6060 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
6062 $self->inst_version,
6068 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
6069 $CPAN::Frontend->mywarn(qq{
6070 \n\n\n ***WARNING***
6071 The module $self->{ID} has no active maintainer.\n\n\n
6075 $self->rematein('install') if $doit;
6077 #-> sub CPAN::Module::clean ;
6078 sub clean { shift->rematein('clean') }
6080 #-> sub CPAN::Module::inst_file ;
6084 @packpath = split /::/, $self->{ID};
6085 $packpath[-1] .= ".pm";
6086 foreach $dir (@INC) {
6087 my $pmfile = File::Spec->catfile($dir,@packpath);
6095 #-> sub CPAN::Module::xs_file ;
6099 @packpath = split /::/, $self->{ID};
6100 push @packpath, $packpath[-1];
6101 $packpath[-1] .= "." . $Config::Config{'dlext'};
6102 foreach $dir (@INC) {
6103 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
6111 #-> sub CPAN::Module::inst_version ;
6114 my $parsefile = $self->inst_file or return;
6115 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
6118 # there was a bug in 5.6.0 that let lots of unini warnings out of
6119 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
6120 # the following workaround after 5.6.1 is out.
6121 local($SIG{__WARN__}) = sub { my $w = shift;
6122 return if $w =~ /uninitialized/i;
6126 $have = MM->parse_version($parsefile) || "undef";
6127 $have =~ s/^ //; # since the %vd hack these two lines here are needed
6128 $have =~ s/ $//; # trailing whitespace happens all the time
6130 # My thoughts about why %vd processing should happen here
6132 # Alt1 maintain it as string with leading v:
6133 # read index files do nothing
6134 # compare it use utility for compare
6135 # print it do nothing
6137 # Alt2 maintain it as what it is
6138 # read index files convert
6139 # compare it use utility because there's still a ">" vs "gt" issue
6140 # print it use CPAN::Version for print
6142 # Seems cleaner to hold it in memory as a string starting with a "v"
6144 # If the author of this module made a mistake and wrote a quoted
6145 # "v1.13" instead of v1.13, we simply leave it at that with the
6146 # effect that *we* will treat it like a v-tring while the rest of
6147 # perl won't. Seems sensible when we consider that any action we
6148 # could take now would just add complexity.
6150 $have = CPAN::Version->readable($have);
6152 $have =~ s/\s*//g; # stringify to float around floating point issues
6153 $have; # no stringify needed, \s* above matches always
6165 CPAN - query, download and build perl modules from CPAN sites
6171 perl -MCPAN -e shell;
6177 autobundle, clean, install, make, recompile, test
6181 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6182 of a modern rewrite from ground up with greater extensibility and more
6183 features but no full compatibility. If you're new to CPAN.pm, you
6184 probably should investigate if CPANPLUS is the better choice for you.
6185 If you're already used to CPAN.pm you're welcome to continue using it,
6186 if you accept that its development is mostly (though not completely)
6191 The CPAN module is designed to automate the make and install of perl
6192 modules and extensions. It includes some primitive searching capabilities and
6193 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6194 to fetch the raw data from the net.
6196 Modules are fetched from one or more of the mirrored CPAN
6197 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6200 The CPAN module also supports the concept of named and versioned
6201 I<bundles> of modules. Bundles simplify the handling of sets of
6202 related modules. See Bundles below.
6204 The package contains a session manager and a cache manager. There is
6205 no status retained between sessions. The session manager keeps track
6206 of what has been fetched, built and installed in the current
6207 session. The cache manager keeps track of the disk space occupied by
6208 the make processes and deletes excess space according to a simple FIFO
6211 For extended searching capabilities there's a plugin for CPAN available,
6212 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6213 that indexes all documents available in CPAN authors directories. If
6214 C<CPAN::WAIT> is installed on your system, the interactive shell of
6215 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6216 which send queries to the WAIT server that has been configured for your
6219 All other methods provided are accessible in a programmer style and in an
6220 interactive shell style.
6222 =head2 Interactive Mode
6224 The interactive mode is entered by running
6226 perl -MCPAN -e shell
6228 which puts you into a readline interface. You will have the most fun if
6229 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6232 Once you are on the command line, type 'h' and the rest should be
6235 The function call C<shell> takes two optional arguments, one is the
6236 prompt, the second is the default initial command line (the latter
6237 only works if a real ReadLine interface module is installed).
6239 The most common uses of the interactive modes are
6243 =item Searching for authors, bundles, distribution files and modules
6245 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6246 for each of the four categories and another, C<i> for any of the
6247 mentioned four. Each of the four entities is implemented as a class
6248 with slightly differing methods for displaying an object.
6250 Arguments you pass to these commands are either strings exactly matching
6251 the identification string of an object or regular expressions that are
6252 then matched case-insensitively against various attributes of the
6253 objects. The parser recognizes a regular expression only if you
6254 enclose it between two slashes.
6256 The principle is that the number of found objects influences how an
6257 item is displayed. If the search finds one item, the result is
6258 displayed with the rather verbose method C<as_string>, but if we find
6259 more than one, we display each object with the terse method
6262 =item make, test, install, clean modules or distributions
6264 These commands take any number of arguments and investigate what is
6265 necessary to perform the action. If the argument is a distribution
6266 file name (recognized by embedded slashes), it is processed. If it is
6267 a module, CPAN determines the distribution file in which this module
6268 is included and processes that, following any dependencies named in
6269 the module's META.yml or Makefile.PL (this behavior is controlled by
6270 I<prerequisites_policy>.)
6272 Any C<make> or C<test> are run unconditionally. An
6274 install <distribution_file>
6276 also is run unconditionally. But for
6280 CPAN checks if an install is actually needed for it and prints
6281 I<module up to date> in the case that the distribution file containing
6282 the module doesn't need to be updated.
6284 CPAN also keeps track of what it has done within the current session
6285 and doesn't try to build a package a second time regardless if it
6286 succeeded or not. The C<force> pragma may precede another command
6287 (currently: C<make>, C<test>, or C<install>) and executes the
6288 command from scratch.
6292 cpan> install OpenGL
6293 OpenGL is up to date.
6294 cpan> force install OpenGL
6297 OpenGL-0.4/COPYRIGHT
6300 The C<notest> pragma may be set to skip the test part in the build
6305 cpan> notest install Tk
6307 A C<clean> command results in a
6311 being executed within the distribution file's working directory.
6313 =item get, readme, perldoc, look module or distribution
6315 C<get> downloads a distribution file without further action. C<readme>
6316 displays the README file of the associated distribution. C<Look> gets
6317 and untars (if not yet done) the distribution file, changes to the
6318 appropriate directory and opens a subshell process in that directory.
6319 C<perldoc> displays the pod documentation of the module in html or
6324 =item ls globbing_expresion
6326 The first form lists all distribution files in and below an author's
6327 CPAN directory as they are stored in the CHECKUMS files distrbute on
6330 The second form allows to limit or expand the output with shell
6331 globbing as in the following examples:
6337 The last example is very slow and outputs extra progress indicators
6338 that break the alignment of the result.
6342 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6343 in the cpan-shell it is intended that you can press C<^C> anytime and
6344 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6345 to clean up and leave the shell loop. You can emulate the effect of a
6346 SIGTERM by sending two consecutive SIGINTs, which usually means by
6347 pressing C<^C> twice.
6349 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6350 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
6351 Build.PL> subprocess.
6357 The commands that are available in the shell interface are methods in
6358 the package CPAN::Shell. If you enter the shell command, all your
6359 input is split by the Text::ParseWords::shellwords() routine which
6360 acts like most shells do. The first word is being interpreted as the
6361 method to be called and the rest of the words are treated as arguments
6362 to this method. Continuation lines are supported if a line ends with a
6367 C<autobundle> writes a bundle file into the
6368 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6369 a list of all modules that are both available from CPAN and currently
6370 installed within @INC. The name of the bundle file is based on the
6371 current date and a counter.
6375 recompile() is a very special command in that it takes no argument and
6376 runs the make/test/install cycle with brute force over all installed
6377 dynamically loadable extensions (aka XS modules) with 'force' in
6378 effect. The primary purpose of this command is to finish a network
6379 installation. Imagine, you have a common source tree for two different
6380 architectures. You decide to do a completely independent fresh
6381 installation. You start on one architecture with the help of a Bundle
6382 file produced earlier. CPAN installs the whole Bundle for you, but
6383 when you try to repeat the job on the second architecture, CPAN
6384 responds with a C<"Foo up to date"> message for all modules. So you
6385 invoke CPAN's recompile on the second architecture and you're done.
6387 Another popular use for C<recompile> is to act as a rescue in case your
6388 perl breaks binary compatibility. If one of the modules that CPAN uses
6389 is in turn depending on binary compatibility (so you cannot run CPAN
6390 commands), then you should try the CPAN::Nox module for recovery.
6392 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6394 Although it may be considered internal, the class hierarchy does matter
6395 for both users and programmer. CPAN.pm deals with above mentioned four
6396 classes, and all those classes share a set of methods. A classical
6397 single polymorphism is in effect. A metaclass object registers all
6398 objects of all kinds and indexes them with a string. The strings
6399 referencing objects have a separated namespace (well, not completely
6404 words containing a "/" (slash) Distribution
6405 words starting with Bundle:: Bundle
6406 everything else Module or Author
6408 Modules know their associated Distribution objects. They always refer
6409 to the most recent official release. Developers may mark their releases
6410 as unstable development versions (by inserting an underbar into the
6411 module version number which will also be reflected in the distribution
6412 name when you run 'make dist'), so the really hottest and newest
6413 distribution is not always the default. If a module Foo circulates
6414 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6415 way to install version 1.23 by saying
6419 This would install the complete distribution file (say
6420 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6421 like to install version 1.23_90, you need to know where the
6422 distribution file resides on CPAN relative to the authors/id/
6423 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6424 so you would have to say
6426 install BAR/Foo-1.23_90.tar.gz
6428 The first example will be driven by an object of the class
6429 CPAN::Module, the second by an object of class CPAN::Distribution.
6431 =head2 Programmer's interface
6433 If you do not enter the shell, the available shell commands are both
6434 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6435 functions in the calling package (C<install(...)>).
6437 There's currently only one class that has a stable interface -
6438 CPAN::Shell. All commands that are available in the CPAN shell are
6439 methods of the class CPAN::Shell. Each of the commands that produce
6440 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6441 the IDs of all modules within the list.
6445 =item expand($type,@things)
6447 The IDs of all objects available within a program are strings that can
6448 be expanded to the corresponding real objects with the
6449 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6450 list of CPAN::Module objects according to the C<@things> arguments
6451 given. In scalar context it only returns the first element of the
6454 =item expandany(@things)
6456 Like expand, but returns objects of the appropriate type, i.e.
6457 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6458 CPAN::Distribution objects fro distributions.
6460 =item Programming Examples
6462 This enables the programmer to do operations that combine
6463 functionalities that are available in the shell.
6465 # install everything that is outdated on my disk:
6466 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6468 # install my favorite programs if necessary:
6469 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
6470 my $obj = CPAN::Shell->expand('Module',$mod);
6474 # list all modules on my disk that have no VERSION number
6475 for $mod (CPAN::Shell->expand("Module","/./")){
6476 next unless $mod->inst_file;
6477 # MakeMaker convention for undefined $VERSION:
6478 next unless $mod->inst_version eq "undef";
6479 print "No VERSION in ", $mod->id, "\n";
6482 # find out which distribution on CPAN contains a module:
6483 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6485 Or if you want to write a cronjob to watch The CPAN, you could list
6486 all modules that need updating. First a quick and dirty way:
6488 perl -e 'use CPAN; CPAN::Shell->r;'
6490 If you don't want to get any output in the case that all modules are
6491 up to date, you can parse the output of above command for the regular
6492 expression //modules are up to date// and decide to mail the output
6493 only if it doesn't match. Ick?
6495 If you prefer to do it more in a programmer style in one single
6496 process, maybe something like this suits you better:
6498 # list all modules on my disk that have newer versions on CPAN
6499 for $mod (CPAN::Shell->expand("Module","/./")){
6500 next unless $mod->inst_file;
6501 next if $mod->uptodate;
6502 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6503 $mod->id, $mod->inst_version, $mod->cpan_version;
6506 If that gives you too much output every day, you maybe only want to
6507 watch for three modules. You can write
6509 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6511 as the first line instead. Or you can combine some of the above
6514 # watch only for a new mod_perl module
6515 $mod = CPAN::Shell->expand("Module","mod_perl");
6516 exit if $mod->uptodate;
6517 # new mod_perl arrived, let me know all update recommendations
6522 =head2 Methods in the other Classes
6524 The programming interface for the classes CPAN::Module,
6525 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6526 beta and partially even alpha. In the following paragraphs only those
6527 methods are documented that have proven useful over a longer time and
6528 thus are unlikely to change.
6532 =item CPAN::Author::as_glimpse()
6534 Returns a one-line description of the author
6536 =item CPAN::Author::as_string()
6538 Returns a multi-line description of the author
6540 =item CPAN::Author::email()
6542 Returns the author's email address
6544 =item CPAN::Author::fullname()
6546 Returns the author's name
6548 =item CPAN::Author::name()
6550 An alias for fullname
6552 =item CPAN::Bundle::as_glimpse()
6554 Returns a one-line description of the bundle
6556 =item CPAN::Bundle::as_string()
6558 Returns a multi-line description of the bundle
6560 =item CPAN::Bundle::clean()
6562 Recursively runs the C<clean> method on all items contained in the bundle.
6564 =item CPAN::Bundle::contains()
6566 Returns a list of objects' IDs contained in a bundle. The associated
6567 objects may be bundles, modules or distributions.
6569 =item CPAN::Bundle::force($method,@args)
6571 Forces CPAN to perform a task that normally would have failed. Force
6572 takes as arguments a method name to be called and any number of
6573 additional arguments that should be passed to the called method. The
6574 internals of the object get the needed changes so that CPAN.pm does
6575 not refuse to take the action. The C<force> is passed recursively to
6576 all contained objects.
6578 =item CPAN::Bundle::get()
6580 Recursively runs the C<get> method on all items contained in the bundle
6582 =item CPAN::Bundle::inst_file()
6584 Returns the highest installed version of the bundle in either @INC or
6585 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6586 CPAN::Module::inst_file.
6588 =item CPAN::Bundle::inst_version()
6590 Like CPAN::Bundle::inst_file, but returns the $VERSION
6592 =item CPAN::Bundle::uptodate()
6594 Returns 1 if the bundle itself and all its members are uptodate.
6596 =item CPAN::Bundle::install()
6598 Recursively runs the C<install> method on all items contained in the bundle
6600 =item CPAN::Bundle::make()
6602 Recursively runs the C<make> method on all items contained in the bundle
6604 =item CPAN::Bundle::readme()
6606 Recursively runs the C<readme> method on all items contained in the bundle
6608 =item CPAN::Bundle::test()
6610 Recursively runs the C<test> method on all items contained in the bundle
6612 =item CPAN::Distribution::as_glimpse()
6614 Returns a one-line description of the distribution
6616 =item CPAN::Distribution::as_string()
6618 Returns a multi-line description of the distribution
6620 =item CPAN::Distribution::clean()
6622 Changes to the directory where the distribution has been unpacked and
6623 runs C<make clean> there.
6625 =item CPAN::Distribution::containsmods()
6627 Returns a list of IDs of modules contained in a distribution file.
6628 Only works for distributions listed in the 02packages.details.txt.gz
6629 file. This typically means that only the most recent version of a
6630 distribution is covered.
6632 =item CPAN::Distribution::cvs_import()
6634 Changes to the directory where the distribution has been unpacked and
6637 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6641 =item CPAN::Distribution::dir()
6643 Returns the directory into which this distribution has been unpacked.
6645 =item CPAN::Distribution::force($method,@args)
6647 Forces CPAN to perform a task that normally would have failed. Force
6648 takes as arguments a method name to be called and any number of
6649 additional arguments that should be passed to the called method. The
6650 internals of the object get the needed changes so that CPAN.pm does
6651 not refuse to take the action.
6653 =item CPAN::Distribution::get()
6655 Downloads the distribution from CPAN and unpacks it. Does nothing if
6656 the distribution has already been downloaded and unpacked within the
6659 =item CPAN::Distribution::install()
6661 Changes to the directory where the distribution has been unpacked and
6662 runs the external command C<make install> there. If C<make> has not
6663 yet been run, it will be run first. A C<make test> will be issued in
6664 any case and if this fails, the install will be canceled. The
6665 cancellation can be avoided by letting C<force> run the C<install> for
6668 =item CPAN::Distribution::isa_perl()
6670 Returns 1 if this distribution file seems to be a perl distribution.
6671 Normally this is derived from the file name only, but the index from
6672 CPAN can contain a hint to achieve a return value of true for other
6675 =item CPAN::Distribution::look()
6677 Changes to the directory where the distribution has been unpacked and
6678 opens a subshell there. Exiting the subshell returns.
6680 =item CPAN::Distribution::make()
6682 First runs the C<get> method to make sure the distribution is
6683 downloaded and unpacked. Changes to the directory where the
6684 distribution has been unpacked and runs the external commands C<perl
6685 Makefile.PL> or C<perl Build.PL> and C<make> there.
6687 =item CPAN::Distribution::prereq_pm()
6689 Returns the hash reference that has been announced by a distribution
6690 as the C<requires> element of the META.yml or the C<PREREQ_PM> hash in
6691 the C<Makefile.PL>. Note: works only after an attempt has been made to
6692 C<make> the distribution. Returns undef otherwise.
6694 =item CPAN::Distribution::readme()
6696 Downloads the README file associated with a distribution and runs it
6697 through the pager specified in C<$CPAN::Config->{pager}>.
6699 =item CPAN::Distribution::perldoc()
6701 Downloads the pod documentation of the file associated with a
6702 distribution (in html format) and runs it through the external
6703 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
6704 isn't available, it converts it to plain text with external
6705 command html2text and runs it through the pager specified
6706 in C<$CPAN::Config->{pager}>
6708 =item CPAN::Distribution::test()
6710 Changes to the directory where the distribution has been unpacked and
6711 runs C<make test> there.
6713 =item CPAN::Distribution::uptodate()
6715 Returns 1 if all the modules contained in the distribution are
6716 uptodate. Relies on containsmods.
6718 =item CPAN::Index::force_reload()
6720 Forces a reload of all indices.
6722 =item CPAN::Index::reload()
6724 Reloads all indices if they have not been read for more than
6725 C<$CPAN::Config->{index_expire}> days.
6727 =item CPAN::InfoObj::dump()
6729 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6730 inherit this method. It prints the data structure associated with an
6731 object. Useful for debugging. Note: the data structure is considered
6732 internal and thus subject to change without notice.
6734 =item CPAN::Module::as_glimpse()
6736 Returns a one-line description of the module
6738 =item CPAN::Module::as_string()
6740 Returns a multi-line description of the module
6742 =item CPAN::Module::clean()
6744 Runs a clean on the distribution associated with this module.
6746 =item CPAN::Module::cpan_file()
6748 Returns the filename on CPAN that is associated with the module.
6750 =item CPAN::Module::cpan_version()
6752 Returns the latest version of this module available on CPAN.
6754 =item CPAN::Module::cvs_import()
6756 Runs a cvs_import on the distribution associated with this module.
6758 =item CPAN::Module::description()
6760 Returns a 44 character description of this module. Only available for
6761 modules listed in The Module List (CPAN/modules/00modlist.long.html
6762 or 00modlist.long.txt.gz)
6764 =item CPAN::Module::force($method,@args)
6766 Forces CPAN to perform a task that normally would have failed. Force
6767 takes as arguments a method name to be called and any number of
6768 additional arguments that should be passed to the called method. The
6769 internals of the object get the needed changes so that CPAN.pm does
6770 not refuse to take the action.
6772 =item CPAN::Module::get()
6774 Runs a get on the distribution associated with this module.
6776 =item CPAN::Module::inst_file()
6778 Returns the filename of the module found in @INC. The first file found
6779 is reported just like perl itself stops searching @INC when it finds a
6782 =item CPAN::Module::inst_version()
6784 Returns the version number of the module in readable format.
6786 =item CPAN::Module::install()
6788 Runs an C<install> on the distribution associated with this module.
6790 =item CPAN::Module::look()
6792 Changes to the directory where the distribution associated with this
6793 module has been unpacked and opens a subshell there. Exiting the
6796 =item CPAN::Module::make()
6798 Runs a C<make> on the distribution associated with this module.
6800 =item CPAN::Module::manpage_headline()
6802 If module is installed, peeks into the module's manpage, reads the
6803 headline and returns it. Moreover, if the module has been downloaded
6804 within this session, does the equivalent on the downloaded module even
6805 if it is not installed.
6807 =item CPAN::Module::readme()
6809 Runs a C<readme> on the distribution associated with this module.
6811 =item CPAN::Module::perldoc()
6813 Runs a C<perldoc> on this module.
6815 =item CPAN::Module::test()
6817 Runs a C<test> on the distribution associated with this module.
6819 =item CPAN::Module::uptodate()
6821 Returns 1 if the module is installed and up-to-date.
6823 =item CPAN::Module::userid()
6825 Returns the author's ID of the module.
6829 =head2 Cache Manager
6831 Currently the cache manager only keeps track of the build directory
6832 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6833 deletes complete directories below C<build_dir> as soon as the size of
6834 all directories there gets bigger than $CPAN::Config->{build_cache}
6835 (in MB). The contents of this cache may be used for later
6836 re-installations that you intend to do manually, but will never be
6837 trusted by CPAN itself. This is due to the fact that the user might
6838 use these directories for building modules on different architectures.
6840 There is another directory ($CPAN::Config->{keep_source_where}) where
6841 the original distribution files are kept. This directory is not
6842 covered by the cache manager and must be controlled by the user. If
6843 you choose to have the same directory as build_dir and as
6844 keep_source_where directory, then your sources will be deleted with
6845 the same fifo mechanism.
6849 A bundle is just a perl module in the namespace Bundle:: that does not
6850 define any functions or methods. It usually only contains documentation.
6852 It starts like a perl module with a package declaration and a $VERSION
6853 variable. After that the pod section looks like any other pod with the
6854 only difference being that I<one special pod section> exists starting with
6859 In this pod section each line obeys the format
6861 Module_Name [Version_String] [- optional text]
6863 The only required part is the first field, the name of a module
6864 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6865 of the line is optional. The comment part is delimited by a dash just
6866 as in the man page header.
6868 The distribution of a bundle should follow the same convention as
6869 other distributions.
6871 Bundles are treated specially in the CPAN package. If you say 'install
6872 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6873 the modules in the CONTENTS section of the pod. You can install your
6874 own Bundles locally by placing a conformant Bundle file somewhere into
6875 your @INC path. The autobundle() command which is available in the
6876 shell interface does that for you by including all currently installed
6877 modules in a snapshot bundle file.
6879 =head2 Prerequisites
6881 If you have a local mirror of CPAN and can access all files with
6882 "file:" URLs, then you only need a perl better than perl5.003 to run
6883 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6884 required for non-UNIX systems or if your nearest CPAN site is
6885 associated with a URL that is not C<ftp:>.
6887 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6888 implemented for an external ftp command or for an external lynx
6891 =head2 Finding packages and VERSION
6893 This module presumes that all packages on CPAN
6899 declare their $VERSION variable in an easy to parse manner. This
6900 prerequisite can hardly be relaxed because it consumes far too much
6901 memory to load all packages into the running program just to determine
6902 the $VERSION variable. Currently all programs that are dealing with
6903 version use something like this
6905 perl -MExtUtils::MakeMaker -le \
6906 'print MM->parse_version(shift)' filename
6908 If you are author of a package and wonder if your $VERSION can be
6909 parsed, please try the above method.
6913 come as compressed or gzipped tarfiles or as zip files and contain a
6914 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
6915 without much enthusiasm).
6921 The debugging of this module is a bit complex, because we have
6922 interferences of the software producing the indices on CPAN, of the
6923 mirroring process on CPAN, of packaging, of configuration, of
6924 synchronicity, and of bugs within CPAN.pm.
6926 For code debugging in interactive mode you can try "o debug" which
6927 will list options for debugging the various parts of the code. You
6928 should know that "o debug" has built-in completion support.
6930 For data debugging there is the C<dump> command which takes the same
6931 arguments as make/test/install and outputs the object's Data::Dumper
6934 =head2 Floppy, Zip, Offline Mode
6936 CPAN.pm works nicely without network too. If you maintain machines
6937 that are not networked at all, you should consider working with file:
6938 URLs. Of course, you have to collect your modules somewhere first. So
6939 you might use CPAN.pm to put together all you need on a networked
6940 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6941 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6942 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6943 with this floppy. See also below the paragraph about CD-ROM support.
6945 =head1 CONFIGURATION
6947 When the CPAN module is used for the first time, a configuration
6948 dialog tries to determine a couple of site specific options. The
6949 result of the dialog is stored in a hash reference C< $CPAN::Config >
6950 in a file CPAN/Config.pm.
6952 The default values defined in the CPAN/Config.pm file can be
6953 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6954 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6955 added to the search path of the CPAN module before the use() or
6956 require() statements.
6958 The configuration dialog can be started any time later again by
6959 issuing the command C< o conf init > in the CPAN shell.
6961 Currently the following keys in the hash reference $CPAN::Config are
6964 build_cache size of cache for directories to build modules
6965 build_dir locally accessible directory to build modules
6966 index_expire after this many days refetch index files
6967 cache_metadata use serializer to cache metadata
6968 cpan_home local directory reserved for this package
6969 dontload_hash anonymous hash: modules in the keys will not be
6970 loaded by the CPAN::has_inst() routine
6971 gzip location of external program gzip
6972 histfile file to maintain history between sessions
6973 histsize maximum number of lines to keep in histfile
6974 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
6975 after this many seconds inactivity. Set to 0 to
6977 inhibit_startup_message
6978 if true, does not print the startup message
6979 keep_source_where directory in which to keep the source (if we do)
6980 make location of external make program
6981 make_arg arguments that should always be passed to 'make'
6982 make_install_make_command
6983 the make command for running 'make install', for
6985 make_install_arg same as make_arg for 'make install'
6986 makepl_arg arguments passed to 'perl Makefile.PL'
6987 mbuild_arg arguments passed to './Build'
6988 mbuild_install_arg arguments passed to './Build install'
6989 mbuild_install_build_command
6990 command to use instead of './Build' when we are
6991 in the install stage, for example 'sudo ./Build'
6992 mbuildpl_arg arguments passed to 'perl Build.PL'
6993 pager location of external program more (or any pager)
6994 prefer_installer legal values are MB and EUMM: if a module
6995 comes with both a Makefile.PL and a Build.PL, use
6996 the former (EUMM) or the latter (MB)
6997 prerequisites_policy
6998 what to do if you are missing module prerequisites
6999 ('follow' automatically, 'ask' me, or 'ignore')
7000 proxy_user username for accessing an authenticating proxy
7001 proxy_pass password for accessing an authenticating proxy
7002 scan_cache controls scanning of cache ('atstart' or 'never')
7003 tar location of external program tar
7004 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
7005 (and nonsense for characters outside latin range)
7006 unzip location of external program unzip
7007 urllist arrayref to nearby CPAN sites (or equivalent locations)
7008 wait_list arrayref to a wait server to try (See CPAN::WAIT)
7009 ftp_proxy, } the three usual variables for configuring
7010 http_proxy, } proxy requests. Both as CPAN::Config variables
7011 no_proxy } and as environment variables configurable.
7013 You can set and query each of these options interactively in the cpan
7014 shell with the command set defined within the C<o conf> command:
7018 =item C<o conf E<lt>scalar optionE<gt>>
7020 prints the current value of the I<scalar option>
7022 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
7024 Sets the value of the I<scalar option> to I<value>
7026 =item C<o conf E<lt>list optionE<gt>>
7028 prints the current value of the I<list option> in MakeMaker's
7031 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
7033 shifts or pops the array in the I<list option> variable
7035 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
7037 works like the corresponding perl commands.
7041 =head2 Note on urllist parameter's format
7043 urllist parameters are URLs according to RFC 1738. We do a little
7044 guessing if your URL is not compliant, but if you have problems with
7045 file URLs, please try the correct format. Either:
7047 file://localhost/whatever/ftp/pub/CPAN/
7051 file:///home/ftp/pub/CPAN/
7053 =head2 urllist parameter has CD-ROM support
7055 The C<urllist> parameter of the configuration table contains a list of
7056 URLs that are to be used for downloading. If the list contains any
7057 C<file> URLs, CPAN always tries to get files from there first. This
7058 feature is disabled for index files. So the recommendation for the
7059 owner of a CD-ROM with CPAN contents is: include your local, possibly
7060 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
7062 o conf urllist push file://localhost/CDROM/CPAN
7064 CPAN.pm will then fetch the index files from one of the CPAN sites
7065 that come at the beginning of urllist. It will later check for each
7066 module if there is a local copy of the most recent version.
7068 Another peculiarity of urllist is that the site that we could
7069 successfully fetch the last file from automatically gets a preference
7070 token and is tried as the first site for the next request. So if you
7071 add a new site at runtime it may happen that the previously preferred
7072 site will be tried another time. This means that if you want to disallow
7073 a site for the next transfer, it must be explicitly removed from
7078 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
7079 install foreign, unmasked, unsigned code on your machine. We compare
7080 to a checksum that comes from the net just as the distribution file
7081 itself. But we try to make it easy to add security on demand:
7083 =head2 Cryptographically signed modules
7085 Since release 1.77 CPAN.pm has been able to verify cryptographically
7086 signed module distributions using Module::Signature. The CPAN modules
7087 can be signed by their authors, thus giving more security. The simple
7088 unsigned MD5 checksums that were used before by CPAN protect mainly
7089 against accidental file corruption.
7091 You will need to have Module::Signature installed, which in turn
7092 requires that you have at least one of Crypt::OpenPGP module or the
7093 command-line F<gpg> tool installed.
7095 You will also need to be able to connect over the Internet to the public
7096 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
7100 Most functions in package CPAN are exported per default. The reason
7101 for this is that the primary use is intended for the cpan shell or for
7104 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
7106 Populating a freshly installed perl with my favorite modules is pretty
7107 easy if you maintain a private bundle definition file. To get a useful
7108 blueprint of a bundle definition file, the command autobundle can be used
7109 on the CPAN shell command line. This command writes a bundle definition
7110 file for all modules that are installed for the currently running perl
7111 interpreter. It's recommended to run this command only once and from then
7112 on maintain the file manually under a private name, say
7113 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
7115 cpan> install Bundle::my_bundle
7117 then answer a few questions and then go out for a coffee.
7119 Maintaining a bundle definition file means keeping track of two
7120 things: dependencies and interactivity. CPAN.pm sometimes fails on
7121 calculating dependencies because not all modules define all MakeMaker
7122 attributes correctly, so a bundle definition file should specify
7123 prerequisites as early as possible. On the other hand, it's a bit
7124 annoying that many distributions need some interactive configuring. So
7125 what I try to accomplish in my private bundle file is to have the
7126 packages that need to be configured early in the file and the gentle
7127 ones later, so I can go out after a few minutes and leave CPAN.pm
7130 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
7132 Thanks to Graham Barr for contributing the following paragraphs about
7133 the interaction between perl, and various firewall configurations. For
7134 further information on firewalls, it is recommended to consult the
7135 documentation that comes with the ncftp program. If you are unable to
7136 go through the firewall with a simple Perl setup, it is very likely
7137 that you can configure ncftp so that it works for your firewall.
7139 =head2 Three basic types of firewalls
7141 Firewalls can be categorized into three basic types.
7147 This is where the firewall machine runs a web server and to access the
7148 outside world you must do it via the web server. If you set environment
7149 variables like http_proxy or ftp_proxy to a values beginning with http://
7150 or in your web browser you have to set proxy information then you know
7151 you are running an http firewall.
7153 To access servers outside these types of firewalls with perl (even for
7154 ftp) you will need to use LWP.
7158 This where the firewall machine runs an ftp server. This kind of
7159 firewall will only let you access ftp servers outside the firewall.
7160 This is usually done by connecting to the firewall with ftp, then
7161 entering a username like "user@outside.host.com"
7163 To access servers outside these type of firewalls with perl you
7164 will need to use Net::FTP.
7166 =item One way visibility
7168 I say one way visibility as these firewalls try to make themselves look
7169 invisible to the users inside the firewall. An FTP data connection is
7170 normally created by sending the remote server your IP address and then
7171 listening for the connection. But the remote server will not be able to
7172 connect to you because of the firewall. So for these types of firewall
7173 FTP connections need to be done in a passive mode.
7175 There are two that I can think off.
7181 If you are using a SOCKS firewall you will need to compile perl and link
7182 it with the SOCKS library, this is what is normally called a 'socksified'
7183 perl. With this executable you will be able to connect to servers outside
7184 the firewall as if it is not there.
7188 This is the firewall implemented in the Linux kernel, it allows you to
7189 hide a complete network behind one IP address. With this firewall no
7190 special compiling is needed as you can access hosts directly.
7192 For accessing ftp servers behind such firewalls you may need to set
7193 the environment variable C<FTP_PASSIVE> to a true value, e.g.
7195 env FTP_PASSIVE=1 perl -MCPAN -eshell
7199 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
7206 =head2 Configuring lynx or ncftp for going through a firewall
7208 If you can go through your firewall with e.g. lynx, presumably with a
7211 /usr/local/bin/lynx -pscott:tiger
7213 then you would configure CPAN.pm with the command
7215 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7217 That's all. Similarly for ncftp or ftp, you would configure something
7220 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7222 Your mileage may vary...
7230 I installed a new version of module X but CPAN keeps saying,
7231 I have the old version installed
7233 Most probably you B<do> have the old version installed. This can
7234 happen if a module installs itself into a different directory in the
7235 @INC path than it was previously installed. This is not really a
7236 CPAN.pm problem, you would have the same problem when installing the
7237 module manually. The easiest way to prevent this behaviour is to add
7238 the argument C<UNINST=1> to the C<make install> call, and that is why
7239 many people add this argument permanently by configuring
7241 o conf make_install_arg UNINST=1
7245 So why is UNINST=1 not the default?
7247 Because there are people who have their precise expectations about who
7248 may install where in the @INC path and who uses which @INC array. In
7249 fine tuned environments C<UNINST=1> can cause damage.
7253 I want to clean up my mess, and install a new perl along with
7254 all modules I have. How do I go about it?
7256 Run the autobundle command for your old perl and optionally rename the
7257 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7258 with the Configure option prefix, e.g.
7260 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7262 Install the bundle file you produced in the first step with something like
7264 cpan> install Bundle::mybundle
7270 When I install bundles or multiple modules with one command
7271 there is too much output to keep track of.
7273 You may want to configure something like
7275 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7276 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7278 so that STDOUT is captured in a file for later inspection.
7283 I am not root, how can I install a module in a personal directory?
7285 First of all, you will want to use your own configuration, not the one
7286 that your root user installed. The following command sequence is a
7289 % mkdir -p $HOME/.cpan/CPAN
7290 % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
7292 [...answer all questions...]
7294 You will most probably like something like this:
7296 o conf makepl_arg "LIB=~/myperl/lib \
7297 INSTALLMAN1DIR=~/myperl/man/man1 \
7298 INSTALLMAN3DIR=~/myperl/man/man3"
7300 You can make this setting permanent like all C<o conf> settings with
7303 You will have to add ~/myperl/man to the MANPATH environment variable
7304 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7307 use lib "$ENV{HOME}/myperl/lib";
7309 or setting the PERL5LIB environment variable.
7311 Another thing you should bear in mind is that the UNINST parameter
7312 should never be set if you are not root.
7316 How to get a package, unwrap it, and make a change before building it?
7318 look Sybase::Sybperl
7322 I installed a Bundle and had a couple of fails. When I
7323 retried, everything resolved nicely. Can this be fixed to work
7326 The reason for this is that CPAN does not know the dependencies of all
7327 modules when it starts out. To decide about the additional items to
7328 install, it just uses data found in the generated Makefile. An
7329 undetected missing piece breaks the process. But it may well be that
7330 your Bundle installs some prerequisite later than some depending item
7331 and thus your second try is able to resolve everything. Please note,
7332 CPAN.pm does not know the dependency tree in advance and cannot sort
7333 the queue of things to install in a topologically correct order. It
7334 resolves perfectly well IFF all modules declare the prerequisites
7335 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7336 fail and you need to install often, it is recommended to sort the Bundle
7337 definition file manually. It is planned to improve the metadata
7338 situation for dependencies on CPAN in general, but this will still
7343 In our intranet we have many modules for internal use. How
7344 can I integrate these modules with CPAN.pm but without uploading
7345 the modules to CPAN?
7347 Have a look at the CPAN::Site module.
7351 When I run CPAN's shell, I get error msg about line 1 to 4,
7352 setting meta input/output via the /etc/inputrc file.
7354 Some versions of readline are picky about capitalization in the
7355 /etc/inputrc file and specifically RedHat 6.2 comes with a
7356 /etc/inputrc that contains the word C<on> in lowercase. Change the
7357 occurrences of C<on> to C<On> and the bug should disappear.
7361 Some authors have strange characters in their names.
7363 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7364 expecting ISO-8859-1 charset, a converter can be activated by setting
7365 term_is_latin to a true value in your config file. One way of doing so
7368 cpan> ! $CPAN::Config->{term_is_latin}=1
7370 Extended support for converters will be made available as soon as perl
7371 becomes stable with regard to charset issues.
7375 When an install fails for some reason and then I correct the error
7376 condition and retry, CPAN.pm refuses to install the module, saying
7377 C<Already tried without success>.
7379 Use the force pragma like so
7381 force install Foo::Bar
7383 This does a bit more than really needed because it untars the
7384 distribution again and runs make and test and only then install.
7386 Or, if you find this is too fast and you would prefer to do smaller
7391 first and then continue as always. C<Force get> I<forgets> previous
7398 and then 'make install' directly in the subshell.
7400 Or you leave the CPAN shell and start it again.
7402 For the really curious, by accessing internals directly, you I<could>
7404 ! delete CPAN::Shell->expand("Distribution", \
7405 CPAN::Shell->expand("Module","Foo::Bar") \
7406 ->cpan_file)->{install}
7408 but this is neither guaranteed to work in the future nor is it a
7415 If a Makefile.PL requires special customization of libraries, prompts
7416 the user for special input, etc. then you may find CPAN is not able to
7417 build the distribution. In that case it is recommended to attempt the
7418 traditional method of building a Perl module package from a shell, for
7419 example by using the 'look' command to open a subshell in the
7420 distribution's own directory.
7424 Andreas Koenig C<< <andk@cpan.org> >>
7428 Kawai,Takanori provides a Japanese translation of this manpage at
7429 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7433 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
7439 # cperl-indent-level: 4