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";
61 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
62 $Revision $Signal $End $Suppress_readline $Frontend
63 $Defaultsite $Have_warned);
65 @CPAN::ISA = qw(CPAN::Debug Exporter);
68 autobundle bundle expand force get cvs_import
69 install make readme recompile shell test clean
72 #-> sub CPAN::AUTOLOAD ;
77 @EXPORT{@EXPORT} = '';
78 CPAN::Config->load unless $CPAN::Config_loaded++;
79 if (exists $EXPORT{$l}){
82 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
91 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
92 CPAN::Config->load unless $CPAN::Config_loaded++;
94 my $oprompt = shift || "cpan> ";
95 my $prompt = $oprompt;
96 my $commandline = shift || "";
99 unless ($Suppress_readline) {
100 require Term::ReadLine;
103 $term->ReadLine eq "Term::ReadLine::Stub"
105 $term = Term::ReadLine->new('CPAN Monitor');
107 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
108 my $attribs = $term->Attribs;
109 $attribs->{attempted_completion_function} = sub {
110 &CPAN::Complete::gnu_cpl;
113 $readline::rl_completion_function =
114 $readline::rl_completion_function = 'CPAN::Complete::cpl';
116 if (my $histfile = $CPAN::Config->{'histfile'}) {{
117 unless ($term->can("AddHistory")) {
118 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
121 my($fh) = FileHandle->new;
122 open $fh, "<$histfile" or last;
126 $term->AddHistory($_);
130 # $term->OUT is autoflushed anyway
131 my $odef = select STDERR;
138 # no strict; # I do not recall why no strict was here (2000-09-03)
140 my $cwd = CPAN::anycwd();
141 my $try_detect_readline;
142 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
143 my $rl_avail = $Suppress_readline ? "suppressed" :
144 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
145 "available (try 'install Bundle::CPAN')";
147 $CPAN::Frontend->myprint(
149 cpan shell -- CPAN exploration and modules installation (v%s%s)
157 unless $CPAN::Config->{'inhibit_startup_message'} ;
158 my($continuation) = "";
159 SHELLCOMMAND: while () {
160 if ($Suppress_readline) {
162 last SHELLCOMMAND unless defined ($_ = <> );
165 last SHELLCOMMAND unless
166 defined ($_ = $term->readline($prompt, $commandline));
168 $_ = "$continuation$_" if $continuation;
170 next SHELLCOMMAND if /^$/;
171 $_ = 'h' if /^\s*\?/;
172 if (/^(?:q(?:uit)?|bye|exit)$/i) {
182 use vars qw($import_done);
183 CPAN->import(':DEFAULT') unless $import_done++;
184 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
191 if ($] < 5.00322) { # parsewords had a bug until recently
194 eval { @line = Text::ParseWords::shellwords($_) };
195 warn($@), next SHELLCOMMAND if $@;
196 warn("Text::Parsewords could not parse the line [$_]"),
197 next SHELLCOMMAND unless @line;
199 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
200 my $command = shift @line;
201 eval { CPAN::Shell->$command(@line) };
203 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
204 $CPAN::Frontend->myprint("\n");
209 $commandline = ""; # I do want to be able to pass a default to
210 # shell, but on the second command I see no
213 CPAN::Queue->nullify_queue;
214 if ($try_detect_readline) {
215 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
217 $CPAN::META->has_inst("Term::ReadLine::Perl")
219 delete $INC{"Term/ReadLine.pm"};
221 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
222 require Term::ReadLine;
223 $CPAN::Frontend->myprint("\n$redef subroutines in ".
224 "Term::ReadLine redefined\n");
230 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
233 package CPAN::CacheMgr;
234 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
237 package CPAN::Config;
238 use vars qw(%can $dot_cpan);
241 'commit' => "Commit changes to disk",
242 'defaults' => "Reload defaults from disk",
243 'init' => "Interactive setting of all options",
247 use vars qw($Ua $Thesite $Themethod);
248 @CPAN::FTP::ISA = qw(CPAN::Debug);
250 package CPAN::LWP::UserAgent;
251 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
252 # we delay requiring LWP::UserAgent and setting up inheritence until we need it
254 package CPAN::Complete;
255 @CPAN::Complete::ISA = qw(CPAN::Debug);
256 @CPAN::Complete::COMMANDS = sort qw(
257 ! a b d h i m o q r u autobundle clean dump
258 make test install force readme reload look
260 ) unless @CPAN::Complete::COMMANDS;
263 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
264 @CPAN::Index::ISA = qw(CPAN::Debug);
267 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
270 package CPAN::InfoObj;
271 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
273 package CPAN::Author;
274 @CPAN::Author::ISA = qw(CPAN::InfoObj);
276 package CPAN::Distribution;
277 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
279 package CPAN::Bundle;
280 @CPAN::Bundle::ISA = qw(CPAN::Module);
282 package CPAN::Module;
283 @CPAN::Module::ISA = qw(CPAN::InfoObj);
285 package CPAN::Exception::RecursiveDependency;
286 use overload '""' => "as_string";
293 for my $dep (@$deps) {
295 last if $seen{$dep}++;
297 bless { deps => \@deps }, $class;
302 "\nRecursive dependency detected:\n " .
303 join("\n => ", @{$self->{deps}}) .
304 ".\nCannot continue.\n";
308 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
309 @CPAN::Shell::ISA = qw(CPAN::Debug);
310 $COLOR_REGISTERED ||= 0;
311 $PRINT_ORNAMENTING ||= 0;
313 #-> sub CPAN::Shell::AUTOLOAD ;
315 my($autoload) = $AUTOLOAD;
316 my $class = shift(@_);
317 # warn "autoload[$autoload] class[$class]";
318 $autoload =~ s/.*:://;
319 if ($autoload =~ /^w/) {
320 if ($CPAN::META->has_inst('CPAN::WAIT')) {
321 CPAN::WAIT->$autoload(@_);
323 $CPAN::Frontend->mywarn(qq{
324 Commands starting with "w" require CPAN::WAIT to be installed.
325 Please consider installing CPAN::WAIT to use the fulltext index.
326 For this you just need to type
331 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
337 package CPAN::Tarzip;
338 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
339 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
340 $BUGHUNTING = 0; # released code must have turned off
344 # One use of the queue is to determine if we should or shouldn't
345 # announce the availability of a new CPAN module
347 # Now we try to use it for dependency tracking. For that to happen
348 # we need to draw a dependency tree and do the leaves first. This can
349 # easily be reached by running CPAN.pm recursively, but we don't want
350 # to waste memory and run into deep recursion. So what we can do is
353 # CPAN::Queue is the package where the queue is maintained. Dependencies
354 # often have high priority and must be brought to the head of the queue,
355 # possibly by jumping the queue if they are already there. My first code
356 # attempt tried to be extremely correct. Whenever a module needed
357 # immediate treatment, I either unshifted it to the front of the queue,
358 # or, if it was already in the queue, I spliced and let it bypass the
359 # others. This became a too correct model that made it impossible to put
360 # an item more than once into the queue. Why would you need that? Well,
361 # you need temporary duplicates as the manager of the queue is a loop
364 # (1) looks at the first item in the queue without shifting it off
366 # (2) cares for the item
368 # (3) removes the item from the queue, *even if its agenda failed and
369 # even if the item isn't the first in the queue anymore* (that way
370 # protecting against never ending queues)
372 # So if an item has prerequisites, the installation fails now, but we
373 # want to retry later. That's easy if we have it twice in the queue.
375 # I also expect insane dependency situations where an item gets more
376 # than two lives in the queue. Simplest example is triggered by 'install
377 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
378 # get in the way. I wanted the queue manager to be a dumb servant, not
379 # one that knows everything.
381 # Who would I tell in this model that the user wants to be asked before
382 # processing? I can't attach that information to the module object,
383 # because not modules are installed but distributions. So I'd have to
384 # tell the distribution object that it should ask the user before
385 # processing. Where would the question be triggered then? Most probably
386 # in CPAN::Distribution::rematein.
387 # Hope that makes sense, my head is a bit off:-) -- AK
394 my $self = bless { qmod => $s }, $class;
399 # CPAN::Queue::first ;
405 # CPAN::Queue::delete_first ;
407 my($class,$what) = @_;
409 for my $i (0..$#All) {
410 if ( $All[$i]->{qmod} eq $what ) {
417 # CPAN::Queue::jumpqueue ;
421 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
422 join(",",map {$_->{qmod}} @All),
425 WHAT: for my $what (reverse @what) {
427 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
428 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
429 if ($All[$i]->{qmod} eq $what){
431 if ($jumped > 100) { # one's OK if e.g. just
432 # processing now; more are OK if
433 # user typed it several times
434 $CPAN::Frontend->mywarn(
435 qq{Object [$what] queued more than 100 times, ignoring}
441 my $obj = bless { qmod => $what }, $class;
444 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
445 join(",",map {$_->{qmod}} @All),
450 # CPAN::Queue::exists ;
452 my($self,$what) = @_;
453 my @all = map { $_->{qmod} } @All;
454 my $exists = grep { $_->{qmod} eq $what } @All;
455 # warn "in exists what[$what] all[@all] exists[$exists]";
459 # CPAN::Queue::delete ;
462 @All = grep { $_->{qmod} ne $mod } @All;
465 # CPAN::Queue::nullify_queue ;
474 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
476 # from here on only subs.
477 ################################################################################
479 #-> sub CPAN::all_objects ;
481 my($mgr,$class) = @_;
482 CPAN::Config->load unless $CPAN::Config_loaded++;
483 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
485 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
487 *all = \&all_objects;
489 # Called by shell, not in batch mode. In batch mode I see no risk in
490 # having many processes updating something as installations are
491 # continually checked at runtime. In shell mode I suspect it is
492 # unintentional to open more than one shell at a time
494 #-> sub CPAN::checklock ;
497 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
498 if (-f $lockfile && -M _ > 0) {
499 my $fh = FileHandle->new($lockfile) or
500 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
501 my $otherpid = <$fh>;
502 my $otherhost = <$fh>;
504 if (defined $otherpid && $otherpid) {
507 if (defined $otherhost && $otherhost) {
510 my $thishost = hostname();
511 if (defined $otherhost && defined $thishost &&
512 $otherhost ne '' && $thishost ne '' &&
513 $otherhost ne $thishost) {
514 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
515 "reports other host $otherhost and other process $otherpid.\n".
516 "Cannot proceed.\n"));
518 elsif (defined $otherpid && $otherpid) {
519 return if $$ == $otherpid; # should never happen
520 $CPAN::Frontend->mywarn(
522 There seems to be running another CPAN process (pid $otherpid). Contacting...
524 if (kill 0, $otherpid) {
525 $CPAN::Frontend->mydie(qq{Other job is running.
526 You may want to kill it and delete the lockfile, maybe. On UNIX try:
530 } elsif (-w $lockfile) {
532 ExtUtils::MakeMaker::prompt
533 (qq{Other job not responding. Shall I overwrite }.
534 qq{the lockfile? (Y/N)},"y");
535 $CPAN::Frontend->myexit("Ok, bye\n")
536 unless $ans =~ /^y/i;
539 qq{Lockfile $lockfile not writeable by you. }.
540 qq{Cannot proceed.\n}.
543 qq{ and then rerun us.\n}
547 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
548 "reports other process with ID ".
549 "$otherpid. Cannot proceed.\n"));
552 my $dotcpan = $CPAN::Config->{cpan_home};
553 eval { File::Path::mkpath($dotcpan);};
555 # A special case at least for Jarkko.
560 $symlinkcpan = readlink $dotcpan;
561 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
562 eval { File::Path::mkpath($symlinkcpan); };
566 $CPAN::Frontend->mywarn(qq{
567 Working directory $symlinkcpan created.
571 unless (-d $dotcpan) {
573 Your configuration suggests "$dotcpan" as your
574 CPAN.pm working directory. I could not create this directory due
575 to this error: $firsterror\n};
577 As "$dotcpan" is a symlink to "$symlinkcpan",
578 I tried to create that, but I failed with this error: $seconderror
581 Please make sure the directory exists and is writable.
583 $CPAN::Frontend->mydie($diemess);
587 unless ($fh = FileHandle->new(">$lockfile")) {
588 if ($! =~ /Permission/) {
589 my $incc = $INC{'CPAN/Config.pm'};
590 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
591 $CPAN::Frontend->myprint(qq{
593 Your configuration suggests that CPAN.pm should use a working
595 $CPAN::Config->{cpan_home}
596 Unfortunately we could not create the lock file
598 due to permission problems.
600 Please make sure that the configuration variable
601 \$CPAN::Config->{cpan_home}
602 points to a directory where you can write a .lock file. You can set
603 this variable in either
610 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
612 $fh->print($$, "\n");
613 $fh->print(hostname(), "\n");
614 $self->{LOCK} = $lockfile;
618 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
623 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
624 print "Caught SIGINT\n";
628 # From: Larry Wall <larry@wall.org>
629 # Subject: Re: deprecating SIGDIE
630 # To: perl5-porters@perl.org
631 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
633 # The original intent of __DIE__ was only to allow you to substitute one
634 # kind of death for another on an application-wide basis without respect
635 # to whether you were in an eval or not. As a global backstop, it should
636 # not be used any more lightly (or any more heavily :-) than class
637 # UNIVERSAL. Any attempt to build a general exception model on it should
638 # be politely squashed. Any bug that causes every eval {} to have to be
639 # modified should be not so politely squashed.
641 # Those are my current opinions. It is also my optinion that polite
642 # arguments degenerate to personal arguments far too frequently, and that
643 # when they do, it's because both people wanted it to, or at least didn't
644 # sufficiently want it not to.
648 # global backstop to cleanup if we should really die
649 $SIG{__DIE__} = \&cleanup;
650 $self->debug("Signal handler set.") if $CPAN::DEBUG;
653 #-> sub CPAN::DESTROY ;
655 &cleanup; # need an eval?
658 #-> sub CPAN::anycwd ;
661 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
666 sub cwd {Cwd::cwd();}
668 #-> sub CPAN::getcwd ;
669 sub getcwd {Cwd::getcwd();}
671 #-> sub CPAN::exists ;
673 my($mgr,$class,$id) = @_;
674 CPAN::Config->load unless $CPAN::Config_loaded++;
676 ### Carp::croak "exists called without class argument" unless $class;
678 exists $META->{readonly}{$class}{$id} or
679 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
682 #-> sub CPAN::delete ;
684 my($mgr,$class,$id) = @_;
685 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
686 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
689 #-> sub CPAN::has_usable
690 # has_inst is sometimes too optimistic, we should replace it with this
691 # has_usable whenever a case is given
693 my($self,$mod,$message) = @_;
694 return 1 if $HAS_USABLE->{$mod};
695 my $has_inst = $self->has_inst($mod,$message);
696 return unless $has_inst;
699 LWP => [ # we frequently had "Can't locate object
700 # method "new" via package "LWP::UserAgent" at
701 # (eval 69) line 2006
703 sub {require LWP::UserAgent},
704 sub {require HTTP::Request},
705 sub {require URI::URL},
708 sub {require Net::FTP},
709 sub {require Net::Config},
712 if ($usable->{$mod}) {
713 for my $c (0..$#{$usable->{$mod}}) {
714 my $code = $usable->{$mod}[$c];
715 my $ret = eval { &$code() };
717 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
722 return $HAS_USABLE->{$mod} = 1;
725 #-> sub CPAN::has_inst
727 my($self,$mod,$message) = @_;
728 Carp::croak("CPAN->has_inst() called without an argument")
730 if (defined $message && $message eq "no"
732 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
734 exists $CPAN::Config->{dontload_hash}{$mod}
736 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
742 $file =~ s|/|\\|g if $^O eq 'MSWin32';
745 # checking %INC is wrong, because $INC{LWP} may be true
746 # although $INC{"URI/URL.pm"} may have failed. But as
747 # I really want to say "bla loaded OK", I have to somehow
749 ### warn "$file in %INC"; #debug
751 } elsif (eval { require $file }) {
752 # eval is good: if we haven't yet read the database it's
753 # perfect and if we have installed the module in the meantime,
754 # it tries again. The second require is only a NOOP returning
755 # 1 if we had success, otherwise it's retrying
757 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
758 if ($mod eq "CPAN::WAIT") {
759 push @CPAN::Shell::ISA, CPAN::WAIT;
762 } elsif ($mod eq "Net::FTP") {
763 $CPAN::Frontend->mywarn(qq{
764 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
766 install Bundle::libnet
768 }) unless $Have_warned->{"Net::FTP"}++;
770 } elsif ($mod eq "Digest::MD5"){
771 $CPAN::Frontend->myprint(qq{
772 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
773 Please consider installing the Digest::MD5 module.
778 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
783 #-> sub CPAN::instance ;
785 my($mgr,$class,$id) = @_;
788 # unsafe meta access, ok?
789 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
790 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
798 #-> sub CPAN::cleanup ;
800 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
801 local $SIG{__DIE__} = '';
806 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
808 $subroutine eq '(eval)';
810 return if $ineval && !$End;
811 return unless defined $META->{LOCK};
812 return unless -f $META->{LOCK};
814 unlink $META->{LOCK};
816 # Carp::cluck("DEBUGGING");
817 $CPAN::Frontend->mywarn("Lockfile removed.\n");
820 #-> sub CPAN::savehist
823 my($histfile,$histsize);
824 unless ($histfile = $CPAN::Config->{'histfile'}){
825 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
828 $histsize = $CPAN::Config->{'histsize'} || 100;
830 unless ($CPAN::term->can("GetHistory")) {
831 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
837 my @h = $CPAN::term->GetHistory;
838 splice @h, 0, @h-$histsize if @h>$histsize;
839 my($fh) = FileHandle->new;
840 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
841 local $\ = local $, = "\n";
847 my($self,$what) = @_;
848 $self->{is_tested}{$what} = 1;
852 my($self,$what) = @_;
853 delete $self->{is_tested}{$what};
858 $self->{is_tested} ||= {};
859 return unless %{$self->{is_tested}};
860 my $env = $ENV{PERL5LIB};
861 $env = $ENV{PERLLIB} unless defined $env;
863 push @env, $env if defined $env and length $env;
864 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
865 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
866 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
869 package CPAN::CacheMgr;
871 #-> sub CPAN::CacheMgr::as_string ;
873 eval { require Data::Dumper };
875 return shift->SUPER::as_string;
877 return Data::Dumper::Dumper(shift);
881 #-> sub CPAN::CacheMgr::cachesize ;
886 #-> sub CPAN::CacheMgr::tidyup ;
889 return unless -d $self->{ID};
890 while ($self->{DU} > $self->{'MAX'} ) {
891 my($toremove) = shift @{$self->{FIFO}};
892 $CPAN::Frontend->myprint(sprintf(
893 "Deleting from cache".
894 ": $toremove (%.1f>%.1f MB)\n",
895 $self->{DU}, $self->{'MAX'})
897 return if $CPAN::Signal;
898 $self->force_clean_cache($toremove);
899 return if $CPAN::Signal;
903 #-> sub CPAN::CacheMgr::dir ;
908 #-> sub CPAN::CacheMgr::entries ;
911 return unless defined $dir;
912 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
913 $dir ||= $self->{ID};
914 my($cwd) = CPAN::anycwd();
915 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
916 my $dh = DirHandle->new(File::Spec->curdir)
917 or Carp::croak("Couldn't opendir $dir: $!");
920 next if $_ eq "." || $_ eq "..";
922 push @entries, File::Spec->catfile($dir,$_);
924 push @entries, File::Spec->catdir($dir,$_);
926 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
929 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
930 sort { -M $b <=> -M $a} @entries;
933 #-> sub CPAN::CacheMgr::disk_usage ;
936 return if exists $self->{SIZE}{$dir};
937 return if $CPAN::Signal;
941 $File::Find::prune++ if $CPAN::Signal;
943 if ($^O eq 'MacOS') {
945 my $cat = Mac::Files::FSpGetCatInfo($_);
946 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
953 return if $CPAN::Signal;
954 $self->{SIZE}{$dir} = $Du/1024/1024;
955 push @{$self->{FIFO}}, $dir;
956 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
957 $self->{DU} += $Du/1024/1024;
961 #-> sub CPAN::CacheMgr::force_clean_cache ;
962 sub force_clean_cache {
964 return unless -e $dir;
965 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
967 File::Path::rmtree($dir);
968 $self->{DU} -= $self->{SIZE}{$dir};
969 delete $self->{SIZE}{$dir};
972 #-> sub CPAN::CacheMgr::new ;
979 ID => $CPAN::Config->{'build_dir'},
980 MAX => $CPAN::Config->{'build_cache'},
981 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
984 File::Path::mkpath($self->{ID});
985 my $dh = DirHandle->new($self->{ID});
989 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
991 CPAN->debug($debug) if $CPAN::DEBUG;
995 #-> sub CPAN::CacheMgr::scan_cache ;
998 return if $self->{SCAN} eq 'never';
999 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1000 unless $self->{SCAN} eq 'atstart';
1001 $CPAN::Frontend->myprint(
1002 sprintf("Scanning cache %s for sizes\n",
1005 for $e ($self->entries($self->{ID})) {
1006 next if $e eq ".." || $e eq ".";
1007 $self->disk_usage($e);
1008 return if $CPAN::Signal;
1013 package CPAN::Debug;
1015 #-> sub CPAN::Debug::debug ;
1017 my($self,$arg) = @_;
1018 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
1019 # Complete, caller(1)
1021 ($caller) = caller(0);
1022 $caller =~ s/.*:://;
1023 $arg = "" unless defined $arg;
1024 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
1025 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
1026 if ($arg and ref $arg) {
1027 eval { require Data::Dumper };
1029 $CPAN::Frontend->myprint($arg->as_string);
1031 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
1034 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
1039 package CPAN::Config;
1041 #-> sub CPAN::Config::edit ;
1042 # returns true on successful action
1044 my($self,@args) = @_;
1045 return unless @args;
1046 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
1047 my($o,$str,$func,$args,$key_exists);
1053 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1054 if ($o =~ /list$/) {
1055 $func = shift @args;
1057 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1059 # Let's avoid eval, it's easier to comprehend without.
1060 if ($func eq "push") {
1061 push @{$CPAN::Config->{$o}}, @args;
1063 } elsif ($func eq "pop") {
1064 pop @{$CPAN::Config->{$o}};
1066 } elsif ($func eq "shift") {
1067 shift @{$CPAN::Config->{$o}};
1069 } elsif ($func eq "unshift") {
1070 unshift @{$CPAN::Config->{$o}}, @args;
1072 } elsif ($func eq "splice") {
1073 splice @{$CPAN::Config->{$o}}, @args;
1076 $CPAN::Config->{$o} = [@args];
1079 $self->prettyprint($o);
1081 if ($o eq "urllist" && $changed) {
1082 # reset the cached values
1083 undef $CPAN::FTP::Thesite;
1084 undef $CPAN::FTP::Themethod;
1088 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1089 $self->prettyprint($o);
1096 my $v = $CPAN::Config->{$k};
1098 my(@report) = ref $v eq "ARRAY" ?
1100 map { sprintf(" %-18s => %s\n",
1102 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1104 $CPAN::Frontend->myprint(
1111 map {"\t$_\n"} @report
1114 } elsif (defined $v) {
1115 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1117 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1121 #-> sub CPAN::Config::commit ;
1123 my($self,$configpm) = @_;
1124 unless (defined $configpm){
1125 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1126 $configpm ||= $INC{"CPAN/Config.pm"};
1127 $configpm || Carp::confess(q{
1128 CPAN::Config::commit called without an argument.
1129 Please specify a filename where to save the configuration or try
1130 "o conf init" to have an interactive course through configing.
1135 $mode = (stat $configpm)[2];
1136 if ($mode && ! -w _) {
1137 Carp::confess("$configpm is not writable");
1142 $msg = <<EOF unless $configpm =~ /MyConfig/;
1144 # This is CPAN.pm's systemwide configuration file. This file provides
1145 # defaults for users, and the values can be changed in a per-user
1146 # configuration file. The user-config file is being looked for as
1147 # ~/.cpan/CPAN/MyConfig.pm.
1151 my($fh) = FileHandle->new;
1152 rename $configpm, "$configpm~" if -f $configpm;
1153 open $fh, ">$configpm" or
1154 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1155 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1156 foreach (sort keys %$CPAN::Config) {
1159 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1164 $fh->print("};\n1;\n__END__\n");
1167 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1168 #chmod $mode, $configpm;
1169 ###why was that so? $self->defaults;
1170 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1174 *default = \&defaults;
1175 #-> sub CPAN::Config::defaults ;
1185 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1194 # This is a piece of repeated code that is abstracted here for
1195 # maintainability. RMB
1198 my($configpmdir, $configpmtest) = @_;
1199 if (-w $configpmtest) {
1200 return $configpmtest;
1201 } elsif (-w $configpmdir) {
1202 #_#_# following code dumped core on me with 5.003_11, a.k.
1203 my $configpm_bak = "$configpmtest.bak";
1204 unlink $configpm_bak if -f $configpm_bak;
1205 if( -f $configpmtest ) {
1206 if( rename $configpmtest, $configpm_bak ) {
1207 $CPAN::Frontend->mywarn(<<END)
1208 Old configuration file $configpmtest
1209 moved to $configpm_bak
1213 my $fh = FileHandle->new;
1214 if ($fh->open(">$configpmtest")) {
1216 return $configpmtest;
1218 # Should never happen
1219 Carp::confess("Cannot open >$configpmtest");
1224 #-> sub CPAN::Config::load ;
1229 eval {require CPAN::Config;}; # We eval because of some
1230 # MakeMaker problems
1231 unless ($dot_cpan++){
1232 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1233 eval {require CPAN::MyConfig;}; # where you can override
1234 # system wide settings
1237 return unless @miss = $self->missing_config_data;
1239 require CPAN::FirstTime;
1240 my($configpm,$fh,$redo,$theycalled);
1242 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1243 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1244 $configpm = $INC{"CPAN/Config.pm"};
1246 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1247 $configpm = $INC{"CPAN/MyConfig.pm"};
1250 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1251 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1252 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1253 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1254 $configpm = _configpmtest($configpmdir,$configpmtest);
1256 unless ($configpm) {
1257 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1258 File::Path::mkpath($configpmdir);
1259 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1260 $configpm = _configpmtest($configpmdir,$configpmtest);
1261 unless ($configpm) {
1262 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1263 qq{create a configuration file.});
1268 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1269 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1273 $CPAN::Frontend->myprint(qq{
1274 $configpm initialized.
1277 CPAN::FirstTime::init($configpm);
1280 #-> sub CPAN::Config::missing_config_data ;
1281 sub missing_config_data {
1284 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1285 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1287 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1288 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1289 "prerequisites_policy",
1292 push @miss, $_ unless defined $CPAN::Config->{$_};
1297 #-> sub CPAN::Config::unload ;
1299 delete $INC{'CPAN/MyConfig.pm'};
1300 delete $INC{'CPAN/Config.pm'};
1303 #-> sub CPAN::Config::help ;
1305 $CPAN::Frontend->myprint(q[
1307 defaults reload default config values from disk
1308 commit commit session changes to disk
1309 init go through a dialog to set all parameters
1311 You may edit key values in the follow fashion (the "o" is a literal
1314 o conf build_cache 15
1316 o conf build_dir "/foo/bar"
1318 o conf urllist shift
1320 o conf urllist unshift ftp://ftp.foo.bar/
1323 undef; #don't reprint CPAN::Config
1326 #-> sub CPAN::Config::cpl ;
1328 my($word,$line,$pos) = @_;
1330 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1331 my(@words) = split " ", substr($line,0,$pos+1);
1336 $words[2] =~ /list$/ && @words == 3
1338 $words[2] =~ /list$/ && @words == 4 && length($word)
1341 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1342 } elsif (@words >= 4) {
1345 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1346 return grep /^\Q$word\E/, @o_conf;
1349 package CPAN::Shell;
1351 #-> sub CPAN::Shell::h ;
1353 my($class,$about) = @_;
1354 if (defined $about) {
1355 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1357 $CPAN::Frontend->myprint(q{
1359 command argument description
1360 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1361 i WORD or /REGEXP/ about anything of above
1362 r NONE reinstall recommendations
1363 ls AUTHOR about files in the author's directory
1365 Download, Test, Make, Install...
1367 make make (implies get)
1368 test MODULES, make test (implies make)
1369 install DISTS, BUNDLES make install (implies test)
1371 look open subshell in these dists' directories
1372 readme display these dists' README files
1375 h,? display this menu ! perl-code eval a perl command
1376 o conf [opt] set and query options q quit the cpan shell
1377 reload cpan load CPAN.pm again reload index load newer indices
1378 autobundle Snapshot force cmd unconditionally do cmd});
1384 #-> sub CPAN::Shell::a ;
1386 my($self,@arg) = @_;
1387 # authors are always UPPERCASE
1389 $_ = uc $_ unless /=/;
1391 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1394 #-> sub CPAN::Shell::ls ;
1396 my($self,@arg) = @_;
1399 unless (/^[A-Z\-]+$/i) {
1400 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1403 push @accept, uc $_;
1405 for my $a (@accept){
1406 my $author = $self->expand('Author',$a) or die "No author found for $a";
1411 #-> sub CPAN::Shell::local_bundles ;
1413 my($self,@which) = @_;
1414 my($incdir,$bdir,$dh);
1415 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1416 my @bbase = "Bundle";
1417 while (my $bbase = shift @bbase) {
1418 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1419 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1420 if ($dh = DirHandle->new($bdir)) { # may fail
1422 for $entry ($dh->read) {
1423 next if $entry =~ /^\./;
1424 if (-d File::Spec->catdir($bdir,$entry)){
1425 push @bbase, "$bbase\::$entry";
1427 next unless $entry =~ s/\.pm(?!\n)\Z//;
1428 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1436 #-> sub CPAN::Shell::b ;
1438 my($self,@which) = @_;
1439 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1440 $self->local_bundles;
1441 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1444 #-> sub CPAN::Shell::d ;
1445 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1447 #-> sub CPAN::Shell::m ;
1448 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1450 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1453 #-> sub CPAN::Shell::i ;
1458 @type = qw/Author Bundle Distribution Module/;
1459 @args = '/./' unless @args;
1462 push @result, $self->expand($type,@args);
1464 my $result = @result == 1 ?
1465 $result[0]->as_string :
1467 "No objects found of any type for argument @args\n" :
1469 (map {$_->as_glimpse} @result),
1470 scalar @result, " items found\n",
1472 $CPAN::Frontend->myprint($result);
1475 #-> sub CPAN::Shell::o ;
1477 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1478 # should have been called set and 'o debug' maybe 'set debug'
1480 my($self,$o_type,@o_what) = @_;
1482 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1483 if ($o_type eq 'conf') {
1484 shift @o_what if @o_what && $o_what[0] eq 'help';
1485 if (!@o_what) { # print all things, "o conf"
1487 $CPAN::Frontend->myprint("CPAN::Config options");
1488 if (exists $INC{'CPAN/Config.pm'}) {
1489 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1491 if (exists $INC{'CPAN/MyConfig.pm'}) {
1492 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1494 $CPAN::Frontend->myprint(":\n");
1495 for $k (sort keys %CPAN::Config::can) {
1496 $v = $CPAN::Config::can{$k};
1497 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1499 $CPAN::Frontend->myprint("\n");
1500 for $k (sort keys %$CPAN::Config) {
1501 CPAN::Config->prettyprint($k);
1503 $CPAN::Frontend->myprint("\n");
1504 } elsif (!CPAN::Config->edit(@o_what)) {
1505 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1506 qq{edit options\n\n});
1508 } elsif ($o_type eq 'debug') {
1510 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1513 my($what) = shift @o_what;
1514 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1515 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1518 if ( exists $CPAN::DEBUG{$what} ) {
1519 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1520 } elsif ($what =~ /^\d/) {
1521 $CPAN::DEBUG = $what;
1522 } elsif (lc $what eq 'all') {
1524 for (values %CPAN::DEBUG) {
1527 $CPAN::DEBUG = $max;
1530 for (keys %CPAN::DEBUG) {
1531 next unless lc($_) eq lc($what);
1532 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1535 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1540 my $raw = "Valid options for debug are ".
1541 join(", ",sort(keys %CPAN::DEBUG), 'all').
1542 qq{ or a number. Completion works on the options. }.
1543 qq{Case is ignored.};
1545 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1546 $CPAN::Frontend->myprint("\n\n");
1549 $CPAN::Frontend->myprint("Options set for debugging:\n");
1551 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1552 $v = $CPAN::DEBUG{$k};
1553 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1554 if $v & $CPAN::DEBUG;
1557 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1560 $CPAN::Frontend->myprint(qq{
1562 conf set or get configuration variables
1563 debug set or get debugging options
1568 sub paintdots_onreload {
1571 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1575 # $CPAN::Frontend->myprint(".($subr)");
1576 $CPAN::Frontend->myprint(".");
1583 #-> sub CPAN::Shell::reload ;
1585 my($self,$command,@arg) = @_;
1587 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1588 if ($command =~ /cpan/i) {
1589 for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1590 next unless $INC{$f};
1591 CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
1592 my $fh = FileHandle->new($INC{$f});
1595 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1598 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1600 } elsif ($command =~ /index/) {
1601 CPAN::Index->force_reload;
1603 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1604 index re-reads the index files\n});
1608 #-> sub CPAN::Shell::_binary_extensions ;
1609 sub _binary_extensions {
1610 my($self) = shift @_;
1611 my(@result,$module,%seen,%need,$headerdone);
1612 for $module ($self->expand('Module','/./')) {
1613 my $file = $module->cpan_file;
1614 next if $file eq "N/A";
1615 next if $file =~ /^Contact Author/;
1616 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1617 next if $dist->isa_perl;
1618 next unless $module->xs_file;
1620 $CPAN::Frontend->myprint(".");
1621 push @result, $module;
1623 # print join " | ", @result;
1624 $CPAN::Frontend->myprint("\n");
1628 #-> sub CPAN::Shell::recompile ;
1630 my($self) = shift @_;
1631 my($module,@module,$cpan_file,%dist);
1632 @module = $self->_binary_extensions();
1633 for $module (@module){ # we force now and compile later, so we
1635 $cpan_file = $module->cpan_file;
1636 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1638 $dist{$cpan_file}++;
1640 for $cpan_file (sort keys %dist) {
1641 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1642 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1644 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1645 # stop a package from recompiling,
1646 # e.g. IO-1.12 when we have perl5.003_10
1650 #-> sub CPAN::Shell::_u_r_common ;
1652 my($self) = shift @_;
1653 my($what) = shift @_;
1654 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1655 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1656 $what && $what =~ /^[aru]$/;
1658 @args = '/./' unless @args;
1659 my(@result,$module,%seen,%need,$headerdone,
1660 $version_undefs,$version_zeroes);
1661 $version_undefs = $version_zeroes = 0;
1662 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1663 my @expand = $self->expand('Module',@args);
1664 my $expand = scalar @expand;
1665 if (0) { # Looks like noise to me, was very useful for debugging
1666 # for metadata cache
1667 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1669 for $module (@expand) {
1670 my $file = $module->cpan_file;
1671 next unless defined $file; # ??
1672 my($latest) = $module->cpan_version;
1673 my($inst_file) = $module->inst_file;
1675 return if $CPAN::Signal;
1678 $have = $module->inst_version;
1679 } elsif ($what eq "r") {
1680 $have = $module->inst_version;
1682 if ($have eq "undef"){
1684 } elsif ($have == 0){
1687 next unless CPAN::Version->vgt($latest, $have);
1688 # to be pedantic we should probably say:
1689 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1690 # to catch the case where CPAN has a version 0 and we have a version undef
1691 } elsif ($what eq "u") {
1697 } elsif ($what eq "r") {
1699 } elsif ($what eq "u") {
1703 return if $CPAN::Signal; # this is sometimes lengthy
1706 push @result, sprintf "%s %s\n", $module->id, $have;
1707 } elsif ($what eq "r") {
1708 push @result, $module->id;
1709 next if $seen{$file}++;
1710 } elsif ($what eq "u") {
1711 push @result, $module->id;
1712 next if $seen{$file}++;
1713 next if $file =~ /^Contact/;
1715 unless ($headerdone++){
1716 $CPAN::Frontend->myprint("\n");
1717 $CPAN::Frontend->myprint(sprintf(
1720 "Package namespace",
1732 $CPAN::META->has_inst("Term::ANSIColor")
1734 $module->{RO}{description}
1736 $color_on = Term::ANSIColor::color("green");
1737 $color_off = Term::ANSIColor::color("reset");
1739 $CPAN::Frontend->myprint(sprintf $sprintf,
1746 $need{$module->id}++;
1750 $CPAN::Frontend->myprint("No modules found for @args\n");
1751 } elsif ($what eq "r") {
1752 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1756 if ($version_zeroes) {
1757 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1758 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1759 qq{a version number of 0\n});
1761 if ($version_undefs) {
1762 my $s_has = $version_undefs > 1 ? "s have" : " has";
1763 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1764 qq{parseable version number\n});
1770 #-> sub CPAN::Shell::r ;
1772 shift->_u_r_common("r",@_);
1775 #-> sub CPAN::Shell::u ;
1777 shift->_u_r_common("u",@_);
1780 #-> sub CPAN::Shell::autobundle ;
1783 CPAN::Config->load unless $CPAN::Config_loaded++;
1784 my(@bundle) = $self->_u_r_common("a",@_);
1785 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1786 File::Path::mkpath($todir);
1787 unless (-d $todir) {
1788 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1791 my($y,$m,$d) = (localtime)[5,4,3];
1795 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1796 my($to) = File::Spec->catfile($todir,"$me.pm");
1798 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1799 $to = File::Spec->catfile($todir,"$me.pm");
1801 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1803 "package Bundle::$me;\n\n",
1804 "\$VERSION = '0.01';\n\n",
1808 "Bundle::$me - Snapshot of installation on ",
1809 $Config::Config{'myhostname'},
1812 "\n\n=head1 SYNOPSIS\n\n",
1813 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1814 "=head1 CONTENTS\n\n",
1815 join("\n", @bundle),
1816 "\n\n=head1 CONFIGURATION\n\n",
1818 "\n\n=head1 AUTHOR\n\n",
1819 "This Bundle has been generated automatically ",
1820 "by the autobundle routine in CPAN.pm.\n",
1823 $CPAN::Frontend->myprint("\nWrote bundle file
1827 #-> sub CPAN::Shell::expandany ;
1830 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1831 if ($s =~ m|/|) { # looks like a file
1832 $s = CPAN::Distribution->normalize($s);
1833 return $CPAN::META->instance('CPAN::Distribution',$s);
1834 # Distributions spring into existence, not expand
1835 } elsif ($s =~ m|^Bundle::|) {
1836 $self->local_bundles; # scanning so late for bundles seems
1837 # both attractive and crumpy: always
1838 # current state but easy to forget
1840 return $self->expand('Bundle',$s);
1842 return $self->expand('Module',$s)
1843 if $CPAN::META->exists('CPAN::Module',$s);
1848 #-> sub CPAN::Shell::expand ;
1851 my($type,@args) = @_;
1853 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1855 my($regex,$command);
1856 if ($arg =~ m|^/(.*)/$|) {
1858 } elsif ($arg =~ m/=/) {
1861 my $class = "CPAN::$type";
1863 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1865 defined $regex ? $regex : "UNDEFINED",
1866 $command || "UNDEFINED",
1868 if (defined $regex) {
1872 $CPAN::META->all_objects($class)
1875 # BUG, we got an empty object somewhere
1876 require Data::Dumper;
1877 CPAN->debug(sprintf(
1878 "Bug in CPAN: Empty id on obj[%s][%s]",
1880 Data::Dumper::Dumper($obj)
1885 if $obj->id =~ /$regex/i
1889 $] < 5.00303 ### provide sort of
1890 ### compatibility with 5.003
1895 $obj->name =~ /$regex/i
1898 } elsif ($command) {
1899 die "equal sign in command disabled (immature interface), ".
1901 ! \$CPAN::Shell::ADVANCED_QUERY=1
1902 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1903 that may go away anytime.\n"
1904 unless $ADVANCED_QUERY;
1905 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1906 my($matchcrit) = $criterion =~ m/^~(.+)/;
1910 $CPAN::META->all_objects($class)
1912 my $lhs = $self->$method() or next; # () for 5.00503
1914 push @m, $self if $lhs =~ m/$matchcrit/;
1916 push @m, $self if $lhs eq $criterion;
1921 if ( $type eq 'Bundle' ) {
1922 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1923 } elsif ($type eq "Distribution") {
1924 $xarg = CPAN::Distribution->normalize($arg);
1926 if ($CPAN::META->exists($class,$xarg)) {
1927 $obj = $CPAN::META->instance($class,$xarg);
1928 } elsif ($CPAN::META->exists($class,$arg)) {
1929 $obj = $CPAN::META->instance($class,$arg);
1936 return wantarray ? @m : $m[0];
1939 #-> sub CPAN::Shell::format_result ;
1942 my($type,@args) = @_;
1943 @args = '/./' unless @args;
1944 my(@result) = $self->expand($type,@args);
1945 my $result = @result == 1 ?
1946 $result[0]->as_string :
1948 "No objects of type $type found for argument @args\n" :
1950 (map {$_->as_glimpse} @result),
1951 scalar @result, " items found\n",
1956 # The only reason for this method is currently to have a reliable
1957 # debugging utility that reveals which output is going through which
1958 # channel. No, I don't like the colors ;-)
1960 #-> sub CPAN::Shell::print_ornameted ;
1961 sub print_ornamented {
1962 my($self,$what,$ornament) = @_;
1964 return unless defined $what;
1966 if ($CPAN::Config->{term_is_latin}){
1969 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1971 if ($PRINT_ORNAMENTING) {
1972 unless (defined &color) {
1973 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1974 import Term::ANSIColor "color";
1976 *color = sub { return "" };
1980 for $line (split /\n/, $what) {
1981 $longest = length($line) if length($line) > $longest;
1983 my $sprintf = "%-" . $longest . "s";
1985 $what =~ s/(.*\n?)//m;
1988 my($nl) = chomp $line ? "\n" : "";
1989 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1990 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1994 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
2000 my($self,$what) = @_;
2002 $self->print_ornamented($what, 'bold blue on_yellow');
2006 my($self,$what) = @_;
2007 $self->myprint($what);
2012 my($self,$what) = @_;
2013 $self->print_ornamented($what, 'bold red on_yellow');
2017 my($self,$what) = @_;
2018 $self->print_ornamented($what, 'bold red on_white');
2019 Carp::confess "died";
2023 my($self,$what) = @_;
2024 $self->print_ornamented($what, 'bold red on_white');
2029 return if -t STDOUT;
2030 my $odef = select STDERR;
2037 #-> sub CPAN::Shell::rematein ;
2038 # RE-adme||MA-ke||TE-st||IN-stall
2041 my($meth,@some) = @_;
2043 if ($meth eq 'force') {
2045 $meth = shift @some;
2048 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
2050 # Here is the place to set "test_count" on all involved parties to
2051 # 0. We then can pass this counter on to the involved
2052 # distributions and those can refuse to test if test_count > X. In
2053 # the first stab at it we could use a 1 for "X".
2055 # But when do I reset the distributions to start with 0 again?
2056 # Jost suggested to have a random or cycling interaction ID that
2057 # we pass through. But the ID is something that is just left lying
2058 # around in addition to the counter, so I'd prefer to set the
2059 # counter to 0 now, and repeat at the end of the loop. But what
2060 # about dependencies? They appear later and are not reset, they
2061 # enter the queue but not its copy. How do they get a sensible
2064 # construct the queue
2066 foreach $s (@some) {
2069 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2071 } elsif ($s =~ m|^/|) { # looks like a regexp
2072 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2077 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2078 $obj = CPAN::Shell->expandany($s);
2081 $obj->color_cmd_tmps(0,1);
2082 CPAN::Queue->new($obj->id);
2084 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2085 $obj = $CPAN::META->instance('CPAN::Author',$s);
2086 if ($meth =~ /^(dump|ls)$/) {
2089 $CPAN::Frontend->myprint(
2091 "Don't be silly, you can't $meth ",
2099 ->myprint(qq{Warning: Cannot $meth $s, }.
2100 qq{don\'t know what it is.
2105 to find objects with matching identifiers.
2111 # queuerunner (please be warned: when I started to change the
2112 # queue to hold objects instead of names, I made one or two
2113 # mistakes and never found which. I reverted back instead)
2114 while ($s = CPAN::Queue->first) {
2117 $obj = $s; # I do not believe, we would survive if this happened
2119 $obj = CPAN::Shell->expandany($s);
2123 ($] < 5.00303 || $obj->can($pragma))){
2124 ### compatibility with 5.003
2125 $obj->$pragma($meth); # the pragma "force" in
2126 # "CPAN::Distribution" must know
2127 # what we are intending
2129 if ($]>=5.00303 && $obj->can('called_for')) {
2130 $obj->called_for($s);
2133 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2139 CPAN::Queue->delete($s);
2141 CPAN->debug("failed");
2145 CPAN::Queue->delete_first($s);
2147 for my $obj (@qcopy) {
2148 $obj->color_cmd_tmps(0,0);
2152 #-> sub CPAN::Shell::dump ;
2153 sub dump { shift->rematein('dump',@_); }
2154 #-> sub CPAN::Shell::force ;
2155 sub force { shift->rematein('force',@_); }
2156 #-> sub CPAN::Shell::get ;
2157 sub get { shift->rematein('get',@_); }
2158 #-> sub CPAN::Shell::readme ;
2159 sub readme { shift->rematein('readme',@_); }
2160 #-> sub CPAN::Shell::make ;
2161 sub make { shift->rematein('make',@_); }
2162 #-> sub CPAN::Shell::test ;
2163 sub test { shift->rematein('test',@_); }
2164 #-> sub CPAN::Shell::install ;
2165 sub install { shift->rematein('install',@_); }
2166 #-> sub CPAN::Shell::clean ;
2167 sub clean { shift->rematein('clean',@_); }
2168 #-> sub CPAN::Shell::look ;
2169 sub look { shift->rematein('look',@_); }
2170 #-> sub CPAN::Shell::cvs_import ;
2171 sub cvs_import { shift->rematein('cvs_import',@_); }
2173 package CPAN::LWP::UserAgent;
2176 return if $SETUPDONE;
2177 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2178 require LWP::UserAgent;
2179 @ISA = qw(Exporter LWP::UserAgent);
2182 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2186 sub get_basic_credentials {
2187 my($self, $realm, $uri, $proxy) = @_;
2188 return unless $proxy;
2189 if ($USER && $PASSWD) {
2190 } elsif (defined $CPAN::Config->{proxy_user} &&
2191 defined $CPAN::Config->{proxy_pass}) {
2192 $USER = $CPAN::Config->{proxy_user};
2193 $PASSWD = $CPAN::Config->{proxy_pass};
2195 require ExtUtils::MakeMaker;
2196 ExtUtils::MakeMaker->import(qw(prompt));
2197 $USER = prompt("Proxy authentication needed!
2198 (Note: to permanently configure username and password run
2199 o conf proxy_user your_username
2200 o conf proxy_pass your_password
2202 if ($CPAN::META->has_inst("Term::ReadKey")) {
2203 Term::ReadKey::ReadMode("noecho");
2205 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2207 $PASSWD = prompt("Password:");
2208 if ($CPAN::META->has_inst("Term::ReadKey")) {
2209 Term::ReadKey::ReadMode("restore");
2211 $CPAN::Frontend->myprint("\n\n");
2213 return($USER,$PASSWD);
2216 # mirror(): Its purpose is to deal with proxy authentication. When we
2217 # call SUPER::mirror, we relly call the mirror method in
2218 # LWP::UserAgent. LWP::UserAgent will then call
2219 # $self->get_basic_credentials or some equivalent and this will be
2220 # $self->dispatched to our own get_basic_credentials method.
2222 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2224 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2225 # although we have gone through our get_basic_credentials, the proxy
2226 # server refuses to connect. This could be a case where the username or
2227 # password has changed in the meantime, so I'm trying once again without
2228 # $USER and $PASSWD to give the get_basic_credentials routine another
2229 # chance to set $USER and $PASSWD.
2232 my($self,$url,$aslocal) = @_;
2233 my $result = $self->SUPER::mirror($url,$aslocal);
2234 if ($result->code == 407) {
2237 $result = $self->SUPER::mirror($url,$aslocal);
2244 #-> sub CPAN::FTP::ftp_get ;
2246 my($class,$host,$dir,$file,$target) = @_;
2248 qq[Going to fetch file [$file] from dir [$dir]
2249 on host [$host] as local [$target]\n]
2251 my $ftp = Net::FTP->new($host);
2252 return 0 unless defined $ftp;
2253 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2254 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2255 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2256 warn "Couldn't login on $host";
2259 unless ( $ftp->cwd($dir) ){
2260 warn "Couldn't cwd $dir";
2264 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2265 unless ( $ftp->get($file,$target) ){
2266 warn "Couldn't fetch $file from $host\n";
2269 $ftp->quit; # it's ok if this fails
2273 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2275 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2276 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2278 # > *** 1562,1567 ****
2279 # > --- 1562,1580 ----
2280 # > return 1 if substr($url,0,4) eq "file";
2281 # > return 1 unless $url =~ m|://([^/]+)|;
2283 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2285 # > + $proxy =~ m|://([^/:]+)|;
2287 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2288 # > + if ($noproxy) {
2289 # > + if ($host !~ /$noproxy$/) {
2290 # > + $host = $proxy;
2293 # > + $host = $proxy;
2296 # > require Net::Ping;
2297 # > return 1 unless $Net::Ping::VERSION >= 2;
2301 #-> sub CPAN::FTP::localize ;
2303 my($self,$file,$aslocal,$force) = @_;
2305 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2306 unless defined $aslocal;
2307 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2310 if ($^O eq 'MacOS') {
2311 # Comment by AK on 2000-09-03: Uniq short filenames would be
2312 # available in CHECKSUMS file
2313 my($name, $path) = File::Basename::fileparse($aslocal, '');
2314 if (length($name) > 31) {
2325 my $size = 31 - length($suf);
2326 while (length($name) > $size) {
2330 $aslocal = File::Spec->catfile($path, $name);
2334 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2337 rename $aslocal, "$aslocal.bak";
2341 my($aslocal_dir) = File::Basename::dirname($aslocal);
2342 File::Path::mkpath($aslocal_dir);
2343 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2344 qq{directory "$aslocal_dir".
2345 I\'ll continue, but if you encounter problems, they may be due
2346 to insufficient permissions.\n}) unless -w $aslocal_dir;
2348 # Inheritance is not easier to manage than a few if/else branches
2349 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2351 CPAN::LWP::UserAgent->config;
2352 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2354 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2358 $Ua->proxy('ftp', $var)
2359 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2360 $Ua->proxy('http', $var)
2361 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2364 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2366 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2367 # > use ones that require basic autorization.
2369 # > Example of when I use it manually in my own stuff:
2371 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2372 # > $req->proxy_authorization_basic("username","password");
2373 # > $res = $ua->request($req);
2377 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2381 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2382 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2385 # Try the list of urls for each single object. We keep a record
2386 # where we did get a file from
2387 my(@reordered,$last);
2388 $CPAN::Config->{urllist} ||= [];
2389 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2390 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2392 $last = $#{$CPAN::Config->{urllist}};
2393 if ($force & 2) { # local cpans probably out of date, don't reorder
2394 @reordered = (0..$last);
2398 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2400 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2411 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2413 @levels = qw/easy hard hardest/;
2415 @levels = qw/easy/ if $^O eq 'MacOS';
2417 for $levelno (0..$#levels) {
2418 my $level = $levels[$levelno];
2419 my $method = "host$level";
2420 my @host_seq = $level eq "easy" ?
2421 @reordered : 0..$last; # reordered has CDROM up front
2422 @host_seq = (0) unless @host_seq;
2423 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2425 $Themethod = $level;
2427 # utime $now, $now, $aslocal; # too bad, if we do that, we
2428 # might alter a local mirror
2429 $self->debug("level[$level]") if $CPAN::DEBUG;
2433 last if $CPAN::Signal; # need to cleanup
2436 unless ($CPAN::Signal) {
2439 qq{Please check, if the URLs I found in your configuration file \(}.
2440 join(", ", @{$CPAN::Config->{urllist}}).
2441 qq{\) are valid. The urllist can be edited.},
2442 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2443 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2445 $CPAN::Frontend->myprint("Could not fetch $file\n");
2448 rename "$aslocal.bak", $aslocal;
2449 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2450 $self->ls($aslocal));
2457 my($self,$host_seq,$file,$aslocal) = @_;
2459 HOSTEASY: for $i (@$host_seq) {
2460 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2461 $url .= "/" unless substr($url,-1) eq "/";
2463 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2464 if ($url =~ /^file:/) {
2466 if ($CPAN::META->has_inst('URI::URL')) {
2467 my $u = URI::URL->new($url);
2469 } else { # works only on Unix, is poorly constructed, but
2470 # hopefully better than nothing.
2471 # RFC 1738 says fileurl BNF is
2472 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2473 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2475 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2476 $l =~ s|^file:||; # assume they
2479 $l =~ s|^/||s unless -f $l; # e.g. /P:
2480 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2482 if ( -f $l && -r _) {
2486 # Maybe mirror has compressed it?
2488 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2489 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2496 if ($CPAN::META->has_usable('LWP')) {
2497 $CPAN::Frontend->myprint("Fetching with LWP:
2501 CPAN::LWP::UserAgent->config;
2502 eval { $Ua = CPAN::LWP::UserAgent->new; };
2504 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2507 my $res = $Ua->mirror($url, $aslocal);
2508 if ($res->is_success) {
2511 utime $now, $now, $aslocal; # download time is more
2512 # important than upload time
2514 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2515 my $gzurl = "$url.gz";
2516 $CPAN::Frontend->myprint("Fetching with LWP:
2519 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2520 if ($res->is_success &&
2521 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2527 $CPAN::Frontend->myprint(sprintf(
2528 "LWP failed with code[%s] message[%s]\n",
2532 # Alan Burlison informed me that in firewall environments
2533 # Net::FTP can still succeed where LWP fails. So we do not
2534 # skip Net::FTP anymore when LWP is available.
2537 $CPAN::Frontend->myprint("LWP not available\n");
2539 return if $CPAN::Signal;
2540 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2541 # that's the nice and easy way thanks to Graham
2542 my($host,$dir,$getfile) = ($1,$2,$3);
2543 if ($CPAN::META->has_usable('Net::FTP')) {
2545 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2548 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2549 "aslocal[$aslocal]") if $CPAN::DEBUG;
2550 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2554 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2555 my $gz = "$aslocal.gz";
2556 $CPAN::Frontend->myprint("Fetching with Net::FTP
2559 if (CPAN::FTP->ftp_get($host,
2563 CPAN::Tarzip->gunzip($gz,$aslocal)
2572 return if $CPAN::Signal;
2577 my($self,$host_seq,$file,$aslocal) = @_;
2579 # Came back if Net::FTP couldn't establish connection (or
2580 # failed otherwise) Maybe they are behind a firewall, but they
2581 # gave us a socksified (or other) ftp program...
2584 my($devnull) = $CPAN::Config->{devnull} || "";
2586 my($aslocal_dir) = File::Basename::dirname($aslocal);
2587 File::Path::mkpath($aslocal_dir);
2588 HOSTHARD: for $i (@$host_seq) {
2589 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2590 $url .= "/" unless substr($url,-1) eq "/";
2592 my($proto,$host,$dir,$getfile);
2594 # Courtesy Mark Conty mark_conty@cargill.com change from
2595 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2597 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2598 # proto not yet used
2599 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2601 next HOSTHARD; # who said, we could ftp anything except ftp?
2603 next HOSTHARD if $proto eq "file"; # file URLs would have had
2604 # success above. Likely a bogus URL
2606 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2609 # Try the most capable first (wget does HTTP, HTTPS and FTP) and
2610 # leave ncftp* for last as it only does FTP.
2611 for $f (qw(wget lynx ncftpget ncftp)) {
2612 next unless exists $CPAN::Config->{$f};
2613 $funkyftp = $CPAN::Config->{$f};
2614 next unless defined $funkyftp;
2615 next if $funkyftp =~ /^\s*$/;
2616 my($asl_ungz, $asl_gz);
2617 ($asl_ungz = $aslocal) =~ s/\.gz//;
2618 $asl_gz = "$asl_ungz.gz";
2619 my($src_switch) = "";
2621 $src_switch = " -source";
2622 } elsif ($f eq "ncftp"){
2623 $src_switch = " -c";
2624 } elsif ($f eq "wget"){
2625 $src_switch = " -O -";
2628 my($stdout_redir) = " > $asl_ungz";
2629 if ($f eq "ncftpget"){
2630 $chdir = "cd $aslocal_dir && ";
2633 $CPAN::Frontend->myprint(
2635 Trying with "$funkyftp$src_switch" to get
2639 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2640 $self->debug("system[$system]") if $CPAN::DEBUG;
2642 if (($wstatus = system($system)) == 0
2645 -s $asl_ungz # lynx returns 0 when it fails somewhere
2651 } elsif ($asl_ungz ne $aslocal) {
2652 # test gzip integrity
2653 if (CPAN::Tarzip->gtest($asl_ungz)) {
2654 # e.g. foo.tar is gzipped --> foo.tar.gz
2655 rename $asl_ungz, $aslocal;
2657 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2662 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2664 -f $asl_ungz && -s _ == 0;
2665 my $gz = "$aslocal.gz";
2666 my $gzurl = "$url.gz";
2667 $CPAN::Frontend->myprint(
2669 Trying with "$funkyftp$src_switch" to get
2672 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2673 $self->debug("system[$system]") if $CPAN::DEBUG;
2675 if (($wstatus = system($system)) == 0
2679 # test gzip integrity
2680 if (CPAN::Tarzip->gtest($asl_gz)) {
2681 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2683 # somebody uncompressed file for us?
2684 rename $asl_ungz, $aslocal;
2689 unlink $asl_gz if -f $asl_gz;
2692 my $estatus = $wstatus >> 8;
2693 my $size = -f $aslocal ?
2694 ", left\n$aslocal with size ".-s _ :
2695 "\nWarning: expected file [$aslocal] doesn't exist";
2696 $CPAN::Frontend->myprint(qq{
2697 System call "$system"
2698 returned status $estatus (wstat $wstatus)$size
2701 return if $CPAN::Signal;
2702 } # wget,lynx,ncftpget,ncftp
2707 my($self,$host_seq,$file,$aslocal) = @_;
2710 my($aslocal_dir) = File::Basename::dirname($aslocal);
2711 File::Path::mkpath($aslocal_dir);
2712 my $ftpbin = $CPAN::Config->{ftp};
2713 HOSTHARDEST: for $i (@$host_seq) {
2714 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2715 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2718 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2719 $url .= "/" unless substr($url,-1) eq "/";
2721 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2722 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2725 my($host,$dir,$getfile) = ($1,$2,$3);
2727 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2728 $ctime,$blksize,$blocks) = stat($aslocal);
2729 $timestamp = $mtime ||= 0;
2730 my($netrc) = CPAN::FTP::netrc->new;
2731 my($netrcfile) = $netrc->netrc;
2732 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2733 my $targetfile = File::Basename::basename($aslocal);
2739 map("cd $_", split /\//, $dir), # RFC 1738
2741 "get $getfile $targetfile",
2745 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2746 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2747 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2749 $netrc->contains($host))) if $CPAN::DEBUG;
2750 if ($netrc->protected) {
2751 $CPAN::Frontend->myprint(qq{
2752 Trying with external ftp to get
2754 As this requires some features that are not thoroughly tested, we\'re
2755 not sure, that we get it right....
2759 $self->talk_ftp("$ftpbin$verbose $host",
2761 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2762 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2764 if ($mtime > $timestamp) {
2765 $CPAN::Frontend->myprint("GOT $aslocal\n");
2769 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2771 return if $CPAN::Signal;
2773 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2774 qq{correctly protected.\n});
2777 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2778 nor does it have a default entry\n");
2781 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2782 # then and login manually to host, using e-mail as
2784 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2788 "user anonymous $Config::Config{'cf_email'}"
2790 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2791 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2792 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2794 if ($mtime > $timestamp) {
2795 $CPAN::Frontend->myprint("GOT $aslocal\n");
2799 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2801 return if $CPAN::Signal;
2802 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2808 my($self,$command,@dialog) = @_;
2809 my $fh = FileHandle->new;
2810 $fh->open("|$command") or die "Couldn't open ftp: $!";
2811 foreach (@dialog) { $fh->print("$_\n") }
2812 $fh->close; # Wait for process to complete
2814 my $estatus = $wstatus >> 8;
2815 $CPAN::Frontend->myprint(qq{
2816 Subprocess "|$command"
2817 returned status $estatus (wstat $wstatus)
2821 # find2perl needs modularization, too, all the following is stolen
2825 my($self,$name) = @_;
2826 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2827 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2829 my($perms,%user,%group);
2833 $blocks = int(($blocks + 1) / 2);
2836 $blocks = int(($sizemm + 1023) / 1024);
2839 if (-f _) { $perms = '-'; }
2840 elsif (-d _) { $perms = 'd'; }
2841 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2842 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2843 elsif (-p _) { $perms = 'p'; }
2844 elsif (-S _) { $perms = 's'; }
2845 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2847 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2848 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2849 my $tmpmode = $mode;
2850 my $tmp = $rwx[$tmpmode & 7];
2852 $tmp = $rwx[$tmpmode & 7] . $tmp;
2854 $tmp = $rwx[$tmpmode & 7] . $tmp;
2855 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2856 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2857 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2860 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2861 my $group = $group{$gid} || $gid;
2863 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2865 my($moname) = $moname[$mon];
2866 if (-M _ > 365.25 / 2) {
2867 $timeyear = $year + 1900;
2870 $timeyear = sprintf("%02d:%02d", $hour, $min);
2873 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2887 package CPAN::FTP::netrc;
2891 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2893 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2894 $atime,$mtime,$ctime,$blksize,$blocks)
2899 my($fh,@machines,$hasdefault);
2901 $fh = FileHandle->new or die "Could not create a filehandle";
2903 if($fh->open($file)){
2904 $protected = ($mode & 077) == 0;
2906 NETRC: while (<$fh>) {
2907 my(@tokens) = split " ", $_;
2908 TOKEN: while (@tokens) {
2909 my($t) = shift @tokens;
2910 if ($t eq "default"){
2914 last TOKEN if $t eq "macdef";
2915 if ($t eq "machine") {
2916 push @machines, shift @tokens;
2921 $file = $hasdefault = $protected = "";
2925 'mach' => [@machines],
2927 'hasdefault' => $hasdefault,
2928 'protected' => $protected,
2932 # CPAN::FTP::hasdefault;
2933 sub hasdefault { shift->{'hasdefault'} }
2934 sub netrc { shift->{'netrc'} }
2935 sub protected { shift->{'protected'} }
2937 my($self,$mach) = @_;
2938 for ( @{$self->{'mach'}} ) {
2939 return 1 if $_ eq $mach;
2944 package CPAN::Complete;
2947 my($text, $line, $start, $end) = @_;
2948 my(@perlret) = cpl($text, $line, $start);
2949 # find longest common match. Can anybody show me how to peruse
2950 # T::R::Gnu to have this done automatically? Seems expensive.
2951 return () unless @perlret;
2952 my($newtext) = $text;
2953 for (my $i = length($text)+1;;$i++) {
2954 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2955 my $try = substr($perlret[0],0,$i);
2956 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2957 # warn "try[$try]tries[@tries]";
2958 if (@tries == @perlret) {
2964 ($newtext,@perlret);
2967 #-> sub CPAN::Complete::cpl ;
2969 my($word,$line,$pos) = @_;
2973 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2975 if ($line =~ s/^(force\s*)//) {
2980 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2981 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2983 } elsif ($line =~ /^(a|ls)\s/) {
2984 @return = cplx('CPAN::Author',uc($word));
2985 } elsif ($line =~ /^b\s/) {
2986 CPAN::Shell->local_bundles;
2987 @return = cplx('CPAN::Bundle',$word);
2988 } elsif ($line =~ /^d\s/) {
2989 @return = cplx('CPAN::Distribution',$word);
2990 } elsif ($line =~ m/^(
2991 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2993 if ($word =~ /^Bundle::/) {
2994 CPAN::Shell->local_bundles;
2996 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2997 } elsif ($line =~ /^i\s/) {
2998 @return = cpl_any($word);
2999 } elsif ($line =~ /^reload\s/) {
3000 @return = cpl_reload($word,$line,$pos);
3001 } elsif ($line =~ /^o\s/) {
3002 @return = cpl_option($word,$line,$pos);
3003 } elsif ($line =~ m/^\S+\s/ ) {
3004 # fallback for future commands and what we have forgotten above
3005 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3012 #-> sub CPAN::Complete::cplx ;
3014 my($class, $word) = @_;
3015 # I believed for many years that this was sorted, today I
3016 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3017 # make it sorted again. Maybe sort was dropped when GNU-readline
3018 # support came in? The RCS file is difficult to read on that:-(
3019 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3022 #-> sub CPAN::Complete::cpl_any ;
3026 cplx('CPAN::Author',$word),
3027 cplx('CPAN::Bundle',$word),
3028 cplx('CPAN::Distribution',$word),
3029 cplx('CPAN::Module',$word),
3033 #-> sub CPAN::Complete::cpl_reload ;
3035 my($word,$line,$pos) = @_;
3037 my(@words) = split " ", $line;
3038 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3039 my(@ok) = qw(cpan index);
3040 return @ok if @words == 1;
3041 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3044 #-> sub CPAN::Complete::cpl_option ;
3046 my($word,$line,$pos) = @_;
3048 my(@words) = split " ", $line;
3049 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3050 my(@ok) = qw(conf debug);
3051 return @ok if @words == 1;
3052 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3054 } elsif ($words[1] eq 'index') {
3056 } elsif ($words[1] eq 'conf') {
3057 return CPAN::Config::cpl(@_);
3058 } elsif ($words[1] eq 'debug') {
3059 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
3063 package CPAN::Index;
3065 #-> sub CPAN::Index::force_reload ;
3068 $CPAN::Index::LAST_TIME = 0;
3072 #-> sub CPAN::Index::reload ;
3074 my($cl,$force) = @_;
3077 # XXX check if a newer one is available. (We currently read it
3078 # from time to time)
3079 for ($CPAN::Config->{index_expire}) {
3080 $_ = 0.001 unless $_ && $_ > 0.001;
3082 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3083 # debug here when CPAN doesn't seem to read the Metadata
3085 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3087 unless ($CPAN::META->{PROTOCOL}) {
3088 $cl->read_metadata_cache;
3089 $CPAN::META->{PROTOCOL} ||= "1.0";
3091 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3092 # warn "Setting last_time to 0";
3093 $LAST_TIME = 0; # No warning necessary
3095 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3098 # IFF we are developing, it helps to wipe out the memory
3099 # between reloads, otherwise it is not what a user expects.
3100 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3101 $CPAN::META = CPAN->new;
3105 local $LAST_TIME = $time;
3106 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3108 my $needshort = $^O eq "dos";
3110 $cl->rd_authindex($cl
3112 "authors/01mailrc.txt.gz",
3114 File::Spec->catfile('authors', '01mailrc.gz') :
3115 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3118 $debug = "timing reading 01[".($t2 - $time)."]";
3120 return if $CPAN::Signal; # this is sometimes lengthy
3121 $cl->rd_modpacks($cl
3123 "modules/02packages.details.txt.gz",
3125 File::Spec->catfile('modules', '02packag.gz') :
3126 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3129 $debug .= "02[".($t2 - $time)."]";
3131 return if $CPAN::Signal; # this is sometimes lengthy
3134 "modules/03modlist.data.gz",
3136 File::Spec->catfile('modules', '03mlist.gz') :
3137 File::Spec->catfile('modules', '03modlist.data.gz'),
3139 $cl->write_metadata_cache;
3141 $debug .= "03[".($t2 - $time)."]";
3143 CPAN->debug($debug) if $CPAN::DEBUG;
3146 $CPAN::META->{PROTOCOL} = PROTOCOL;
3149 #-> sub CPAN::Index::reload_x ;
3151 my($cl,$wanted,$localname,$force) = @_;
3152 $force |= 2; # means we're dealing with an index here
3153 CPAN::Config->load; # we should guarantee loading wherever we rely
3155 $localname ||= $wanted;
3156 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3160 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3163 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3164 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3165 qq{day$s. I\'ll use that.});
3168 $force |= 1; # means we're quite serious about it.
3170 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3173 #-> sub CPAN::Index::rd_authindex ;
3175 my($cl, $index_target) = @_;
3177 return unless defined $index_target;
3178 $CPAN::Frontend->myprint("Going to read $index_target\n");
3180 tie *FH, CPAN::Tarzip, $index_target;
3182 push @lines, split /\012/ while <FH>;
3184 my($userid,$fullname,$email) =
3185 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3186 next unless $userid && $fullname && $email;
3188 # instantiate an author object
3189 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3190 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3191 return if $CPAN::Signal;
3196 my($self,$dist) = @_;
3197 $dist = $self->{'id'} unless defined $dist;
3198 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3202 #-> sub CPAN::Index::rd_modpacks ;
3204 my($self, $index_target) = @_;
3206 return unless defined $index_target;
3207 $CPAN::Frontend->myprint("Going to read $index_target\n");
3208 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3210 while ($_ = $fh->READLINE) {
3212 my @ls = map {"$_\n"} split /\n/, $_;
3213 unshift @ls, "\n" x length($1) if /^(\n+)/;
3217 my($line_count,$last_updated);
3219 my $shift = shift(@lines);
3220 last if $shift =~ /^\s*$/;
3221 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3222 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3224 if (not defined $line_count) {
3226 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3227 Please check the validity of the index file by comparing it to more
3228 than one CPAN mirror. I'll continue but problems seem likely to
3233 } elsif ($line_count != scalar @lines) {
3235 warn sprintf qq{Warning: Your %s
3236 contains a Line-Count header of %d but I see %d lines there. Please
3237 check the validity of the index file by comparing it to more than one
3238 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3239 $index_target, $line_count, scalar(@lines);
3242 if (not defined $last_updated) {
3244 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3245 Please check the validity of the index file by comparing it to more
3246 than one CPAN mirror. I'll continue but problems seem likely to
3254 ->myprint(sprintf qq{ Database was generated on %s\n},
3256 $DATE_OF_02 = $last_updated;
3258 if ($CPAN::META->has_inst(HTTP::Date)) {
3260 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3265 qq{Warning: This index file is %d days old.
3266 Please check the host you chose as your CPAN mirror for staleness.
3267 I'll continue but problems seem likely to happen.\a\n},
3272 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3277 # A necessity since we have metadata_cache: delete what isn't
3279 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3280 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3284 # before 1.56 we split into 3 and discarded the rest. From
3285 # 1.57 we assign remaining text to $comment thus allowing to
3286 # influence isa_perl
3287 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3288 my($bundle,$id,$userid);
3290 if ($mod eq 'CPAN' &&
3292 CPAN::Queue->exists('Bundle::CPAN') ||
3293 CPAN::Queue->exists('CPAN')
3297 if ($version > $CPAN::VERSION){
3298 $CPAN::Frontend->myprint(qq{
3299 There's a new CPAN.pm version (v$version) available!
3300 [Current version is v$CPAN::VERSION]
3301 You might want to try
3302 install Bundle::CPAN
3304 without quitting the current session. It should be a seamless upgrade
3305 while we are running...
3308 $CPAN::Frontend->myprint(qq{\n});
3310 last if $CPAN::Signal;
3311 } elsif ($mod =~ /^Bundle::(.*)/) {
3316 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3317 # Let's make it a module too, because bundles have so much
3318 # in common with modules.
3320 # Changed in 1.57_63: seems like memory bloat now without
3321 # any value, so commented out
3323 # $CPAN::META->instance('CPAN::Module',$mod);
3327 # instantiate a module object
3328 $id = $CPAN::META->instance('CPAN::Module',$mod);
3332 if ($id->cpan_file ne $dist){ # update only if file is
3333 # different. CPAN prohibits same
3334 # name with different version
3335 $userid = $id->userid || $self->userid($dist);
3337 'CPAN_USERID' => $userid,
3338 'CPAN_VERSION' => $version,
3339 'CPAN_FILE' => $dist,
3343 # instantiate a distribution object
3344 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3345 # we do not need CONTAINSMODS unless we do something with
3346 # this dist, so we better produce it on demand.
3348 ## my $obj = $CPAN::META->instance(
3349 ## 'CPAN::Distribution' => $dist
3351 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3353 $CPAN::META->instance(
3354 'CPAN::Distribution' => $dist
3356 'CPAN_USERID' => $userid,
3357 'CPAN_COMMENT' => $comment,
3361 for my $name ($mod,$dist) {
3362 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3363 $exists{$name} = undef;
3366 return if $CPAN::Signal;
3370 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3371 for my $o ($CPAN::META->all_objects($class)) {
3372 next if exists $exists{$o->{ID}};
3373 $CPAN::META->delete($class,$o->{ID});
3374 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3381 #-> sub CPAN::Index::rd_modlist ;
3383 my($cl,$index_target) = @_;
3384 return unless defined $index_target;
3385 $CPAN::Frontend->myprint("Going to read $index_target\n");
3386 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3389 while ($_ = $fh->READLINE) {
3391 my @ls = map {"$_\n"} split /\n/, $_;
3392 unshift @ls, "\n" x length($1) if /^(\n+)/;
3396 my $shift = shift(@eval);
3397 if ($shift =~ /^Date:\s+(.*)/){
3398 return if $DATE_OF_03 eq $1;
3401 last if $shift =~ /^\s*$/;
3404 push @eval, q{CPAN::Modulelist->data;};
3406 my($comp) = Safe->new("CPAN::Safe1");
3407 my($eval) = join("", @eval);
3408 my $ret = $comp->reval($eval);
3409 Carp::confess($@) if $@;
3410 return if $CPAN::Signal;
3412 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3413 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3414 $obj->set(%{$ret->{$_}});
3415 return if $CPAN::Signal;
3419 #-> sub CPAN::Index::write_metadata_cache ;
3420 sub write_metadata_cache {
3422 return unless $CPAN::Config->{'cache_metadata'};
3423 return unless $CPAN::META->has_usable("Storable");
3425 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3426 CPAN::Distribution)) {
3427 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3429 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3430 $cache->{last_time} = $LAST_TIME;
3431 $cache->{DATE_OF_02} = $DATE_OF_02;
3432 $cache->{PROTOCOL} = PROTOCOL;
3433 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3434 eval { Storable::nstore($cache, $metadata_file) };
3435 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3438 #-> sub CPAN::Index::read_metadata_cache ;
3439 sub read_metadata_cache {
3441 return unless $CPAN::Config->{'cache_metadata'};
3442 return unless $CPAN::META->has_usable("Storable");
3443 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3444 return unless -r $metadata_file and -f $metadata_file;
3445 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3447 eval { $cache = Storable::retrieve($metadata_file) };
3448 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3449 if (!$cache || ref $cache ne 'HASH'){
3453 if (exists $cache->{PROTOCOL}) {
3454 if (PROTOCOL > $cache->{PROTOCOL}) {
3455 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3456 "with protocol v%s, requiring v%s\n",
3463 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3464 "with protocol v1.0\n");
3469 while(my($class,$v) = each %$cache) {
3470 next unless $class =~ /^CPAN::/;
3471 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3472 while (my($id,$ro) = each %$v) {
3473 $CPAN::META->{readwrite}{$class}{$id} ||=
3474 $class->new(ID=>$id, RO=>$ro);
3479 unless ($clcnt) { # sanity check
3480 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3483 if ($idcnt < 1000) {
3484 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3485 "in $metadata_file\n");
3488 $CPAN::META->{PROTOCOL} ||=
3489 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3490 # does initialize to some protocol
3491 $LAST_TIME = $cache->{last_time};
3492 $DATE_OF_02 = $cache->{DATE_OF_02};
3493 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3494 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3498 package CPAN::InfoObj;
3503 $self->{RO}{CPAN_USERID}
3506 sub id { shift->{ID}; }
3508 #-> sub CPAN::InfoObj::new ;
3510 my $this = bless {}, shift;
3515 # The set method may only be used by code that reads index data or
3516 # otherwise "objective" data from the outside world. All session
3517 # related material may do anything else with instance variables but
3518 # must not touch the hash under the RO attribute. The reason is that
3519 # the RO hash gets written to Metadata file and is thus persistent.
3521 #-> sub CPAN::InfoObj::set ;
3523 my($self,%att) = @_;
3524 my $class = ref $self;
3526 # This must be ||=, not ||, because only if we write an empty
3527 # reference, only then the set method will write into the readonly
3528 # area. But for Distributions that spring into existence, maybe
3529 # because of a typo, we do not like it that they are written into
3530 # the readonly area and made permanent (at least for a while) and
3531 # that is why we do not "allow" other places to call ->set.
3532 unless ($self->id) {
3533 CPAN->debug("Bug? Empty ID, rejecting");
3536 my $ro = $self->{RO} =
3537 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3539 while (my($k,$v) = each %att) {
3544 #-> sub CPAN::InfoObj::as_glimpse ;
3548 my $class = ref($self);
3549 $class =~ s/^CPAN:://;
3550 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3554 #-> sub CPAN::InfoObj::as_string ;
3558 my $class = ref($self);
3559 $class =~ s/^CPAN:://;
3560 push @m, $class, " id = $self->{ID}\n";
3561 for (sort keys %{$self->{RO}}) {
3562 # next if m/^(ID|RO)$/;
3564 if ($_ eq "CPAN_USERID") {
3565 $extra .= " (".$self->author;
3566 my $email; # old perls!
3567 if ($email = $CPAN::META->instance("CPAN::Author",
3570 $extra .= " <$email>";
3572 $extra .= " <no email>";
3575 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3576 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3579 next unless defined $self->{RO}{$_};
3580 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3582 for (sort keys %$self) {
3583 next if m/^(ID|RO)$/;
3584 if (ref($self->{$_}) eq "ARRAY") {
3585 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3586 } elsif (ref($self->{$_}) eq "HASH") {
3590 join(" ",keys %{$self->{$_}}),
3593 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3599 #-> sub CPAN::InfoObj::author ;
3602 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3605 #-> sub CPAN::InfoObj::dump ;
3608 require Data::Dumper;
3609 print Data::Dumper::Dumper($self);
3612 package CPAN::Author;
3614 #-> sub CPAN::Author::id
3617 my $id = $self->{ID};
3618 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3622 #-> sub CPAN::Author::as_glimpse ;
3626 my $class = ref($self);
3627 $class =~ s/^CPAN:://;
3628 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3636 #-> sub CPAN::Author::fullname ;
3638 shift->{RO}{FULLNAME};
3642 #-> sub CPAN::Author::email ;
3643 sub email { shift->{RO}{EMAIL}; }
3645 #-> sub CPAN::Author::ls ;
3650 # adapted from CPAN::Distribution::verifyMD5 ;
3651 my(@csf); # chksumfile
3652 @csf = $self->id =~ /(.)(.)(.*)/;
3653 $csf[1] = join "", @csf[0,1];
3654 $csf[2] = join "", @csf[1,2];
3656 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3657 unless (grep {$_->[2] eq $csf[1]} @dl) {
3658 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3661 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3662 unless (grep {$_->[2] eq $csf[2]} @dl) {
3663 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3666 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3667 $CPAN::Frontend->myprint(join "", map {
3668 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3669 } sort { $a->[2] cmp $b->[2] } @dl);
3672 # returns an array of arrays, the latter contain (size,mtime,filename)
3673 #-> sub CPAN::Author::dir_listing ;
3676 my $chksumfile = shift;
3677 my $recursive = shift;
3679 File::Spec->catfile($CPAN::Config->{keep_source_where},
3680 "authors", "id", @$chksumfile);
3682 # connect "force" argument with "index_expire".
3684 if (my @stat = stat $lc_want) {
3685 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3687 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3690 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3691 $chksumfile->[-1] .= ".gz";
3692 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3695 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3696 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3702 # adapted from CPAN::Distribution::MD5_check_file ;
3703 my $fh = FileHandle->new;
3705 if (open $fh, $lc_file){
3708 $eval =~ s/\015?\012/\n/g;
3710 my($comp) = Safe->new();
3711 $cksum = $comp->reval($eval);
3713 rename $lc_file, "$lc_file.bad";
3714 Carp::confess($@) if $@;
3717 Carp::carp "Could not open $lc_file for reading";
3720 for $f (sort keys %$cksum) {
3721 if (exists $cksum->{$f}{isdir}) {
3723 my(@dir) = @$chksumfile;
3725 push @dir, $f, "CHECKSUMS";
3727 [$_->[0], $_->[1], "$f/$_->[2]"]
3728 } $self->dir_listing(\@dir,1);
3730 push @result, [ 0, "-", $f ];
3734 ($cksum->{$f}{"size"}||0),
3735 $cksum->{$f}{"mtime"}||"---",
3743 package CPAN::Distribution;
3746 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3750 delete $self->{later};
3753 # CPAN::Distribution::normalize
3756 $s = $self->id unless defined $s;
3760 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3762 return $s if $s =~ m:^N/A|^Contact Author: ;
3763 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3764 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3765 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3770 #-> sub CPAN::Distribution::color_cmd_tmps ;
3771 sub color_cmd_tmps {
3773 my($depth) = shift || 0;
3774 my($color) = shift || 0;
3775 my($ancestors) = shift || [];
3776 # a distribution needs to recurse into its prereq_pms
3778 return if exists $self->{incommandcolor}
3779 && $self->{incommandcolor}==$color;
3781 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3783 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3784 my $prereq_pm = $self->prereq_pm;
3785 if (defined $prereq_pm) {
3786 for my $pre (keys %$prereq_pm) {
3787 my $premo = CPAN::Shell->expand("Module",$pre);
3788 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3792 delete $self->{sponsored_mods};
3793 delete $self->{badtestcnt};
3795 $self->{incommandcolor} = $color;
3798 #-> sub CPAN::Distribution::as_string ;
3801 $self->containsmods;
3802 $self->SUPER::as_string(@_);
3805 #-> sub CPAN::Distribution::containsmods ;
3808 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3809 my $dist_id = $self->{ID};
3810 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3811 my $mod_file = $mod->cpan_file or next;
3812 my $mod_id = $mod->{ID} or next;
3813 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3815 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3817 keys %{$self->{CONTAINSMODS}};
3820 #-> sub CPAN::Distribution::uptodate ;
3824 foreach $c ($self->containsmods) {
3825 my $obj = CPAN::Shell->expandany($c);
3826 return 0 unless $obj->uptodate;
3831 #-> sub CPAN::Distribution::called_for ;
3834 $self->{CALLED_FOR} = $id if defined $id;
3835 return $self->{CALLED_FOR};
3838 #-> sub CPAN::Distribution::safe_chdir ;
3840 my($self,$todir) = @_;
3841 # we die if we cannot chdir and we are debuggable
3842 Carp::confess("safe_chdir called without todir argument")
3843 unless defined $todir and length $todir;
3845 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3848 my $cwd = CPAN::anycwd();
3849 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3850 qq{to todir[$todir]: $!});
3854 #-> sub CPAN::Distribution::get ;
3859 exists $self->{'build_dir'} and push @e,
3860 "Is already unwrapped into directory $self->{'build_dir'}";
3861 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3863 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3866 # Get the file on local disk
3871 File::Spec->catfile(
3872 $CPAN::Config->{keep_source_where},
3875 split(/\//,$self->id)
3878 $self->debug("Doing localize") if $CPAN::DEBUG;
3879 unless ($local_file =
3880 CPAN::FTP->localize("authors/id/$self->{ID}",
3883 if ($CPAN::Index::DATE_OF_02) {
3884 $note = "Note: Current database in memory was generated ".
3885 "on $CPAN::Index::DATE_OF_02\n";
3887 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3889 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3890 $self->{localfile} = $local_file;
3891 return if $CPAN::Signal;
3896 if ($CPAN::META->has_inst("Digest::MD5")) {
3897 $self->debug("Digest::MD5 is installed, verifying");
3900 $self->debug("Digest::MD5 is NOT installed");
3902 return if $CPAN::Signal;
3905 # Create a clean room and go there
3907 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3908 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3909 $self->safe_chdir($builddir);
3910 $self->debug("Removing tmp") if $CPAN::DEBUG;
3911 File::Path::rmtree("tmp");
3912 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3914 $self->safe_chdir($sub_wd);
3917 $self->safe_chdir("tmp");
3922 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3923 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3924 $self->untar_me($local_file);
3925 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3926 $self->unzip_me($local_file);
3927 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3928 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3929 $self->pm2dir_me($local_file);
3931 $self->{archived} = "NO";
3932 $self->safe_chdir($sub_wd);
3936 # we are still in the tmp directory!
3937 # Let's check if the package has its own directory.
3938 my $dh = DirHandle->new(File::Spec->curdir)
3939 or Carp::croak("Couldn't opendir .: $!");
3940 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3942 my ($distdir,$packagedir);
3943 if (@readdir == 1 && -d $readdir[0]) {
3944 $distdir = $readdir[0];
3945 $packagedir = File::Spec->catdir($builddir,$distdir);
3946 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3948 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3950 File::Path::rmtree($packagedir);
3951 File::Copy::move($distdir,$packagedir) or
3952 Carp::confess("Couldn't move $distdir to $packagedir: $!");
3953 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3960 my $userid = $self->cpan_userid;
3962 CPAN->debug("no userid? self[$self]");
3965 my $pragmatic_dir = $userid . '000';
3966 $pragmatic_dir =~ s/\W_//g;
3967 $pragmatic_dir++ while -d "../$pragmatic_dir";
3968 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3969 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3970 File::Path::mkpath($packagedir);
3972 for $f (@readdir) { # is already without "." and ".."
3973 my $to = File::Spec->catdir($packagedir,$f);
3974 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
3978 $self->safe_chdir($sub_wd);
3982 $self->{'build_dir'} = $packagedir;
3983 $self->safe_chdir($builddir);
3984 File::Path::rmtree("tmp");
3986 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3987 my($mpl_exists) = -f $mpl;
3988 unless ($mpl_exists) {
3989 # NFS has been reported to have racing problems after the
3990 # renaming of a directory in some environments.
3993 my $mpldh = DirHandle->new($packagedir)
3994 or Carp::croak("Couldn't opendir $packagedir: $!");
3995 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3998 unless ($mpl_exists) {
3999 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4003 my($configure) = File::Spec->catfile($packagedir,"Configure");
4004 if (-f $configure) {
4005 # do we have anything to do?
4006 $self->{'configure'} = $configure;
4007 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4008 $CPAN::Frontend->myprint(qq{
4009 Package comes with a Makefile and without a Makefile.PL.
4010 We\'ll try to build it with that Makefile then.
4012 $self->{writemakefile} = "YES";
4015 my $cf = $self->called_for || "unknown";
4020 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4021 $cf = "unknown" unless length($cf);
4022 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4023 (The test -f "$mpl" returned false.)
4024 Writing one on our own (setting NAME to $cf)\a\n});
4025 $self->{had_no_makefile_pl}++;
4028 # Writing our own Makefile.PL
4030 my $fh = FileHandle->new;
4032 or Carp::croak("Could not open >$mpl: $!");
4034 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4035 # because there was no Makefile.PL supplied.
4036 # Autogenerated on: }.scalar localtime().qq{
4038 use ExtUtils::MakeMaker;
4039 WriteMakefile(NAME => q[$cf]);
4049 # CPAN::Distribution::untar_me ;
4051 my($self,$local_file) = @_;
4052 $self->{archived} = "tar";
4053 if (CPAN::Tarzip->untar($local_file)) {
4054 $self->{unwrapped} = "YES";
4056 $self->{unwrapped} = "NO";
4060 # CPAN::Distribution::unzip_me ;
4062 my($self,$local_file) = @_;
4063 $self->{archived} = "zip";
4064 if (CPAN::Tarzip->unzip($local_file)) {
4065 $self->{unwrapped} = "YES";
4067 $self->{unwrapped} = "NO";
4073 my($self,$local_file) = @_;
4074 $self->{archived} = "pm";
4075 my $to = File::Basename::basename($local_file);
4076 $to =~ s/\.(gz|Z)(?!\n)\Z//;
4077 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4078 $self->{unwrapped} = "YES";
4080 $self->{unwrapped} = "NO";
4084 #-> sub CPAN::Distribution::new ;
4086 my($class,%att) = @_;
4088 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4090 my $this = { %att };
4091 return bless $this, $class;
4094 #-> sub CPAN::Distribution::look ;
4098 if ($^O eq 'MacOS') {
4099 $self->Mac::BuildTools::look;
4103 if ( $CPAN::Config->{'shell'} ) {
4104 $CPAN::Frontend->myprint(qq{
4105 Trying to open a subshell in the build directory...
4108 $CPAN::Frontend->myprint(qq{
4109 Your configuration does not define a value for subshells.
4110 Please define it with "o conf shell <your shell>"
4114 my $dist = $self->id;
4116 unless ($dir = $self->dir) {
4119 unless ($dir ||= $self->dir) {
4120 $CPAN::Frontend->mywarn(qq{
4121 Could not determine which directory to use for looking at $dist.
4125 my $pwd = CPAN::anycwd();
4126 $self->safe_chdir($dir);
4127 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4128 unless (system($CPAN::Config->{'shell'}) == 0) {
4130 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4132 $self->safe_chdir($pwd);
4135 # CPAN::Distribution::cvs_import ;
4139 my $dir = $self->dir;
4141 my $package = $self->called_for;
4142 my $module = $CPAN::META->instance('CPAN::Module', $package);
4143 my $version = $module->cpan_version;
4145 my $userid = $self->cpan_userid;
4147 my $cvs_dir = (split /\//, $dir)[-1];
4148 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4150 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4152 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4153 if ($cvs_site_perl) {
4154 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4156 my $cvs_log = qq{"imported $package $version sources"};
4157 $version =~ s/\./_/g;
4158 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4159 "$cvs_dir", $userid, "v$version");
4161 my $pwd = CPAN::anycwd();
4162 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4164 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4166 $CPAN::Frontend->myprint(qq{@cmd\n});
4167 system(@cmd) == 0 or
4168 $CPAN::Frontend->mydie("cvs import failed");
4169 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4172 #-> sub CPAN::Distribution::readme ;
4175 my($dist) = $self->id;
4176 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4177 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4180 File::Spec->catfile(
4181 $CPAN::Config->{keep_source_where},
4184 split(/\//,"$sans.readme"),
4186 $self->debug("Doing localize") if $CPAN::DEBUG;
4187 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4189 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4191 if ($^O eq 'MacOS') {
4192 Mac::BuildTools::launch_file($local_file);
4196 my $fh_pager = FileHandle->new;
4197 local($SIG{PIPE}) = "IGNORE";
4198 $fh_pager->open("|$CPAN::Config->{'pager'}")
4199 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4200 my $fh_readme = FileHandle->new;
4201 $fh_readme->open($local_file)
4202 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4203 $CPAN::Frontend->myprint(qq{
4206 with pager "$CPAN::Config->{'pager'}"
4209 $fh_pager->print(<$fh_readme>);
4212 #-> sub CPAN::Distribution::verifyMD5 ;
4217 $self->{MD5_STATUS} ||= "";
4218 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4219 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4221 my($lc_want,$lc_file,@local,$basename);
4222 @local = split(/\//,$self->id);
4224 push @local, "CHECKSUMS";
4226 File::Spec->catfile($CPAN::Config->{keep_source_where},
4227 "authors", "id", @local);
4232 $self->MD5_check_file($lc_want)
4234 return $self->{MD5_STATUS} = "OK";
4236 $lc_file = CPAN::FTP->localize("authors/id/@local",
4239 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4240 $local[-1] .= ".gz";
4241 $lc_file = CPAN::FTP->localize("authors/id/@local",
4244 $lc_file =~ s/\.gz(?!\n)\Z//;
4245 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4250 $self->MD5_check_file($lc_file);
4253 #-> sub CPAN::Distribution::MD5_check_file ;
4254 sub MD5_check_file {
4255 my($self,$chk_file) = @_;
4256 my($cksum,$file,$basename);
4257 $file = $self->{localfile};
4258 $basename = File::Basename::basename($file);
4259 my $fh = FileHandle->new;
4260 if (open $fh, $chk_file){
4263 $eval =~ s/\015?\012/\n/g;
4265 my($comp) = Safe->new();
4266 $cksum = $comp->reval($eval);
4268 rename $chk_file, "$chk_file.bad";
4269 Carp::confess($@) if $@;
4272 Carp::carp "Could not open $chk_file for reading";
4275 if (exists $cksum->{$basename}{md5}) {
4276 $self->debug("Found checksum for $basename:" .
4277 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4281 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4283 $fh = CPAN::Tarzip->TIEHANDLE($file);
4286 # had to inline it, when I tied it, the tiedness got lost on
4287 # the call to eq_MD5. (Jan 1998)
4288 my $md5 = Digest::MD5->new;
4291 while ($fh->READ($ref, 4096) > 0){
4294 my $hexdigest = $md5->hexdigest;
4295 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4299 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4300 return $self->{MD5_STATUS} = "OK";
4302 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4303 qq{distribution file. }.
4304 qq{Please investigate.\n\n}.
4306 $CPAN::META->instance(
4311 my $wrap = qq{I\'d recommend removing $file. Its MD5
4312 checksum is incorrect. Maybe you have configured your 'urllist' with
4313 a bad URL. Please check this array with 'o conf urllist', and
4316 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4318 # former versions just returned here but this seems a
4319 # serious threat that deserves a die
4321 # $CPAN::Frontend->myprint("\n\n");
4325 # close $fh if fileno($fh);
4327 $self->{MD5_STATUS} ||= "";
4328 if ($self->{MD5_STATUS} eq "NIL") {
4329 $CPAN::Frontend->mywarn(qq{
4330 Warning: No md5 checksum for $basename in $chk_file.
4332 The cause for this may be that the file is very new and the checksum
4333 has not yet been calculated, but it may also be that something is
4334 going awry right now.
4336 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4337 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4339 $self->{MD5_STATUS} = "NIL";
4344 #-> sub CPAN::Distribution::eq_MD5 ;
4346 my($self,$fh,$expectMD5) = @_;
4347 my $md5 = Digest::MD5->new;
4349 while (read($fh, $data, 4096)){
4352 # $md5->addfile($fh);
4353 my $hexdigest = $md5->hexdigest;
4354 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4355 $hexdigest eq $expectMD5;
4358 #-> sub CPAN::Distribution::force ;
4360 # Both modules and distributions know if "force" is in effect by
4361 # autoinspection, not by inspecting a global variable. One of the
4362 # reason why this was chosen to work that way was the treatment of
4363 # dependencies. They should not autpomatically inherit the force
4364 # status. But this has the downside that ^C and die() will return to
4365 # the prompt but will not be able to reset the force_update
4366 # attributes. We try to correct for it currently in the read_metadata
4367 # routine, and immediately before we check for a Signal. I hope this
4368 # works out in one of v1.57_53ff
4371 my($self, $method) = @_;
4373 MD5_STATUS archived build_dir localfile make install unwrapped
4376 delete $self->{$att};
4378 if ($method && $method eq "install") {
4379 $self->{"force_update"}++; # name should probably have been force_install
4383 #-> sub CPAN::Distribution::unforce ;
4386 delete $self->{'force_update'};
4389 #-> sub CPAN::Distribution::isa_perl ;
4392 my $file = File::Basename::basename($self->id);
4393 if ($file =~ m{ ^ perl
4406 } elsif ($self->cpan_comment
4408 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4413 #-> sub CPAN::Distribution::perl ;
4416 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4417 my $pwd = CPAN::anycwd();
4418 my $candidate = File::Spec->catfile($pwd,$^X);
4419 $perl ||= $candidate if MM->maybe_command($candidate);
4421 my ($component,$perl_name);
4422 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4423 PATH_COMPONENT: foreach $component (File::Spec->path(),
4424 $Config::Config{'binexp'}) {
4425 next unless defined($component) && $component;
4426 my($abs) = File::Spec->catfile($component,$perl_name);
4427 if (MM->maybe_command($abs)) {
4437 #-> sub CPAN::Distribution::make ;
4440 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4441 # Emergency brake if they said install Pippi and get newest perl
4442 if ($self->isa_perl) {
4444 $self->called_for ne $self->id &&
4445 ! $self->{force_update}
4447 # if we die here, we break bundles
4448 $CPAN::Frontend->mywarn(sprintf qq{
4449 The most recent version "%s" of the module "%s"
4450 comes with the current version of perl (%s).
4451 I\'ll build that only if you ask for something like
4456 $CPAN::META->instance(
4470 $self->{archived} eq "NO" and push @e,
4471 "Is neither a tar nor a zip archive.";
4473 $self->{unwrapped} eq "NO" and push @e,
4474 "had problems unarchiving. Please build manually";
4476 exists $self->{writemakefile} &&
4477 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4478 $1 || "Had some problem writing Makefile";
4480 defined $self->{'make'} and push @e,
4481 "Has already been processed within this session";
4483 exists $self->{later} and length($self->{later}) and
4484 push @e, $self->{later};
4486 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4488 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4489 my $builddir = $self->dir;
4490 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4491 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4493 if ($^O eq 'MacOS') {
4494 Mac::BuildTools::make($self);
4499 if ($self->{'configure'}) {
4500 $system = $self->{'configure'};
4502 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4504 # This needs a handler that can be turned on or off:
4505 # $switch = "-MExtUtils::MakeMaker ".
4506 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4508 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4510 unless (exists $self->{writemakefile}) {
4511 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4514 if ($CPAN::Config->{inactivity_timeout}) {
4516 alarm $CPAN::Config->{inactivity_timeout};
4517 local $SIG{CHLD}; # = sub { wait };
4518 if (defined($pid = fork)) {
4523 # note, this exec isn't necessary if
4524 # inactivity_timeout is 0. On the Mac I'd
4525 # suggest, we set it always to 0.
4529 $CPAN::Frontend->myprint("Cannot fork: $!");
4537 $CPAN::Frontend->myprint($@);
4538 $self->{writemakefile} = "NO $@";
4543 $ret = system($system);
4545 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4549 if (-f "Makefile") {
4550 $self->{writemakefile} = "YES";
4551 delete $self->{make_clean}; # if cleaned before, enable next
4553 $self->{writemakefile} =
4554 qq{NO Makefile.PL refused to write a Makefile.};
4555 # It's probably worth it to record the reason, so let's retry
4557 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4558 # $self->{writemakefile} .= <$fh>;
4562 delete $self->{force_update};
4565 if (my @prereq = $self->unsat_prereq){
4566 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4568 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4569 if (system($system) == 0) {
4570 $CPAN::Frontend->myprint(" $system -- OK\n");
4571 $self->{'make'} = "YES";
4573 $self->{writemakefile} ||= "YES";
4574 $self->{'make'} = "NO";
4575 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4579 sub follow_prereqs {
4583 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4584 "during [$id] -----\n");
4586 for my $p (@prereq) {
4587 $CPAN::Frontend->myprint(" $p\n");
4590 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4592 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4593 require ExtUtils::MakeMaker;
4594 my $answer = ExtUtils::MakeMaker::prompt(
4595 "Shall I follow them and prepend them to the queue
4596 of modules we are processing right now?", "yes");
4597 $follow = $answer =~ /^\s*y/i;
4601 myprint(" Ignoring dependencies on modules @prereq\n");
4604 # color them as dirty
4605 for my $p (@prereq) {
4606 # warn "calling color_cmd_tmps(0,1)";
4607 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4609 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4610 $self->{later} = "Delayed until after prerequisites";
4611 return 1; # signal success to the queuerunner
4615 #-> sub CPAN::Distribution::unsat_prereq ;
4618 my $prereq_pm = $self->prereq_pm or return;
4620 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4621 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4622 # we were too demanding:
4623 next if $nmo->uptodate;
4625 # if they have not specified a version, we accept any installed one
4626 if (not defined $need_version or
4627 $need_version == 0 or
4628 $need_version eq "undef") {
4629 next if defined $nmo->inst_file;
4632 # We only want to install prereqs if either they're not installed
4633 # or if the installed version is too old. We cannot omit this
4634 # check, because if 'force' is in effect, nobody else will check.
4638 defined $nmo->inst_file &&
4639 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4641 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4645 CPAN::Version->readable($need_version)
4651 if ($self->{sponsored_mods}{$need_module}++){
4652 # We have already sponsored it and for some reason it's still
4653 # not available. So we do nothing. Or what should we do?
4654 # if we push it again, we have a potential infinite loop
4657 push @need, $need_module;
4662 #-> sub CPAN::Distribution::prereq_pm ;
4665 return $self->{prereq_pm} if
4666 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4667 return unless $self->{writemakefile}; # no need to have succeeded
4668 # but we must have run it
4669 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4670 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4675 $fh = FileHandle->new("<$makefile\0")) {
4679 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4681 last if /MakeMaker post_initialize section/;
4683 \s+PREREQ_PM\s+=>\s+(.+)
4686 # warn "Found prereq expr[$p]";
4688 # Regexp modified by A.Speer to remember actual version of file
4689 # PREREQ_PM hash key wants, then add to
4690 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4691 # In case a prereq is mentioned twice, complain.
4692 if ( defined $p{$1} ) {
4693 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4700 $self->{prereq_pm_detected}++;
4701 return $self->{prereq_pm} = \%p;
4704 #-> sub CPAN::Distribution::test ;
4709 delete $self->{force_update};
4712 $CPAN::Frontend->myprint("Running make test\n");
4713 if (my @prereq = $self->unsat_prereq){
4714 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4718 exists $self->{make} or exists $self->{later} or push @e,
4719 "Make had some problems, maybe interrupted? Won't test";
4721 exists $self->{'make'} and
4722 $self->{'make'} eq 'NO' and
4723 push @e, "Can't test without successful make";
4725 exists $self->{build_dir} or push @e, "Has no own directory";
4726 $self->{badtestcnt} ||= 0;
4727 $self->{badtestcnt} > 0 and
4728 push @e, "Won't repeat unsuccessful test during this command";
4730 exists $self->{later} and length($self->{later}) and
4731 push @e, $self->{later};
4733 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4735 chdir $self->{'build_dir'} or
4736 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4737 $self->debug("Changed directory to $self->{'build_dir'}")
4740 if ($^O eq 'MacOS') {
4741 Mac::BuildTools::make_test($self);
4745 local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4746 $CPAN::META->set_perl5lib;
4747 my $system = join " ", $CPAN::Config->{'make'}, "test";
4748 if (system($system) == 0) {
4749 $CPAN::Frontend->myprint(" $system -- OK\n");
4750 $CPAN::META->is_tested($self->{'build_dir'});
4751 $self->{make_test} = "YES";
4753 $self->{make_test} = "NO";
4754 $self->{badtestcnt}++;
4755 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4759 #-> sub CPAN::Distribution::clean ;
4762 $CPAN::Frontend->myprint("Running make clean\n");
4765 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4766 push @e, "make clean already called once";
4767 exists $self->{build_dir} or push @e, "Has no own directory";
4768 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4770 chdir $self->{'build_dir'} or
4771 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4772 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4774 if ($^O eq 'MacOS') {
4775 Mac::BuildTools::make_clean($self);
4779 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4780 if (system($system) == 0) {
4781 $CPAN::Frontend->myprint(" $system -- OK\n");
4785 # Jost Krieger pointed out that this "force" was wrong because
4786 # it has the effect that the next "install" on this distribution
4787 # will untar everything again. Instead we should bring the
4788 # object's state back to where it is after untarring.
4790 delete $self->{force_update};
4791 delete $self->{install};
4792 delete $self->{writemakefile};
4793 delete $self->{make};
4794 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4795 $self->{make_clean} = "YES";
4798 # Hmmm, what to do if make clean failed?
4800 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4802 make clean did not succeed, marking directory as unusable for further work.
4804 $self->force("make"); # so that this directory won't be used again
4809 #-> sub CPAN::Distribution::install ;
4814 delete $self->{force_update};
4817 $CPAN::Frontend->myprint("Running make install\n");
4820 exists $self->{build_dir} or push @e, "Has no own directory";
4822 exists $self->{make} or exists $self->{later} or push @e,
4823 "Make had some problems, maybe interrupted? Won't install";
4825 exists $self->{'make'} and
4826 $self->{'make'} eq 'NO' and
4827 push @e, "make had returned bad status, install seems impossible";
4829 push @e, "make test had returned bad status, ".
4830 "won't install without force"
4831 if exists $self->{'make_test'} and
4832 $self->{'make_test'} eq 'NO' and
4833 ! $self->{'force_update'};
4835 exists $self->{'install'} and push @e,
4836 $self->{'install'} eq "YES" ?
4837 "Already done" : "Already tried without success";
4839 exists $self->{later} and length($self->{later}) and
4840 push @e, $self->{later};
4842 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4844 chdir $self->{'build_dir'} or
4845 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4846 $self->debug("Changed directory to $self->{'build_dir'}")
4849 if ($^O eq 'MacOS') {
4850 Mac::BuildTools::make_install($self);
4854 my $system = join(" ", $CPAN::Config->{'make'},
4855 "install", $CPAN::Config->{make_install_arg});
4856 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4857 my($pipe) = FileHandle->new("$system $stderr |");
4860 $CPAN::Frontend->myprint($_);
4865 $CPAN::Frontend->myprint(" $system -- OK\n");
4866 $CPAN::META->is_installed($self->{'build_dir'});
4867 return $self->{'install'} = "YES";
4869 $self->{'install'} = "NO";
4870 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4871 if ($makeout =~ /permission/s && $> > 0) {
4872 $CPAN::Frontend->myprint(qq{ You may have to su }.
4873 qq{to root to install the package\n});
4876 delete $self->{force_update};
4879 #-> sub CPAN::Distribution::dir ;
4881 shift->{'build_dir'};
4884 package CPAN::Bundle;
4888 $CPAN::Frontend->myprint($self->as_string);
4893 delete $self->{later};
4894 for my $c ( $self->contains ) {
4895 my $obj = CPAN::Shell->expandany($c) or next;
4900 #-> sub CPAN::Bundle::color_cmd_tmps ;
4901 sub color_cmd_tmps {
4903 my($depth) = shift || 0;
4904 my($color) = shift || 0;
4905 my($ancestors) = shift || [];
4906 # a module needs to recurse to its cpan_file, a distribution needs
4907 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4909 return if exists $self->{incommandcolor}
4910 && $self->{incommandcolor}==$color;
4912 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4914 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4916 for my $c ( $self->contains ) {
4917 my $obj = CPAN::Shell->expandany($c) or next;
4918 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4919 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4922 delete $self->{badtestcnt};
4924 $self->{incommandcolor} = $color;
4927 #-> sub CPAN::Bundle::as_string ;
4931 # following line must be "=", not "||=" because we have a moving target
4932 $self->{INST_VERSION} = $self->inst_version;
4933 return $self->SUPER::as_string;
4936 #-> sub CPAN::Bundle::contains ;
4939 my($inst_file) = $self->inst_file || "";
4940 my($id) = $self->id;
4941 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4942 unless ($inst_file) {
4943 # Try to get at it in the cpan directory
4944 $self->debug("no inst_file") if $CPAN::DEBUG;
4946 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4947 $cpan_file = $self->cpan_file;
4948 if ($cpan_file eq "N/A") {
4949 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4950 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4952 my $dist = $CPAN::META->instance('CPAN::Distribution',
4955 $self->debug($dist->as_string) if $CPAN::DEBUG;
4956 my($todir) = $CPAN::Config->{'cpan_home'};
4957 my(@me,$from,$to,$me);
4958 @me = split /::/, $self->id;
4960 $me = File::Spec->catfile(@me);
4961 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4962 $to = File::Spec->catfile($todir,$me);
4963 File::Path::mkpath(File::Basename::dirname($to));
4964 File::Copy::copy($from, $to)
4965 or Carp::confess("Couldn't copy $from to $to: $!");
4969 my $fh = FileHandle->new;
4971 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4973 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4975 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4976 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4977 next unless $in_cont;
4982 push @result, (split " ", $_, 2)[0];
4985 delete $self->{STATUS};
4986 $self->{CONTAINS} = \@result;
4987 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4989 $CPAN::Frontend->mywarn(qq{
4990 The bundle file "$inst_file" may be a broken
4991 bundlefile. It seems not to contain any bundle definition.
4992 Please check the file and if it is bogus, please delete it.
4993 Sorry for the inconvenience.
4999 #-> sub CPAN::Bundle::find_bundle_file
5000 sub find_bundle_file {
5001 my($self,$where,$what) = @_;
5002 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5003 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5004 ### my $bu = File::Spec->catfile($where,$what);
5005 ### return $bu if -f $bu;
5006 my $manifest = File::Spec->catfile($where,"MANIFEST");
5007 unless (-f $manifest) {
5008 require ExtUtils::Manifest;
5009 my $cwd = CPAN::anycwd();
5010 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5011 ExtUtils::Manifest::mkmanifest();
5012 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5014 my $fh = FileHandle->new($manifest)
5015 or Carp::croak("Couldn't open $manifest: $!");
5018 if ($^O eq 'MacOS') {
5021 $what2 =~ s/:Bundle://;
5024 $what2 =~ s|Bundle[/\\]||;
5029 my($file) = /(\S+)/;
5030 if ($file =~ m|\Q$what\E$|) {
5032 # return File::Spec->catfile($where,$bu); # bad
5035 # retry if she managed to
5036 # have no Bundle directory
5037 $bu = $file if $file =~ m|\Q$what2\E$|;
5039 $bu =~ tr|/|:| if $^O eq 'MacOS';
5040 return File::Spec->catfile($where, $bu) if $bu;
5041 Carp::croak("Couldn't find a Bundle file in $where");
5044 # needs to work quite differently from Module::inst_file because of
5045 # cpan_home/Bundle/ directory and the possibility that we have
5046 # shadowing effect. As it makes no sense to take the first in @INC for
5047 # Bundles, we parse them all for $VERSION and take the newest.
5049 #-> sub CPAN::Bundle::inst_file ;
5054 @me = split /::/, $self->id;
5057 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5058 my $bfile = File::Spec->catfile($incdir, @me);
5059 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5060 next unless -f $bfile;
5061 my $foundv = MM->parse_version($bfile);
5062 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5063 $self->{INST_FILE} = $bfile;
5064 $self->{INST_VERSION} = $bestv = $foundv;
5070 #-> sub CPAN::Bundle::inst_version ;
5073 $self->inst_file; # finds INST_VERSION as side effect
5074 $self->{INST_VERSION};
5077 #-> sub CPAN::Bundle::rematein ;
5079 my($self,$meth) = @_;
5080 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5081 my($id) = $self->id;
5082 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5083 unless $self->inst_file || $self->cpan_file;
5085 for $s ($self->contains) {
5086 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5087 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5088 if ($type eq 'CPAN::Distribution') {
5089 $CPAN::Frontend->mywarn(qq{
5090 The Bundle }.$self->id.qq{ contains
5091 explicitly a file $s.
5095 # possibly noisy action:
5096 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5097 my $obj = $CPAN::META->instance($type,$s);
5099 if ($obj->isa(CPAN::Bundle)
5101 exists $obj->{install_failed}
5103 ref($obj->{install_failed}) eq "HASH"
5105 for (keys %{$obj->{install_failed}}) {
5106 $self->{install_failed}{$_} = undef; # propagate faiure up
5109 $fail{$s} = 1; # the bundle itself may have succeeded but
5114 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5115 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5117 delete $self->{install_failed}{$s};
5124 # recap with less noise
5125 if ( $meth eq "install" ) {
5128 my $raw = sprintf(qq{Bundle summary:
5129 The following items in bundle %s had installation problems:},
5132 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5133 $CPAN::Frontend->myprint("\n");
5136 for $s ($self->contains) {
5138 $paragraph .= "$s ";
5139 $self->{install_failed}{$s} = undef;
5140 $reported{$s} = undef;
5143 my $report_propagated;
5144 for $s (sort keys %{$self->{install_failed}}) {
5145 next if exists $reported{$s};
5146 $paragraph .= "and the following items had problems
5147 during recursive bundle calls: " unless $report_propagated++;
5148 $paragraph .= "$s ";
5150 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5151 $CPAN::Frontend->myprint("\n");
5153 $self->{'install'} = 'YES';
5158 #sub CPAN::Bundle::xs_file
5160 # If a bundle contains another that contains an xs_file we have
5161 # here, we just don't bother I suppose
5165 #-> sub CPAN::Bundle::force ;
5166 sub force { shift->rematein('force',@_); }
5167 #-> sub CPAN::Bundle::get ;
5168 sub get { shift->rematein('get',@_); }
5169 #-> sub CPAN::Bundle::make ;
5170 sub make { shift->rematein('make',@_); }
5171 #-> sub CPAN::Bundle::test ;
5174 $self->{badtestcnt} ||= 0;
5175 $self->rematein('test',@_);
5177 #-> sub CPAN::Bundle::install ;
5180 $self->rematein('install',@_);
5182 #-> sub CPAN::Bundle::clean ;
5183 sub clean { shift->rematein('clean',@_); }
5185 #-> sub CPAN::Bundle::uptodate ;
5188 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5190 foreach $c ($self->contains) {
5191 my $obj = CPAN::Shell->expandany($c);
5192 return 0 unless $obj->uptodate;
5197 #-> sub CPAN::Bundle::readme ;
5200 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5201 No File found for bundle } . $self->id . qq{\n}), return;
5202 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5203 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5206 package CPAN::Module;
5209 # sub CPAN::Module::userid
5212 return unless exists $self->{RO}; # should never happen
5213 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5215 # sub CPAN::Module::description
5216 sub description { shift->{RO}{description} }
5220 delete $self->{later};
5221 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5226 #-> sub CPAN::Module::color_cmd_tmps ;
5227 sub color_cmd_tmps {
5229 my($depth) = shift || 0;
5230 my($color) = shift || 0;
5231 my($ancestors) = shift || [];
5232 # a module needs to recurse to its cpan_file
5234 return if exists $self->{incommandcolor}
5235 && $self->{incommandcolor}==$color;
5237 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5239 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5241 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5242 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5245 delete $self->{badtestcnt};
5247 $self->{incommandcolor} = $color;
5250 #-> sub CPAN::Module::as_glimpse ;
5254 my $class = ref($self);
5255 $class =~ s/^CPAN:://;
5259 $CPAN::Shell::COLOR_REGISTERED
5261 $CPAN::META->has_inst("Term::ANSIColor")
5263 $self->{RO}{description}
5265 $color_on = Term::ANSIColor::color("green");
5266 $color_off = Term::ANSIColor::color("reset");
5268 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5277 #-> sub CPAN::Module::as_string ;
5281 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5282 my $class = ref($self);
5283 $class =~ s/^CPAN:://;
5285 push @m, $class, " id = $self->{ID}\n";
5286 my $sprintf = " %-12s %s\n";
5287 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5288 if $self->description;
5289 my $sprintf2 = " %-12s %s (%s)\n";
5291 $userid = $self->userid;
5294 if ($author = CPAN::Shell->expand('Author',$userid)) {
5297 if ($m = $author->email) {
5304 $author->fullname . $email
5308 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5309 if $self->cpan_version;
5310 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5311 if $self->cpan_file;
5312 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5313 my(%statd,%stats,%statl,%stati);
5314 @statd{qw,? i c a b R M S,} = qw,unknown idea
5315 pre-alpha alpha beta released mature standard,;
5316 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5317 developer comp.lang.perl.* none abandoned,;
5318 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5319 @stati{qw,? f r O h,} = qw,unknown functions
5320 references+ties object-oriented hybrid,;
5321 $statd{' '} = 'unknown';
5322 $stats{' '} = 'unknown';
5323 $statl{' '} = 'unknown';
5324 $stati{' '} = 'unknown';
5332 $statd{$self->{RO}{statd}},
5333 $stats{$self->{RO}{stats}},
5334 $statl{$self->{RO}{statl}},
5335 $stati{$self->{RO}{stati}}
5336 ) if $self->{RO}{statd};
5337 my $local_file = $self->inst_file;
5338 unless ($self->{MANPAGE}) {
5340 $self->{MANPAGE} = $self->manpage_headline($local_file);
5342 # If we have already untarred it, we should look there
5343 my $dist = $CPAN::META->instance('CPAN::Distribution',
5345 # warn "dist[$dist]";
5346 # mff=manifest file; mfh=manifest handle
5351 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5353 $mfh = FileHandle->new($mff)
5355 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5356 my $lfre = $self->id; # local file RE
5359 my($lfl); # local file file
5361 my(@mflines) = <$mfh>;
5366 while (length($lfre)>5 and !$lfl) {
5367 ($lfl) = grep /$lfre/, @mflines;
5368 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5371 $lfl =~ s/\s.*//; # remove comments
5372 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5373 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5374 # warn "lfl_abs[$lfl_abs]";
5376 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5382 for $item (qw/MANPAGE/) {
5383 push @m, sprintf($sprintf, $item, $self->{$item})
5384 if exists $self->{$item};
5386 for $item (qw/CONTAINS/) {
5387 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5388 if exists $self->{$item} && @{$self->{$item}};
5390 push @m, sprintf($sprintf, 'INST_FILE',
5391 $local_file || "(not installed)");
5392 push @m, sprintf($sprintf, 'INST_VERSION',
5393 $self->inst_version) if $local_file;
5397 sub manpage_headline {
5398 my($self,$local_file) = @_;
5399 my(@local_file) = $local_file;
5400 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5401 push @local_file, $local_file;
5403 for $locf (@local_file) {
5404 next unless -f $locf;
5405 my $fh = FileHandle->new($locf)
5406 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5410 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5411 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5424 #-> sub CPAN::Module::cpan_file ;
5425 # Note: also inherited by CPAN::Bundle
5428 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5429 unless (defined $self->{RO}{CPAN_FILE}) {
5430 CPAN::Index->reload;
5432 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5433 return $self->{RO}{CPAN_FILE};
5435 my $userid = $self->userid;
5437 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5438 my $author = $CPAN::META->instance("CPAN::Author",
5440 my $fullname = $author->fullname;
5441 my $email = $author->email;
5442 unless (defined $fullname && defined $email) {
5443 return sprintf("Contact Author %s",
5447 return "Contact Author $fullname <$email>";
5449 return "Contact Author $userid (Email address not available)";
5457 #-> sub CPAN::Module::cpan_version ;
5461 $self->{RO}{CPAN_VERSION} = 'undef'
5462 unless defined $self->{RO}{CPAN_VERSION};
5463 # I believe this is always a bug in the index and should be reported
5464 # as such, but usually I find out such an error and do not want to
5465 # provoke too many bugreports
5467 $self->{RO}{CPAN_VERSION};
5470 #-> sub CPAN::Module::force ;
5473 $self->{'force_update'}++;
5476 #-> sub CPAN::Module::rematein ;
5478 my($self,$meth) = @_;
5479 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5482 my $cpan_file = $self->cpan_file;
5483 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5484 $CPAN::Frontend->mywarn(sprintf qq{
5485 The module %s isn\'t available on CPAN.
5487 Either the module has not yet been uploaded to CPAN, or it is
5488 temporary unavailable. Please contact the author to find out
5489 more about the status. Try 'i %s'.
5496 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5497 $pack->called_for($self->id);
5498 $pack->force($meth) if exists $self->{'force_update'};
5500 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5501 delete $self->{'force_update'};
5504 #-> sub CPAN::Module::readme ;
5505 sub readme { shift->rematein('readme') }
5506 #-> sub CPAN::Module::look ;
5507 sub look { shift->rematein('look') }
5508 #-> sub CPAN::Module::cvs_import ;
5509 sub cvs_import { shift->rematein('cvs_import') }
5510 #-> sub CPAN::Module::get ;
5511 sub get { shift->rematein('get',@_); }
5512 #-> sub CPAN::Module::make ;
5515 $self->rematein('make');
5517 #-> sub CPAN::Module::test ;
5520 $self->{badtestcnt} ||= 0;
5521 $self->rematein('test',@_);
5523 #-> sub CPAN::Module::uptodate ;
5526 my($latest) = $self->cpan_version;
5528 my($inst_file) = $self->inst_file;
5530 if (defined $inst_file) {
5531 $have = $self->inst_version;
5536 ! CPAN::Version->vgt($latest, $have)
5538 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5539 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5544 #-> sub CPAN::Module::install ;
5550 not exists $self->{'force_update'}
5552 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5556 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
5557 $CPAN::Frontend->mywarn(qq{
5558 \n\n\n ***WARNING***
5559 The module $self->{ID} has no active maintainer.\n\n\n
5563 $self->rematein('install') if $doit;
5565 #-> sub CPAN::Module::clean ;
5566 sub clean { shift->rematein('clean') }
5568 #-> sub CPAN::Module::inst_file ;
5572 @packpath = split /::/, $self->{ID};
5573 $packpath[-1] .= ".pm";
5574 foreach $dir (@INC) {
5575 my $pmfile = File::Spec->catfile($dir,@packpath);
5583 #-> sub CPAN::Module::xs_file ;
5587 @packpath = split /::/, $self->{ID};
5588 push @packpath, $packpath[-1];
5589 $packpath[-1] .= "." . $Config::Config{'dlext'};
5590 foreach $dir (@INC) {
5591 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5599 #-> sub CPAN::Module::inst_version ;
5602 my $parsefile = $self->inst_file or return;
5603 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5606 # there was a bug in 5.6.0 that let lots of unini warnings out of
5607 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5608 # the following workaround after 5.6.1 is out.
5609 local($SIG{__WARN__}) = sub { my $w = shift;
5610 return if $w =~ /uninitialized/i;
5614 $have = MM->parse_version($parsefile) || "undef";
5615 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5616 $have =~ s/ $//; # trailing whitespace happens all the time
5618 # My thoughts about why %vd processing should happen here
5620 # Alt1 maintain it as string with leading v:
5621 # read index files do nothing
5622 # compare it use utility for compare
5623 # print it do nothing
5625 # Alt2 maintain it as what it is
5626 # read index files convert
5627 # compare it use utility because there's still a ">" vs "gt" issue
5628 # print it use CPAN::Version for print
5630 # Seems cleaner to hold it in memory as a string starting with a "v"
5632 # If the author of this module made a mistake and wrote a quoted
5633 # "v1.13" instead of v1.13, we simply leave it at that with the
5634 # effect that *we* will treat it like a v-tring while the rest of
5635 # perl won't. Seems sensible when we consider that any action we
5636 # could take now would just add complexity.
5638 $have = CPAN::Version->readable($have);
5640 $have =~ s/\s*//g; # stringify to float around floating point issues
5641 $have; # no stringify needed, \s* above matches always
5644 package CPAN::Tarzip;
5646 # CPAN::Tarzip::gzip
5648 my($class,$read,$write) = @_;
5649 if ($CPAN::META->has_inst("Compress::Zlib")) {
5651 $fhw = FileHandle->new($read)
5652 or $CPAN::Frontend->mydie("Could not open $read: $!");
5653 my $gz = Compress::Zlib::gzopen($write, "wb")
5654 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5655 $gz->gzwrite($buffer)
5656 while read($fhw,$buffer,4096) > 0 ;
5661 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5666 # CPAN::Tarzip::gunzip
5668 my($class,$read,$write) = @_;
5669 if ($CPAN::META->has_inst("Compress::Zlib")) {
5671 $fhw = FileHandle->new(">$write")
5672 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5673 my $gz = Compress::Zlib::gzopen($read, "rb")
5674 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5675 $fhw->print($buffer)
5676 while $gz->gzread($buffer) > 0 ;
5677 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5678 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5683 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5688 # CPAN::Tarzip::gtest
5690 my($class,$read) = @_;
5691 # After I had reread the documentation in zlib.h, I discovered that
5692 # uncompressed files do not lead to an gzerror (anymore?).
5693 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5696 my $gz = Compress::Zlib::gzopen($read, "rb")
5697 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5699 $Compress::Zlib::gzerrno));
5700 while ($gz->gzread($buffer) > 0 ){
5701 $len += length($buffer);
5704 my $err = $gz->gzerror;
5705 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5706 if ($len == -s $read){
5708 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5711 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5714 return system("$CPAN::Config->{gzip} -dt $read")==0;
5719 # CPAN::Tarzip::TIEHANDLE
5721 my($class,$file) = @_;
5723 $class->debug("file[$file]");
5724 if ($CPAN::META->has_inst("Compress::Zlib")) {
5725 my $gz = Compress::Zlib::gzopen($file,"rb") or
5726 die "Could not gzopen $file";
5727 $ret = bless {GZ => $gz}, $class;
5729 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5730 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5732 $ret = bless {FH => $fh}, $class;
5738 # CPAN::Tarzip::READLINE
5741 if (exists $self->{GZ}) {
5742 my $gz = $self->{GZ};
5743 my($line,$bytesread);
5744 $bytesread = $gz->gzreadline($line);
5745 return undef if $bytesread <= 0;
5748 my $fh = $self->{FH};
5749 return scalar <$fh>;
5754 # CPAN::Tarzip::READ
5756 my($self,$ref,$length,$offset) = @_;
5757 die "read with offset not implemented" if defined $offset;
5758 if (exists $self->{GZ}) {
5759 my $gz = $self->{GZ};
5760 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5763 my $fh = $self->{FH};
5764 return read($fh,$$ref,$length);
5769 # CPAN::Tarzip::DESTROY
5772 if (exists $self->{GZ}) {
5773 my $gz = $self->{GZ};
5774 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5775 # to be undef ever. AK, 2000-09
5777 my $fh = $self->{FH};
5778 $fh->close if defined $fh;
5784 # CPAN::Tarzip::untar
5786 my($class,$file) = @_;
5789 if (0) { # makes changing order easier
5790 } elsif ($BUGHUNTING){
5792 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5794 MM->maybe_command($CPAN::Config->{'tar'})) {
5795 # should be default until Archive::Tar is fixed
5798 $CPAN::META->has_inst("Archive::Tar")
5800 $CPAN::META->has_inst("Compress::Zlib") ) {
5803 $CPAN::Frontend->mydie(qq{
5804 CPAN.pm needs either both external programs tar and gzip installed or
5805 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5806 is available. Can\'t continue.
5809 if ($prefer==1) { # 1 => external gzip+tar
5811 my $is_compressed = $class->gtest($file);
5812 if ($is_compressed) {
5813 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5814 "< $file | $CPAN::Config->{tar} xvf -";
5816 $system = "$CPAN::Config->{tar} xvf $file";
5818 if (system($system) != 0) {
5819 # people find the most curious tar binaries that cannot handle
5821 if ($is_compressed) {
5822 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5823 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5824 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5826 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5830 $system = "$CPAN::Config->{tar} xvf $file";
5831 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5832 if (system($system)==0) {
5833 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5835 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5841 } elsif ($prefer==2) { # 2 => modules
5842 my $tar = Archive::Tar->new($file,1);
5843 my $af; # archive file
5846 # RCS 1.337 had this code, it turned out unacceptable slow but
5847 # it revealed a bug in Archive::Tar. Code is only here to hunt
5848 # the bug again. It should never be enabled in published code.
5849 # GDGraph3d-0.53 was an interesting case according to Larry
5851 warn(">>>Bughunting code enabled<<< " x 20);
5852 for $af ($tar->list_files) {
5853 if ($af =~ m!^(/|\.\./)!) {
5854 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5855 "illegal member [$af]");
5857 $CPAN::Frontend->myprint("$af\n");
5858 $tar->extract($af); # slow but effective for finding the bug
5859 return if $CPAN::Signal;
5862 for $af ($tar->list_files) {
5863 if ($af =~ m!^(/|\.\./)!) {
5864 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5865 "illegal member [$af]");
5867 $CPAN::Frontend->myprint("$af\n");
5869 return if $CPAN::Signal;
5874 Mac::BuildTools::convert_files([$tar->list_files], 1)
5875 if ($^O eq 'MacOS');
5882 my($class,$file) = @_;
5883 if ($CPAN::META->has_inst("Archive::Zip")) {
5884 # blueprint of the code from Archive::Zip::Tree::extractTree();
5885 my $zip = Archive::Zip->new();
5887 $status = $zip->read($file);
5888 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5889 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5890 my @members = $zip->members();
5891 for my $member ( @members ) {
5892 my $af = $member->fileName();
5893 if ($af =~ m!^(/|\.\./)!) {
5894 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5895 "illegal member [$af]");
5897 my $status = $member->extractToFileNamed( $af );
5898 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5899 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5900 $status != Archive::Zip::AZ_OK();
5901 return if $CPAN::Signal;
5905 my $unzip = $CPAN::Config->{unzip} or
5906 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5907 my @system = ($unzip, $file);
5908 return system(@system) == 0;
5913 package CPAN::Version;
5914 # CPAN::Version::vcmp courtesy Jost Krieger
5916 my($self,$l,$r) = @_;
5918 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5920 return 0 if $l eq $r; # short circuit for quicker success
5922 if ($l=~/^v/ <=> $r=~/^v/) {
5925 $_ = $self->float2vv($_);
5930 ($l ne "undef") <=> ($r ne "undef") ||
5934 $self->vstring($l) cmp $self->vstring($r)) ||
5940 my($self,$l,$r) = @_;
5941 $self->vcmp($l,$r) > 0;
5946 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5947 pack "U*", split /\./, $n;
5950 # vv => visible vstring
5955 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5956 # architecture influence
5958 $mantissa .= "0" while length($mantissa)%3;
5959 my $ret = "v" . $rev;
5961 $mantissa =~ s/(\d{1,3})// or
5962 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5963 $ret .= ".".int($1);
5965 # warn "n[$n]ret[$ret]";
5971 $n =~ /^([\w\-\+\.]+)/;
5973 return $1 if defined $1 && length($1)>0;
5974 # if the first user reaches version v43, he will be treated as "+".
5975 # We'll have to decide about a new rule here then, depending on what
5976 # will be the prevailing versioning behavior then.
5978 if ($] < 5.006) { # or whenever v-strings were introduced
5979 # we get them wrong anyway, whatever we do, because 5.005 will
5980 # have already interpreted 0.2.4 to be "0.24". So even if he
5981 # indexer sends us something like "v0.2.4" we compare wrongly.
5983 # And if they say v1.2, then the old perl takes it as "v12"
5985 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
5988 my $better = sprintf "v%vd", $n;
5989 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
6001 CPAN - query, download and build perl modules from CPAN sites
6007 perl -MCPAN -e shell;
6013 autobundle, clean, install, make, recompile, test
6017 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6018 of a modern rewrite from ground up with greater extensibility and more
6019 features but no full compatibility. If you're new to CPAN.pm, you
6020 probably should investigate if CPANPLUS is the better choice for you.
6021 If you're already used to CPAN.pm you're welcome to continue using it,
6022 if you accept that its development is mostly (though not completely)
6027 The CPAN module is designed to automate the make and install of perl
6028 modules and extensions. It includes some primitive searching capabilities and
6029 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6030 to fetch the raw data from the net.
6032 Modules are fetched from one or more of the mirrored CPAN
6033 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6036 The CPAN module also supports the concept of named and versioned
6037 I<bundles> of modules. Bundles simplify the handling of sets of
6038 related modules. See Bundles below.
6040 The package contains a session manager and a cache manager. There is
6041 no status retained between sessions. The session manager keeps track
6042 of what has been fetched, built and installed in the current
6043 session. The cache manager keeps track of the disk space occupied by
6044 the make processes and deletes excess space according to a simple FIFO
6047 For extended searching capabilities there's a plugin for CPAN available,
6048 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6049 that indexes all documents available in CPAN authors directories. If
6050 C<CPAN::WAIT> is installed on your system, the interactive shell of
6051 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6052 which send queries to the WAIT server that has been configured for your
6055 All other methods provided are accessible in a programmer style and in an
6056 interactive shell style.
6058 =head2 Interactive Mode
6060 The interactive mode is entered by running
6062 perl -MCPAN -e shell
6064 which puts you into a readline interface. You will have the most fun if
6065 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6068 Once you are on the command line, type 'h' and the rest should be
6071 The function call C<shell> takes two optional arguments, one is the
6072 prompt, the second is the default initial command line (the latter
6073 only works if a real ReadLine interface module is installed).
6075 The most common uses of the interactive modes are
6079 =item Searching for authors, bundles, distribution files and modules
6081 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6082 for each of the four categories and another, C<i> for any of the
6083 mentioned four. Each of the four entities is implemented as a class
6084 with slightly differing methods for displaying an object.
6086 Arguments you pass to these commands are either strings exactly matching
6087 the identification string of an object or regular expressions that are
6088 then matched case-insensitively against various attributes of the
6089 objects. The parser recognizes a regular expression only if you
6090 enclose it between two slashes.
6092 The principle is that the number of found objects influences how an
6093 item is displayed. If the search finds one item, the result is
6094 displayed with the rather verbose method C<as_string>, but if we find
6095 more than one, we display each object with the terse method
6098 =item make, test, install, clean modules or distributions
6100 These commands take any number of arguments and investigate what is
6101 necessary to perform the action. If the argument is a distribution
6102 file name (recognized by embedded slashes), it is processed. If it is
6103 a module, CPAN determines the distribution file in which this module
6104 is included and processes that, following any dependencies named in
6105 the module's Makefile.PL (this behavior is controlled by
6106 I<prerequisites_policy>.)
6108 Any C<make> or C<test> are run unconditionally. An
6110 install <distribution_file>
6112 also is run unconditionally. But for
6116 CPAN checks if an install is actually needed for it and prints
6117 I<module up to date> in the case that the distribution file containing
6118 the module doesn't need to be updated.
6120 CPAN also keeps track of what it has done within the current session
6121 and doesn't try to build a package a second time regardless if it
6122 succeeded or not. The C<force> command takes as a first argument the
6123 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6124 command from scratch.
6128 cpan> install OpenGL
6129 OpenGL is up to date.
6130 cpan> force install OpenGL
6133 OpenGL-0.4/COPYRIGHT
6136 A C<clean> command results in a
6140 being executed within the distribution file's working directory.
6142 =item get, readme, look module or distribution
6144 C<get> downloads a distribution file without further action. C<readme>
6145 displays the README file of the associated distribution. C<Look> gets
6146 and untars (if not yet done) the distribution file, changes to the
6147 appropriate directory and opens a subshell process in that directory.
6151 C<ls> lists all distribution files in and below an author's CPAN
6152 directory. Only those files that contain modules are listed and if
6153 there is more than one for any given module, only the most recent one
6158 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6159 in the cpan-shell it is intended that you can press C<^C> anytime and
6160 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6161 to clean up and leave the shell loop. You can emulate the effect of a
6162 SIGTERM by sending two consecutive SIGINTs, which usually means by
6163 pressing C<^C> twice.
6165 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6166 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6172 The commands that are available in the shell interface are methods in
6173 the package CPAN::Shell. If you enter the shell command, all your
6174 input is split by the Text::ParseWords::shellwords() routine which
6175 acts like most shells do. The first word is being interpreted as the
6176 method to be called and the rest of the words are treated as arguments
6177 to this method. Continuation lines are supported if a line ends with a
6182 C<autobundle> writes a bundle file into the
6183 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6184 a list of all modules that are both available from CPAN and currently
6185 installed within @INC. The name of the bundle file is based on the
6186 current date and a counter.
6190 recompile() is a very special command in that it takes no argument and
6191 runs the make/test/install cycle with brute force over all installed
6192 dynamically loadable extensions (aka XS modules) with 'force' in
6193 effect. The primary purpose of this command is to finish a network
6194 installation. Imagine, you have a common source tree for two different
6195 architectures. You decide to do a completely independent fresh
6196 installation. You start on one architecture with the help of a Bundle
6197 file produced earlier. CPAN installs the whole Bundle for you, but
6198 when you try to repeat the job on the second architecture, CPAN
6199 responds with a C<"Foo up to date"> message for all modules. So you
6200 invoke CPAN's recompile on the second architecture and you're done.
6202 Another popular use for C<recompile> is to act as a rescue in case your
6203 perl breaks binary compatibility. If one of the modules that CPAN uses
6204 is in turn depending on binary compatibility (so you cannot run CPAN
6205 commands), then you should try the CPAN::Nox module for recovery.
6207 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6209 Although it may be considered internal, the class hierarchy does matter
6210 for both users and programmer. CPAN.pm deals with above mentioned four
6211 classes, and all those classes share a set of methods. A classical
6212 single polymorphism is in effect. A metaclass object registers all
6213 objects of all kinds and indexes them with a string. The strings
6214 referencing objects have a separated namespace (well, not completely
6219 words containing a "/" (slash) Distribution
6220 words starting with Bundle:: Bundle
6221 everything else Module or Author
6223 Modules know their associated Distribution objects. They always refer
6224 to the most recent official release. Developers may mark their releases
6225 as unstable development versions (by inserting an underbar into the
6226 module version number which will also be reflected in the distribution
6227 name when you run 'make dist'), so the really hottest and newest
6228 distribution is not always the default. If a module Foo circulates
6229 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6230 way to install version 1.23 by saying
6234 This would install the complete distribution file (say
6235 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6236 like to install version 1.23_90, you need to know where the
6237 distribution file resides on CPAN relative to the authors/id/
6238 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6239 so you would have to say
6241 install BAR/Foo-1.23_90.tar.gz
6243 The first example will be driven by an object of the class
6244 CPAN::Module, the second by an object of class CPAN::Distribution.
6246 =head2 Programmer's interface
6248 If you do not enter the shell, the available shell commands are both
6249 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6250 functions in the calling package (C<install(...)>).
6252 There's currently only one class that has a stable interface -
6253 CPAN::Shell. All commands that are available in the CPAN shell are
6254 methods of the class CPAN::Shell. Each of the commands that produce
6255 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6256 the IDs of all modules within the list.
6260 =item expand($type,@things)
6262 The IDs of all objects available within a program are strings that can
6263 be expanded to the corresponding real objects with the
6264 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6265 list of CPAN::Module objects according to the C<@things> arguments
6266 given. In scalar context it only returns the first element of the
6269 =item expandany(@things)
6271 Like expand, but returns objects of the appropriate type, i.e.
6272 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6273 CPAN::Distribution objects fro distributions.
6275 =item Programming Examples
6277 This enables the programmer to do operations that combine
6278 functionalities that are available in the shell.
6280 # install everything that is outdated on my disk:
6281 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6283 # install my favorite programs if necessary:
6284 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6285 my $obj = CPAN::Shell->expand('Module',$mod);
6289 # list all modules on my disk that have no VERSION number
6290 for $mod (CPAN::Shell->expand("Module","/./")){
6291 next unless $mod->inst_file;
6292 # MakeMaker convention for undefined $VERSION:
6293 next unless $mod->inst_version eq "undef";
6294 print "No VERSION in ", $mod->id, "\n";
6297 # find out which distribution on CPAN contains a module:
6298 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6300 Or if you want to write a cronjob to watch The CPAN, you could list
6301 all modules that need updating. First a quick and dirty way:
6303 perl -e 'use CPAN; CPAN::Shell->r;'
6305 If you don't want to get any output in the case that all modules are
6306 up to date, you can parse the output of above command for the regular
6307 expression //modules are up to date// and decide to mail the output
6308 only if it doesn't match. Ick?
6310 If you prefer to do it more in a programmer style in one single
6311 process, maybe something like this suits you better:
6313 # list all modules on my disk that have newer versions on CPAN
6314 for $mod (CPAN::Shell->expand("Module","/./")){
6315 next unless $mod->inst_file;
6316 next if $mod->uptodate;
6317 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6318 $mod->id, $mod->inst_version, $mod->cpan_version;
6321 If that gives you too much output every day, you maybe only want to
6322 watch for three modules. You can write
6324 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6326 as the first line instead. Or you can combine some of the above
6329 # watch only for a new mod_perl module
6330 $mod = CPAN::Shell->expand("Module","mod_perl");
6331 exit if $mod->uptodate;
6332 # new mod_perl arrived, let me know all update recommendations
6337 =head2 Methods in the other Classes
6339 The programming interface for the classes CPAN::Module,
6340 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6341 beta and partially even alpha. In the following paragraphs only those
6342 methods are documented that have proven useful over a longer time and
6343 thus are unlikely to change.
6347 =item CPAN::Author::as_glimpse()
6349 Returns a one-line description of the author
6351 =item CPAN::Author::as_string()
6353 Returns a multi-line description of the author
6355 =item CPAN::Author::email()
6357 Returns the author's email address
6359 =item CPAN::Author::fullname()
6361 Returns the author's name
6363 =item CPAN::Author::name()
6365 An alias for fullname
6367 =item CPAN::Bundle::as_glimpse()
6369 Returns a one-line description of the bundle
6371 =item CPAN::Bundle::as_string()
6373 Returns a multi-line description of the bundle
6375 =item CPAN::Bundle::clean()
6377 Recursively runs the C<clean> method on all items contained in the bundle.
6379 =item CPAN::Bundle::contains()
6381 Returns a list of objects' IDs contained in a bundle. The associated
6382 objects may be bundles, modules or distributions.
6384 =item CPAN::Bundle::force($method,@args)
6386 Forces CPAN to perform a task that normally would have failed. Force
6387 takes as arguments a method name to be called and any number of
6388 additional arguments that should be passed to the called method. The
6389 internals of the object get the needed changes so that CPAN.pm does
6390 not refuse to take the action. The C<force> is passed recursively to
6391 all contained objects.
6393 =item CPAN::Bundle::get()
6395 Recursively runs the C<get> method on all items contained in the bundle
6397 =item CPAN::Bundle::inst_file()
6399 Returns the highest installed version of the bundle in either @INC or
6400 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6401 CPAN::Module::inst_file.
6403 =item CPAN::Bundle::inst_version()
6405 Like CPAN::Bundle::inst_file, but returns the $VERSION
6407 =item CPAN::Bundle::uptodate()
6409 Returns 1 if the bundle itself and all its members are uptodate.
6411 =item CPAN::Bundle::install()
6413 Recursively runs the C<install> method on all items contained in the bundle
6415 =item CPAN::Bundle::make()
6417 Recursively runs the C<make> method on all items contained in the bundle
6419 =item CPAN::Bundle::readme()
6421 Recursively runs the C<readme> method on all items contained in the bundle
6423 =item CPAN::Bundle::test()
6425 Recursively runs the C<test> method on all items contained in the bundle
6427 =item CPAN::Distribution::as_glimpse()
6429 Returns a one-line description of the distribution
6431 =item CPAN::Distribution::as_string()
6433 Returns a multi-line description of the distribution
6435 =item CPAN::Distribution::clean()
6437 Changes to the directory where the distribution has been unpacked and
6438 runs C<make clean> there.
6440 =item CPAN::Distribution::containsmods()
6442 Returns a list of IDs of modules contained in a distribution file.
6443 Only works for distributions listed in the 02packages.details.txt.gz
6444 file. This typically means that only the most recent version of a
6445 distribution is covered.
6447 =item CPAN::Distribution::cvs_import()
6449 Changes to the directory where the distribution has been unpacked and
6452 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6456 =item CPAN::Distribution::dir()
6458 Returns the directory into which this distribution has been unpacked.
6460 =item CPAN::Distribution::force($method,@args)
6462 Forces CPAN to perform a task that normally would have failed. Force
6463 takes as arguments a method name to be called and any number of
6464 additional arguments that should be passed to the called method. The
6465 internals of the object get the needed changes so that CPAN.pm does
6466 not refuse to take the action.
6468 =item CPAN::Distribution::get()
6470 Downloads the distribution from CPAN and unpacks it. Does nothing if
6471 the distribution has already been downloaded and unpacked within the
6474 =item CPAN::Distribution::install()
6476 Changes to the directory where the distribution has been unpacked and
6477 runs the external command C<make install> there. If C<make> has not
6478 yet been run, it will be run first. A C<make test> will be issued in
6479 any case and if this fails, the install will be canceled. The
6480 cancellation can be avoided by letting C<force> run the C<install> for
6483 =item CPAN::Distribution::isa_perl()
6485 Returns 1 if this distribution file seems to be a perl distribution.
6486 Normally this is derived from the file name only, but the index from
6487 CPAN can contain a hint to achieve a return value of true for other
6490 =item CPAN::Distribution::look()
6492 Changes to the directory where the distribution has been unpacked and
6493 opens a subshell there. Exiting the subshell returns.
6495 =item CPAN::Distribution::make()
6497 First runs the C<get> method to make sure the distribution is
6498 downloaded and unpacked. Changes to the directory where the
6499 distribution has been unpacked and runs the external commands C<perl
6500 Makefile.PL> and C<make> there.
6502 =item CPAN::Distribution::prereq_pm()
6504 Returns the hash reference that has been announced by a distribution
6505 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6506 attempt has been made to C<make> the distribution. Returns undef
6509 =item CPAN::Distribution::readme()
6511 Downloads the README file associated with a distribution and runs it
6512 through the pager specified in C<$CPAN::Config->{pager}>.
6514 =item CPAN::Distribution::test()
6516 Changes to the directory where the distribution has been unpacked and
6517 runs C<make test> there.
6519 =item CPAN::Distribution::uptodate()
6521 Returns 1 if all the modules contained in the distribution are
6522 uptodate. Relies on containsmods.
6524 =item CPAN::Index::force_reload()
6526 Forces a reload of all indices.
6528 =item CPAN::Index::reload()
6530 Reloads all indices if they have been read more than
6531 C<$CPAN::Config->{index_expire}> days.
6533 =item CPAN::InfoObj::dump()
6535 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6536 inherit this method. It prints the data structure associated with an
6537 object. Useful for debugging. Note: the data structure is considered
6538 internal and thus subject to change without notice.
6540 =item CPAN::Module::as_glimpse()
6542 Returns a one-line description of the module
6544 =item CPAN::Module::as_string()
6546 Returns a multi-line description of the module
6548 =item CPAN::Module::clean()
6550 Runs a clean on the distribution associated with this module.
6552 =item CPAN::Module::cpan_file()
6554 Returns the filename on CPAN that is associated with the module.
6556 =item CPAN::Module::cpan_version()
6558 Returns the latest version of this module available on CPAN.
6560 =item CPAN::Module::cvs_import()
6562 Runs a cvs_import on the distribution associated with this module.
6564 =item CPAN::Module::description()
6566 Returns a 44 character description of this module. Only available for
6567 modules listed in The Module List (CPAN/modules/00modlist.long.html
6568 or 00modlist.long.txt.gz)
6570 =item CPAN::Module::force($method,@args)
6572 Forces CPAN to perform a task that normally would have failed. Force
6573 takes as arguments a method name to be called and any number of
6574 additional arguments that should be passed to the called method. The
6575 internals of the object get the needed changes so that CPAN.pm does
6576 not refuse to take the action.
6578 =item CPAN::Module::get()
6580 Runs a get on the distribution associated with this module.
6582 =item CPAN::Module::inst_file()
6584 Returns the filename of the module found in @INC. The first file found
6585 is reported just like perl itself stops searching @INC when it finds a
6588 =item CPAN::Module::inst_version()
6590 Returns the version number of the module in readable format.
6592 =item CPAN::Module::install()
6594 Runs an C<install> on the distribution associated with this module.
6596 =item CPAN::Module::look()
6598 Changes to the directory where the distribution associated with this
6599 module has been unpacked and opens a subshell there. Exiting the
6602 =item CPAN::Module::make()
6604 Runs a C<make> on the distribution associated with this module.
6606 =item CPAN::Module::manpage_headline()
6608 If module is installed, peeks into the module's manpage, reads the
6609 headline and returns it. Moreover, if the module has been downloaded
6610 within this session, does the equivalent on the downloaded module even
6611 if it is not installed.
6613 =item CPAN::Module::readme()
6615 Runs a C<readme> on the distribution associated with this module.
6617 =item CPAN::Module::test()
6619 Runs a C<test> on the distribution associated with this module.
6621 =item CPAN::Module::uptodate()
6623 Returns 1 if the module is installed and up-to-date.
6625 =item CPAN::Module::userid()
6627 Returns the author's ID of the module.
6631 =head2 Cache Manager
6633 Currently the cache manager only keeps track of the build directory
6634 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6635 deletes complete directories below C<build_dir> as soon as the size of
6636 all directories there gets bigger than $CPAN::Config->{build_cache}
6637 (in MB). The contents of this cache may be used for later
6638 re-installations that you intend to do manually, but will never be
6639 trusted by CPAN itself. This is due to the fact that the user might
6640 use these directories for building modules on different architectures.
6642 There is another directory ($CPAN::Config->{keep_source_where}) where
6643 the original distribution files are kept. This directory is not
6644 covered by the cache manager and must be controlled by the user. If
6645 you choose to have the same directory as build_dir and as
6646 keep_source_where directory, then your sources will be deleted with
6647 the same fifo mechanism.
6651 A bundle is just a perl module in the namespace Bundle:: that does not
6652 define any functions or methods. It usually only contains documentation.
6654 It starts like a perl module with a package declaration and a $VERSION
6655 variable. After that the pod section looks like any other pod with the
6656 only difference being that I<one special pod section> exists starting with
6661 In this pod section each line obeys the format
6663 Module_Name [Version_String] [- optional text]
6665 The only required part is the first field, the name of a module
6666 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6667 of the line is optional. The comment part is delimited by a dash just
6668 as in the man page header.
6670 The distribution of a bundle should follow the same convention as
6671 other distributions.
6673 Bundles are treated specially in the CPAN package. If you say 'install
6674 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6675 the modules in the CONTENTS section of the pod. You can install your
6676 own Bundles locally by placing a conformant Bundle file somewhere into
6677 your @INC path. The autobundle() command which is available in the
6678 shell interface does that for you by including all currently installed
6679 modules in a snapshot bundle file.
6681 =head2 Prerequisites
6683 If you have a local mirror of CPAN and can access all files with
6684 "file:" URLs, then you only need a perl better than perl5.003 to run
6685 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6686 required for non-UNIX systems or if your nearest CPAN site is
6687 associated with a URL that is not C<ftp:>.
6689 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6690 implemented for an external ftp command or for an external lynx
6693 =head2 Finding packages and VERSION
6695 This module presumes that all packages on CPAN
6701 declare their $VERSION variable in an easy to parse manner. This
6702 prerequisite can hardly be relaxed because it consumes far too much
6703 memory to load all packages into the running program just to determine
6704 the $VERSION variable. Currently all programs that are dealing with
6705 version use something like this
6707 perl -MExtUtils::MakeMaker -le \
6708 'print MM->parse_version(shift)' filename
6710 If you are author of a package and wonder if your $VERSION can be
6711 parsed, please try the above method.
6715 come as compressed or gzipped tarfiles or as zip files and contain a
6716 Makefile.PL (well, we try to handle a bit more, but without much
6723 The debugging of this module is a bit complex, because we have
6724 interferences of the software producing the indices on CPAN, of the
6725 mirroring process on CPAN, of packaging, of configuration, of
6726 synchronicity, and of bugs within CPAN.pm.
6728 For code debugging in interactive mode you can try "o debug" which
6729 will list options for debugging the various parts of the code. You
6730 should know that "o debug" has built-in completion support.
6732 For data debugging there is the C<dump> command which takes the same
6733 arguments as make/test/install and outputs the object's Data::Dumper
6736 =head2 Floppy, Zip, Offline Mode
6738 CPAN.pm works nicely without network too. If you maintain machines
6739 that are not networked at all, you should consider working with file:
6740 URLs. Of course, you have to collect your modules somewhere first. So
6741 you might use CPAN.pm to put together all you need on a networked
6742 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6743 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6744 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6745 with this floppy. See also below the paragraph about CD-ROM support.
6747 =head1 CONFIGURATION
6749 When the CPAN module is used for the first time, a configuration
6750 dialog tries to determine a couple of site specific options. The
6751 result of the dialog is stored in a hash reference C< $CPAN::Config >
6752 in a file CPAN/Config.pm.
6754 The default values defined in the CPAN/Config.pm file can be
6755 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6756 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6757 added to the search path of the CPAN module before the use() or
6758 require() statements.
6760 The configuration dialog can be started any time later again by
6761 issueing the command C< o conf init > in the CPAN shell.
6763 Currently the following keys in the hash reference $CPAN::Config are
6766 build_cache size of cache for directories to build modules
6767 build_dir locally accessible directory to build modules
6768 index_expire after this many days refetch index files
6769 cache_metadata use serializer to cache metadata
6770 cpan_home local directory reserved for this package
6771 dontload_hash anonymous hash: modules in the keys will not be
6772 loaded by the CPAN::has_inst() routine
6773 gzip location of external program gzip
6774 histfile file to maintain history between sessions
6775 histsize maximum number of lines to keep in histfile
6776 inactivity_timeout breaks interactive Makefile.PLs after this
6777 many seconds inactivity. Set to 0 to never break.
6778 inhibit_startup_message
6779 if true, does not print the startup message
6780 keep_source_where directory in which to keep the source (if we do)
6781 make location of external make program
6782 make_arg arguments that should always be passed to 'make'
6783 make_install_arg same as make_arg for 'make install'
6784 makepl_arg arguments passed to 'perl Makefile.PL'
6785 pager location of external program more (or any pager)
6786 prerequisites_policy
6787 what to do if you are missing module prerequisites
6788 ('follow' automatically, 'ask' me, or 'ignore')
6789 proxy_user username for accessing an authenticating proxy
6790 proxy_pass password for accessing an authenticating proxy
6791 scan_cache controls scanning of cache ('atstart' or 'never')
6792 tar location of external program tar
6793 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6794 (and nonsense for characters outside latin range)
6795 unzip location of external program unzip
6796 urllist arrayref to nearby CPAN sites (or equivalent locations)
6797 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6798 ftp_proxy, } the three usual variables for configuring
6799 http_proxy, } proxy requests. Both as CPAN::Config variables
6800 no_proxy } and as environment variables configurable.
6802 You can set and query each of these options interactively in the cpan
6803 shell with the command set defined within the C<o conf> command:
6807 =item C<o conf E<lt>scalar optionE<gt>>
6809 prints the current value of the I<scalar option>
6811 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6813 Sets the value of the I<scalar option> to I<value>
6815 =item C<o conf E<lt>list optionE<gt>>
6817 prints the current value of the I<list option> in MakeMaker's
6820 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6822 shifts or pops the array in the I<list option> variable
6824 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6826 works like the corresponding perl commands.
6830 =head2 Note on urllist parameter's format
6832 urllist parameters are URLs according to RFC 1738. We do a little
6833 guessing if your URL is not compliant, but if you have problems with
6834 file URLs, please try the correct format. Either:
6836 file://localhost/whatever/ftp/pub/CPAN/
6840 file:///home/ftp/pub/CPAN/
6842 =head2 urllist parameter has CD-ROM support
6844 The C<urllist> parameter of the configuration table contains a list of
6845 URLs that are to be used for downloading. If the list contains any
6846 C<file> URLs, CPAN always tries to get files from there first. This
6847 feature is disabled for index files. So the recommendation for the
6848 owner of a CD-ROM with CPAN contents is: include your local, possibly
6849 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6851 o conf urllist push file://localhost/CDROM/CPAN
6853 CPAN.pm will then fetch the index files from one of the CPAN sites
6854 that come at the beginning of urllist. It will later check for each
6855 module if there is a local copy of the most recent version.
6857 Another peculiarity of urllist is that the site that we could
6858 successfully fetch the last file from automatically gets a preference
6859 token and is tried as the first site for the next request. So if you
6860 add a new site at runtime it may happen that the previously preferred
6861 site will be tried another time. This means that if you want to disallow
6862 a site for the next transfer, it must be explicitly removed from
6867 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6868 install foreign, unmasked, unsigned code on your machine. We compare
6869 to a checksum that comes from the net just as the distribution file
6870 itself. If somebody has managed to tamper with the distribution file,
6871 they may have as well tampered with the CHECKSUMS file. Future
6872 development will go towards strong authentication.
6876 Most functions in package CPAN are exported per default. The reason
6877 for this is that the primary use is intended for the cpan shell or for
6880 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6882 Populating a freshly installed perl with my favorite modules is pretty
6883 easy if you maintain a private bundle definition file. To get a useful
6884 blueprint of a bundle definition file, the command autobundle can be used
6885 on the CPAN shell command line. This command writes a bundle definition
6886 file for all modules that are installed for the currently running perl
6887 interpreter. It's recommended to run this command only once and from then
6888 on maintain the file manually under a private name, say
6889 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6891 cpan> install Bundle::my_bundle
6893 then answer a few questions and then go out for a coffee.
6895 Maintaining a bundle definition file means keeping track of two
6896 things: dependencies and interactivity. CPAN.pm sometimes fails on
6897 calculating dependencies because not all modules define all MakeMaker
6898 attributes correctly, so a bundle definition file should specify
6899 prerequisites as early as possible. On the other hand, it's a bit
6900 annoying that many distributions need some interactive configuring. So
6901 what I try to accomplish in my private bundle file is to have the
6902 packages that need to be configured early in the file and the gentle
6903 ones later, so I can go out after a few minutes and leave CPAN.pm
6906 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6908 Thanks to Graham Barr for contributing the following paragraphs about
6909 the interaction between perl, and various firewall configurations. For
6910 further informations on firewalls, it is recommended to consult the
6911 documentation that comes with the ncftp program. If you are unable to
6912 go through the firewall with a simple Perl setup, it is very likely
6913 that you can configure ncftp so that it works for your firewall.
6915 =head2 Three basic types of firewalls
6917 Firewalls can be categorized into three basic types.
6923 This is where the firewall machine runs a web server and to access the
6924 outside world you must do it via the web server. If you set environment
6925 variables like http_proxy or ftp_proxy to a values beginning with http://
6926 or in your web browser you have to set proxy information then you know
6927 you are running an http firewall.
6929 To access servers outside these types of firewalls with perl (even for
6930 ftp) you will need to use LWP.
6934 This where the firewall machine runs an ftp server. This kind of
6935 firewall will only let you access ftp servers outside the firewall.
6936 This is usually done by connecting to the firewall with ftp, then
6937 entering a username like "user@outside.host.com"
6939 To access servers outside these type of firewalls with perl you
6940 will need to use Net::FTP.
6942 =item One way visibility
6944 I say one way visibility as these firewalls try to make themselves look
6945 invisible to the users inside the firewall. An FTP data connection is
6946 normally created by sending the remote server your IP address and then
6947 listening for the connection. But the remote server will not be able to
6948 connect to you because of the firewall. So for these types of firewall
6949 FTP connections need to be done in a passive mode.
6951 There are two that I can think off.
6957 If you are using a SOCKS firewall you will need to compile perl and link
6958 it with the SOCKS library, this is what is normally called a 'socksified'
6959 perl. With this executable you will be able to connect to servers outside
6960 the firewall as if it is not there.
6964 This is the firewall implemented in the Linux kernel, it allows you to
6965 hide a complete network behind one IP address. With this firewall no
6966 special compiling is needed as you can access hosts directly.
6968 For accessing ftp servers behind such firewalls you may need to set
6969 the environment variable C<FTP_PASSIVE> to a true value, e.g.
6971 env FTP_PASSIVE=1 perl -MCPAN -eshell
6975 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
6982 =head2 Configuring lynx or ncftp for going through a firewall
6984 If you can go through your firewall with e.g. lynx, presumably with a
6987 /usr/local/bin/lynx -pscott:tiger
6989 then you would configure CPAN.pm with the command
6991 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6993 That's all. Similarly for ncftp or ftp, you would configure something
6996 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6998 Your mileage may vary...
7006 I installed a new version of module X but CPAN keeps saying,
7007 I have the old version installed
7009 Most probably you B<do> have the old version installed. This can
7010 happen if a module installs itself into a different directory in the
7011 @INC path than it was previously installed. This is not really a
7012 CPAN.pm problem, you would have the same problem when installing the
7013 module manually. The easiest way to prevent this behaviour is to add
7014 the argument C<UNINST=1> to the C<make install> call, and that is why
7015 many people add this argument permanently by configuring
7017 o conf make_install_arg UNINST=1
7021 So why is UNINST=1 not the default?
7023 Because there are people who have their precise expectations about who
7024 may install where in the @INC path and who uses which @INC array. In
7025 fine tuned environments C<UNINST=1> can cause damage.
7029 I want to clean up my mess, and install a new perl along with
7030 all modules I have. How do I go about it?
7032 Run the autobundle command for your old perl and optionally rename the
7033 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7034 with the Configure option prefix, e.g.
7036 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7038 Install the bundle file you produced in the first step with something like
7040 cpan> install Bundle::mybundle
7046 When I install bundles or multiple modules with one command
7047 there is too much output to keep track of.
7049 You may want to configure something like
7051 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7052 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7054 so that STDOUT is captured in a file for later inspection.
7059 I am not root, how can I install a module in a personal directory?
7061 You will most probably like something like this:
7063 o conf makepl_arg "LIB=~/myperl/lib \
7064 INSTALLMAN1DIR=~/myperl/man/man1 \
7065 INSTALLMAN3DIR=~/myperl/man/man3"
7066 install Sybase::Sybperl
7068 You can make this setting permanent like all C<o conf> settings with
7071 You will have to add ~/myperl/man to the MANPATH environment variable
7072 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7075 use lib "$ENV{HOME}/myperl/lib";
7077 or setting the PERL5LIB environment variable.
7079 Another thing you should bear in mind is that the UNINST parameter
7080 should never be set if you are not root.
7084 How to get a package, unwrap it, and make a change before building it?
7086 look Sybase::Sybperl
7090 I installed a Bundle and had a couple of fails. When I
7091 retried, everything resolved nicely. Can this be fixed to work
7094 The reason for this is that CPAN does not know the dependencies of all
7095 modules when it starts out. To decide about the additional items to
7096 install, it just uses data found in the generated Makefile. An
7097 undetected missing piece breaks the process. But it may well be that
7098 your Bundle installs some prerequisite later than some depending item
7099 and thus your second try is able to resolve everything. Please note,
7100 CPAN.pm does not know the dependency tree in advance and cannot sort
7101 the queue of things to install in a topologically correct order. It
7102 resolves perfectly well IFF all modules declare the prerequisites
7103 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7104 fail and you need to install often, it is recommended sort the Bundle
7105 definition file manually. It is planned to improve the metadata
7106 situation for dependencies on CPAN in general, but this will still
7111 In our intranet we have many modules for internal use. How
7112 can I integrate these modules with CPAN.pm but without uploading
7113 the modules to CPAN?
7115 Have a look at the CPAN::Site module.
7119 When I run CPAN's shell, I get error msg about line 1 to 4,
7120 setting meta input/output via the /etc/inputrc file.
7122 Some versions of readline are picky about capitalization in the
7123 /etc/inputrc file and specifically RedHat 6.2 comes with a
7124 /etc/inputrc that contains the word C<on> in lowercase. Change the
7125 occurrences of C<on> to C<On> and the bug should disappear.
7129 Some authors have strange characters in their names.
7131 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7132 expecting ISO-8859-1 charset, a converter can be activated by setting
7133 term_is_latin to a true value in your config file. One way of doing so
7136 cpan> ! $CPAN::Config->{term_is_latin}=1
7138 Extended support for converters will be made available as soon as perl
7139 becomes stable with regard to charset issues.
7145 We should give coverage for B<all> of the CPAN and not just the PAUSE
7146 part, right? In this discussion CPAN and PAUSE have become equal --
7147 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7148 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7150 Future development should be directed towards a better integration of
7153 If a Makefile.PL requires special customization of libraries, prompts
7154 the user for special input, etc. then you may find CPAN is not able to
7155 build the distribution. In that case, you should attempt the
7156 traditional method of building a Perl module package from a shell.
7160 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7164 Kawai,Takanori provides a Japanese translation of this manpage at
7165 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7169 perl(1), CPAN::Nox(3)