1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $VERSION = eval $VERSION;
5 # $Id: CPAN.pm,v 1.412 2003/07/31 14:53:04 k Exp $
7 # only used during development:
9 # $Revision = "[".substr(q$Revision: 1.412 $, 10)."]";
16 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
17 use File::Basename ();
23 use Text::ParseWords ();
27 no lib "."; # we need to run chdir all over and we would get at wrong
30 require Mac::BuildTools if $^O eq 'MacOS';
32 END { $End++; &cleanup; }
55 $CPAN::Frontend ||= "CPAN::Shell";
56 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
57 $CPAN::Perl ||= CPAN::find_perl();
63 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
64 $Revision $Signal $End $Suppress_readline $Frontend
65 $Defaultsite $Have_warned);
67 @CPAN::ISA = qw(CPAN::Debug Exporter);
70 autobundle bundle expand force get cvs_import
71 install make readme recompile shell test clean
74 #-> sub CPAN::AUTOLOAD ;
79 @EXPORT{@EXPORT} = '';
80 CPAN::Config->load unless $CPAN::Config_loaded++;
81 if (exists $EXPORT{$l}){
84 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
94 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
95 CPAN::Config->load unless $CPAN::Config_loaded++;
97 my $oprompt = shift || "cpan> ";
98 my $prompt = $oprompt;
99 my $commandline = shift || "";
102 unless ($Suppress_readline) {
103 require Term::ReadLine;
106 $term->ReadLine eq "Term::ReadLine::Stub"
108 $term = Term::ReadLine->new('CPAN Monitor');
110 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
111 my $attribs = $term->Attribs;
112 $attribs->{attempted_completion_function} = sub {
113 &CPAN::Complete::gnu_cpl;
116 $readline::rl_completion_function =
117 $readline::rl_completion_function = 'CPAN::Complete::cpl';
119 if (my $histfile = $CPAN::Config->{'histfile'}) {{
120 unless ($term->can("AddHistory")) {
121 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
124 my($fh) = FileHandle->new;
125 open $fh, "<$histfile" or last;
129 $term->AddHistory($_);
133 # $term->OUT is autoflushed anyway
134 my $odef = select STDERR;
141 # no strict; # I do not recall why no strict was here (2000-09-03)
143 my $cwd = CPAN::anycwd();
144 my $try_detect_readline;
145 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
146 my $rl_avail = $Suppress_readline ? "suppressed" :
147 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
148 "available (try 'install Bundle::CPAN')";
150 $CPAN::Frontend->myprint(
152 cpan shell -- CPAN exploration and modules installation (v%s%s)
160 unless $CPAN::Config->{'inhibit_startup_message'} ;
161 my($continuation) = "";
162 SHELLCOMMAND: while () {
163 if ($Suppress_readline) {
165 last SHELLCOMMAND unless defined ($_ = <> );
168 last SHELLCOMMAND unless
169 defined ($_ = $term->readline($prompt, $commandline));
171 $_ = "$continuation$_" if $continuation;
173 next SHELLCOMMAND if /^$/;
174 $_ = 'h' if /^\s*\?/;
175 if (/^(?:q(?:uit)?|bye|exit)$/i) {
185 use vars qw($import_done);
186 CPAN->import(':DEFAULT') unless $import_done++;
187 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
194 if ($] < 5.00322) { # parsewords had a bug until recently
197 eval { @line = Text::ParseWords::shellwords($_) };
198 warn($@), next SHELLCOMMAND if $@;
199 warn("Text::Parsewords could not parse the line [$_]"),
200 next SHELLCOMMAND unless @line;
202 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
203 my $command = shift @line;
204 eval { CPAN::Shell->$command(@line) };
206 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
207 $CPAN::Frontend->myprint("\n");
212 $commandline = ""; # I do want to be able to pass a default to
213 # shell, but on the second command I see no
216 CPAN::Queue->nullify_queue;
217 if ($try_detect_readline) {
218 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
220 $CPAN::META->has_inst("Term::ReadLine::Perl")
222 delete $INC{"Term/ReadLine.pm"};
224 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
225 require Term::ReadLine;
226 $CPAN::Frontend->myprint("\n$redef subroutines in ".
227 "Term::ReadLine redefined\n");
233 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
236 package CPAN::CacheMgr;
237 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
240 package CPAN::Config;
241 use vars qw(%can $dot_cpan);
244 'commit' => "Commit changes to disk",
245 'defaults' => "Reload defaults from disk",
246 'init' => "Interactive setting of all options",
250 use vars qw($Ua $Thesite $Themethod);
251 @CPAN::FTP::ISA = qw(CPAN::Debug);
253 package CPAN::LWP::UserAgent;
254 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
255 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
257 package CPAN::Complete;
258 @CPAN::Complete::ISA = qw(CPAN::Debug);
259 @CPAN::Complete::COMMANDS = sort qw(
260 ! a b d h i m o q r u autobundle clean dump
261 make test install force readme reload look
263 ) unless @CPAN::Complete::COMMANDS;
266 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
267 @CPAN::Index::ISA = qw(CPAN::Debug);
270 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
273 package CPAN::InfoObj;
274 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
276 package CPAN::Author;
277 @CPAN::Author::ISA = qw(CPAN::InfoObj);
279 package CPAN::Distribution;
280 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
282 package CPAN::Bundle;
283 @CPAN::Bundle::ISA = qw(CPAN::Module);
285 package CPAN::Module;
286 @CPAN::Module::ISA = qw(CPAN::InfoObj);
288 package CPAN::Exception::RecursiveDependency;
289 use overload '""' => "as_string";
296 for my $dep (@$deps) {
298 last if $seen{$dep}++;
300 bless { deps => \@deps }, $class;
305 "\nRecursive dependency detected:\n " .
306 join("\n => ", @{$self->{deps}}) .
307 ".\nCannot continue.\n";
311 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
312 @CPAN::Shell::ISA = qw(CPAN::Debug);
313 $COLOR_REGISTERED ||= 0;
314 $PRINT_ORNAMENTING ||= 0;
316 #-> sub CPAN::Shell::AUTOLOAD ;
318 my($autoload) = $AUTOLOAD;
319 my $class = shift(@_);
320 # warn "autoload[$autoload] class[$class]";
321 $autoload =~ s/.*:://;
322 if ($autoload =~ /^w/) {
323 if ($CPAN::META->has_inst('CPAN::WAIT')) {
324 CPAN::WAIT->$autoload(@_);
326 $CPAN::Frontend->mywarn(qq{
327 Commands starting with "w" require CPAN::WAIT to be installed.
328 Please consider installing CPAN::WAIT to use the fulltext index.
329 For this you just need to type
334 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
340 package CPAN::Tarzip;
341 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
342 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
343 $BUGHUNTING = 0; # released code must have turned off
347 # One use of the queue is to determine if we should or shouldn't
348 # announce the availability of a new CPAN module
350 # Now we try to use it for dependency tracking. For that to happen
351 # we need to draw a dependency tree and do the leaves first. This can
352 # easily be reached by running CPAN.pm recursively, but we don't want
353 # to waste memory and run into deep recursion. So what we can do is
356 # CPAN::Queue is the package where the queue is maintained. Dependencies
357 # often have high priority and must be brought to the head of the queue,
358 # possibly by jumping the queue if they are already there. My first code
359 # attempt tried to be extremely correct. Whenever a module needed
360 # immediate treatment, I either unshifted it to the front of the queue,
361 # or, if it was already in the queue, I spliced and let it bypass the
362 # others. This became a too correct model that made it impossible to put
363 # an item more than once into the queue. Why would you need that? Well,
364 # you need temporary duplicates as the manager of the queue is a loop
367 # (1) looks at the first item in the queue without shifting it off
369 # (2) cares for the item
371 # (3) removes the item from the queue, *even if its agenda failed and
372 # even if the item isn't the first in the queue anymore* (that way
373 # protecting against never ending queues)
375 # So if an item has prerequisites, the installation fails now, but we
376 # want to retry later. That's easy if we have it twice in the queue.
378 # I also expect insane dependency situations where an item gets more
379 # than two lives in the queue. Simplest example is triggered by 'install
380 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
381 # get in the way. I wanted the queue manager to be a dumb servant, not
382 # one that knows everything.
384 # Who would I tell in this model that the user wants to be asked before
385 # processing? I can't attach that information to the module object,
386 # because not modules are installed but distributions. So I'd have to
387 # tell the distribution object that it should ask the user before
388 # processing. Where would the question be triggered then? Most probably
389 # in CPAN::Distribution::rematein.
390 # Hope that makes sense, my head is a bit off:-) -- AK
397 my $self = bless { qmod => $s }, $class;
402 # CPAN::Queue::first ;
408 # CPAN::Queue::delete_first ;
410 my($class,$what) = @_;
412 for my $i (0..$#All) {
413 if ( $All[$i]->{qmod} eq $what ) {
420 # CPAN::Queue::jumpqueue ;
424 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
425 join(",",map {$_->{qmod}} @All),
428 WHAT: for my $what (reverse @what) {
430 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
431 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
432 if ($All[$i]->{qmod} eq $what){
434 if ($jumped > 100) { # one's OK if e.g. just
435 # processing now; more are OK if
436 # user typed it several times
437 $CPAN::Frontend->mywarn(
438 qq{Object [$what] queued more than 100 times, ignoring}
444 my $obj = bless { qmod => $what }, $class;
447 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
448 join(",",map {$_->{qmod}} @All),
453 # CPAN::Queue::exists ;
455 my($self,$what) = @_;
456 my @all = map { $_->{qmod} } @All;
457 my $exists = grep { $_->{qmod} eq $what } @All;
458 # warn "in exists what[$what] all[@all] exists[$exists]";
462 # CPAN::Queue::delete ;
465 @All = grep { $_->{qmod} ne $mod } @All;
468 # CPAN::Queue::nullify_queue ;
477 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
479 # from here on only subs.
480 ################################################################################
482 #-> sub CPAN::all_objects ;
484 my($mgr,$class) = @_;
485 CPAN::Config->load unless $CPAN::Config_loaded++;
486 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
488 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
490 *all = \&all_objects;
492 # Called by shell, not in batch mode. In batch mode I see no risk in
493 # having many processes updating something as installations are
494 # continually checked at runtime. In shell mode I suspect it is
495 # unintentional to open more than one shell at a time
497 #-> sub CPAN::checklock ;
500 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
501 if (-f $lockfile && -M _ > 0) {
502 my $fh = FileHandle->new($lockfile) or
503 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
504 my $otherpid = <$fh>;
505 my $otherhost = <$fh>;
507 if (defined $otherpid && $otherpid) {
510 if (defined $otherhost && $otherhost) {
513 my $thishost = hostname();
514 if (defined $otherhost && defined $thishost &&
515 $otherhost ne '' && $thishost ne '' &&
516 $otherhost ne $thishost) {
517 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
518 "reports other host $otherhost and other process $otherpid.\n".
519 "Cannot proceed.\n"));
521 elsif (defined $otherpid && $otherpid) {
522 return if $$ == $otherpid; # should never happen
523 $CPAN::Frontend->mywarn(
525 There seems to be running another CPAN process (pid $otherpid). Contacting...
527 if (kill 0, $otherpid) {
528 $CPAN::Frontend->mydie(qq{Other job is running.
529 You may want to kill it and delete the lockfile, maybe. On UNIX try:
533 } elsif (-w $lockfile) {
535 ExtUtils::MakeMaker::prompt
536 (qq{Other job not responding. Shall I overwrite }.
537 qq{the lockfile? (Y/N)},"y");
538 $CPAN::Frontend->myexit("Ok, bye\n")
539 unless $ans =~ /^y/i;
542 qq{Lockfile $lockfile not writeable by you. }.
543 qq{Cannot proceed.\n}.
546 qq{ and then rerun us.\n}
550 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
551 "reports other process with ID ".
552 "$otherpid. Cannot proceed.\n"));
555 my $dotcpan = $CPAN::Config->{cpan_home};
556 eval { File::Path::mkpath($dotcpan);};
558 # A special case at least for Jarkko.
563 $symlinkcpan = readlink $dotcpan;
564 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
565 eval { File::Path::mkpath($symlinkcpan); };
569 $CPAN::Frontend->mywarn(qq{
570 Working directory $symlinkcpan created.
574 unless (-d $dotcpan) {
576 Your configuration suggests "$dotcpan" as your
577 CPAN.pm working directory. I could not create this directory due
578 to this error: $firsterror\n};
580 As "$dotcpan" is a symlink to "$symlinkcpan",
581 I tried to create that, but I failed with this error: $seconderror
584 Please make sure the directory exists and is writable.
586 $CPAN::Frontend->mydie($diemess);
590 unless ($fh = FileHandle->new(">$lockfile")) {
591 if ($! =~ /Permission/) {
592 my $incc = $INC{'CPAN/Config.pm'};
593 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
594 $CPAN::Frontend->myprint(qq{
596 Your configuration suggests that CPAN.pm should use a working
598 $CPAN::Config->{cpan_home}
599 Unfortunately we could not create the lock file
601 due to permission problems.
603 Please make sure that the configuration variable
604 \$CPAN::Config->{cpan_home}
605 points to a directory where you can write a .lock file. You can set
606 this variable in either
613 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
615 $fh->print($$, "\n");
616 $fh->print(hostname(), "\n");
617 $self->{LOCK} = $lockfile;
621 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
626 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
627 print "Caught SIGINT\n";
631 # From: Larry Wall <larry@wall.org>
632 # Subject: Re: deprecating SIGDIE
633 # To: perl5-porters@perl.org
634 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
636 # The original intent of __DIE__ was only to allow you to substitute one
637 # kind of death for another on an application-wide basis without respect
638 # to whether you were in an eval or not. As a global backstop, it should
639 # not be used any more lightly (or any more heavily :-) than class
640 # UNIVERSAL. Any attempt to build a general exception model on it should
641 # be politely squashed. Any bug that causes every eval {} to have to be
642 # modified should be not so politely squashed.
644 # Those are my current opinions. It is also my optinion that polite
645 # arguments degenerate to personal arguments far too frequently, and that
646 # when they do, it's because both people wanted it to, or at least didn't
647 # sufficiently want it not to.
651 # global backstop to cleanup if we should really die
652 $SIG{__DIE__} = \&cleanup;
653 $self->debug("Signal handler set.") if $CPAN::DEBUG;
656 #-> sub CPAN::DESTROY ;
658 &cleanup; # need an eval?
661 #-> sub CPAN::anycwd ;
664 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
669 sub cwd {Cwd::cwd();}
671 #-> sub CPAN::getcwd ;
672 sub getcwd {Cwd::getcwd();}
674 #-> sub CPAN::find_perl ;
676 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
677 my $pwd = CPAN::anycwd();
678 my $candidate = File::Spec->catfile($pwd,$^X);
679 $perl ||= $candidate if MM->maybe_command($candidate);
682 my ($component,$perl_name);
683 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
684 PATH_COMPONENT: foreach $component (File::Spec->path(),
685 $Config::Config{'binexp'}) {
686 next unless defined($component) && $component;
687 my($abs) = File::Spec->catfile($component,$perl_name);
688 if (MM->maybe_command($abs)) {
700 #-> sub CPAN::exists ;
702 my($mgr,$class,$id) = @_;
703 CPAN::Config->load unless $CPAN::Config_loaded++;
705 ### Carp::croak "exists called without class argument" unless $class;
707 exists $META->{readonly}{$class}{$id} or
708 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
711 #-> sub CPAN::delete ;
713 my($mgr,$class,$id) = @_;
714 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
715 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
718 #-> sub CPAN::has_usable
719 # has_inst is sometimes too optimistic, we should replace it with this
720 # has_usable whenever a case is given
722 my($self,$mod,$message) = @_;
723 return 1 if $HAS_USABLE->{$mod};
724 my $has_inst = $self->has_inst($mod,$message);
725 return unless $has_inst;
728 LWP => [ # we frequently had "Can't locate object
729 # method "new" via package "LWP::UserAgent" at
730 # (eval 69) line 2006
732 sub {require LWP::UserAgent},
733 sub {require HTTP::Request},
734 sub {require URI::URL},
737 sub {require Net::FTP},
738 sub {require Net::Config},
741 if ($usable->{$mod}) {
742 for my $c (0..$#{$usable->{$mod}}) {
743 my $code = $usable->{$mod}[$c];
744 my $ret = eval { &$code() };
746 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
751 return $HAS_USABLE->{$mod} = 1;
754 #-> sub CPAN::has_inst
756 my($self,$mod,$message) = @_;
757 Carp::croak("CPAN->has_inst() called without an argument")
759 if (defined $message && $message eq "no"
761 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
763 exists $CPAN::Config->{dontload_hash}{$mod}
765 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
773 # checking %INC is wrong, because $INC{LWP} may be true
774 # although $INC{"URI/URL.pm"} may have failed. But as
775 # I really want to say "bla loaded OK", I have to somehow
777 ### warn "$file in %INC"; #debug
779 } elsif (eval { require $file }) {
780 # eval is good: if we haven't yet read the database it's
781 # perfect and if we have installed the module in the meantime,
782 # it tries again. The second require is only a NOOP returning
783 # 1 if we had success, otherwise it's retrying
785 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
786 if ($mod eq "CPAN::WAIT") {
787 push @CPAN::Shell::ISA, CPAN::WAIT;
790 } elsif ($mod eq "Net::FTP") {
791 $CPAN::Frontend->mywarn(qq{
792 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
794 install Bundle::libnet
796 }) unless $Have_warned->{"Net::FTP"}++;
798 } elsif ($mod eq "Digest::MD5"){
799 $CPAN::Frontend->myprint(qq{
800 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
801 Please consider installing the Digest::MD5 module.
806 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
811 #-> sub CPAN::instance ;
813 my($mgr,$class,$id) = @_;
816 # unsafe meta access, ok?
817 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
818 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
826 #-> sub CPAN::cleanup ;
828 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
829 local $SIG{__DIE__} = '';
834 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
836 $subroutine eq '(eval)';
838 return if $ineval && !$End;
839 return unless defined $META->{LOCK};
840 return unless -f $META->{LOCK};
842 unlink $META->{LOCK};
844 # Carp::cluck("DEBUGGING");
845 $CPAN::Frontend->mywarn("Lockfile removed.\n");
848 #-> sub CPAN::savehist
851 my($histfile,$histsize);
852 unless ($histfile = $CPAN::Config->{'histfile'}){
853 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
856 $histsize = $CPAN::Config->{'histsize'} || 100;
858 unless ($CPAN::term->can("GetHistory")) {
859 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
865 my @h = $CPAN::term->GetHistory;
866 splice @h, 0, @h-$histsize if @h>$histsize;
867 my($fh) = FileHandle->new;
868 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
869 local $\ = local $, = "\n";
875 my($self,$what) = @_;
876 $self->{is_tested}{$what} = 1;
880 my($self,$what) = @_;
881 delete $self->{is_tested}{$what};
886 $self->{is_tested} ||= {};
887 return unless %{$self->{is_tested}};
888 my $env = $ENV{PERL5LIB};
889 $env = $ENV{PERLLIB} unless defined $env;
891 push @env, $env if defined $env and length $env;
892 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
893 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
894 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
897 package CPAN::CacheMgr;
899 #-> sub CPAN::CacheMgr::as_string ;
901 eval { require Data::Dumper };
903 return shift->SUPER::as_string;
905 return Data::Dumper::Dumper(shift);
909 #-> sub CPAN::CacheMgr::cachesize ;
914 #-> sub CPAN::CacheMgr::tidyup ;
917 return unless -d $self->{ID};
918 while ($self->{DU} > $self->{'MAX'} ) {
919 my($toremove) = shift @{$self->{FIFO}};
920 $CPAN::Frontend->myprint(sprintf(
921 "Deleting from cache".
922 ": $toremove (%.1f>%.1f MB)\n",
923 $self->{DU}, $self->{'MAX'})
925 return if $CPAN::Signal;
926 $self->force_clean_cache($toremove);
927 return if $CPAN::Signal;
931 #-> sub CPAN::CacheMgr::dir ;
936 #-> sub CPAN::CacheMgr::entries ;
939 return unless defined $dir;
940 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
941 $dir ||= $self->{ID};
942 my($cwd) = CPAN::anycwd();
943 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
944 my $dh = DirHandle->new(File::Spec->curdir)
945 or Carp::croak("Couldn't opendir $dir: $!");
948 next if $_ eq "." || $_ eq "..";
950 push @entries, File::Spec->catfile($dir,$_);
952 push @entries, File::Spec->catdir($dir,$_);
954 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
957 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
958 sort { -M $b <=> -M $a} @entries;
961 #-> sub CPAN::CacheMgr::disk_usage ;
964 return if exists $self->{SIZE}{$dir};
965 return if $CPAN::Signal;
969 $File::Find::prune++ if $CPAN::Signal;
971 if ($^O eq 'MacOS') {
973 my $cat = Mac::Files::FSpGetCatInfo($_);
974 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
981 return if $CPAN::Signal;
982 $self->{SIZE}{$dir} = $Du/1024/1024;
983 push @{$self->{FIFO}}, $dir;
984 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
985 $self->{DU} += $Du/1024/1024;
989 #-> sub CPAN::CacheMgr::force_clean_cache ;
990 sub force_clean_cache {
992 return unless -e $dir;
993 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
995 File::Path::rmtree($dir);
996 $self->{DU} -= $self->{SIZE}{$dir};
997 delete $self->{SIZE}{$dir};
1000 #-> sub CPAN::CacheMgr::new ;
1007 ID => $CPAN::Config->{'build_dir'},
1008 MAX => $CPAN::Config->{'build_cache'},
1009 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1012 File::Path::mkpath($self->{ID});
1013 my $dh = DirHandle->new($self->{ID});
1014 bless $self, $class;
1017 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1019 CPAN->debug($debug) if $CPAN::DEBUG;
1023 #-> sub CPAN::CacheMgr::scan_cache ;
1026 return if $self->{SCAN} eq 'never';
1027 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1028 unless $self->{SCAN} eq 'atstart';
1029 $CPAN::Frontend->myprint(
1030 sprintf("Scanning cache %s for sizes\n",
1033 for $e ($self->entries($self->{ID})) {
1034 next if $e eq ".." || $e eq ".";
1035 $self->disk_usage($e);
1036 return if $CPAN::Signal;
1041 package CPAN::Debug;
1043 #-> sub CPAN::Debug::debug ;
1045 my($self,$arg) = @_;
1046 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
1047 # Complete, caller(1)
1049 ($caller) = caller(0);
1050 $caller =~ s/.*:://;
1051 $arg = "" unless defined $arg;
1052 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
1053 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
1054 if ($arg and ref $arg) {
1055 eval { require Data::Dumper };
1057 $CPAN::Frontend->myprint($arg->as_string);
1059 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
1062 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
1067 package CPAN::Config;
1069 #-> sub CPAN::Config::edit ;
1070 # returns true on successful action
1072 my($self,@args) = @_;
1073 return unless @args;
1074 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
1075 my($o,$str,$func,$args,$key_exists);
1081 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1082 if ($o =~ /list$/) {
1083 $func = shift @args;
1085 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1087 # Let's avoid eval, it's easier to comprehend without.
1088 if ($func eq "push") {
1089 push @{$CPAN::Config->{$o}}, @args;
1091 } elsif ($func eq "pop") {
1092 pop @{$CPAN::Config->{$o}};
1094 } elsif ($func eq "shift") {
1095 shift @{$CPAN::Config->{$o}};
1097 } elsif ($func eq "unshift") {
1098 unshift @{$CPAN::Config->{$o}}, @args;
1100 } elsif ($func eq "splice") {
1101 splice @{$CPAN::Config->{$o}}, @args;
1104 $CPAN::Config->{$o} = [@args];
1107 $self->prettyprint($o);
1109 if ($o eq "urllist" && $changed) {
1110 # reset the cached values
1111 undef $CPAN::FTP::Thesite;
1112 undef $CPAN::FTP::Themethod;
1116 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1117 $self->prettyprint($o);
1124 my $v = $CPAN::Config->{$k};
1126 my(@report) = ref $v eq "ARRAY" ?
1128 map { sprintf(" %-18s => %s\n",
1130 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1132 $CPAN::Frontend->myprint(
1139 map {"\t$_\n"} @report
1142 } elsif (defined $v) {
1143 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1145 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1149 #-> sub CPAN::Config::commit ;
1151 my($self,$configpm) = @_;
1152 unless (defined $configpm){
1153 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1154 $configpm ||= $INC{"CPAN/Config.pm"};
1155 $configpm || Carp::confess(q{
1156 CPAN::Config::commit called without an argument.
1157 Please specify a filename where to save the configuration or try
1158 "o conf init" to have an interactive course through configing.
1163 $mode = (stat $configpm)[2];
1164 if ($mode && ! -w _) {
1165 Carp::confess("$configpm is not writable");
1170 $msg = <<EOF unless $configpm =~ /MyConfig/;
1172 # This is CPAN.pm's systemwide configuration file. This file provides
1173 # defaults for users, and the values can be changed in a per-user
1174 # configuration file. The user-config file is being looked for as
1175 # ~/.cpan/CPAN/MyConfig.pm.
1179 my($fh) = FileHandle->new;
1180 rename $configpm, "$configpm~" if -f $configpm;
1181 open $fh, ">$configpm" or
1182 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1183 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1184 foreach (sort keys %$CPAN::Config) {
1187 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1192 $fh->print("};\n1;\n__END__\n");
1195 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1196 #chmod $mode, $configpm;
1197 ###why was that so? $self->defaults;
1198 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1202 *default = \&defaults;
1203 #-> sub CPAN::Config::defaults ;
1213 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1222 # This is a piece of repeated code that is abstracted here for
1223 # maintainability. RMB
1226 my($configpmdir, $configpmtest) = @_;
1227 if (-w $configpmtest) {
1228 return $configpmtest;
1229 } elsif (-w $configpmdir) {
1230 #_#_# following code dumped core on me with 5.003_11, a.k.
1231 my $configpm_bak = "$configpmtest.bak";
1232 unlink $configpm_bak if -f $configpm_bak;
1233 if( -f $configpmtest ) {
1234 if( rename $configpmtest, $configpm_bak ) {
1235 $CPAN::Frontend->mywarn(<<END)
1236 Old configuration file $configpmtest
1237 moved to $configpm_bak
1241 my $fh = FileHandle->new;
1242 if ($fh->open(">$configpmtest")) {
1244 return $configpmtest;
1246 # Should never happen
1247 Carp::confess("Cannot open >$configpmtest");
1252 #-> sub CPAN::Config::load ;
1257 eval {require CPAN::Config;}; # We eval because of some
1258 # MakeMaker problems
1259 unless ($dot_cpan++){
1260 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1261 eval {require CPAN::MyConfig;}; # where you can override
1262 # system wide settings
1265 return unless @miss = $self->missing_config_data;
1267 require CPAN::FirstTime;
1268 my($configpm,$fh,$redo,$theycalled);
1270 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1271 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1272 $configpm = $INC{"CPAN/Config.pm"};
1274 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1275 $configpm = $INC{"CPAN/MyConfig.pm"};
1278 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1279 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1280 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1281 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1282 $configpm = _configpmtest($configpmdir,$configpmtest);
1284 unless ($configpm) {
1285 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1286 File::Path::mkpath($configpmdir);
1287 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1288 $configpm = _configpmtest($configpmdir,$configpmtest);
1289 unless ($configpm) {
1290 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1291 qq{create a configuration file.});
1296 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1297 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1301 $CPAN::Frontend->myprint(qq{
1302 $configpm initialized.
1305 CPAN::FirstTime::init($configpm);
1308 #-> sub CPAN::Config::missing_config_data ;
1309 sub missing_config_data {
1312 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1313 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1315 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1316 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1317 "prerequisites_policy",
1320 push @miss, $_ unless defined $CPAN::Config->{$_};
1325 #-> sub CPAN::Config::unload ;
1327 delete $INC{'CPAN/MyConfig.pm'};
1328 delete $INC{'CPAN/Config.pm'};
1331 #-> sub CPAN::Config::help ;
1333 $CPAN::Frontend->myprint(q[
1335 defaults reload default config values from disk
1336 commit commit session changes to disk
1337 init go through a dialog to set all parameters
1339 You may edit key values in the follow fashion (the "o" is a literal
1342 o conf build_cache 15
1344 o conf build_dir "/foo/bar"
1346 o conf urllist shift
1348 o conf urllist unshift ftp://ftp.foo.bar/
1351 undef; #don't reprint CPAN::Config
1354 #-> sub CPAN::Config::cpl ;
1356 my($word,$line,$pos) = @_;
1358 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1359 my(@words) = split " ", substr($line,0,$pos+1);
1364 $words[2] =~ /list$/ && @words == 3
1366 $words[2] =~ /list$/ && @words == 4 && length($word)
1369 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1370 } elsif (@words >= 4) {
1373 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1374 return grep /^\Q$word\E/, @o_conf;
1377 package CPAN::Shell;
1379 #-> sub CPAN::Shell::h ;
1381 my($class,$about) = @_;
1382 if (defined $about) {
1383 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1385 $CPAN::Frontend->myprint(q{
1387 command argument description
1388 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1389 i WORD or /REGEXP/ about any of the above
1390 r NONE report updatable modules
1391 ls AUTHOR about files in the author's directory
1393 Download, Test, Make, Install...
1395 make make (implies get)
1396 test MODULES, make test (implies make)
1397 install DISTS, BUNDLES make install (implies test)
1399 look open subshell in these dists' directories
1400 readme display these dists' README files
1403 h,? display this menu ! perl-code eval a perl command
1404 o conf [opt] set and query options q quit the cpan shell
1405 reload cpan load CPAN.pm again reload index load newer indices
1406 autobundle Snapshot force cmd unconditionally do cmd});
1412 #-> sub CPAN::Shell::a ;
1414 my($self,@arg) = @_;
1415 # authors are always UPPERCASE
1417 $_ = uc $_ unless /=/;
1419 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1422 #-> sub CPAN::Shell::ls ;
1424 my($self,@arg) = @_;
1427 unless (/^[A-Z\-]+$/i) {
1428 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1431 push @accept, uc $_;
1433 for my $a (@accept){
1434 my $author = $self->expand('Author',$a) or die "No author found for $a";
1439 #-> sub CPAN::Shell::local_bundles ;
1441 my($self,@which) = @_;
1442 my($incdir,$bdir,$dh);
1443 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1444 my @bbase = "Bundle";
1445 while (my $bbase = shift @bbase) {
1446 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1447 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1448 if ($dh = DirHandle->new($bdir)) { # may fail
1450 for $entry ($dh->read) {
1451 next if $entry =~ /^\./;
1452 if (-d File::Spec->catdir($bdir,$entry)){
1453 push @bbase, "$bbase\::$entry";
1455 next unless $entry =~ s/\.pm(?!\n)\Z//;
1456 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1464 #-> sub CPAN::Shell::b ;
1466 my($self,@which) = @_;
1467 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1468 $self->local_bundles;
1469 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1472 #-> sub CPAN::Shell::d ;
1473 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1475 #-> sub CPAN::Shell::m ;
1476 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1478 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1481 #-> sub CPAN::Shell::i ;
1485 @args = '/./' unless @args;
1487 for my $type (qw/Bundle Distribution Module/) {
1488 push @result, $self->expand($type,@args);
1490 # Authors are always uppercase.
1491 push @result, $self->expand("Author", map { uc $_ } @args);
1493 my $result = @result == 1 ?
1494 $result[0]->as_string :
1496 "No objects found of any type for argument @args\n" :
1498 (map {$_->as_glimpse} @result),
1499 scalar @result, " items found\n",
1501 $CPAN::Frontend->myprint($result);
1504 #-> sub CPAN::Shell::o ;
1506 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1507 # should have been called set and 'o debug' maybe 'set debug'
1509 my($self,$o_type,@o_what) = @_;
1511 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1512 if ($o_type eq 'conf') {
1513 shift @o_what if @o_what && $o_what[0] eq 'help';
1514 if (!@o_what) { # print all things, "o conf"
1516 $CPAN::Frontend->myprint("CPAN::Config options");
1517 if (exists $INC{'CPAN/Config.pm'}) {
1518 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1520 if (exists $INC{'CPAN/MyConfig.pm'}) {
1521 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1523 $CPAN::Frontend->myprint(":\n");
1524 for $k (sort keys %CPAN::Config::can) {
1525 $v = $CPAN::Config::can{$k};
1526 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1528 $CPAN::Frontend->myprint("\n");
1529 for $k (sort keys %$CPAN::Config) {
1530 CPAN::Config->prettyprint($k);
1532 $CPAN::Frontend->myprint("\n");
1533 } elsif (!CPAN::Config->edit(@o_what)) {
1534 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1535 qq{edit options\n\n});
1537 } elsif ($o_type eq 'debug') {
1539 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1542 my($what) = shift @o_what;
1543 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1544 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1547 if ( exists $CPAN::DEBUG{$what} ) {
1548 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1549 } elsif ($what =~ /^\d/) {
1550 $CPAN::DEBUG = $what;
1551 } elsif (lc $what eq 'all') {
1553 for (values %CPAN::DEBUG) {
1556 $CPAN::DEBUG = $max;
1559 for (keys %CPAN::DEBUG) {
1560 next unless lc($_) eq lc($what);
1561 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1564 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1569 my $raw = "Valid options for debug are ".
1570 join(", ",sort(keys %CPAN::DEBUG), 'all').
1571 qq{ or a number. Completion works on the options. }.
1572 qq{Case is ignored.};
1574 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1575 $CPAN::Frontend->myprint("\n\n");
1578 $CPAN::Frontend->myprint("Options set for debugging:\n");
1580 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1581 $v = $CPAN::DEBUG{$k};
1582 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1583 if $v & $CPAN::DEBUG;
1586 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1589 $CPAN::Frontend->myprint(qq{
1591 conf set or get configuration variables
1592 debug set or get debugging options
1597 sub paintdots_onreload {
1600 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1604 # $CPAN::Frontend->myprint(".($subr)");
1605 $CPAN::Frontend->myprint(".");
1612 #-> sub CPAN::Shell::reload ;
1614 my($self,$command,@arg) = @_;
1616 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1617 if ($command =~ /cpan/i) {
1618 for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1619 next unless $INC{$f};
1620 CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
1621 my $fh = FileHandle->new($INC{$f});
1624 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1627 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1629 } elsif ($command =~ /index/) {
1630 CPAN::Index->force_reload;
1632 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1633 index re-reads the index files\n});
1637 #-> sub CPAN::Shell::_binary_extensions ;
1638 sub _binary_extensions {
1639 my($self) = shift @_;
1640 my(@result,$module,%seen,%need,$headerdone);
1641 for $module ($self->expand('Module','/./')) {
1642 my $file = $module->cpan_file;
1643 next if $file eq "N/A";
1644 next if $file =~ /^Contact Author/;
1645 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1646 next if $dist->isa_perl;
1647 next unless $module->xs_file;
1649 $CPAN::Frontend->myprint(".");
1650 push @result, $module;
1652 # print join " | ", @result;
1653 $CPAN::Frontend->myprint("\n");
1657 #-> sub CPAN::Shell::recompile ;
1659 my($self) = shift @_;
1660 my($module,@module,$cpan_file,%dist);
1661 @module = $self->_binary_extensions();
1662 for $module (@module){ # we force now and compile later, so we
1664 $cpan_file = $module->cpan_file;
1665 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1667 $dist{$cpan_file}++;
1669 for $cpan_file (sort keys %dist) {
1670 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1671 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1673 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1674 # stop a package from recompiling,
1675 # e.g. IO-1.12 when we have perl5.003_10
1679 #-> sub CPAN::Shell::_u_r_common ;
1681 my($self) = shift @_;
1682 my($what) = shift @_;
1683 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1684 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1685 $what && $what =~ /^[aru]$/;
1687 @args = '/./' unless @args;
1688 my(@result,$module,%seen,%need,$headerdone,
1689 $version_undefs,$version_zeroes);
1690 $version_undefs = $version_zeroes = 0;
1691 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1692 my @expand = $self->expand('Module',@args);
1693 my $expand = scalar @expand;
1694 if (0) { # Looks like noise to me, was very useful for debugging
1695 # for metadata cache
1696 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1698 for $module (@expand) {
1699 my $file = $module->cpan_file;
1700 next unless defined $file; # ??
1701 my($latest) = $module->cpan_version;
1702 my($inst_file) = $module->inst_file;
1704 return if $CPAN::Signal;
1707 $have = $module->inst_version;
1708 } elsif ($what eq "r") {
1709 $have = $module->inst_version;
1711 if ($have eq "undef"){
1713 } elsif ($have == 0){
1716 next unless CPAN::Version->vgt($latest, $have);
1717 # to be pedantic we should probably say:
1718 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1719 # to catch the case where CPAN has a version 0 and we have a version undef
1720 } elsif ($what eq "u") {
1726 } elsif ($what eq "r") {
1728 } elsif ($what eq "u") {
1732 return if $CPAN::Signal; # this is sometimes lengthy
1735 push @result, sprintf "%s %s\n", $module->id, $have;
1736 } elsif ($what eq "r") {
1737 push @result, $module->id;
1738 next if $seen{$file}++;
1739 } elsif ($what eq "u") {
1740 push @result, $module->id;
1741 next if $seen{$file}++;
1742 next if $file =~ /^Contact/;
1744 unless ($headerdone++){
1745 $CPAN::Frontend->myprint("\n");
1746 $CPAN::Frontend->myprint(sprintf(
1749 "Package namespace",
1761 $CPAN::META->has_inst("Term::ANSIColor")
1763 $module->{RO}{description}
1765 $color_on = Term::ANSIColor::color("green");
1766 $color_off = Term::ANSIColor::color("reset");
1768 $CPAN::Frontend->myprint(sprintf $sprintf,
1775 $need{$module->id}++;
1779 $CPAN::Frontend->myprint("No modules found for @args\n");
1780 } elsif ($what eq "r") {
1781 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1785 if ($version_zeroes) {
1786 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1787 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1788 qq{a version number of 0\n});
1790 if ($version_undefs) {
1791 my $s_has = $version_undefs > 1 ? "s have" : " has";
1792 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1793 qq{parseable version number\n});
1799 #-> sub CPAN::Shell::r ;
1801 shift->_u_r_common("r",@_);
1804 #-> sub CPAN::Shell::u ;
1806 shift->_u_r_common("u",@_);
1809 #-> sub CPAN::Shell::autobundle ;
1812 CPAN::Config->load unless $CPAN::Config_loaded++;
1813 my(@bundle) = $self->_u_r_common("a",@_);
1814 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1815 File::Path::mkpath($todir);
1816 unless (-d $todir) {
1817 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1820 my($y,$m,$d) = (localtime)[5,4,3];
1824 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1825 my($to) = File::Spec->catfile($todir,"$me.pm");
1827 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1828 $to = File::Spec->catfile($todir,"$me.pm");
1830 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1832 "package Bundle::$me;\n\n",
1833 "\$VERSION = '0.01';\n\n",
1837 "Bundle::$me - Snapshot of installation on ",
1838 $Config::Config{'myhostname'},
1841 "\n\n=head1 SYNOPSIS\n\n",
1842 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1843 "=head1 CONTENTS\n\n",
1844 join("\n", @bundle),
1845 "\n\n=head1 CONFIGURATION\n\n",
1847 "\n\n=head1 AUTHOR\n\n",
1848 "This Bundle has been generated automatically ",
1849 "by the autobundle routine in CPAN.pm.\n",
1852 $CPAN::Frontend->myprint("\nWrote bundle file
1856 #-> sub CPAN::Shell::expandany ;
1859 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1860 if ($s =~ m|/|) { # looks like a file
1861 $s = CPAN::Distribution->normalize($s);
1862 return $CPAN::META->instance('CPAN::Distribution',$s);
1863 # Distributions spring into existence, not expand
1864 } elsif ($s =~ m|^Bundle::|) {
1865 $self->local_bundles; # scanning so late for bundles seems
1866 # both attractive and crumpy: always
1867 # current state but easy to forget
1869 return $self->expand('Bundle',$s);
1871 return $self->expand('Module',$s)
1872 if $CPAN::META->exists('CPAN::Module',$s);
1877 #-> sub CPAN::Shell::expand ;
1880 my($type,@args) = @_;
1882 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1884 my($regex,$command);
1885 if ($arg =~ m|^/(.*)/$|) {
1887 } elsif ($arg =~ m/=/) {
1890 my $class = "CPAN::$type";
1892 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1894 defined $regex ? $regex : "UNDEFINED",
1895 $command || "UNDEFINED",
1897 if (defined $regex) {
1901 $CPAN::META->all_objects($class)
1904 # BUG, we got an empty object somewhere
1905 require Data::Dumper;
1906 CPAN->debug(sprintf(
1907 "Bug in CPAN: Empty id on obj[%s][%s]",
1909 Data::Dumper::Dumper($obj)
1914 if $obj->id =~ /$regex/i
1918 $] < 5.00303 ### provide sort of
1919 ### compatibility with 5.003
1924 $obj->name =~ /$regex/i
1927 } elsif ($command) {
1928 die "equal sign in command disabled (immature interface), ".
1930 ! \$CPAN::Shell::ADVANCED_QUERY=1
1931 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1932 that may go away anytime.\n"
1933 unless $ADVANCED_QUERY;
1934 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1935 my($matchcrit) = $criterion =~ m/^~(.+)/;
1939 $CPAN::META->all_objects($class)
1941 my $lhs = $self->$method() or next; # () for 5.00503
1943 push @m, $self if $lhs =~ m/$matchcrit/;
1945 push @m, $self if $lhs eq $criterion;
1950 if ( $type eq 'Bundle' ) {
1951 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1952 } elsif ($type eq "Distribution") {
1953 $xarg = CPAN::Distribution->normalize($arg);
1955 if ($CPAN::META->exists($class,$xarg)) {
1956 $obj = $CPAN::META->instance($class,$xarg);
1957 } elsif ($CPAN::META->exists($class,$arg)) {
1958 $obj = $CPAN::META->instance($class,$arg);
1965 return wantarray ? @m : $m[0];
1968 #-> sub CPAN::Shell::format_result ;
1971 my($type,@args) = @_;
1972 @args = '/./' unless @args;
1973 my(@result) = $self->expand($type,@args);
1974 my $result = @result == 1 ?
1975 $result[0]->as_string :
1977 "No objects of type $type found for argument @args\n" :
1979 (map {$_->as_glimpse} @result),
1980 scalar @result, " items found\n",
1985 # The only reason for this method is currently to have a reliable
1986 # debugging utility that reveals which output is going through which
1987 # channel. No, I don't like the colors ;-)
1989 #-> sub CPAN::Shell::print_ornameted ;
1990 sub print_ornamented {
1991 my($self,$what,$ornament) = @_;
1993 return unless defined $what;
1995 if ($CPAN::Config->{term_is_latin}){
1998 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2000 if ($PRINT_ORNAMENTING) {
2001 unless (defined &color) {
2002 if ($CPAN::META->has_inst("Term::ANSIColor")) {
2003 import Term::ANSIColor "color";
2005 *color = sub { return "" };
2009 for $line (split /\n/, $what) {
2010 $longest = length($line) if length($line) > $longest;
2012 my $sprintf = "%-" . $longest . "s";
2014 $what =~ s/(.*\n?)//m;
2017 my($nl) = chomp $line ? "\n" : "";
2018 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
2019 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
2023 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
2029 my($self,$what) = @_;
2031 $self->print_ornamented($what, 'bold blue on_yellow');
2035 my($self,$what) = @_;
2036 $self->myprint($what);
2041 my($self,$what) = @_;
2042 $self->print_ornamented($what, 'bold red on_yellow');
2046 my($self,$what) = @_;
2047 $self->print_ornamented($what, 'bold red on_white');
2048 Carp::confess "died";
2052 my($self,$what) = @_;
2053 $self->print_ornamented($what, 'bold red on_white');
2058 return if -t STDOUT;
2059 my $odef = select STDERR;
2066 #-> sub CPAN::Shell::rematein ;
2067 # RE-adme||MA-ke||TE-st||IN-stall
2070 my($meth,@some) = @_;
2072 if ($meth eq 'force') {
2074 $meth = shift @some;
2077 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
2079 # Here is the place to set "test_count" on all involved parties to
2080 # 0. We then can pass this counter on to the involved
2081 # distributions and those can refuse to test if test_count > X. In
2082 # the first stab at it we could use a 1 for "X".
2084 # But when do I reset the distributions to start with 0 again?
2085 # Jost suggested to have a random or cycling interaction ID that
2086 # we pass through. But the ID is something that is just left lying
2087 # around in addition to the counter, so I'd prefer to set the
2088 # counter to 0 now, and repeat at the end of the loop. But what
2089 # about dependencies? They appear later and are not reset, they
2090 # enter the queue but not its copy. How do they get a sensible
2093 # construct the queue
2095 foreach $s (@some) {
2098 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2100 } elsif ($s =~ m|^/|) { # looks like a regexp
2101 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2106 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2107 $obj = CPAN::Shell->expandany($s);
2110 $obj->color_cmd_tmps(0,1);
2111 CPAN::Queue->new($obj->id);
2113 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2114 $obj = $CPAN::META->instance('CPAN::Author',$s);
2115 if ($meth =~ /^(dump|ls)$/) {
2118 $CPAN::Frontend->myprint(
2120 "Don't be silly, you can't $meth ",
2128 ->myprint(qq{Warning: Cannot $meth $s, }.
2129 qq{don\'t know what it is.
2134 to find objects with matching identifiers.
2140 # queuerunner (please be warned: when I started to change the
2141 # queue to hold objects instead of names, I made one or two
2142 # mistakes and never found which. I reverted back instead)
2143 while ($s = CPAN::Queue->first) {
2146 $obj = $s; # I do not believe, we would survive if this happened
2148 $obj = CPAN::Shell->expandany($s);
2152 ($] < 5.00303 || $obj->can($pragma))){
2153 ### compatibility with 5.003
2154 $obj->$pragma($meth); # the pragma "force" in
2155 # "CPAN::Distribution" must know
2156 # what we are intending
2158 if ($]>=5.00303 && $obj->can('called_for')) {
2159 $obj->called_for($s);
2162 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2168 CPAN::Queue->delete($s);
2170 CPAN->debug("failed");
2174 CPAN::Queue->delete_first($s);
2176 for my $obj (@qcopy) {
2177 $obj->color_cmd_tmps(0,0);
2181 #-> sub CPAN::Shell::dump ;
2182 sub dump { shift->rematein('dump',@_); }
2183 #-> sub CPAN::Shell::force ;
2184 sub force { shift->rematein('force',@_); }
2185 #-> sub CPAN::Shell::get ;
2186 sub get { shift->rematein('get',@_); }
2187 #-> sub CPAN::Shell::readme ;
2188 sub readme { shift->rematein('readme',@_); }
2189 #-> sub CPAN::Shell::make ;
2190 sub make { shift->rematein('make',@_); }
2191 #-> sub CPAN::Shell::test ;
2192 sub test { shift->rematein('test',@_); }
2193 #-> sub CPAN::Shell::install ;
2194 sub install { shift->rematein('install',@_); }
2195 #-> sub CPAN::Shell::clean ;
2196 sub clean { shift->rematein('clean',@_); }
2197 #-> sub CPAN::Shell::look ;
2198 sub look { shift->rematein('look',@_); }
2199 #-> sub CPAN::Shell::cvs_import ;
2200 sub cvs_import { shift->rematein('cvs_import',@_); }
2202 package CPAN::LWP::UserAgent;
2205 return if $SETUPDONE;
2206 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2207 require LWP::UserAgent;
2208 @ISA = qw(Exporter LWP::UserAgent);
2211 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2215 sub get_basic_credentials {
2216 my($self, $realm, $uri, $proxy) = @_;
2217 return unless $proxy;
2218 if ($USER && $PASSWD) {
2219 } elsif (defined $CPAN::Config->{proxy_user} &&
2220 defined $CPAN::Config->{proxy_pass}) {
2221 $USER = $CPAN::Config->{proxy_user};
2222 $PASSWD = $CPAN::Config->{proxy_pass};
2224 require ExtUtils::MakeMaker;
2225 ExtUtils::MakeMaker->import(qw(prompt));
2226 $USER = prompt("Proxy authentication needed!
2227 (Note: to permanently configure username and password run
2228 o conf proxy_user your_username
2229 o conf proxy_pass your_password
2231 if ($CPAN::META->has_inst("Term::ReadKey")) {
2232 Term::ReadKey::ReadMode("noecho");
2234 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2236 $PASSWD = prompt("Password:");
2237 if ($CPAN::META->has_inst("Term::ReadKey")) {
2238 Term::ReadKey::ReadMode("restore");
2240 $CPAN::Frontend->myprint("\n\n");
2242 return($USER,$PASSWD);
2245 # mirror(): Its purpose is to deal with proxy authentication. When we
2246 # call SUPER::mirror, we relly call the mirror method in
2247 # LWP::UserAgent. LWP::UserAgent will then call
2248 # $self->get_basic_credentials or some equivalent and this will be
2249 # $self->dispatched to our own get_basic_credentials method.
2251 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2253 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2254 # although we have gone through our get_basic_credentials, the proxy
2255 # server refuses to connect. This could be a case where the username or
2256 # password has changed in the meantime, so I'm trying once again without
2257 # $USER and $PASSWD to give the get_basic_credentials routine another
2258 # chance to set $USER and $PASSWD.
2261 my($self,$url,$aslocal) = @_;
2262 my $result = $self->SUPER::mirror($url,$aslocal);
2263 if ($result->code == 407) {
2266 $result = $self->SUPER::mirror($url,$aslocal);
2273 #-> sub CPAN::FTP::ftp_get ;
2275 my($class,$host,$dir,$file,$target) = @_;
2277 qq[Going to fetch file [$file] from dir [$dir]
2278 on host [$host] as local [$target]\n]
2280 my $ftp = Net::FTP->new($host);
2281 return 0 unless defined $ftp;
2282 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2283 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2284 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2285 warn "Couldn't login on $host";
2288 unless ( $ftp->cwd($dir) ){
2289 warn "Couldn't cwd $dir";
2293 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2294 unless ( $ftp->get($file,$target) ){
2295 warn "Couldn't fetch $file from $host\n";
2298 $ftp->quit; # it's ok if this fails
2302 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2304 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2305 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2307 # > *** 1562,1567 ****
2308 # > --- 1562,1580 ----
2309 # > return 1 if substr($url,0,4) eq "file";
2310 # > return 1 unless $url =~ m|://([^/]+)|;
2312 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2314 # > + $proxy =~ m|://([^/:]+)|;
2316 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2317 # > + if ($noproxy) {
2318 # > + if ($host !~ /$noproxy$/) {
2319 # > + $host = $proxy;
2322 # > + $host = $proxy;
2325 # > require Net::Ping;
2326 # > return 1 unless $Net::Ping::VERSION >= 2;
2330 #-> sub CPAN::FTP::localize ;
2332 my($self,$file,$aslocal,$force) = @_;
2334 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2335 unless defined $aslocal;
2336 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2339 if ($^O eq 'MacOS') {
2340 # Comment by AK on 2000-09-03: Uniq short filenames would be
2341 # available in CHECKSUMS file
2342 my($name, $path) = File::Basename::fileparse($aslocal, '');
2343 if (length($name) > 31) {
2354 my $size = 31 - length($suf);
2355 while (length($name) > $size) {
2359 $aslocal = File::Spec->catfile($path, $name);
2363 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2366 rename $aslocal, "$aslocal.bak";
2370 my($aslocal_dir) = File::Basename::dirname($aslocal);
2371 File::Path::mkpath($aslocal_dir);
2372 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2373 qq{directory "$aslocal_dir".
2374 I\'ll continue, but if you encounter problems, they may be due
2375 to insufficient permissions.\n}) unless -w $aslocal_dir;
2377 # Inheritance is not easier to manage than a few if/else branches
2378 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2380 CPAN::LWP::UserAgent->config;
2381 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2383 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2387 $Ua->proxy('ftp', $var)
2388 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2389 $Ua->proxy('http', $var)
2390 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2393 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2395 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2396 # > use ones that require basic autorization.
2398 # > Example of when I use it manually in my own stuff:
2400 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2401 # > $req->proxy_authorization_basic("username","password");
2402 # > $res = $ua->request($req);
2406 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2410 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2411 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2414 # Try the list of urls for each single object. We keep a record
2415 # where we did get a file from
2416 my(@reordered,$last);
2417 $CPAN::Config->{urllist} ||= [];
2418 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2419 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2421 $last = $#{$CPAN::Config->{urllist}};
2422 if ($force & 2) { # local cpans probably out of date, don't reorder
2423 @reordered = (0..$last);
2427 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2429 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2440 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2442 @levels = qw/easy hard hardest/;
2444 @levels = qw/easy/ if $^O eq 'MacOS';
2446 for $levelno (0..$#levels) {
2447 my $level = $levels[$levelno];
2448 my $method = "host$level";
2449 my @host_seq = $level eq "easy" ?
2450 @reordered : 0..$last; # reordered has CDROM up front
2451 @host_seq = (0) unless @host_seq;
2452 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2454 $Themethod = $level;
2456 # utime $now, $now, $aslocal; # too bad, if we do that, we
2457 # might alter a local mirror
2458 $self->debug("level[$level]") if $CPAN::DEBUG;
2462 last if $CPAN::Signal; # need to cleanup
2465 unless ($CPAN::Signal) {
2468 qq{Please check, if the URLs I found in your configuration file \(}.
2469 join(", ", @{$CPAN::Config->{urllist}}).
2470 qq{\) are valid. The urllist can be edited.},
2471 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2472 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2474 $CPAN::Frontend->myprint("Could not fetch $file\n");
2477 rename "$aslocal.bak", $aslocal;
2478 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2479 $self->ls($aslocal));
2486 my($self,$host_seq,$file,$aslocal) = @_;
2488 HOSTEASY: for $i (@$host_seq) {
2489 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2490 $url .= "/" unless substr($url,-1) eq "/";
2492 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2493 if ($url =~ /^file:/) {
2495 if ($CPAN::META->has_inst('URI::URL')) {
2496 my $u = URI::URL->new($url);
2498 } else { # works only on Unix, is poorly constructed, but
2499 # hopefully better than nothing.
2500 # RFC 1738 says fileurl BNF is
2501 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2502 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2504 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2505 $l =~ s|^file:||; # assume they
2508 $l =~ s|^/||s unless -f $l; # e.g. /P:
2509 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2511 if ( -f $l && -r _) {
2515 # Maybe mirror has compressed it?
2517 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2518 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2525 if ($CPAN::META->has_usable('LWP')) {
2526 $CPAN::Frontend->myprint("Fetching with LWP:
2530 CPAN::LWP::UserAgent->config;
2531 eval { $Ua = CPAN::LWP::UserAgent->new; };
2533 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2536 my $res = $Ua->mirror($url, $aslocal);
2537 if ($res->is_success) {
2540 utime $now, $now, $aslocal; # download time is more
2541 # important than upload time
2543 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2544 my $gzurl = "$url.gz";
2545 $CPAN::Frontend->myprint("Fetching with LWP:
2548 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2549 if ($res->is_success &&
2550 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2556 $CPAN::Frontend->myprint(sprintf(
2557 "LWP failed with code[%s] message[%s]\n",
2561 # Alan Burlison informed me that in firewall environments
2562 # Net::FTP can still succeed where LWP fails. So we do not
2563 # skip Net::FTP anymore when LWP is available.
2566 $CPAN::Frontend->myprint("LWP not available\n");
2568 return if $CPAN::Signal;
2569 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2570 # that's the nice and easy way thanks to Graham
2571 my($host,$dir,$getfile) = ($1,$2,$3);
2572 if ($CPAN::META->has_usable('Net::FTP')) {
2574 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2577 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2578 "aslocal[$aslocal]") if $CPAN::DEBUG;
2579 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2583 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2584 my $gz = "$aslocal.gz";
2585 $CPAN::Frontend->myprint("Fetching with Net::FTP
2588 if (CPAN::FTP->ftp_get($host,
2592 CPAN::Tarzip->gunzip($gz,$aslocal)
2601 return if $CPAN::Signal;
2606 my($self,$host_seq,$file,$aslocal) = @_;
2608 # Came back if Net::FTP couldn't establish connection (or
2609 # failed otherwise) Maybe they are behind a firewall, but they
2610 # gave us a socksified (or other) ftp program...
2613 my($devnull) = $CPAN::Config->{devnull} || "";
2615 my($aslocal_dir) = File::Basename::dirname($aslocal);
2616 File::Path::mkpath($aslocal_dir);
2617 HOSTHARD: for $i (@$host_seq) {
2618 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2619 $url .= "/" unless substr($url,-1) eq "/";
2621 my($proto,$host,$dir,$getfile);
2623 # Courtesy Mark Conty mark_conty@cargill.com change from
2624 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2626 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2627 # proto not yet used
2628 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2630 next HOSTHARD; # who said, we could ftp anything except ftp?
2632 next HOSTHARD if $proto eq "file"; # file URLs would have had
2633 # success above. Likely a bogus URL
2635 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2637 # Try the most capable first and leave ncftp* for last as it only
2639 for my $f (qw(curl wget lynx ncftpget ncftp)) {
2640 my $funkyftp = $CPAN::Config->{$f};
2641 next unless defined $funkyftp;
2642 next if $funkyftp =~ /^\s*$/;
2644 my($asl_ungz, $asl_gz);
2645 ($asl_ungz = $aslocal) =~ s/\.gz//;
2646 $asl_gz = "$asl_ungz.gz";
2648 my($src_switch) = "";
2650 $src_switch = " -source";
2651 } elsif ($f eq "ncftp"){
2652 $src_switch = " -c";
2653 } elsif ($f eq "wget"){
2654 $src_switch = " -O -";
2655 } elsif ($f eq 'curl'){
2656 $src_switch = ' -L';
2660 my($stdout_redir) = " > $asl_ungz";
2661 if ($f eq "ncftpget"){
2662 $chdir = "cd $aslocal_dir && ";
2665 $CPAN::Frontend->myprint(
2667 Trying with "$funkyftp$src_switch" to get
2671 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2672 $self->debug("system[$system]") if $CPAN::DEBUG;
2674 if (($wstatus = system($system)) == 0
2677 -s $asl_ungz # lynx returns 0 when it fails somewhere
2683 } elsif ($asl_ungz ne $aslocal) {
2684 # test gzip integrity
2685 if (CPAN::Tarzip->gtest($asl_ungz)) {
2686 # e.g. foo.tar is gzipped --> foo.tar.gz
2687 rename $asl_ungz, $aslocal;
2689 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2694 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2696 -f $asl_ungz && -s _ == 0;
2697 my $gz = "$aslocal.gz";
2698 my $gzurl = "$url.gz";
2699 $CPAN::Frontend->myprint(
2701 Trying with "$funkyftp$src_switch" to get
2704 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2705 $self->debug("system[$system]") if $CPAN::DEBUG;
2707 if (($wstatus = system($system)) == 0
2711 # test gzip integrity
2712 if (CPAN::Tarzip->gtest($asl_gz)) {
2713 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2715 # somebody uncompressed file for us?
2716 rename $asl_ungz, $aslocal;
2721 unlink $asl_gz if -f $asl_gz;
2724 my $estatus = $wstatus >> 8;
2725 my $size = -f $aslocal ?
2726 ", left\n$aslocal with size ".-s _ :
2727 "\nWarning: expected file [$aslocal] doesn't exist";
2728 $CPAN::Frontend->myprint(qq{
2729 System call "$system"
2730 returned status $estatus (wstat $wstatus)$size
2733 return if $CPAN::Signal;
2734 } # transfer programs
2739 my($self,$host_seq,$file,$aslocal) = @_;
2742 my($aslocal_dir) = File::Basename::dirname($aslocal);
2743 File::Path::mkpath($aslocal_dir);
2744 my $ftpbin = $CPAN::Config->{ftp};
2745 HOSTHARDEST: for $i (@$host_seq) {
2746 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2747 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2750 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2751 $url .= "/" unless substr($url,-1) eq "/";
2753 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2754 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2757 my($host,$dir,$getfile) = ($1,$2,$3);
2759 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2760 $ctime,$blksize,$blocks) = stat($aslocal);
2761 $timestamp = $mtime ||= 0;
2762 my($netrc) = CPAN::FTP::netrc->new;
2763 my($netrcfile) = $netrc->netrc;
2764 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2765 my $targetfile = File::Basename::basename($aslocal);
2771 map("cd $_", split /\//, $dir), # RFC 1738
2773 "get $getfile $targetfile",
2777 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2778 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2779 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2781 $netrc->contains($host))) if $CPAN::DEBUG;
2782 if ($netrc->protected) {
2783 $CPAN::Frontend->myprint(qq{
2784 Trying with external ftp to get
2786 As this requires some features that are not thoroughly tested, we\'re
2787 not sure, that we get it right....
2791 $self->talk_ftp("$ftpbin$verbose $host",
2793 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2794 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2796 if ($mtime > $timestamp) {
2797 $CPAN::Frontend->myprint("GOT $aslocal\n");
2801 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2803 return if $CPAN::Signal;
2805 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2806 qq{correctly protected.\n});
2809 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2810 nor does it have a default entry\n");
2813 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2814 # then and login manually to host, using e-mail as
2816 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2820 "user anonymous $Config::Config{'cf_email'}"
2822 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2823 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2824 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2826 if ($mtime > $timestamp) {
2827 $CPAN::Frontend->myprint("GOT $aslocal\n");
2831 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2833 return if $CPAN::Signal;
2834 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2840 my($self,$command,@dialog) = @_;
2841 my $fh = FileHandle->new;
2842 $fh->open("|$command") or die "Couldn't open ftp: $!";
2843 foreach (@dialog) { $fh->print("$_\n") }
2844 $fh->close; # Wait for process to complete
2846 my $estatus = $wstatus >> 8;
2847 $CPAN::Frontend->myprint(qq{
2848 Subprocess "|$command"
2849 returned status $estatus (wstat $wstatus)
2853 # find2perl needs modularization, too, all the following is stolen
2857 my($self,$name) = @_;
2858 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2859 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2861 my($perms,%user,%group);
2865 $blocks = int(($blocks + 1) / 2);
2868 $blocks = int(($sizemm + 1023) / 1024);
2871 if (-f _) { $perms = '-'; }
2872 elsif (-d _) { $perms = 'd'; }
2873 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2874 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2875 elsif (-p _) { $perms = 'p'; }
2876 elsif (-S _) { $perms = 's'; }
2877 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2879 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2880 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2881 my $tmpmode = $mode;
2882 my $tmp = $rwx[$tmpmode & 7];
2884 $tmp = $rwx[$tmpmode & 7] . $tmp;
2886 $tmp = $rwx[$tmpmode & 7] . $tmp;
2887 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2888 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2889 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2892 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2893 my $group = $group{$gid} || $gid;
2895 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2897 my($moname) = $moname[$mon];
2898 if (-M _ > 365.25 / 2) {
2899 $timeyear = $year + 1900;
2902 $timeyear = sprintf("%02d:%02d", $hour, $min);
2905 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2919 package CPAN::FTP::netrc;
2923 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2925 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2926 $atime,$mtime,$ctime,$blksize,$blocks)
2931 my($fh,@machines,$hasdefault);
2933 $fh = FileHandle->new or die "Could not create a filehandle";
2935 if($fh->open($file)){
2936 $protected = ($mode & 077) == 0;
2938 NETRC: while (<$fh>) {
2939 my(@tokens) = split " ", $_;
2940 TOKEN: while (@tokens) {
2941 my($t) = shift @tokens;
2942 if ($t eq "default"){
2946 last TOKEN if $t eq "macdef";
2947 if ($t eq "machine") {
2948 push @machines, shift @tokens;
2953 $file = $hasdefault = $protected = "";
2957 'mach' => [@machines],
2959 'hasdefault' => $hasdefault,
2960 'protected' => $protected,
2964 # CPAN::FTP::hasdefault;
2965 sub hasdefault { shift->{'hasdefault'} }
2966 sub netrc { shift->{'netrc'} }
2967 sub protected { shift->{'protected'} }
2969 my($self,$mach) = @_;
2970 for ( @{$self->{'mach'}} ) {
2971 return 1 if $_ eq $mach;
2976 package CPAN::Complete;
2979 my($text, $line, $start, $end) = @_;
2980 my(@perlret) = cpl($text, $line, $start);
2981 # find longest common match. Can anybody show me how to peruse
2982 # T::R::Gnu to have this done automatically? Seems expensive.
2983 return () unless @perlret;
2984 my($newtext) = $text;
2985 for (my $i = length($text)+1;;$i++) {
2986 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2987 my $try = substr($perlret[0],0,$i);
2988 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2989 # warn "try[$try]tries[@tries]";
2990 if (@tries == @perlret) {
2996 ($newtext,@perlret);
2999 #-> sub CPAN::Complete::cpl ;
3001 my($word,$line,$pos) = @_;
3005 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3007 if ($line =~ s/^(force\s*)//) {
3012 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3013 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3015 } elsif ($line =~ /^(a|ls)\s/) {
3016 @return = cplx('CPAN::Author',uc($word));
3017 } elsif ($line =~ /^b\s/) {
3018 CPAN::Shell->local_bundles;
3019 @return = cplx('CPAN::Bundle',$word);
3020 } elsif ($line =~ /^d\s/) {
3021 @return = cplx('CPAN::Distribution',$word);
3022 } elsif ($line =~ m/^(
3023 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
3025 if ($word =~ /^Bundle::/) {
3026 CPAN::Shell->local_bundles;
3028 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3029 } elsif ($line =~ /^i\s/) {
3030 @return = cpl_any($word);
3031 } elsif ($line =~ /^reload\s/) {
3032 @return = cpl_reload($word,$line,$pos);
3033 } elsif ($line =~ /^o\s/) {
3034 @return = cpl_option($word,$line,$pos);
3035 } elsif ($line =~ m/^\S+\s/ ) {
3036 # fallback for future commands and what we have forgotten above
3037 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3044 #-> sub CPAN::Complete::cplx ;
3046 my($class, $word) = @_;
3047 # I believed for many years that this was sorted, today I
3048 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3049 # make it sorted again. Maybe sort was dropped when GNU-readline
3050 # support came in? The RCS file is difficult to read on that:-(
3051 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3054 #-> sub CPAN::Complete::cpl_any ;
3058 cplx('CPAN::Author',$word),
3059 cplx('CPAN::Bundle',$word),
3060 cplx('CPAN::Distribution',$word),
3061 cplx('CPAN::Module',$word),
3065 #-> sub CPAN::Complete::cpl_reload ;
3067 my($word,$line,$pos) = @_;
3069 my(@words) = split " ", $line;
3070 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3071 my(@ok) = qw(cpan index);
3072 return @ok if @words == 1;
3073 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3076 #-> sub CPAN::Complete::cpl_option ;
3078 my($word,$line,$pos) = @_;
3080 my(@words) = split " ", $line;
3081 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3082 my(@ok) = qw(conf debug);
3083 return @ok if @words == 1;
3084 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3086 } elsif ($words[1] eq 'index') {
3088 } elsif ($words[1] eq 'conf') {
3089 return CPAN::Config::cpl(@_);
3090 } elsif ($words[1] eq 'debug') {
3091 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
3095 package CPAN::Index;
3097 #-> sub CPAN::Index::force_reload ;
3100 $CPAN::Index::LAST_TIME = 0;
3104 #-> sub CPAN::Index::reload ;
3106 my($cl,$force) = @_;
3109 # XXX check if a newer one is available. (We currently read it
3110 # from time to time)
3111 for ($CPAN::Config->{index_expire}) {
3112 $_ = 0.001 unless $_ && $_ > 0.001;
3114 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3115 # debug here when CPAN doesn't seem to read the Metadata
3117 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3119 unless ($CPAN::META->{PROTOCOL}) {
3120 $cl->read_metadata_cache;
3121 $CPAN::META->{PROTOCOL} ||= "1.0";
3123 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3124 # warn "Setting last_time to 0";
3125 $LAST_TIME = 0; # No warning necessary
3127 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3130 # IFF we are developing, it helps to wipe out the memory
3131 # between reloads, otherwise it is not what a user expects.
3132 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3133 $CPAN::META = CPAN->new;
3137 local $LAST_TIME = $time;
3138 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3140 my $needshort = $^O eq "dos";
3142 $cl->rd_authindex($cl
3144 "authors/01mailrc.txt.gz",
3146 File::Spec->catfile('authors', '01mailrc.gz') :
3147 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3150 $debug = "timing reading 01[".($t2 - $time)."]";
3152 return if $CPAN::Signal; # this is sometimes lengthy
3153 $cl->rd_modpacks($cl
3155 "modules/02packages.details.txt.gz",
3157 File::Spec->catfile('modules', '02packag.gz') :
3158 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3161 $debug .= "02[".($t2 - $time)."]";
3163 return if $CPAN::Signal; # this is sometimes lengthy
3166 "modules/03modlist.data.gz",
3168 File::Spec->catfile('modules', '03mlist.gz') :
3169 File::Spec->catfile('modules', '03modlist.data.gz'),
3171 $cl->write_metadata_cache;
3173 $debug .= "03[".($t2 - $time)."]";
3175 CPAN->debug($debug) if $CPAN::DEBUG;
3178 $CPAN::META->{PROTOCOL} = PROTOCOL;
3181 #-> sub CPAN::Index::reload_x ;
3183 my($cl,$wanted,$localname,$force) = @_;
3184 $force |= 2; # means we're dealing with an index here
3185 CPAN::Config->load; # we should guarantee loading wherever we rely
3187 $localname ||= $wanted;
3188 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3192 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3195 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3196 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3197 qq{day$s. I\'ll use that.});
3200 $force |= 1; # means we're quite serious about it.
3202 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3205 #-> sub CPAN::Index::rd_authindex ;
3207 my($cl, $index_target) = @_;
3209 return unless defined $index_target;
3210 $CPAN::Frontend->myprint("Going to read $index_target\n");
3212 tie *FH, CPAN::Tarzip, $index_target;
3214 push @lines, split /\012/ while <FH>;
3216 my($userid,$fullname,$email) =
3217 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3218 next unless $userid && $fullname && $email;
3220 # instantiate an author object
3221 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3222 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3223 return if $CPAN::Signal;
3228 my($self,$dist) = @_;
3229 $dist = $self->{'id'} unless defined $dist;
3230 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3234 #-> sub CPAN::Index::rd_modpacks ;
3236 my($self, $index_target) = @_;
3238 return unless defined $index_target;
3239 $CPAN::Frontend->myprint("Going to read $index_target\n");
3240 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3242 while ($_ = $fh->READLINE) {
3244 my @ls = map {"$_\n"} split /\n/, $_;
3245 unshift @ls, "\n" x length($1) if /^(\n+)/;
3249 my($line_count,$last_updated);
3251 my $shift = shift(@lines);
3252 last if $shift =~ /^\s*$/;
3253 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3254 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3256 if (not defined $line_count) {
3258 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3259 Please check the validity of the index file by comparing it to more
3260 than one CPAN mirror. I'll continue but problems seem likely to
3265 } elsif ($line_count != scalar @lines) {
3267 warn sprintf qq{Warning: Your %s
3268 contains a Line-Count header of %d but I see %d lines there. Please
3269 check the validity of the index file by comparing it to more than one
3270 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3271 $index_target, $line_count, scalar(@lines);
3274 if (not defined $last_updated) {
3276 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3277 Please check the validity of the index file by comparing it to more
3278 than one CPAN mirror. I'll continue but problems seem likely to
3286 ->myprint(sprintf qq{ Database was generated on %s\n},
3288 $DATE_OF_02 = $last_updated;
3290 if ($CPAN::META->has_inst(HTTP::Date)) {
3292 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3297 qq{Warning: This index file is %d days old.
3298 Please check the host you chose as your CPAN mirror for staleness.
3299 I'll continue but problems seem likely to happen.\a\n},
3304 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3309 # A necessity since we have metadata_cache: delete what isn't
3311 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3312 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3316 # before 1.56 we split into 3 and discarded the rest. From
3317 # 1.57 we assign remaining text to $comment thus allowing to
3318 # influence isa_perl
3319 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3320 my($bundle,$id,$userid);
3322 if ($mod eq 'CPAN' &&
3324 CPAN::Queue->exists('Bundle::CPAN') ||
3325 CPAN::Queue->exists('CPAN')
3329 if ($version > $CPAN::VERSION){
3330 $CPAN::Frontend->myprint(qq{
3331 There's a new CPAN.pm version (v$version) available!
3332 [Current version is v$CPAN::VERSION]
3333 You might want to try
3334 install Bundle::CPAN
3336 without quitting the current session. It should be a seamless upgrade
3337 while we are running...
3340 $CPAN::Frontend->myprint(qq{\n});
3342 last if $CPAN::Signal;
3343 } elsif ($mod =~ /^Bundle::(.*)/) {
3348 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3349 # Let's make it a module too, because bundles have so much
3350 # in common with modules.
3352 # Changed in 1.57_63: seems like memory bloat now without
3353 # any value, so commented out
3355 # $CPAN::META->instance('CPAN::Module',$mod);
3359 # instantiate a module object
3360 $id = $CPAN::META->instance('CPAN::Module',$mod);
3364 if ($id->cpan_file ne $dist){ # update only if file is
3365 # different. CPAN prohibits same
3366 # name with different version
3367 $userid = $id->userid || $self->userid($dist);
3369 'CPAN_USERID' => $userid,
3370 'CPAN_VERSION' => $version,
3371 'CPAN_FILE' => $dist,
3375 # instantiate a distribution object
3376 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3377 # we do not need CONTAINSMODS unless we do something with
3378 # this dist, so we better produce it on demand.
3380 ## my $obj = $CPAN::META->instance(
3381 ## 'CPAN::Distribution' => $dist
3383 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3385 $CPAN::META->instance(
3386 'CPAN::Distribution' => $dist
3388 'CPAN_USERID' => $userid,
3389 'CPAN_COMMENT' => $comment,
3393 for my $name ($mod,$dist) {
3394 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3395 $exists{$name} = undef;
3398 return if $CPAN::Signal;
3402 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3403 for my $o ($CPAN::META->all_objects($class)) {
3404 next if exists $exists{$o->{ID}};
3405 $CPAN::META->delete($class,$o->{ID});
3406 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3413 #-> sub CPAN::Index::rd_modlist ;
3415 my($cl,$index_target) = @_;
3416 return unless defined $index_target;
3417 $CPAN::Frontend->myprint("Going to read $index_target\n");
3418 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3421 while ($_ = $fh->READLINE) {
3423 my @ls = map {"$_\n"} split /\n/, $_;
3424 unshift @ls, "\n" x length($1) if /^(\n+)/;
3428 my $shift = shift(@eval);
3429 if ($shift =~ /^Date:\s+(.*)/){
3430 return if $DATE_OF_03 eq $1;
3433 last if $shift =~ /^\s*$/;
3436 push @eval, q{CPAN::Modulelist->data;};
3438 my($comp) = Safe->new("CPAN::Safe1");
3439 my($eval) = join("", @eval);
3440 my $ret = $comp->reval($eval);
3441 Carp::confess($@) if $@;
3442 return if $CPAN::Signal;
3444 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3445 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3446 $obj->set(%{$ret->{$_}});
3447 return if $CPAN::Signal;
3451 #-> sub CPAN::Index::write_metadata_cache ;
3452 sub write_metadata_cache {
3454 return unless $CPAN::Config->{'cache_metadata'};
3455 return unless $CPAN::META->has_usable("Storable");
3457 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3458 CPAN::Distribution)) {
3459 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3461 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3462 $cache->{last_time} = $LAST_TIME;
3463 $cache->{DATE_OF_02} = $DATE_OF_02;
3464 $cache->{PROTOCOL} = PROTOCOL;
3465 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3466 eval { Storable::nstore($cache, $metadata_file) };
3467 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3470 #-> sub CPAN::Index::read_metadata_cache ;
3471 sub read_metadata_cache {
3473 return unless $CPAN::Config->{'cache_metadata'};
3474 return unless $CPAN::META->has_usable("Storable");
3475 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3476 return unless -r $metadata_file and -f $metadata_file;
3477 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3479 eval { $cache = Storable::retrieve($metadata_file) };
3480 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3481 if (!$cache || ref $cache ne 'HASH'){
3485 if (exists $cache->{PROTOCOL}) {
3486 if (PROTOCOL > $cache->{PROTOCOL}) {
3487 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3488 "with protocol v%s, requiring v%s\n",
3495 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3496 "with protocol v1.0\n");
3501 while(my($class,$v) = each %$cache) {
3502 next unless $class =~ /^CPAN::/;
3503 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3504 while (my($id,$ro) = each %$v) {
3505 $CPAN::META->{readwrite}{$class}{$id} ||=
3506 $class->new(ID=>$id, RO=>$ro);
3511 unless ($clcnt) { # sanity check
3512 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3515 if ($idcnt < 1000) {
3516 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3517 "in $metadata_file\n");
3520 $CPAN::META->{PROTOCOL} ||=
3521 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3522 # does initialize to some protocol
3523 $LAST_TIME = $cache->{last_time};
3524 $DATE_OF_02 = $cache->{DATE_OF_02};
3525 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3526 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3530 package CPAN::InfoObj;
3535 $self->{RO}{CPAN_USERID}
3538 sub id { shift->{ID}; }
3540 #-> sub CPAN::InfoObj::new ;
3542 my $this = bless {}, shift;
3547 # The set method may only be used by code that reads index data or
3548 # otherwise "objective" data from the outside world. All session
3549 # related material may do anything else with instance variables but
3550 # must not touch the hash under the RO attribute. The reason is that
3551 # the RO hash gets written to Metadata file and is thus persistent.
3553 #-> sub CPAN::InfoObj::set ;
3555 my($self,%att) = @_;
3556 my $class = ref $self;
3558 # This must be ||=, not ||, because only if we write an empty
3559 # reference, only then the set method will write into the readonly
3560 # area. But for Distributions that spring into existence, maybe
3561 # because of a typo, we do not like it that they are written into
3562 # the readonly area and made permanent (at least for a while) and
3563 # that is why we do not "allow" other places to call ->set.
3564 unless ($self->id) {
3565 CPAN->debug("Bug? Empty ID, rejecting");
3568 my $ro = $self->{RO} =
3569 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3571 while (my($k,$v) = each %att) {
3576 #-> sub CPAN::InfoObj::as_glimpse ;
3580 my $class = ref($self);
3581 $class =~ s/^CPAN:://;
3582 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3586 #-> sub CPAN::InfoObj::as_string ;
3590 my $class = ref($self);
3591 $class =~ s/^CPAN:://;
3592 push @m, $class, " id = $self->{ID}\n";
3593 for (sort keys %{$self->{RO}}) {
3594 # next if m/^(ID|RO)$/;
3596 if ($_ eq "CPAN_USERID") {
3597 $extra .= " (".$self->author;
3598 my $email; # old perls!
3599 if ($email = $CPAN::META->instance("CPAN::Author",
3602 $extra .= " <$email>";
3604 $extra .= " <no email>";
3607 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3608 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3611 next unless defined $self->{RO}{$_};
3612 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3614 for (sort keys %$self) {
3615 next if m/^(ID|RO)$/;
3616 if (ref($self->{$_}) eq "ARRAY") {
3617 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3618 } elsif (ref($self->{$_}) eq "HASH") {
3622 join(" ",keys %{$self->{$_}}),
3625 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3631 #-> sub CPAN::InfoObj::author ;
3634 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3637 #-> sub CPAN::InfoObj::dump ;
3640 require Data::Dumper;
3641 print Data::Dumper::Dumper($self);
3644 package CPAN::Author;
3646 #-> sub CPAN::Author::id
3649 my $id = $self->{ID};
3650 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3654 #-> sub CPAN::Author::as_glimpse ;
3658 my $class = ref($self);
3659 $class =~ s/^CPAN:://;
3660 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3668 #-> sub CPAN::Author::fullname ;
3670 shift->{RO}{FULLNAME};
3674 #-> sub CPAN::Author::email ;
3675 sub email { shift->{RO}{EMAIL}; }
3677 #-> sub CPAN::Author::ls ;
3682 # adapted from CPAN::Distribution::verifyMD5 ;
3683 my(@csf); # chksumfile
3684 @csf = $self->id =~ /(.)(.)(.*)/;
3685 $csf[1] = join "", @csf[0,1];
3686 $csf[2] = join "", @csf[1,2];
3688 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3689 unless (grep {$_->[2] eq $csf[1]} @dl) {
3690 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3693 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3694 unless (grep {$_->[2] eq $csf[2]} @dl) {
3695 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3698 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3699 $CPAN::Frontend->myprint(join "", map {
3700 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3701 } sort { $a->[2] cmp $b->[2] } @dl);
3704 # returns an array of arrays, the latter contain (size,mtime,filename)
3705 #-> sub CPAN::Author::dir_listing ;
3708 my $chksumfile = shift;
3709 my $recursive = shift;
3711 File::Spec->catfile($CPAN::Config->{keep_source_where},
3712 "authors", "id", @$chksumfile);
3714 # connect "force" argument with "index_expire".
3716 if (my @stat = stat $lc_want) {
3717 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3719 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3722 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3723 $chksumfile->[-1] .= ".gz";
3724 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3727 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3728 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3734 # adapted from CPAN::Distribution::MD5_check_file ;
3735 my $fh = FileHandle->new;
3737 if (open $fh, $lc_file){
3740 $eval =~ s/\015?\012/\n/g;
3742 my($comp) = Safe->new();
3743 $cksum = $comp->reval($eval);
3745 rename $lc_file, "$lc_file.bad";
3746 Carp::confess($@) if $@;
3749 Carp::carp "Could not open $lc_file for reading";
3752 for $f (sort keys %$cksum) {
3753 if (exists $cksum->{$f}{isdir}) {
3755 my(@dir) = @$chksumfile;
3757 push @dir, $f, "CHECKSUMS";
3759 [$_->[0], $_->[1], "$f/$_->[2]"]
3760 } $self->dir_listing(\@dir,1);
3762 push @result, [ 0, "-", $f ];
3766 ($cksum->{$f}{"size"}||0),
3767 $cksum->{$f}{"mtime"}||"---",
3775 package CPAN::Distribution;
3778 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3782 delete $self->{later};
3785 # CPAN::Distribution::normalize
3788 $s = $self->id unless defined $s;
3792 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3794 return $s if $s =~ m:^N/A|^Contact Author: ;
3795 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3796 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3797 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3802 #-> sub CPAN::Distribution::color_cmd_tmps ;
3803 sub color_cmd_tmps {
3805 my($depth) = shift || 0;
3806 my($color) = shift || 0;
3807 my($ancestors) = shift || [];
3808 # a distribution needs to recurse into its prereq_pms
3810 return if exists $self->{incommandcolor}
3811 && $self->{incommandcolor}==$color;
3813 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3815 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3816 my $prereq_pm = $self->prereq_pm;
3817 if (defined $prereq_pm) {
3818 for my $pre (keys %$prereq_pm) {
3819 my $premo = CPAN::Shell->expand("Module",$pre);
3820 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3824 delete $self->{sponsored_mods};
3825 delete $self->{badtestcnt};
3827 $self->{incommandcolor} = $color;
3830 #-> sub CPAN::Distribution::as_string ;
3833 $self->containsmods;
3834 $self->SUPER::as_string(@_);
3837 #-> sub CPAN::Distribution::containsmods ;
3840 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3841 my $dist_id = $self->{ID};
3842 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3843 my $mod_file = $mod->cpan_file or next;
3844 my $mod_id = $mod->{ID} or next;
3845 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3847 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3849 keys %{$self->{CONTAINSMODS}};
3852 #-> sub CPAN::Distribution::uptodate ;
3856 foreach $c ($self->containsmods) {
3857 my $obj = CPAN::Shell->expandany($c);
3858 return 0 unless $obj->uptodate;
3863 #-> sub CPAN::Distribution::called_for ;
3866 $self->{CALLED_FOR} = $id if defined $id;
3867 return $self->{CALLED_FOR};
3870 #-> sub CPAN::Distribution::safe_chdir ;
3872 my($self,$todir) = @_;
3873 # we die if we cannot chdir and we are debuggable
3874 Carp::confess("safe_chdir called without todir argument")
3875 unless defined $todir and length $todir;
3877 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3880 my $cwd = CPAN::anycwd();
3881 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3882 qq{to todir[$todir]: $!});
3886 #-> sub CPAN::Distribution::get ;
3891 exists $self->{'build_dir'} and push @e,
3892 "Is already unwrapped into directory $self->{'build_dir'}";
3893 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3895 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3898 # Get the file on local disk
3903 File::Spec->catfile(
3904 $CPAN::Config->{keep_source_where},
3907 split(/\//,$self->id)
3910 $self->debug("Doing localize") if $CPAN::DEBUG;
3911 unless ($local_file =
3912 CPAN::FTP->localize("authors/id/$self->{ID}",
3915 if ($CPAN::Index::DATE_OF_02) {
3916 $note = "Note: Current database in memory was generated ".
3917 "on $CPAN::Index::DATE_OF_02\n";
3919 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3921 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3922 $self->{localfile} = $local_file;
3923 return if $CPAN::Signal;
3928 if ($CPAN::META->has_inst("Digest::MD5")) {
3929 $self->debug("Digest::MD5 is installed, verifying");
3932 $self->debug("Digest::MD5 is NOT installed");
3934 return if $CPAN::Signal;
3937 # Create a clean room and go there
3939 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3940 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3941 $self->safe_chdir($builddir);
3942 $self->debug("Removing tmp") if $CPAN::DEBUG;
3943 File::Path::rmtree("tmp");
3944 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3946 $self->safe_chdir($sub_wd);
3949 $self->safe_chdir("tmp");
3954 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3955 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3956 $self->untar_me($local_file);
3957 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3958 $self->unzip_me($local_file);
3959 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3960 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3961 $self->pm2dir_me($local_file);
3963 $self->{archived} = "NO";
3964 $self->safe_chdir($sub_wd);
3968 # we are still in the tmp directory!
3969 # Let's check if the package has its own directory.
3970 my $dh = DirHandle->new(File::Spec->curdir)
3971 or Carp::croak("Couldn't opendir .: $!");
3972 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3974 my ($distdir,$packagedir);
3975 if (@readdir == 1 && -d $readdir[0]) {
3976 $distdir = $readdir[0];
3977 $packagedir = File::Spec->catdir($builddir,$distdir);
3978 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3980 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3982 File::Path::rmtree($packagedir);
3983 File::Copy::move($distdir,$packagedir) or
3984 Carp::confess("Couldn't move $distdir to $packagedir: $!");
3985 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3992 my $userid = $self->cpan_userid;
3994 CPAN->debug("no userid? self[$self]");
3997 my $pragmatic_dir = $userid . '000';
3998 $pragmatic_dir =~ s/\W_//g;
3999 $pragmatic_dir++ while -d "../$pragmatic_dir";
4000 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4001 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4002 File::Path::mkpath($packagedir);
4004 for $f (@readdir) { # is already without "." and ".."
4005 my $to = File::Spec->catdir($packagedir,$f);
4006 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4010 $self->safe_chdir($sub_wd);
4014 $self->{'build_dir'} = $packagedir;
4015 $self->safe_chdir($builddir);
4016 File::Path::rmtree("tmp");
4018 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4019 my($mpl_exists) = -f $mpl;
4020 unless ($mpl_exists) {
4021 # NFS has been reported to have racing problems after the
4022 # renaming of a directory in some environments.
4025 my $mpldh = DirHandle->new($packagedir)
4026 or Carp::croak("Couldn't opendir $packagedir: $!");
4027 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4030 unless ($mpl_exists) {
4031 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4035 my($configure) = File::Spec->catfile($packagedir,"Configure");
4036 if (-f $configure) {
4037 # do we have anything to do?
4038 $self->{'configure'} = $configure;
4039 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4040 $CPAN::Frontend->myprint(qq{
4041 Package comes with a Makefile and without a Makefile.PL.
4042 We\'ll try to build it with that Makefile then.
4044 $self->{writemakefile} = "YES";
4047 my $cf = $self->called_for || "unknown";
4052 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4053 $cf = "unknown" unless length($cf);
4054 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4055 (The test -f "$mpl" returned false.)
4056 Writing one on our own (setting NAME to $cf)\a\n});
4057 $self->{had_no_makefile_pl}++;
4060 # Writing our own Makefile.PL
4062 my $fh = FileHandle->new;
4064 or Carp::croak("Could not open >$mpl: $!");
4066 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4067 # because there was no Makefile.PL supplied.
4068 # Autogenerated on: }.scalar localtime().qq{
4070 use ExtUtils::MakeMaker;
4071 WriteMakefile(NAME => q[$cf]);
4081 # CPAN::Distribution::untar_me ;
4083 my($self,$local_file) = @_;
4084 $self->{archived} = "tar";
4085 if (CPAN::Tarzip->untar($local_file)) {
4086 $self->{unwrapped} = "YES";
4088 $self->{unwrapped} = "NO";
4092 # CPAN::Distribution::unzip_me ;
4094 my($self,$local_file) = @_;
4095 $self->{archived} = "zip";
4096 if (CPAN::Tarzip->unzip($local_file)) {
4097 $self->{unwrapped} = "YES";
4099 $self->{unwrapped} = "NO";
4105 my($self,$local_file) = @_;
4106 $self->{archived} = "pm";
4107 my $to = File::Basename::basename($local_file);
4108 $to =~ s/\.(gz|Z)(?!\n)\Z//;
4109 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4110 $self->{unwrapped} = "YES";
4112 $self->{unwrapped} = "NO";
4116 #-> sub CPAN::Distribution::new ;
4118 my($class,%att) = @_;
4120 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4122 my $this = { %att };
4123 return bless $this, $class;
4126 #-> sub CPAN::Distribution::look ;
4130 if ($^O eq 'MacOS') {
4131 $self->Mac::BuildTools::look;
4135 if ( $CPAN::Config->{'shell'} ) {
4136 $CPAN::Frontend->myprint(qq{
4137 Trying to open a subshell in the build directory...
4140 $CPAN::Frontend->myprint(qq{
4141 Your configuration does not define a value for subshells.
4142 Please define it with "o conf shell <your shell>"
4146 my $dist = $self->id;
4148 unless ($dir = $self->dir) {
4151 unless ($dir ||= $self->dir) {
4152 $CPAN::Frontend->mywarn(qq{
4153 Could not determine which directory to use for looking at $dist.
4157 my $pwd = CPAN::anycwd();
4158 $self->safe_chdir($dir);
4159 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4160 unless (system($CPAN::Config->{'shell'}) == 0) {
4162 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4164 $self->safe_chdir($pwd);
4167 # CPAN::Distribution::cvs_import ;
4171 my $dir = $self->dir;
4173 my $package = $self->called_for;
4174 my $module = $CPAN::META->instance('CPAN::Module', $package);
4175 my $version = $module->cpan_version;
4177 my $userid = $self->cpan_userid;
4179 my $cvs_dir = (split /\//, $dir)[-1];
4180 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4182 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4184 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4185 if ($cvs_site_perl) {
4186 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4188 my $cvs_log = qq{"imported $package $version sources"};
4189 $version =~ s/\./_/g;
4190 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4191 "$cvs_dir", $userid, "v$version");
4193 my $pwd = CPAN::anycwd();
4194 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4196 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4198 $CPAN::Frontend->myprint(qq{@cmd\n});
4199 system(@cmd) == 0 or
4200 $CPAN::Frontend->mydie("cvs import failed");
4201 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4204 #-> sub CPAN::Distribution::readme ;
4207 my($dist) = $self->id;
4208 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4209 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4212 File::Spec->catfile(
4213 $CPAN::Config->{keep_source_where},
4216 split(/\//,"$sans.readme"),
4218 $self->debug("Doing localize") if $CPAN::DEBUG;
4219 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4221 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4223 if ($^O eq 'MacOS') {
4224 Mac::BuildTools::launch_file($local_file);
4228 my $fh_pager = FileHandle->new;
4229 local($SIG{PIPE}) = "IGNORE";
4230 $fh_pager->open("|$CPAN::Config->{'pager'}")
4231 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4232 my $fh_readme = FileHandle->new;
4233 $fh_readme->open($local_file)
4234 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4235 $CPAN::Frontend->myprint(qq{
4238 with pager "$CPAN::Config->{'pager'}"
4241 $fh_pager->print(<$fh_readme>);
4244 #-> sub CPAN::Distribution::verifyMD5 ;
4249 $self->{MD5_STATUS} ||= "";
4250 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4251 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4253 my($lc_want,$lc_file,@local,$basename);
4254 @local = split(/\//,$self->id);
4256 push @local, "CHECKSUMS";
4258 File::Spec->catfile($CPAN::Config->{keep_source_where},
4259 "authors", "id", @local);
4264 $self->MD5_check_file($lc_want)
4266 return $self->{MD5_STATUS} = "OK";
4268 $lc_file = CPAN::FTP->localize("authors/id/@local",
4271 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4272 $local[-1] .= ".gz";
4273 $lc_file = CPAN::FTP->localize("authors/id/@local",
4276 $lc_file =~ s/\.gz(?!\n)\Z//;
4277 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4282 $self->MD5_check_file($lc_file);
4285 #-> sub CPAN::Distribution::MD5_check_file ;
4286 sub MD5_check_file {
4287 my($self,$chk_file) = @_;
4288 my($cksum,$file,$basename);
4289 $file = $self->{localfile};
4290 $basename = File::Basename::basename($file);
4291 my $fh = FileHandle->new;
4292 if (open $fh, $chk_file){
4295 $eval =~ s/\015?\012/\n/g;
4297 my($comp) = Safe->new();
4298 $cksum = $comp->reval($eval);
4300 rename $chk_file, "$chk_file.bad";
4301 Carp::confess($@) if $@;
4304 Carp::carp "Could not open $chk_file for reading";
4307 if (exists $cksum->{$basename}{md5}) {
4308 $self->debug("Found checksum for $basename:" .
4309 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4313 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4315 $fh = CPAN::Tarzip->TIEHANDLE($file);
4318 # had to inline it, when I tied it, the tiedness got lost on
4319 # the call to eq_MD5. (Jan 1998)
4320 my $md5 = Digest::MD5->new;
4323 while ($fh->READ($ref, 4096) > 0){
4326 my $hexdigest = $md5->hexdigest;
4327 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4331 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4332 return $self->{MD5_STATUS} = "OK";
4334 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4335 qq{distribution file. }.
4336 qq{Please investigate.\n\n}.
4338 $CPAN::META->instance(
4343 my $wrap = qq{I\'d recommend removing $file. Its MD5
4344 checksum is incorrect. Maybe you have configured your 'urllist' with
4345 a bad URL. Please check this array with 'o conf urllist', and
4348 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4350 # former versions just returned here but this seems a
4351 # serious threat that deserves a die
4353 # $CPAN::Frontend->myprint("\n\n");
4357 # close $fh if fileno($fh);
4359 $self->{MD5_STATUS} ||= "";
4360 if ($self->{MD5_STATUS} eq "NIL") {
4361 $CPAN::Frontend->mywarn(qq{
4362 Warning: No md5 checksum for $basename in $chk_file.
4364 The cause for this may be that the file is very new and the checksum
4365 has not yet been calculated, but it may also be that something is
4366 going awry right now.
4368 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4369 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4371 $self->{MD5_STATUS} = "NIL";
4376 #-> sub CPAN::Distribution::eq_MD5 ;
4378 my($self,$fh,$expectMD5) = @_;
4379 my $md5 = Digest::MD5->new;
4381 while (read($fh, $data, 4096)){
4384 # $md5->addfile($fh);
4385 my $hexdigest = $md5->hexdigest;
4386 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4387 $hexdigest eq $expectMD5;
4390 #-> sub CPAN::Distribution::force ;
4392 # Both modules and distributions know if "force" is in effect by
4393 # autoinspection, not by inspecting a global variable. One of the
4394 # reason why this was chosen to work that way was the treatment of
4395 # dependencies. They should not autpomatically inherit the force
4396 # status. But this has the downside that ^C and die() will return to
4397 # the prompt but will not be able to reset the force_update
4398 # attributes. We try to correct for it currently in the read_metadata
4399 # routine, and immediately before we check for a Signal. I hope this
4400 # works out in one of v1.57_53ff
4403 my($self, $method) = @_;
4405 MD5_STATUS archived build_dir localfile make install unwrapped
4408 delete $self->{$att};
4410 if ($method && $method eq "install") {
4411 $self->{"force_update"}++; # name should probably have been force_install
4415 #-> sub CPAN::Distribution::unforce ;
4418 delete $self->{'force_update'};
4421 #-> sub CPAN::Distribution::isa_perl ;
4424 my $file = File::Basename::basename($self->id);
4425 if ($file =~ m{ ^ perl
4438 } elsif ($self->cpan_comment
4440 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4446 #-> sub CPAN::Distribution::perl ;
4452 #-> sub CPAN::Distribution::make ;
4455 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4456 # Emergency brake if they said install Pippi and get newest perl
4457 if ($self->isa_perl) {
4459 $self->called_for ne $self->id &&
4460 ! $self->{force_update}
4462 # if we die here, we break bundles
4463 $CPAN::Frontend->mywarn(sprintf qq{
4464 The most recent version "%s" of the module "%s"
4465 comes with the current version of perl (%s).
4466 I\'ll build that only if you ask for something like
4471 $CPAN::META->instance(
4485 $self->{archived} eq "NO" and push @e,
4486 "Is neither a tar nor a zip archive.";
4488 $self->{unwrapped} eq "NO" and push @e,
4489 "had problems unarchiving. Please build manually";
4491 exists $self->{writemakefile} &&
4492 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4493 $1 || "Had some problem writing Makefile";
4495 defined $self->{'make'} and push @e,
4496 "Has already been processed within this session";
4498 exists $self->{later} and length($self->{later}) and
4499 push @e, $self->{later};
4501 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4503 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4504 my $builddir = $self->dir;
4505 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4506 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4508 if ($^O eq 'MacOS') {
4509 Mac::BuildTools::make($self);
4514 if ($self->{'configure'}) {
4515 $system = $self->{'configure'};
4517 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4519 # This needs a handler that can be turned on or off:
4520 # $switch = "-MExtUtils::MakeMaker ".
4521 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4523 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4525 unless (exists $self->{writemakefile}) {
4526 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4529 if ($CPAN::Config->{inactivity_timeout}) {
4531 alarm $CPAN::Config->{inactivity_timeout};
4532 local $SIG{CHLD}; # = sub { wait };
4533 if (defined($pid = fork)) {
4538 # note, this exec isn't necessary if
4539 # inactivity_timeout is 0. On the Mac I'd
4540 # suggest, we set it always to 0.
4544 $CPAN::Frontend->myprint("Cannot fork: $!");
4552 $CPAN::Frontend->myprint($@);
4553 $self->{writemakefile} = "NO $@";
4558 $ret = system($system);
4560 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4564 if (-f "Makefile") {
4565 $self->{writemakefile} = "YES";
4566 delete $self->{make_clean}; # if cleaned before, enable next
4568 $self->{writemakefile} =
4569 qq{NO Makefile.PL refused to write a Makefile.};
4570 # It's probably worth it to record the reason, so let's retry
4572 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4573 # $self->{writemakefile} .= <$fh>;
4577 delete $self->{force_update};
4580 if (my @prereq = $self->unsat_prereq){
4581 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4583 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4584 if (system($system) == 0) {
4585 $CPAN::Frontend->myprint(" $system -- OK\n");
4586 $self->{'make'} = "YES";
4588 $self->{writemakefile} ||= "YES";
4589 $self->{'make'} = "NO";
4590 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4594 sub follow_prereqs {
4598 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4599 "during [$id] -----\n");
4601 for my $p (@prereq) {
4602 $CPAN::Frontend->myprint(" $p\n");
4605 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4607 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4608 require ExtUtils::MakeMaker;
4609 my $answer = ExtUtils::MakeMaker::prompt(
4610 "Shall I follow them and prepend them to the queue
4611 of modules we are processing right now?", "yes");
4612 $follow = $answer =~ /^\s*y/i;
4616 myprint(" Ignoring dependencies on modules @prereq\n");
4619 # color them as dirty
4620 for my $p (@prereq) {
4621 # warn "calling color_cmd_tmps(0,1)";
4622 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4624 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4625 $self->{later} = "Delayed until after prerequisites";
4626 return 1; # signal success to the queuerunner
4630 #-> sub CPAN::Distribution::unsat_prereq ;
4633 my $prereq_pm = $self->prereq_pm or return;
4635 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4636 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4637 # we were too demanding:
4638 next if $nmo->uptodate;
4640 # if they have not specified a version, we accept any installed one
4641 if (not defined $need_version or
4642 $need_version == 0 or
4643 $need_version eq "undef") {
4644 next if defined $nmo->inst_file;
4647 # We only want to install prereqs if either they're not installed
4648 # or if the installed version is too old. We cannot omit this
4649 # check, because if 'force' is in effect, nobody else will check.
4653 defined $nmo->inst_file &&
4654 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4656 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4660 CPAN::Version->readable($need_version)
4666 if ($self->{sponsored_mods}{$need_module}++){
4667 # We have already sponsored it and for some reason it's still
4668 # not available. So we do nothing. Or what should we do?
4669 # if we push it again, we have a potential infinite loop
4672 push @need, $need_module;
4677 #-> sub CPAN::Distribution::prereq_pm ;
4680 return $self->{prereq_pm} if
4681 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4682 return unless $self->{writemakefile}; # no need to have succeeded
4683 # but we must have run it
4684 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4685 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4690 $fh = FileHandle->new("<$makefile\0")) {
4694 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4696 last if /MakeMaker post_initialize section/;
4698 \s+PREREQ_PM\s+=>\s+(.+)
4701 # warn "Found prereq expr[$p]";
4703 # Regexp modified by A.Speer to remember actual version of file
4704 # PREREQ_PM hash key wants, then add to
4705 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4706 # In case a prereq is mentioned twice, complain.
4707 if ( defined $p{$1} ) {
4708 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4715 $self->{prereq_pm_detected}++;
4716 return $self->{prereq_pm} = \%p;
4719 #-> sub CPAN::Distribution::test ;
4724 delete $self->{force_update};
4727 $CPAN::Frontend->myprint("Running make test\n");
4728 if (my @prereq = $self->unsat_prereq){
4729 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4733 exists $self->{make} or exists $self->{later} or push @e,
4734 "Make had some problems, maybe interrupted? Won't test";
4736 exists $self->{'make'} and
4737 $self->{'make'} eq 'NO' and
4738 push @e, "Can't test without successful make";
4740 exists $self->{build_dir} or push @e, "Has no own directory";
4741 $self->{badtestcnt} ||= 0;
4742 $self->{badtestcnt} > 0 and
4743 push @e, "Won't repeat unsuccessful test during this command";
4745 exists $self->{later} and length($self->{later}) and
4746 push @e, $self->{later};
4748 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4750 chdir $self->{'build_dir'} or
4751 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4752 $self->debug("Changed directory to $self->{'build_dir'}")
4755 if ($^O eq 'MacOS') {
4756 Mac::BuildTools::make_test($self);
4760 local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4761 $CPAN::META->set_perl5lib;
4762 my $system = join " ", $CPAN::Config->{'make'}, "test";
4763 if (system($system) == 0) {
4764 $CPAN::Frontend->myprint(" $system -- OK\n");
4765 $CPAN::META->is_tested($self->{'build_dir'});
4766 $self->{make_test} = "YES";
4768 $self->{make_test} = "NO";
4769 $self->{badtestcnt}++;
4770 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4774 #-> sub CPAN::Distribution::clean ;
4777 $CPAN::Frontend->myprint("Running make clean\n");
4780 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4781 push @e, "make clean already called once";
4782 exists $self->{build_dir} or push @e, "Has no own directory";
4783 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4785 chdir $self->{'build_dir'} or
4786 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4787 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4789 if ($^O eq 'MacOS') {
4790 Mac::BuildTools::make_clean($self);
4794 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4795 if (system($system) == 0) {
4796 $CPAN::Frontend->myprint(" $system -- OK\n");
4800 # Jost Krieger pointed out that this "force" was wrong because
4801 # it has the effect that the next "install" on this distribution
4802 # will untar everything again. Instead we should bring the
4803 # object's state back to where it is after untarring.
4805 delete $self->{force_update};
4806 delete $self->{install};
4807 delete $self->{writemakefile};
4808 delete $self->{make};
4809 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4810 $self->{make_clean} = "YES";
4813 # Hmmm, what to do if make clean failed?
4815 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4817 make clean did not succeed, marking directory as unusable for further work.
4819 $self->force("make"); # so that this directory won't be used again
4824 #-> sub CPAN::Distribution::install ;
4829 delete $self->{force_update};
4832 $CPAN::Frontend->myprint("Running make install\n");
4835 exists $self->{build_dir} or push @e, "Has no own directory";
4837 exists $self->{make} or exists $self->{later} or push @e,
4838 "Make had some problems, maybe interrupted? Won't install";
4840 exists $self->{'make'} and
4841 $self->{'make'} eq 'NO' and
4842 push @e, "make had returned bad status, install seems impossible";
4844 push @e, "make test had returned bad status, ".
4845 "won't install without force"
4846 if exists $self->{'make_test'} and
4847 $self->{'make_test'} eq 'NO' and
4848 ! $self->{'force_update'};
4850 exists $self->{'install'} and push @e,
4851 $self->{'install'} eq "YES" ?
4852 "Already done" : "Already tried without success";
4854 exists $self->{later} and length($self->{later}) and
4855 push @e, $self->{later};
4857 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4859 chdir $self->{'build_dir'} or
4860 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4861 $self->debug("Changed directory to $self->{'build_dir'}")
4864 if ($^O eq 'MacOS') {
4865 Mac::BuildTools::make_install($self);
4869 my $system = join(" ", $CPAN::Config->{'make'},
4870 "install", $CPAN::Config->{make_install_arg});
4871 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4872 my($pipe) = FileHandle->new("$system $stderr |");
4875 $CPAN::Frontend->myprint($_);
4880 $CPAN::Frontend->myprint(" $system -- OK\n");
4881 $CPAN::META->is_installed($self->{'build_dir'});
4882 return $self->{'install'} = "YES";
4884 $self->{'install'} = "NO";
4885 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4886 if ($makeout =~ /permission/s && $> > 0) {
4887 $CPAN::Frontend->myprint(qq{ You may have to su }.
4888 qq{to root to install the package\n});
4891 delete $self->{force_update};
4894 #-> sub CPAN::Distribution::dir ;
4896 shift->{'build_dir'};
4899 package CPAN::Bundle;
4903 $CPAN::Frontend->myprint($self->as_string);
4908 delete $self->{later};
4909 for my $c ( $self->contains ) {
4910 my $obj = CPAN::Shell->expandany($c) or next;
4915 #-> sub CPAN::Bundle::color_cmd_tmps ;
4916 sub color_cmd_tmps {
4918 my($depth) = shift || 0;
4919 my($color) = shift || 0;
4920 my($ancestors) = shift || [];
4921 # a module needs to recurse to its cpan_file, a distribution needs
4922 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4924 return if exists $self->{incommandcolor}
4925 && $self->{incommandcolor}==$color;
4927 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4929 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4931 for my $c ( $self->contains ) {
4932 my $obj = CPAN::Shell->expandany($c) or next;
4933 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4934 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4937 delete $self->{badtestcnt};
4939 $self->{incommandcolor} = $color;
4942 #-> sub CPAN::Bundle::as_string ;
4946 # following line must be "=", not "||=" because we have a moving target
4947 $self->{INST_VERSION} = $self->inst_version;
4948 return $self->SUPER::as_string;
4951 #-> sub CPAN::Bundle::contains ;
4954 my($inst_file) = $self->inst_file || "";
4955 my($id) = $self->id;
4956 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4957 unless ($inst_file) {
4958 # Try to get at it in the cpan directory
4959 $self->debug("no inst_file") if $CPAN::DEBUG;
4961 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4962 $cpan_file = $self->cpan_file;
4963 if ($cpan_file eq "N/A") {
4964 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4965 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4967 my $dist = $CPAN::META->instance('CPAN::Distribution',
4970 $self->debug($dist->as_string) if $CPAN::DEBUG;
4971 my($todir) = $CPAN::Config->{'cpan_home'};
4972 my(@me,$from,$to,$me);
4973 @me = split /::/, $self->id;
4975 $me = File::Spec->catfile(@me);
4976 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4977 $to = File::Spec->catfile($todir,$me);
4978 File::Path::mkpath(File::Basename::dirname($to));
4979 File::Copy::copy($from, $to)
4980 or Carp::confess("Couldn't copy $from to $to: $!");
4984 my $fh = FileHandle->new;
4986 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4988 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4990 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4991 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4992 next unless $in_cont;
4997 push @result, (split " ", $_, 2)[0];
5000 delete $self->{STATUS};
5001 $self->{CONTAINS} = \@result;
5002 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5004 $CPAN::Frontend->mywarn(qq{
5005 The bundle file "$inst_file" may be a broken
5006 bundlefile. It seems not to contain any bundle definition.
5007 Please check the file and if it is bogus, please delete it.
5008 Sorry for the inconvenience.
5014 #-> sub CPAN::Bundle::find_bundle_file
5015 sub find_bundle_file {
5016 my($self,$where,$what) = @_;
5017 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5018 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5019 ### my $bu = File::Spec->catfile($where,$what);
5020 ### return $bu if -f $bu;
5021 my $manifest = File::Spec->catfile($where,"MANIFEST");
5022 unless (-f $manifest) {
5023 require ExtUtils::Manifest;
5024 my $cwd = CPAN::anycwd();
5025 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5026 ExtUtils::Manifest::mkmanifest();
5027 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5029 my $fh = FileHandle->new($manifest)
5030 or Carp::croak("Couldn't open $manifest: $!");
5033 if ($^O eq 'MacOS') {
5036 $what2 =~ s/:Bundle://;
5039 $what2 =~ s|Bundle[/\\]||;
5044 my($file) = /(\S+)/;
5045 if ($file =~ m|\Q$what\E$|) {
5047 # return File::Spec->catfile($where,$bu); # bad
5050 # retry if she managed to
5051 # have no Bundle directory
5052 $bu = $file if $file =~ m|\Q$what2\E$|;
5054 $bu =~ tr|/|:| if $^O eq 'MacOS';
5055 return File::Spec->catfile($where, $bu) if $bu;
5056 Carp::croak("Couldn't find a Bundle file in $where");
5059 # needs to work quite differently from Module::inst_file because of
5060 # cpan_home/Bundle/ directory and the possibility that we have
5061 # shadowing effect. As it makes no sense to take the first in @INC for
5062 # Bundles, we parse them all for $VERSION and take the newest.
5064 #-> sub CPAN::Bundle::inst_file ;
5069 @me = split /::/, $self->id;
5072 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5073 my $bfile = File::Spec->catfile($incdir, @me);
5074 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5075 next unless -f $bfile;
5076 my $foundv = MM->parse_version($bfile);
5077 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5078 $self->{INST_FILE} = $bfile;
5079 $self->{INST_VERSION} = $bestv = $foundv;
5085 #-> sub CPAN::Bundle::inst_version ;
5088 $self->inst_file; # finds INST_VERSION as side effect
5089 $self->{INST_VERSION};
5092 #-> sub CPAN::Bundle::rematein ;
5094 my($self,$meth) = @_;
5095 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5096 my($id) = $self->id;
5097 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5098 unless $self->inst_file || $self->cpan_file;
5100 for $s ($self->contains) {
5101 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5102 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5103 if ($type eq 'CPAN::Distribution') {
5104 $CPAN::Frontend->mywarn(qq{
5105 The Bundle }.$self->id.qq{ contains
5106 explicitly a file $s.
5110 # possibly noisy action:
5111 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5112 my $obj = $CPAN::META->instance($type,$s);
5114 if ($obj->isa(CPAN::Bundle)
5116 exists $obj->{install_failed}
5118 ref($obj->{install_failed}) eq "HASH"
5120 for (keys %{$obj->{install_failed}}) {
5121 $self->{install_failed}{$_} = undef; # propagate faiure up
5124 $fail{$s} = 1; # the bundle itself may have succeeded but
5129 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5130 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5132 delete $self->{install_failed}{$s};
5139 # recap with less noise
5140 if ( $meth eq "install" ) {
5143 my $raw = sprintf(qq{Bundle summary:
5144 The following items in bundle %s had installation problems:},
5147 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5148 $CPAN::Frontend->myprint("\n");
5151 for $s ($self->contains) {
5153 $paragraph .= "$s ";
5154 $self->{install_failed}{$s} = undef;
5155 $reported{$s} = undef;
5158 my $report_propagated;
5159 for $s (sort keys %{$self->{install_failed}}) {
5160 next if exists $reported{$s};
5161 $paragraph .= "and the following items had problems
5162 during recursive bundle calls: " unless $report_propagated++;
5163 $paragraph .= "$s ";
5165 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5166 $CPAN::Frontend->myprint("\n");
5168 $self->{'install'} = 'YES';
5173 #sub CPAN::Bundle::xs_file
5175 # If a bundle contains another that contains an xs_file we have
5176 # here, we just don't bother I suppose
5180 #-> sub CPAN::Bundle::force ;
5181 sub force { shift->rematein('force',@_); }
5182 #-> sub CPAN::Bundle::get ;
5183 sub get { shift->rematein('get',@_); }
5184 #-> sub CPAN::Bundle::make ;
5185 sub make { shift->rematein('make',@_); }
5186 #-> sub CPAN::Bundle::test ;
5189 $self->{badtestcnt} ||= 0;
5190 $self->rematein('test',@_);
5192 #-> sub CPAN::Bundle::install ;
5195 $self->rematein('install',@_);
5197 #-> sub CPAN::Bundle::clean ;
5198 sub clean { shift->rematein('clean',@_); }
5200 #-> sub CPAN::Bundle::uptodate ;
5203 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5205 foreach $c ($self->contains) {
5206 my $obj = CPAN::Shell->expandany($c);
5207 return 0 unless $obj->uptodate;
5212 #-> sub CPAN::Bundle::readme ;
5215 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5216 No File found for bundle } . $self->id . qq{\n}), return;
5217 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5218 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5221 package CPAN::Module;
5224 # sub CPAN::Module::userid
5227 return unless exists $self->{RO}; # should never happen
5228 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5230 # sub CPAN::Module::description
5231 sub description { shift->{RO}{description} }
5235 delete $self->{later};
5236 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5241 #-> sub CPAN::Module::color_cmd_tmps ;
5242 sub color_cmd_tmps {
5244 my($depth) = shift || 0;
5245 my($color) = shift || 0;
5246 my($ancestors) = shift || [];
5247 # a module needs to recurse to its cpan_file
5249 return if exists $self->{incommandcolor}
5250 && $self->{incommandcolor}==$color;
5252 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5254 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5256 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5257 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5260 delete $self->{badtestcnt};
5262 $self->{incommandcolor} = $color;
5265 #-> sub CPAN::Module::as_glimpse ;
5269 my $class = ref($self);
5270 $class =~ s/^CPAN:://;
5274 $CPAN::Shell::COLOR_REGISTERED
5276 $CPAN::META->has_inst("Term::ANSIColor")
5278 $self->{RO}{description}
5280 $color_on = Term::ANSIColor::color("green");
5281 $color_off = Term::ANSIColor::color("reset");
5283 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5292 #-> sub CPAN::Module::as_string ;
5296 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5297 my $class = ref($self);
5298 $class =~ s/^CPAN:://;
5300 push @m, $class, " id = $self->{ID}\n";
5301 my $sprintf = " %-12s %s\n";
5302 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5303 if $self->description;
5304 my $sprintf2 = " %-12s %s (%s)\n";
5306 $userid = $self->userid;
5309 if ($author = CPAN::Shell->expand('Author',$userid)) {
5312 if ($m = $author->email) {
5319 $author->fullname . $email
5323 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5324 if $self->cpan_version;
5325 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5326 if $self->cpan_file;
5327 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5328 my(%statd,%stats,%statl,%stati);
5329 @statd{qw,? i c a b R M S,} = qw,unknown idea
5330 pre-alpha alpha beta released mature standard,;
5331 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5332 developer comp.lang.perl.* none abandoned,;
5333 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5334 @stati{qw,? f r O h,} = qw,unknown functions
5335 references+ties object-oriented hybrid,;
5336 $statd{' '} = 'unknown';
5337 $stats{' '} = 'unknown';
5338 $statl{' '} = 'unknown';
5339 $stati{' '} = 'unknown';
5347 $statd{$self->{RO}{statd}},
5348 $stats{$self->{RO}{stats}},
5349 $statl{$self->{RO}{statl}},
5350 $stati{$self->{RO}{stati}}
5351 ) if $self->{RO}{statd};
5352 my $local_file = $self->inst_file;
5353 unless ($self->{MANPAGE}) {
5355 $self->{MANPAGE} = $self->manpage_headline($local_file);
5357 # If we have already untarred it, we should look there
5358 my $dist = $CPAN::META->instance('CPAN::Distribution',
5360 # warn "dist[$dist]";
5361 # mff=manifest file; mfh=manifest handle
5366 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5368 $mfh = FileHandle->new($mff)
5370 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5371 my $lfre = $self->id; # local file RE
5374 my($lfl); # local file file
5376 my(@mflines) = <$mfh>;
5381 while (length($lfre)>5 and !$lfl) {
5382 ($lfl) = grep /$lfre/, @mflines;
5383 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5386 $lfl =~ s/\s.*//; # remove comments
5387 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5388 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5389 # warn "lfl_abs[$lfl_abs]";
5391 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5397 for $item (qw/MANPAGE/) {
5398 push @m, sprintf($sprintf, $item, $self->{$item})
5399 if exists $self->{$item};
5401 for $item (qw/CONTAINS/) {
5402 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5403 if exists $self->{$item} && @{$self->{$item}};
5405 push @m, sprintf($sprintf, 'INST_FILE',
5406 $local_file || "(not installed)");
5407 push @m, sprintf($sprintf, 'INST_VERSION',
5408 $self->inst_version) if $local_file;
5412 sub manpage_headline {
5413 my($self,$local_file) = @_;
5414 my(@local_file) = $local_file;
5415 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5416 push @local_file, $local_file;
5418 for $locf (@local_file) {
5419 next unless -f $locf;
5420 my $fh = FileHandle->new($locf)
5421 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5425 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5426 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5439 #-> sub CPAN::Module::cpan_file ;
5440 # Note: also inherited by CPAN::Bundle
5443 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5444 unless (defined $self->{RO}{CPAN_FILE}) {
5445 CPAN::Index->reload;
5447 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5448 return $self->{RO}{CPAN_FILE};
5450 my $userid = $self->userid;
5452 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5453 my $author = $CPAN::META->instance("CPAN::Author",
5455 my $fullname = $author->fullname;
5456 my $email = $author->email;
5457 unless (defined $fullname && defined $email) {
5458 return sprintf("Contact Author %s",
5462 return "Contact Author $fullname <$email>";
5464 return "Contact Author $userid (Email address not available)";
5472 #-> sub CPAN::Module::cpan_version ;
5476 $self->{RO}{CPAN_VERSION} = 'undef'
5477 unless defined $self->{RO}{CPAN_VERSION};
5478 # I believe this is always a bug in the index and should be reported
5479 # as such, but usually I find out such an error and do not want to
5480 # provoke too many bugreports
5482 $self->{RO}{CPAN_VERSION};
5485 #-> sub CPAN::Module::force ;
5488 $self->{'force_update'}++;
5491 #-> sub CPAN::Module::rematein ;
5493 my($self,$meth) = @_;
5494 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5497 my $cpan_file = $self->cpan_file;
5498 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5499 $CPAN::Frontend->mywarn(sprintf qq{
5500 The module %s isn\'t available on CPAN.
5502 Either the module has not yet been uploaded to CPAN, or it is
5503 temporary unavailable. Please contact the author to find out
5504 more about the status. Try 'i %s'.
5511 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5512 $pack->called_for($self->id);
5513 $pack->force($meth) if exists $self->{'force_update'};
5515 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5516 delete $self->{'force_update'};
5519 #-> sub CPAN::Module::readme ;
5520 sub readme { shift->rematein('readme') }
5521 #-> sub CPAN::Module::look ;
5522 sub look { shift->rematein('look') }
5523 #-> sub CPAN::Module::cvs_import ;
5524 sub cvs_import { shift->rematein('cvs_import') }
5525 #-> sub CPAN::Module::get ;
5526 sub get { shift->rematein('get',@_); }
5527 #-> sub CPAN::Module::make ;
5530 $self->rematein('make');
5532 #-> sub CPAN::Module::test ;
5535 $self->{badtestcnt} ||= 0;
5536 $self->rematein('test',@_);
5538 #-> sub CPAN::Module::uptodate ;
5541 my($latest) = $self->cpan_version;
5543 my($inst_file) = $self->inst_file;
5545 if (defined $inst_file) {
5546 $have = $self->inst_version;
5551 ! CPAN::Version->vgt($latest, $have)
5553 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5554 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5559 #-> sub CPAN::Module::install ;
5565 not exists $self->{'force_update'}
5567 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5571 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
5572 $CPAN::Frontend->mywarn(qq{
5573 \n\n\n ***WARNING***
5574 The module $self->{ID} has no active maintainer.\n\n\n
5578 $self->rematein('install') if $doit;
5580 #-> sub CPAN::Module::clean ;
5581 sub clean { shift->rematein('clean') }
5583 #-> sub CPAN::Module::inst_file ;
5587 @packpath = split /::/, $self->{ID};
5588 $packpath[-1] .= ".pm";
5589 foreach $dir (@INC) {
5590 my $pmfile = File::Spec->catfile($dir,@packpath);
5598 #-> sub CPAN::Module::xs_file ;
5602 @packpath = split /::/, $self->{ID};
5603 push @packpath, $packpath[-1];
5604 $packpath[-1] .= "." . $Config::Config{'dlext'};
5605 foreach $dir (@INC) {
5606 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5614 #-> sub CPAN::Module::inst_version ;
5617 my $parsefile = $self->inst_file or return;
5618 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5621 # there was a bug in 5.6.0 that let lots of unini warnings out of
5622 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5623 # the following workaround after 5.6.1 is out.
5624 local($SIG{__WARN__}) = sub { my $w = shift;
5625 return if $w =~ /uninitialized/i;
5629 $have = MM->parse_version($parsefile) || "undef";
5630 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5631 $have =~ s/ $//; # trailing whitespace happens all the time
5633 # My thoughts about why %vd processing should happen here
5635 # Alt1 maintain it as string with leading v:
5636 # read index files do nothing
5637 # compare it use utility for compare
5638 # print it do nothing
5640 # Alt2 maintain it as what it is
5641 # read index files convert
5642 # compare it use utility because there's still a ">" vs "gt" issue
5643 # print it use CPAN::Version for print
5645 # Seems cleaner to hold it in memory as a string starting with a "v"
5647 # If the author of this module made a mistake and wrote a quoted
5648 # "v1.13" instead of v1.13, we simply leave it at that with the
5649 # effect that *we* will treat it like a v-tring while the rest of
5650 # perl won't. Seems sensible when we consider that any action we
5651 # could take now would just add complexity.
5653 $have = CPAN::Version->readable($have);
5655 $have =~ s/\s*//g; # stringify to float around floating point issues
5656 $have; # no stringify needed, \s* above matches always
5659 package CPAN::Tarzip;
5661 # CPAN::Tarzip::gzip
5663 my($class,$read,$write) = @_;
5664 if ($CPAN::META->has_inst("Compress::Zlib")) {
5666 $fhw = FileHandle->new($read)
5667 or $CPAN::Frontend->mydie("Could not open $read: $!");
5668 my $gz = Compress::Zlib::gzopen($write, "wb")
5669 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5670 $gz->gzwrite($buffer)
5671 while read($fhw,$buffer,4096) > 0 ;
5676 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5681 # CPAN::Tarzip::gunzip
5683 my($class,$read,$write) = @_;
5684 if ($CPAN::META->has_inst("Compress::Zlib")) {
5686 $fhw = FileHandle->new(">$write")
5687 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5688 my $gz = Compress::Zlib::gzopen($read, "rb")
5689 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5690 $fhw->print($buffer)
5691 while $gz->gzread($buffer) > 0 ;
5692 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5693 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5698 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5703 # CPAN::Tarzip::gtest
5705 my($class,$read) = @_;
5706 # After I had reread the documentation in zlib.h, I discovered that
5707 # uncompressed files do not lead to an gzerror (anymore?).
5708 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5711 my $gz = Compress::Zlib::gzopen($read, "rb")
5712 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5714 $Compress::Zlib::gzerrno));
5715 while ($gz->gzread($buffer) > 0 ){
5716 $len += length($buffer);
5719 my $err = $gz->gzerror;
5720 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5721 if ($len == -s $read){
5723 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5726 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5729 return system("$CPAN::Config->{gzip} -dt $read")==0;
5734 # CPAN::Tarzip::TIEHANDLE
5736 my($class,$file) = @_;
5738 $class->debug("file[$file]");
5739 if ($CPAN::META->has_inst("Compress::Zlib")) {
5740 my $gz = Compress::Zlib::gzopen($file,"rb") or
5741 die "Could not gzopen $file";
5742 $ret = bless {GZ => $gz}, $class;
5744 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5745 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5747 $ret = bless {FH => $fh}, $class;
5753 # CPAN::Tarzip::READLINE
5756 if (exists $self->{GZ}) {
5757 my $gz = $self->{GZ};
5758 my($line,$bytesread);
5759 $bytesread = $gz->gzreadline($line);
5760 return undef if $bytesread <= 0;
5763 my $fh = $self->{FH};
5764 return scalar <$fh>;
5769 # CPAN::Tarzip::READ
5771 my($self,$ref,$length,$offset) = @_;
5772 die "read with offset not implemented" if defined $offset;
5773 if (exists $self->{GZ}) {
5774 my $gz = $self->{GZ};
5775 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5778 my $fh = $self->{FH};
5779 return read($fh,$$ref,$length);
5784 # CPAN::Tarzip::DESTROY
5787 if (exists $self->{GZ}) {
5788 my $gz = $self->{GZ};
5789 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5790 # to be undef ever. AK, 2000-09
5792 my $fh = $self->{FH};
5793 $fh->close if defined $fh;
5799 # CPAN::Tarzip::untar
5801 my($class,$file) = @_;
5804 if (0) { # makes changing order easier
5805 } elsif ($BUGHUNTING){
5807 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5809 MM->maybe_command($CPAN::Config->{'tar'})) {
5810 # should be default until Archive::Tar is fixed
5813 $CPAN::META->has_inst("Archive::Tar")
5815 $CPAN::META->has_inst("Compress::Zlib") ) {
5818 $CPAN::Frontend->mydie(qq{
5819 CPAN.pm needs either both external programs tar and gzip installed or
5820 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5821 is available. Can\'t continue.
5824 if ($prefer==1) { # 1 => external gzip+tar
5826 my $is_compressed = $class->gtest($file);
5827 if ($is_compressed) {
5828 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5829 "< $file | $CPAN::Config->{tar} xvf -";
5831 $system = "$CPAN::Config->{tar} xvf $file";
5833 if (system($system) != 0) {
5834 # people find the most curious tar binaries that cannot handle
5836 if ($is_compressed) {
5837 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5838 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5839 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5841 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5845 $system = "$CPAN::Config->{tar} xvf $file";
5846 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5847 if (system($system)==0) {
5848 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5850 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5856 } elsif ($prefer==2) { # 2 => modules
5857 my $tar = Archive::Tar->new($file,1);
5858 my $af; # archive file
5861 # RCS 1.337 had this code, it turned out unacceptable slow but
5862 # it revealed a bug in Archive::Tar. Code is only here to hunt
5863 # the bug again. It should never be enabled in published code.
5864 # GDGraph3d-0.53 was an interesting case according to Larry
5866 warn(">>>Bughunting code enabled<<< " x 20);
5867 for $af ($tar->list_files) {
5868 if ($af =~ m!^(/|\.\./)!) {
5869 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5870 "illegal member [$af]");
5872 $CPAN::Frontend->myprint("$af\n");
5873 $tar->extract($af); # slow but effective for finding the bug
5874 return if $CPAN::Signal;
5877 for $af ($tar->list_files) {
5878 if ($af =~ m!^(/|\.\./)!) {
5879 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5880 "illegal member [$af]");
5882 $CPAN::Frontend->myprint("$af\n");
5884 return if $CPAN::Signal;
5889 Mac::BuildTools::convert_files([$tar->list_files], 1)
5890 if ($^O eq 'MacOS');
5897 my($class,$file) = @_;
5898 if ($CPAN::META->has_inst("Archive::Zip")) {
5899 # blueprint of the code from Archive::Zip::Tree::extractTree();
5900 my $zip = Archive::Zip->new();
5902 $status = $zip->read($file);
5903 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5904 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5905 my @members = $zip->members();
5906 for my $member ( @members ) {
5907 my $af = $member->fileName();
5908 if ($af =~ m!^(/|\.\./)!) {
5909 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5910 "illegal member [$af]");
5912 my $status = $member->extractToFileNamed( $af );
5913 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5914 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5915 $status != Archive::Zip::AZ_OK();
5916 return if $CPAN::Signal;
5920 my $unzip = $CPAN::Config->{unzip} or
5921 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5922 my @system = ($unzip, $file);
5923 return system(@system) == 0;
5928 package CPAN::Version;
5929 # CPAN::Version::vcmp courtesy Jost Krieger
5931 my($self,$l,$r) = @_;
5933 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5935 return 0 if $l eq $r; # short circuit for quicker success
5937 if ($l=~/^v/ <=> $r=~/^v/) {
5940 $_ = $self->float2vv($_);
5945 ($l ne "undef") <=> ($r ne "undef") ||
5949 $self->vstring($l) cmp $self->vstring($r)) ||
5955 my($self,$l,$r) = @_;
5956 $self->vcmp($l,$r) > 0;
5961 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5962 pack "U*", split /\./, $n;
5965 # vv => visible vstring
5970 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5971 # architecture influence
5973 $mantissa .= "0" while length($mantissa)%3;
5974 my $ret = "v" . $rev;
5976 $mantissa =~ s/(\d{1,3})// or
5977 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5978 $ret .= ".".int($1);
5980 # warn "n[$n]ret[$ret]";
5986 $n =~ /^([\w\-\+\.]+)/;
5988 return $1 if defined $1 && length($1)>0;
5989 # if the first user reaches version v43, he will be treated as "+".
5990 # We'll have to decide about a new rule here then, depending on what
5991 # will be the prevailing versioning behavior then.
5993 if ($] < 5.006) { # or whenever v-strings were introduced
5994 # we get them wrong anyway, whatever we do, because 5.005 will
5995 # have already interpreted 0.2.4 to be "0.24". So even if he
5996 # indexer sends us something like "v0.2.4" we compare wrongly.
5998 # And if they say v1.2, then the old perl takes it as "v12"
6000 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
6003 my $better = sprintf "v%vd", $n;
6004 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
6016 CPAN - query, download and build perl modules from CPAN sites
6022 perl -MCPAN -e shell;
6028 autobundle, clean, install, make, recompile, test
6032 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6033 of a modern rewrite from ground up with greater extensibility and more
6034 features but no full compatibility. If you're new to CPAN.pm, you
6035 probably should investigate if CPANPLUS is the better choice for you.
6036 If you're already used to CPAN.pm you're welcome to continue using it,
6037 if you accept that its development is mostly (though not completely)
6042 The CPAN module is designed to automate the make and install of perl
6043 modules and extensions. It includes some primitive searching capabilities and
6044 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6045 to fetch the raw data from the net.
6047 Modules are fetched from one or more of the mirrored CPAN
6048 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6051 The CPAN module also supports the concept of named and versioned
6052 I<bundles> of modules. Bundles simplify the handling of sets of
6053 related modules. See Bundles below.
6055 The package contains a session manager and a cache manager. There is
6056 no status retained between sessions. The session manager keeps track
6057 of what has been fetched, built and installed in the current
6058 session. The cache manager keeps track of the disk space occupied by
6059 the make processes and deletes excess space according to a simple FIFO
6062 For extended searching capabilities there's a plugin for CPAN available,
6063 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6064 that indexes all documents available in CPAN authors directories. If
6065 C<CPAN::WAIT> is installed on your system, the interactive shell of
6066 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6067 which send queries to the WAIT server that has been configured for your
6070 All other methods provided are accessible in a programmer style and in an
6071 interactive shell style.
6073 =head2 Interactive Mode
6075 The interactive mode is entered by running
6077 perl -MCPAN -e shell
6079 which puts you into a readline interface. You will have the most fun if
6080 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6083 Once you are on the command line, type 'h' and the rest should be
6086 The function call C<shell> takes two optional arguments, one is the
6087 prompt, the second is the default initial command line (the latter
6088 only works if a real ReadLine interface module is installed).
6090 The most common uses of the interactive modes are
6094 =item Searching for authors, bundles, distribution files and modules
6096 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6097 for each of the four categories and another, C<i> for any of the
6098 mentioned four. Each of the four entities is implemented as a class
6099 with slightly differing methods for displaying an object.
6101 Arguments you pass to these commands are either strings exactly matching
6102 the identification string of an object or regular expressions that are
6103 then matched case-insensitively against various attributes of the
6104 objects. The parser recognizes a regular expression only if you
6105 enclose it between two slashes.
6107 The principle is that the number of found objects influences how an
6108 item is displayed. If the search finds one item, the result is
6109 displayed with the rather verbose method C<as_string>, but if we find
6110 more than one, we display each object with the terse method
6113 =item make, test, install, clean modules or distributions
6115 These commands take any number of arguments and investigate what is
6116 necessary to perform the action. If the argument is a distribution
6117 file name (recognized by embedded slashes), it is processed. If it is
6118 a module, CPAN determines the distribution file in which this module
6119 is included and processes that, following any dependencies named in
6120 the module's Makefile.PL (this behavior is controlled by
6121 I<prerequisites_policy>.)
6123 Any C<make> or C<test> are run unconditionally. An
6125 install <distribution_file>
6127 also is run unconditionally. But for
6131 CPAN checks if an install is actually needed for it and prints
6132 I<module up to date> in the case that the distribution file containing
6133 the module doesn't need to be updated.
6135 CPAN also keeps track of what it has done within the current session
6136 and doesn't try to build a package a second time regardless if it
6137 succeeded or not. The C<force> command takes as a first argument the
6138 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6139 command from scratch.
6143 cpan> install OpenGL
6144 OpenGL is up to date.
6145 cpan> force install OpenGL
6148 OpenGL-0.4/COPYRIGHT
6151 A C<clean> command results in a
6155 being executed within the distribution file's working directory.
6157 =item get, readme, look module or distribution
6159 C<get> downloads a distribution file without further action. C<readme>
6160 displays the README file of the associated distribution. C<Look> gets
6161 and untars (if not yet done) the distribution file, changes to the
6162 appropriate directory and opens a subshell process in that directory.
6166 C<ls> lists all distribution files in and below an author's CPAN
6167 directory. Only those files that contain modules are listed and if
6168 there is more than one for any given module, only the most recent one
6173 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6174 in the cpan-shell it is intended that you can press C<^C> anytime and
6175 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6176 to clean up and leave the shell loop. You can emulate the effect of a
6177 SIGTERM by sending two consecutive SIGINTs, which usually means by
6178 pressing C<^C> twice.
6180 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6181 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6187 The commands that are available in the shell interface are methods in
6188 the package CPAN::Shell. If you enter the shell command, all your
6189 input is split by the Text::ParseWords::shellwords() routine which
6190 acts like most shells do. The first word is being interpreted as the
6191 method to be called and the rest of the words are treated as arguments
6192 to this method. Continuation lines are supported if a line ends with a
6197 C<autobundle> writes a bundle file into the
6198 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6199 a list of all modules that are both available from CPAN and currently
6200 installed within @INC. The name of the bundle file is based on the
6201 current date and a counter.
6205 recompile() is a very special command in that it takes no argument and
6206 runs the make/test/install cycle with brute force over all installed
6207 dynamically loadable extensions (aka XS modules) with 'force' in
6208 effect. The primary purpose of this command is to finish a network
6209 installation. Imagine, you have a common source tree for two different
6210 architectures. You decide to do a completely independent fresh
6211 installation. You start on one architecture with the help of a Bundle
6212 file produced earlier. CPAN installs the whole Bundle for you, but
6213 when you try to repeat the job on the second architecture, CPAN
6214 responds with a C<"Foo up to date"> message for all modules. So you
6215 invoke CPAN's recompile on the second architecture and you're done.
6217 Another popular use for C<recompile> is to act as a rescue in case your
6218 perl breaks binary compatibility. If one of the modules that CPAN uses
6219 is in turn depending on binary compatibility (so you cannot run CPAN
6220 commands), then you should try the CPAN::Nox module for recovery.
6222 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6224 Although it may be considered internal, the class hierarchy does matter
6225 for both users and programmer. CPAN.pm deals with above mentioned four
6226 classes, and all those classes share a set of methods. A classical
6227 single polymorphism is in effect. A metaclass object registers all
6228 objects of all kinds and indexes them with a string. The strings
6229 referencing objects have a separated namespace (well, not completely
6234 words containing a "/" (slash) Distribution
6235 words starting with Bundle:: Bundle
6236 everything else Module or Author
6238 Modules know their associated Distribution objects. They always refer
6239 to the most recent official release. Developers may mark their releases
6240 as unstable development versions (by inserting an underbar into the
6241 module version number which will also be reflected in the distribution
6242 name when you run 'make dist'), so the really hottest and newest
6243 distribution is not always the default. If a module Foo circulates
6244 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6245 way to install version 1.23 by saying
6249 This would install the complete distribution file (say
6250 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6251 like to install version 1.23_90, you need to know where the
6252 distribution file resides on CPAN relative to the authors/id/
6253 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6254 so you would have to say
6256 install BAR/Foo-1.23_90.tar.gz
6258 The first example will be driven by an object of the class
6259 CPAN::Module, the second by an object of class CPAN::Distribution.
6261 =head2 Programmer's interface
6263 If you do not enter the shell, the available shell commands are both
6264 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6265 functions in the calling package (C<install(...)>).
6267 There's currently only one class that has a stable interface -
6268 CPAN::Shell. All commands that are available in the CPAN shell are
6269 methods of the class CPAN::Shell. Each of the commands that produce
6270 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6271 the IDs of all modules within the list.
6275 =item expand($type,@things)
6277 The IDs of all objects available within a program are strings that can
6278 be expanded to the corresponding real objects with the
6279 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6280 list of CPAN::Module objects according to the C<@things> arguments
6281 given. In scalar context it only returns the first element of the
6284 =item expandany(@things)
6286 Like expand, but returns objects of the appropriate type, i.e.
6287 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6288 CPAN::Distribution objects fro distributions.
6290 =item Programming Examples
6292 This enables the programmer to do operations that combine
6293 functionalities that are available in the shell.
6295 # install everything that is outdated on my disk:
6296 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6298 # install my favorite programs if necessary:
6299 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6300 my $obj = CPAN::Shell->expand('Module',$mod);
6304 # list all modules on my disk that have no VERSION number
6305 for $mod (CPAN::Shell->expand("Module","/./")){
6306 next unless $mod->inst_file;
6307 # MakeMaker convention for undefined $VERSION:
6308 next unless $mod->inst_version eq "undef";
6309 print "No VERSION in ", $mod->id, "\n";
6312 # find out which distribution on CPAN contains a module:
6313 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6315 Or if you want to write a cronjob to watch The CPAN, you could list
6316 all modules that need updating. First a quick and dirty way:
6318 perl -e 'use CPAN; CPAN::Shell->r;'
6320 If you don't want to get any output in the case that all modules are
6321 up to date, you can parse the output of above command for the regular
6322 expression //modules are up to date// and decide to mail the output
6323 only if it doesn't match. Ick?
6325 If you prefer to do it more in a programmer style in one single
6326 process, maybe something like this suits you better:
6328 # list all modules on my disk that have newer versions on CPAN
6329 for $mod (CPAN::Shell->expand("Module","/./")){
6330 next unless $mod->inst_file;
6331 next if $mod->uptodate;
6332 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6333 $mod->id, $mod->inst_version, $mod->cpan_version;
6336 If that gives you too much output every day, you maybe only want to
6337 watch for three modules. You can write
6339 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6341 as the first line instead. Or you can combine some of the above
6344 # watch only for a new mod_perl module
6345 $mod = CPAN::Shell->expand("Module","mod_perl");
6346 exit if $mod->uptodate;
6347 # new mod_perl arrived, let me know all update recommendations
6352 =head2 Methods in the other Classes
6354 The programming interface for the classes CPAN::Module,
6355 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6356 beta and partially even alpha. In the following paragraphs only those
6357 methods are documented that have proven useful over a longer time and
6358 thus are unlikely to change.
6362 =item CPAN::Author::as_glimpse()
6364 Returns a one-line description of the author
6366 =item CPAN::Author::as_string()
6368 Returns a multi-line description of the author
6370 =item CPAN::Author::email()
6372 Returns the author's email address
6374 =item CPAN::Author::fullname()
6376 Returns the author's name
6378 =item CPAN::Author::name()
6380 An alias for fullname
6382 =item CPAN::Bundle::as_glimpse()
6384 Returns a one-line description of the bundle
6386 =item CPAN::Bundle::as_string()
6388 Returns a multi-line description of the bundle
6390 =item CPAN::Bundle::clean()
6392 Recursively runs the C<clean> method on all items contained in the bundle.
6394 =item CPAN::Bundle::contains()
6396 Returns a list of objects' IDs contained in a bundle. The associated
6397 objects may be bundles, modules or distributions.
6399 =item CPAN::Bundle::force($method,@args)
6401 Forces CPAN to perform a task that normally would have failed. Force
6402 takes as arguments a method name to be called and any number of
6403 additional arguments that should be passed to the called method. The
6404 internals of the object get the needed changes so that CPAN.pm does
6405 not refuse to take the action. The C<force> is passed recursively to
6406 all contained objects.
6408 =item CPAN::Bundle::get()
6410 Recursively runs the C<get> method on all items contained in the bundle
6412 =item CPAN::Bundle::inst_file()
6414 Returns the highest installed version of the bundle in either @INC or
6415 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6416 CPAN::Module::inst_file.
6418 =item CPAN::Bundle::inst_version()
6420 Like CPAN::Bundle::inst_file, but returns the $VERSION
6422 =item CPAN::Bundle::uptodate()
6424 Returns 1 if the bundle itself and all its members are uptodate.
6426 =item CPAN::Bundle::install()
6428 Recursively runs the C<install> method on all items contained in the bundle
6430 =item CPAN::Bundle::make()
6432 Recursively runs the C<make> method on all items contained in the bundle
6434 =item CPAN::Bundle::readme()
6436 Recursively runs the C<readme> method on all items contained in the bundle
6438 =item CPAN::Bundle::test()
6440 Recursively runs the C<test> method on all items contained in the bundle
6442 =item CPAN::Distribution::as_glimpse()
6444 Returns a one-line description of the distribution
6446 =item CPAN::Distribution::as_string()
6448 Returns a multi-line description of the distribution
6450 =item CPAN::Distribution::clean()
6452 Changes to the directory where the distribution has been unpacked and
6453 runs C<make clean> there.
6455 =item CPAN::Distribution::containsmods()
6457 Returns a list of IDs of modules contained in a distribution file.
6458 Only works for distributions listed in the 02packages.details.txt.gz
6459 file. This typically means that only the most recent version of a
6460 distribution is covered.
6462 =item CPAN::Distribution::cvs_import()
6464 Changes to the directory where the distribution has been unpacked and
6467 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6471 =item CPAN::Distribution::dir()
6473 Returns the directory into which this distribution has been unpacked.
6475 =item CPAN::Distribution::force($method,@args)
6477 Forces CPAN to perform a task that normally would have failed. Force
6478 takes as arguments a method name to be called and any number of
6479 additional arguments that should be passed to the called method. The
6480 internals of the object get the needed changes so that CPAN.pm does
6481 not refuse to take the action.
6483 =item CPAN::Distribution::get()
6485 Downloads the distribution from CPAN and unpacks it. Does nothing if
6486 the distribution has already been downloaded and unpacked within the
6489 =item CPAN::Distribution::install()
6491 Changes to the directory where the distribution has been unpacked and
6492 runs the external command C<make install> there. If C<make> has not
6493 yet been run, it will be run first. A C<make test> will be issued in
6494 any case and if this fails, the install will be canceled. The
6495 cancellation can be avoided by letting C<force> run the C<install> for
6498 =item CPAN::Distribution::isa_perl()
6500 Returns 1 if this distribution file seems to be a perl distribution.
6501 Normally this is derived from the file name only, but the index from
6502 CPAN can contain a hint to achieve a return value of true for other
6505 =item CPAN::Distribution::look()
6507 Changes to the directory where the distribution has been unpacked and
6508 opens a subshell there. Exiting the subshell returns.
6510 =item CPAN::Distribution::make()
6512 First runs the C<get> method to make sure the distribution is
6513 downloaded and unpacked. Changes to the directory where the
6514 distribution has been unpacked and runs the external commands C<perl
6515 Makefile.PL> and C<make> there.
6517 =item CPAN::Distribution::prereq_pm()
6519 Returns the hash reference that has been announced by a distribution
6520 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6521 attempt has been made to C<make> the distribution. Returns undef
6524 =item CPAN::Distribution::readme()
6526 Downloads the README file associated with a distribution and runs it
6527 through the pager specified in C<$CPAN::Config->{pager}>.
6529 =item CPAN::Distribution::test()
6531 Changes to the directory where the distribution has been unpacked and
6532 runs C<make test> there.
6534 =item CPAN::Distribution::uptodate()
6536 Returns 1 if all the modules contained in the distribution are
6537 uptodate. Relies on containsmods.
6539 =item CPAN::Index::force_reload()
6541 Forces a reload of all indices.
6543 =item CPAN::Index::reload()
6545 Reloads all indices if they have been read more than
6546 C<$CPAN::Config->{index_expire}> days.
6548 =item CPAN::InfoObj::dump()
6550 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6551 inherit this method. It prints the data structure associated with an
6552 object. Useful for debugging. Note: the data structure is considered
6553 internal and thus subject to change without notice.
6555 =item CPAN::Module::as_glimpse()
6557 Returns a one-line description of the module
6559 =item CPAN::Module::as_string()
6561 Returns a multi-line description of the module
6563 =item CPAN::Module::clean()
6565 Runs a clean on the distribution associated with this module.
6567 =item CPAN::Module::cpan_file()
6569 Returns the filename on CPAN that is associated with the module.
6571 =item CPAN::Module::cpan_version()
6573 Returns the latest version of this module available on CPAN.
6575 =item CPAN::Module::cvs_import()
6577 Runs a cvs_import on the distribution associated with this module.
6579 =item CPAN::Module::description()
6581 Returns a 44 character description of this module. Only available for
6582 modules listed in The Module List (CPAN/modules/00modlist.long.html
6583 or 00modlist.long.txt.gz)
6585 =item CPAN::Module::force($method,@args)
6587 Forces CPAN to perform a task that normally would have failed. Force
6588 takes as arguments a method name to be called and any number of
6589 additional arguments that should be passed to the called method. The
6590 internals of the object get the needed changes so that CPAN.pm does
6591 not refuse to take the action.
6593 =item CPAN::Module::get()
6595 Runs a get on the distribution associated with this module.
6597 =item CPAN::Module::inst_file()
6599 Returns the filename of the module found in @INC. The first file found
6600 is reported just like perl itself stops searching @INC when it finds a
6603 =item CPAN::Module::inst_version()
6605 Returns the version number of the module in readable format.
6607 =item CPAN::Module::install()
6609 Runs an C<install> on the distribution associated with this module.
6611 =item CPAN::Module::look()
6613 Changes to the directory where the distribution associated with this
6614 module has been unpacked and opens a subshell there. Exiting the
6617 =item CPAN::Module::make()
6619 Runs a C<make> on the distribution associated with this module.
6621 =item CPAN::Module::manpage_headline()
6623 If module is installed, peeks into the module's manpage, reads the
6624 headline and returns it. Moreover, if the module has been downloaded
6625 within this session, does the equivalent on the downloaded module even
6626 if it is not installed.
6628 =item CPAN::Module::readme()
6630 Runs a C<readme> on the distribution associated with this module.
6632 =item CPAN::Module::test()
6634 Runs a C<test> on the distribution associated with this module.
6636 =item CPAN::Module::uptodate()
6638 Returns 1 if the module is installed and up-to-date.
6640 =item CPAN::Module::userid()
6642 Returns the author's ID of the module.
6646 =head2 Cache Manager
6648 Currently the cache manager only keeps track of the build directory
6649 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6650 deletes complete directories below C<build_dir> as soon as the size of
6651 all directories there gets bigger than $CPAN::Config->{build_cache}
6652 (in MB). The contents of this cache may be used for later
6653 re-installations that you intend to do manually, but will never be
6654 trusted by CPAN itself. This is due to the fact that the user might
6655 use these directories for building modules on different architectures.
6657 There is another directory ($CPAN::Config->{keep_source_where}) where
6658 the original distribution files are kept. This directory is not
6659 covered by the cache manager and must be controlled by the user. If
6660 you choose to have the same directory as build_dir and as
6661 keep_source_where directory, then your sources will be deleted with
6662 the same fifo mechanism.
6666 A bundle is just a perl module in the namespace Bundle:: that does not
6667 define any functions or methods. It usually only contains documentation.
6669 It starts like a perl module with a package declaration and a $VERSION
6670 variable. After that the pod section looks like any other pod with the
6671 only difference being that I<one special pod section> exists starting with
6676 In this pod section each line obeys the format
6678 Module_Name [Version_String] [- optional text]
6680 The only required part is the first field, the name of a module
6681 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6682 of the line is optional. The comment part is delimited by a dash just
6683 as in the man page header.
6685 The distribution of a bundle should follow the same convention as
6686 other distributions.
6688 Bundles are treated specially in the CPAN package. If you say 'install
6689 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6690 the modules in the CONTENTS section of the pod. You can install your
6691 own Bundles locally by placing a conformant Bundle file somewhere into
6692 your @INC path. The autobundle() command which is available in the
6693 shell interface does that for you by including all currently installed
6694 modules in a snapshot bundle file.
6696 =head2 Prerequisites
6698 If you have a local mirror of CPAN and can access all files with
6699 "file:" URLs, then you only need a perl better than perl5.003 to run
6700 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6701 required for non-UNIX systems or if your nearest CPAN site is
6702 associated with a URL that is not C<ftp:>.
6704 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6705 implemented for an external ftp command or for an external lynx
6708 =head2 Finding packages and VERSION
6710 This module presumes that all packages on CPAN
6716 declare their $VERSION variable in an easy to parse manner. This
6717 prerequisite can hardly be relaxed because it consumes far too much
6718 memory to load all packages into the running program just to determine
6719 the $VERSION variable. Currently all programs that are dealing with
6720 version use something like this
6722 perl -MExtUtils::MakeMaker -le \
6723 'print MM->parse_version(shift)' filename
6725 If you are author of a package and wonder if your $VERSION can be
6726 parsed, please try the above method.
6730 come as compressed or gzipped tarfiles or as zip files and contain a
6731 Makefile.PL (well, we try to handle a bit more, but without much
6738 The debugging of this module is a bit complex, because we have
6739 interferences of the software producing the indices on CPAN, of the
6740 mirroring process on CPAN, of packaging, of configuration, of
6741 synchronicity, and of bugs within CPAN.pm.
6743 For code debugging in interactive mode you can try "o debug" which
6744 will list options for debugging the various parts of the code. You
6745 should know that "o debug" has built-in completion support.
6747 For data debugging there is the C<dump> command which takes the same
6748 arguments as make/test/install and outputs the object's Data::Dumper
6751 =head2 Floppy, Zip, Offline Mode
6753 CPAN.pm works nicely without network too. If you maintain machines
6754 that are not networked at all, you should consider working with file:
6755 URLs. Of course, you have to collect your modules somewhere first. So
6756 you might use CPAN.pm to put together all you need on a networked
6757 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6758 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6759 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6760 with this floppy. See also below the paragraph about CD-ROM support.
6762 =head1 CONFIGURATION
6764 When the CPAN module is used for the first time, a configuration
6765 dialog tries to determine a couple of site specific options. The
6766 result of the dialog is stored in a hash reference C< $CPAN::Config >
6767 in a file CPAN/Config.pm.
6769 The default values defined in the CPAN/Config.pm file can be
6770 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6771 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6772 added to the search path of the CPAN module before the use() or
6773 require() statements.
6775 The configuration dialog can be started any time later again by
6776 issuing the command C< o conf init > in the CPAN shell.
6778 Currently the following keys in the hash reference $CPAN::Config are
6781 build_cache size of cache for directories to build modules
6782 build_dir locally accessible directory to build modules
6783 index_expire after this many days refetch index files
6784 cache_metadata use serializer to cache metadata
6785 cpan_home local directory reserved for this package
6786 dontload_hash anonymous hash: modules in the keys will not be
6787 loaded by the CPAN::has_inst() routine
6788 gzip location of external program gzip
6789 histfile file to maintain history between sessions
6790 histsize maximum number of lines to keep in histfile
6791 inactivity_timeout breaks interactive Makefile.PLs after this
6792 many seconds inactivity. Set to 0 to never break.
6793 inhibit_startup_message
6794 if true, does not print the startup message
6795 keep_source_where directory in which to keep the source (if we do)
6796 make location of external make program
6797 make_arg arguments that should always be passed to 'make'
6798 make_install_arg same as make_arg for 'make install'
6799 makepl_arg arguments passed to 'perl Makefile.PL'
6800 pager location of external program more (or any pager)
6801 prerequisites_policy
6802 what to do if you are missing module prerequisites
6803 ('follow' automatically, 'ask' me, or 'ignore')
6804 proxy_user username for accessing an authenticating proxy
6805 proxy_pass password for accessing an authenticating proxy
6806 scan_cache controls scanning of cache ('atstart' or 'never')
6807 tar location of external program tar
6808 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6809 (and nonsense for characters outside latin range)
6810 unzip location of external program unzip
6811 urllist arrayref to nearby CPAN sites (or equivalent locations)
6812 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6813 ftp_proxy, } the three usual variables for configuring
6814 http_proxy, } proxy requests. Both as CPAN::Config variables
6815 no_proxy } and as environment variables configurable.
6817 You can set and query each of these options interactively in the cpan
6818 shell with the command set defined within the C<o conf> command:
6822 =item C<o conf E<lt>scalar optionE<gt>>
6824 prints the current value of the I<scalar option>
6826 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6828 Sets the value of the I<scalar option> to I<value>
6830 =item C<o conf E<lt>list optionE<gt>>
6832 prints the current value of the I<list option> in MakeMaker's
6835 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6837 shifts or pops the array in the I<list option> variable
6839 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6841 works like the corresponding perl commands.
6845 =head2 Note on urllist parameter's format
6847 urllist parameters are URLs according to RFC 1738. We do a little
6848 guessing if your URL is not compliant, but if you have problems with
6849 file URLs, please try the correct format. Either:
6851 file://localhost/whatever/ftp/pub/CPAN/
6855 file:///home/ftp/pub/CPAN/
6857 =head2 urllist parameter has CD-ROM support
6859 The C<urllist> parameter of the configuration table contains a list of
6860 URLs that are to be used for downloading. If the list contains any
6861 C<file> URLs, CPAN always tries to get files from there first. This
6862 feature is disabled for index files. So the recommendation for the
6863 owner of a CD-ROM with CPAN contents is: include your local, possibly
6864 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6866 o conf urllist push file://localhost/CDROM/CPAN
6868 CPAN.pm will then fetch the index files from one of the CPAN sites
6869 that come at the beginning of urllist. It will later check for each
6870 module if there is a local copy of the most recent version.
6872 Another peculiarity of urllist is that the site that we could
6873 successfully fetch the last file from automatically gets a preference
6874 token and is tried as the first site for the next request. So if you
6875 add a new site at runtime it may happen that the previously preferred
6876 site will be tried another time. This means that if you want to disallow
6877 a site for the next transfer, it must be explicitly removed from
6882 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6883 install foreign, unmasked, unsigned code on your machine. We compare
6884 to a checksum that comes from the net just as the distribution file
6885 itself. If somebody has managed to tamper with the distribution file,
6886 they may have as well tampered with the CHECKSUMS file. Future
6887 development will go towards strong authentication.
6891 Most functions in package CPAN are exported per default. The reason
6892 for this is that the primary use is intended for the cpan shell or for
6895 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6897 Populating a freshly installed perl with my favorite modules is pretty
6898 easy if you maintain a private bundle definition file. To get a useful
6899 blueprint of a bundle definition file, the command autobundle can be used
6900 on the CPAN shell command line. This command writes a bundle definition
6901 file for all modules that are installed for the currently running perl
6902 interpreter. It's recommended to run this command only once and from then
6903 on maintain the file manually under a private name, say
6904 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6906 cpan> install Bundle::my_bundle
6908 then answer a few questions and then go out for a coffee.
6910 Maintaining a bundle definition file means keeping track of two
6911 things: dependencies and interactivity. CPAN.pm sometimes fails on
6912 calculating dependencies because not all modules define all MakeMaker
6913 attributes correctly, so a bundle definition file should specify
6914 prerequisites as early as possible. On the other hand, it's a bit
6915 annoying that many distributions need some interactive configuring. So
6916 what I try to accomplish in my private bundle file is to have the
6917 packages that need to be configured early in the file and the gentle
6918 ones later, so I can go out after a few minutes and leave CPAN.pm
6921 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6923 Thanks to Graham Barr for contributing the following paragraphs about
6924 the interaction between perl, and various firewall configurations. For
6925 further information on firewalls, it is recommended to consult the
6926 documentation that comes with the ncftp program. If you are unable to
6927 go through the firewall with a simple Perl setup, it is very likely
6928 that you can configure ncftp so that it works for your firewall.
6930 =head2 Three basic types of firewalls
6932 Firewalls can be categorized into three basic types.
6938 This is where the firewall machine runs a web server and to access the
6939 outside world you must do it via the web server. If you set environment
6940 variables like http_proxy or ftp_proxy to a values beginning with http://
6941 or in your web browser you have to set proxy information then you know
6942 you are running an http firewall.
6944 To access servers outside these types of firewalls with perl (even for
6945 ftp) you will need to use LWP.
6949 This where the firewall machine runs an ftp server. This kind of
6950 firewall will only let you access ftp servers outside the firewall.
6951 This is usually done by connecting to the firewall with ftp, then
6952 entering a username like "user@outside.host.com"
6954 To access servers outside these type of firewalls with perl you
6955 will need to use Net::FTP.
6957 =item One way visibility
6959 I say one way visibility as these firewalls try to make themselves look
6960 invisible to the users inside the firewall. An FTP data connection is
6961 normally created by sending the remote server your IP address and then
6962 listening for the connection. But the remote server will not be able to
6963 connect to you because of the firewall. So for these types of firewall
6964 FTP connections need to be done in a passive mode.
6966 There are two that I can think off.
6972 If you are using a SOCKS firewall you will need to compile perl and link
6973 it with the SOCKS library, this is what is normally called a 'socksified'
6974 perl. With this executable you will be able to connect to servers outside
6975 the firewall as if it is not there.
6979 This is the firewall implemented in the Linux kernel, it allows you to
6980 hide a complete network behind one IP address. With this firewall no
6981 special compiling is needed as you can access hosts directly.
6983 For accessing ftp servers behind such firewalls you may need to set
6984 the environment variable C<FTP_PASSIVE> to a true value, e.g.
6986 env FTP_PASSIVE=1 perl -MCPAN -eshell
6990 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
6997 =head2 Configuring lynx or ncftp for going through a firewall
6999 If you can go through your firewall with e.g. lynx, presumably with a
7002 /usr/local/bin/lynx -pscott:tiger
7004 then you would configure CPAN.pm with the command
7006 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7008 That's all. Similarly for ncftp or ftp, you would configure something
7011 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7013 Your mileage may vary...
7021 I installed a new version of module X but CPAN keeps saying,
7022 I have the old version installed
7024 Most probably you B<do> have the old version installed. This can
7025 happen if a module installs itself into a different directory in the
7026 @INC path than it was previously installed. This is not really a
7027 CPAN.pm problem, you would have the same problem when installing the
7028 module manually. The easiest way to prevent this behaviour is to add
7029 the argument C<UNINST=1> to the C<make install> call, and that is why
7030 many people add this argument permanently by configuring
7032 o conf make_install_arg UNINST=1
7036 So why is UNINST=1 not the default?
7038 Because there are people who have their precise expectations about who
7039 may install where in the @INC path and who uses which @INC array. In
7040 fine tuned environments C<UNINST=1> can cause damage.
7044 I want to clean up my mess, and install a new perl along with
7045 all modules I have. How do I go about it?
7047 Run the autobundle command for your old perl and optionally rename the
7048 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7049 with the Configure option prefix, e.g.
7051 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7053 Install the bundle file you produced in the first step with something like
7055 cpan> install Bundle::mybundle
7061 When I install bundles or multiple modules with one command
7062 there is too much output to keep track of.
7064 You may want to configure something like
7066 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7067 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7069 so that STDOUT is captured in a file for later inspection.
7074 I am not root, how can I install a module in a personal directory?
7076 You will most probably like something like this:
7078 o conf makepl_arg "LIB=~/myperl/lib \
7079 INSTALLMAN1DIR=~/myperl/man/man1 \
7080 INSTALLMAN3DIR=~/myperl/man/man3"
7081 install Sybase::Sybperl
7083 You can make this setting permanent like all C<o conf> settings with
7086 You will have to add ~/myperl/man to the MANPATH environment variable
7087 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7090 use lib "$ENV{HOME}/myperl/lib";
7092 or setting the PERL5LIB environment variable.
7094 Another thing you should bear in mind is that the UNINST parameter
7095 should never be set if you are not root.
7099 How to get a package, unwrap it, and make a change before building it?
7101 look Sybase::Sybperl
7105 I installed a Bundle and had a couple of fails. When I
7106 retried, everything resolved nicely. Can this be fixed to work
7109 The reason for this is that CPAN does not know the dependencies of all
7110 modules when it starts out. To decide about the additional items to
7111 install, it just uses data found in the generated Makefile. An
7112 undetected missing piece breaks the process. But it may well be that
7113 your Bundle installs some prerequisite later than some depending item
7114 and thus your second try is able to resolve everything. Please note,
7115 CPAN.pm does not know the dependency tree in advance and cannot sort
7116 the queue of things to install in a topologically correct order. It
7117 resolves perfectly well IFF all modules declare the prerequisites
7118 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7119 fail and you need to install often, it is recommended sort the Bundle
7120 definition file manually. It is planned to improve the metadata
7121 situation for dependencies on CPAN in general, but this will still
7126 In our intranet we have many modules for internal use. How
7127 can I integrate these modules with CPAN.pm but without uploading
7128 the modules to CPAN?
7130 Have a look at the CPAN::Site module.
7134 When I run CPAN's shell, I get error msg about line 1 to 4,
7135 setting meta input/output via the /etc/inputrc file.
7137 Some versions of readline are picky about capitalization in the
7138 /etc/inputrc file and specifically RedHat 6.2 comes with a
7139 /etc/inputrc that contains the word C<on> in lowercase. Change the
7140 occurrences of C<on> to C<On> and the bug should disappear.
7144 Some authors have strange characters in their names.
7146 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7147 expecting ISO-8859-1 charset, a converter can be activated by setting
7148 term_is_latin to a true value in your config file. One way of doing so
7151 cpan> ! $CPAN::Config->{term_is_latin}=1
7153 Extended support for converters will be made available as soon as perl
7154 becomes stable with regard to charset issues.
7160 We should give coverage for B<all> of the CPAN and not just the PAUSE
7161 part, right? In this discussion CPAN and PAUSE have become equal --
7162 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7163 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7165 Future development should be directed towards a better integration of
7168 If a Makefile.PL requires special customization of libraries, prompts
7169 the user for special input, etc. then you may find CPAN is not able to
7170 build the distribution. In that case, you should attempt the
7171 traditional method of building a Perl module package from a shell.
7175 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7179 Kawai,Takanori provides a Japanese translation of this manpage at
7180 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7184 perl(1), CPAN::Nox(3)