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 any of the above
1362 r NONE report updatable modules
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 ;
1457 @args = '/./' unless @args;
1459 for my $type (qw/Bundle Distribution Module/) {
1460 push @result, $self->expand($type,@args);
1462 # Authors are always uppercase.
1463 push @result, $self->expand("Author", map { uc $_ } @args);
1465 my $result = @result == 1 ?
1466 $result[0]->as_string :
1468 "No objects found of any type for argument @args\n" :
1470 (map {$_->as_glimpse} @result),
1471 scalar @result, " items found\n",
1473 $CPAN::Frontend->myprint($result);
1476 #-> sub CPAN::Shell::o ;
1478 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1479 # should have been called set and 'o debug' maybe 'set debug'
1481 my($self,$o_type,@o_what) = @_;
1483 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1484 if ($o_type eq 'conf') {
1485 shift @o_what if @o_what && $o_what[0] eq 'help';
1486 if (!@o_what) { # print all things, "o conf"
1488 $CPAN::Frontend->myprint("CPAN::Config options");
1489 if (exists $INC{'CPAN/Config.pm'}) {
1490 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1492 if (exists $INC{'CPAN/MyConfig.pm'}) {
1493 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1495 $CPAN::Frontend->myprint(":\n");
1496 for $k (sort keys %CPAN::Config::can) {
1497 $v = $CPAN::Config::can{$k};
1498 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1500 $CPAN::Frontend->myprint("\n");
1501 for $k (sort keys %$CPAN::Config) {
1502 CPAN::Config->prettyprint($k);
1504 $CPAN::Frontend->myprint("\n");
1505 } elsif (!CPAN::Config->edit(@o_what)) {
1506 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1507 qq{edit options\n\n});
1509 } elsif ($o_type eq 'debug') {
1511 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1514 my($what) = shift @o_what;
1515 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1516 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1519 if ( exists $CPAN::DEBUG{$what} ) {
1520 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1521 } elsif ($what =~ /^\d/) {
1522 $CPAN::DEBUG = $what;
1523 } elsif (lc $what eq 'all') {
1525 for (values %CPAN::DEBUG) {
1528 $CPAN::DEBUG = $max;
1531 for (keys %CPAN::DEBUG) {
1532 next unless lc($_) eq lc($what);
1533 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1536 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1541 my $raw = "Valid options for debug are ".
1542 join(", ",sort(keys %CPAN::DEBUG), 'all').
1543 qq{ or a number. Completion works on the options. }.
1544 qq{Case is ignored.};
1546 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1547 $CPAN::Frontend->myprint("\n\n");
1550 $CPAN::Frontend->myprint("Options set for debugging:\n");
1552 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1553 $v = $CPAN::DEBUG{$k};
1554 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1555 if $v & $CPAN::DEBUG;
1558 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1561 $CPAN::Frontend->myprint(qq{
1563 conf set or get configuration variables
1564 debug set or get debugging options
1569 sub paintdots_onreload {
1572 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1576 # $CPAN::Frontend->myprint(".($subr)");
1577 $CPAN::Frontend->myprint(".");
1584 #-> sub CPAN::Shell::reload ;
1586 my($self,$command,@arg) = @_;
1588 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1589 if ($command =~ /cpan/i) {
1590 for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1591 next unless $INC{$f};
1592 CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
1593 my $fh = FileHandle->new($INC{$f});
1596 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1599 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1601 } elsif ($command =~ /index/) {
1602 CPAN::Index->force_reload;
1604 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1605 index re-reads the index files\n});
1609 #-> sub CPAN::Shell::_binary_extensions ;
1610 sub _binary_extensions {
1611 my($self) = shift @_;
1612 my(@result,$module,%seen,%need,$headerdone);
1613 for $module ($self->expand('Module','/./')) {
1614 my $file = $module->cpan_file;
1615 next if $file eq "N/A";
1616 next if $file =~ /^Contact Author/;
1617 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1618 next if $dist->isa_perl;
1619 next unless $module->xs_file;
1621 $CPAN::Frontend->myprint(".");
1622 push @result, $module;
1624 # print join " | ", @result;
1625 $CPAN::Frontend->myprint("\n");
1629 #-> sub CPAN::Shell::recompile ;
1631 my($self) = shift @_;
1632 my($module,@module,$cpan_file,%dist);
1633 @module = $self->_binary_extensions();
1634 for $module (@module){ # we force now and compile later, so we
1636 $cpan_file = $module->cpan_file;
1637 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1639 $dist{$cpan_file}++;
1641 for $cpan_file (sort keys %dist) {
1642 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1643 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1645 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1646 # stop a package from recompiling,
1647 # e.g. IO-1.12 when we have perl5.003_10
1651 #-> sub CPAN::Shell::_u_r_common ;
1653 my($self) = shift @_;
1654 my($what) = shift @_;
1655 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1656 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1657 $what && $what =~ /^[aru]$/;
1659 @args = '/./' unless @args;
1660 my(@result,$module,%seen,%need,$headerdone,
1661 $version_undefs,$version_zeroes);
1662 $version_undefs = $version_zeroes = 0;
1663 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1664 my @expand = $self->expand('Module',@args);
1665 my $expand = scalar @expand;
1666 if (0) { # Looks like noise to me, was very useful for debugging
1667 # for metadata cache
1668 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1670 for $module (@expand) {
1671 my $file = $module->cpan_file;
1672 next unless defined $file; # ??
1673 my($latest) = $module->cpan_version;
1674 my($inst_file) = $module->inst_file;
1676 return if $CPAN::Signal;
1679 $have = $module->inst_version;
1680 } elsif ($what eq "r") {
1681 $have = $module->inst_version;
1683 if ($have eq "undef"){
1685 } elsif ($have == 0){
1688 next unless CPAN::Version->vgt($latest, $have);
1689 # to be pedantic we should probably say:
1690 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1691 # to catch the case where CPAN has a version 0 and we have a version undef
1692 } elsif ($what eq "u") {
1698 } elsif ($what eq "r") {
1700 } elsif ($what eq "u") {
1704 return if $CPAN::Signal; # this is sometimes lengthy
1707 push @result, sprintf "%s %s\n", $module->id, $have;
1708 } elsif ($what eq "r") {
1709 push @result, $module->id;
1710 next if $seen{$file}++;
1711 } elsif ($what eq "u") {
1712 push @result, $module->id;
1713 next if $seen{$file}++;
1714 next if $file =~ /^Contact/;
1716 unless ($headerdone++){
1717 $CPAN::Frontend->myprint("\n");
1718 $CPAN::Frontend->myprint(sprintf(
1721 "Package namespace",
1733 $CPAN::META->has_inst("Term::ANSIColor")
1735 $module->{RO}{description}
1737 $color_on = Term::ANSIColor::color("green");
1738 $color_off = Term::ANSIColor::color("reset");
1740 $CPAN::Frontend->myprint(sprintf $sprintf,
1747 $need{$module->id}++;
1751 $CPAN::Frontend->myprint("No modules found for @args\n");
1752 } elsif ($what eq "r") {
1753 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1757 if ($version_zeroes) {
1758 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1759 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1760 qq{a version number of 0\n});
1762 if ($version_undefs) {
1763 my $s_has = $version_undefs > 1 ? "s have" : " has";
1764 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1765 qq{parseable version number\n});
1771 #-> sub CPAN::Shell::r ;
1773 shift->_u_r_common("r",@_);
1776 #-> sub CPAN::Shell::u ;
1778 shift->_u_r_common("u",@_);
1781 #-> sub CPAN::Shell::autobundle ;
1784 CPAN::Config->load unless $CPAN::Config_loaded++;
1785 my(@bundle) = $self->_u_r_common("a",@_);
1786 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1787 File::Path::mkpath($todir);
1788 unless (-d $todir) {
1789 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1792 my($y,$m,$d) = (localtime)[5,4,3];
1796 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1797 my($to) = File::Spec->catfile($todir,"$me.pm");
1799 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1800 $to = File::Spec->catfile($todir,"$me.pm");
1802 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1804 "package Bundle::$me;\n\n",
1805 "\$VERSION = '0.01';\n\n",
1809 "Bundle::$me - Snapshot of installation on ",
1810 $Config::Config{'myhostname'},
1813 "\n\n=head1 SYNOPSIS\n\n",
1814 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1815 "=head1 CONTENTS\n\n",
1816 join("\n", @bundle),
1817 "\n\n=head1 CONFIGURATION\n\n",
1819 "\n\n=head1 AUTHOR\n\n",
1820 "This Bundle has been generated automatically ",
1821 "by the autobundle routine in CPAN.pm.\n",
1824 $CPAN::Frontend->myprint("\nWrote bundle file
1828 #-> sub CPAN::Shell::expandany ;
1831 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1832 if ($s =~ m|/|) { # looks like a file
1833 $s = CPAN::Distribution->normalize($s);
1834 return $CPAN::META->instance('CPAN::Distribution',$s);
1835 # Distributions spring into existence, not expand
1836 } elsif ($s =~ m|^Bundle::|) {
1837 $self->local_bundles; # scanning so late for bundles seems
1838 # both attractive and crumpy: always
1839 # current state but easy to forget
1841 return $self->expand('Bundle',$s);
1843 return $self->expand('Module',$s)
1844 if $CPAN::META->exists('CPAN::Module',$s);
1849 #-> sub CPAN::Shell::expand ;
1852 my($type,@args) = @_;
1854 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1856 my($regex,$command);
1857 if ($arg =~ m|^/(.*)/$|) {
1859 } elsif ($arg =~ m/=/) {
1862 my $class = "CPAN::$type";
1864 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1866 defined $regex ? $regex : "UNDEFINED",
1867 $command || "UNDEFINED",
1869 if (defined $regex) {
1873 $CPAN::META->all_objects($class)
1876 # BUG, we got an empty object somewhere
1877 require Data::Dumper;
1878 CPAN->debug(sprintf(
1879 "Bug in CPAN: Empty id on obj[%s][%s]",
1881 Data::Dumper::Dumper($obj)
1886 if $obj->id =~ /$regex/i
1890 $] < 5.00303 ### provide sort of
1891 ### compatibility with 5.003
1896 $obj->name =~ /$regex/i
1899 } elsif ($command) {
1900 die "equal sign in command disabled (immature interface), ".
1902 ! \$CPAN::Shell::ADVANCED_QUERY=1
1903 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1904 that may go away anytime.\n"
1905 unless $ADVANCED_QUERY;
1906 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1907 my($matchcrit) = $criterion =~ m/^~(.+)/;
1911 $CPAN::META->all_objects($class)
1913 my $lhs = $self->$method() or next; # () for 5.00503
1915 push @m, $self if $lhs =~ m/$matchcrit/;
1917 push @m, $self if $lhs eq $criterion;
1922 if ( $type eq 'Bundle' ) {
1923 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1924 } elsif ($type eq "Distribution") {
1925 $xarg = CPAN::Distribution->normalize($arg);
1927 if ($CPAN::META->exists($class,$xarg)) {
1928 $obj = $CPAN::META->instance($class,$xarg);
1929 } elsif ($CPAN::META->exists($class,$arg)) {
1930 $obj = $CPAN::META->instance($class,$arg);
1937 return wantarray ? @m : $m[0];
1940 #-> sub CPAN::Shell::format_result ;
1943 my($type,@args) = @_;
1944 @args = '/./' unless @args;
1945 my(@result) = $self->expand($type,@args);
1946 my $result = @result == 1 ?
1947 $result[0]->as_string :
1949 "No objects of type $type found for argument @args\n" :
1951 (map {$_->as_glimpse} @result),
1952 scalar @result, " items found\n",
1957 # The only reason for this method is currently to have a reliable
1958 # debugging utility that reveals which output is going through which
1959 # channel. No, I don't like the colors ;-)
1961 #-> sub CPAN::Shell::print_ornameted ;
1962 sub print_ornamented {
1963 my($self,$what,$ornament) = @_;
1965 return unless defined $what;
1967 if ($CPAN::Config->{term_is_latin}){
1970 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1972 if ($PRINT_ORNAMENTING) {
1973 unless (defined &color) {
1974 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1975 import Term::ANSIColor "color";
1977 *color = sub { return "" };
1981 for $line (split /\n/, $what) {
1982 $longest = length($line) if length($line) > $longest;
1984 my $sprintf = "%-" . $longest . "s";
1986 $what =~ s/(.*\n?)//m;
1989 my($nl) = chomp $line ? "\n" : "";
1990 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1991 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1995 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
2001 my($self,$what) = @_;
2003 $self->print_ornamented($what, 'bold blue on_yellow');
2007 my($self,$what) = @_;
2008 $self->myprint($what);
2013 my($self,$what) = @_;
2014 $self->print_ornamented($what, 'bold red on_yellow');
2018 my($self,$what) = @_;
2019 $self->print_ornamented($what, 'bold red on_white');
2020 Carp::confess "died";
2024 my($self,$what) = @_;
2025 $self->print_ornamented($what, 'bold red on_white');
2030 return if -t STDOUT;
2031 my $odef = select STDERR;
2038 #-> sub CPAN::Shell::rematein ;
2039 # RE-adme||MA-ke||TE-st||IN-stall
2042 my($meth,@some) = @_;
2044 if ($meth eq 'force') {
2046 $meth = shift @some;
2049 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
2051 # Here is the place to set "test_count" on all involved parties to
2052 # 0. We then can pass this counter on to the involved
2053 # distributions and those can refuse to test if test_count > X. In
2054 # the first stab at it we could use a 1 for "X".
2056 # But when do I reset the distributions to start with 0 again?
2057 # Jost suggested to have a random or cycling interaction ID that
2058 # we pass through. But the ID is something that is just left lying
2059 # around in addition to the counter, so I'd prefer to set the
2060 # counter to 0 now, and repeat at the end of the loop. But what
2061 # about dependencies? They appear later and are not reset, they
2062 # enter the queue but not its copy. How do they get a sensible
2065 # construct the queue
2067 foreach $s (@some) {
2070 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2072 } elsif ($s =~ m|^/|) { # looks like a regexp
2073 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2078 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2079 $obj = CPAN::Shell->expandany($s);
2082 $obj->color_cmd_tmps(0,1);
2083 CPAN::Queue->new($obj->id);
2085 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2086 $obj = $CPAN::META->instance('CPAN::Author',$s);
2087 if ($meth =~ /^(dump|ls)$/) {
2090 $CPAN::Frontend->myprint(
2092 "Don't be silly, you can't $meth ",
2100 ->myprint(qq{Warning: Cannot $meth $s, }.
2101 qq{don\'t know what it is.
2106 to find objects with matching identifiers.
2112 # queuerunner (please be warned: when I started to change the
2113 # queue to hold objects instead of names, I made one or two
2114 # mistakes and never found which. I reverted back instead)
2115 while ($s = CPAN::Queue->first) {
2118 $obj = $s; # I do not believe, we would survive if this happened
2120 $obj = CPAN::Shell->expandany($s);
2124 ($] < 5.00303 || $obj->can($pragma))){
2125 ### compatibility with 5.003
2126 $obj->$pragma($meth); # the pragma "force" in
2127 # "CPAN::Distribution" must know
2128 # what we are intending
2130 if ($]>=5.00303 && $obj->can('called_for')) {
2131 $obj->called_for($s);
2134 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2140 CPAN::Queue->delete($s);
2142 CPAN->debug("failed");
2146 CPAN::Queue->delete_first($s);
2148 for my $obj (@qcopy) {
2149 $obj->color_cmd_tmps(0,0);
2153 #-> sub CPAN::Shell::dump ;
2154 sub dump { shift->rematein('dump',@_); }
2155 #-> sub CPAN::Shell::force ;
2156 sub force { shift->rematein('force',@_); }
2157 #-> sub CPAN::Shell::get ;
2158 sub get { shift->rematein('get',@_); }
2159 #-> sub CPAN::Shell::readme ;
2160 sub readme { shift->rematein('readme',@_); }
2161 #-> sub CPAN::Shell::make ;
2162 sub make { shift->rematein('make',@_); }
2163 #-> sub CPAN::Shell::test ;
2164 sub test { shift->rematein('test',@_); }
2165 #-> sub CPAN::Shell::install ;
2166 sub install { shift->rematein('install',@_); }
2167 #-> sub CPAN::Shell::clean ;
2168 sub clean { shift->rematein('clean',@_); }
2169 #-> sub CPAN::Shell::look ;
2170 sub look { shift->rematein('look',@_); }
2171 #-> sub CPAN::Shell::cvs_import ;
2172 sub cvs_import { shift->rematein('cvs_import',@_); }
2174 package CPAN::LWP::UserAgent;
2177 return if $SETUPDONE;
2178 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2179 require LWP::UserAgent;
2180 @ISA = qw(Exporter LWP::UserAgent);
2183 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2187 sub get_basic_credentials {
2188 my($self, $realm, $uri, $proxy) = @_;
2189 return unless $proxy;
2190 if ($USER && $PASSWD) {
2191 } elsif (defined $CPAN::Config->{proxy_user} &&
2192 defined $CPAN::Config->{proxy_pass}) {
2193 $USER = $CPAN::Config->{proxy_user};
2194 $PASSWD = $CPAN::Config->{proxy_pass};
2196 require ExtUtils::MakeMaker;
2197 ExtUtils::MakeMaker->import(qw(prompt));
2198 $USER = prompt("Proxy authentication needed!
2199 (Note: to permanently configure username and password run
2200 o conf proxy_user your_username
2201 o conf proxy_pass your_password
2203 if ($CPAN::META->has_inst("Term::ReadKey")) {
2204 Term::ReadKey::ReadMode("noecho");
2206 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2208 $PASSWD = prompt("Password:");
2209 if ($CPAN::META->has_inst("Term::ReadKey")) {
2210 Term::ReadKey::ReadMode("restore");
2212 $CPAN::Frontend->myprint("\n\n");
2214 return($USER,$PASSWD);
2217 # mirror(): Its purpose is to deal with proxy authentication. When we
2218 # call SUPER::mirror, we relly call the mirror method in
2219 # LWP::UserAgent. LWP::UserAgent will then call
2220 # $self->get_basic_credentials or some equivalent and this will be
2221 # $self->dispatched to our own get_basic_credentials method.
2223 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2225 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2226 # although we have gone through our get_basic_credentials, the proxy
2227 # server refuses to connect. This could be a case where the username or
2228 # password has changed in the meantime, so I'm trying once again without
2229 # $USER and $PASSWD to give the get_basic_credentials routine another
2230 # chance to set $USER and $PASSWD.
2233 my($self,$url,$aslocal) = @_;
2234 my $result = $self->SUPER::mirror($url,$aslocal);
2235 if ($result->code == 407) {
2238 $result = $self->SUPER::mirror($url,$aslocal);
2245 #-> sub CPAN::FTP::ftp_get ;
2247 my($class,$host,$dir,$file,$target) = @_;
2249 qq[Going to fetch file [$file] from dir [$dir]
2250 on host [$host] as local [$target]\n]
2252 my $ftp = Net::FTP->new($host);
2253 return 0 unless defined $ftp;
2254 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2255 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2256 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2257 warn "Couldn't login on $host";
2260 unless ( $ftp->cwd($dir) ){
2261 warn "Couldn't cwd $dir";
2265 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2266 unless ( $ftp->get($file,$target) ){
2267 warn "Couldn't fetch $file from $host\n";
2270 $ftp->quit; # it's ok if this fails
2274 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2276 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2277 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2279 # > *** 1562,1567 ****
2280 # > --- 1562,1580 ----
2281 # > return 1 if substr($url,0,4) eq "file";
2282 # > return 1 unless $url =~ m|://([^/]+)|;
2284 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2286 # > + $proxy =~ m|://([^/:]+)|;
2288 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2289 # > + if ($noproxy) {
2290 # > + if ($host !~ /$noproxy$/) {
2291 # > + $host = $proxy;
2294 # > + $host = $proxy;
2297 # > require Net::Ping;
2298 # > return 1 unless $Net::Ping::VERSION >= 2;
2302 #-> sub CPAN::FTP::localize ;
2304 my($self,$file,$aslocal,$force) = @_;
2306 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2307 unless defined $aslocal;
2308 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2311 if ($^O eq 'MacOS') {
2312 # Comment by AK on 2000-09-03: Uniq short filenames would be
2313 # available in CHECKSUMS file
2314 my($name, $path) = File::Basename::fileparse($aslocal, '');
2315 if (length($name) > 31) {
2326 my $size = 31 - length($suf);
2327 while (length($name) > $size) {
2331 $aslocal = File::Spec->catfile($path, $name);
2335 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2338 rename $aslocal, "$aslocal.bak";
2342 my($aslocal_dir) = File::Basename::dirname($aslocal);
2343 File::Path::mkpath($aslocal_dir);
2344 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2345 qq{directory "$aslocal_dir".
2346 I\'ll continue, but if you encounter problems, they may be due
2347 to insufficient permissions.\n}) unless -w $aslocal_dir;
2349 # Inheritance is not easier to manage than a few if/else branches
2350 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2352 CPAN::LWP::UserAgent->config;
2353 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2355 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2359 $Ua->proxy('ftp', $var)
2360 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2361 $Ua->proxy('http', $var)
2362 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2365 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2367 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2368 # > use ones that require basic autorization.
2370 # > Example of when I use it manually in my own stuff:
2372 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2373 # > $req->proxy_authorization_basic("username","password");
2374 # > $res = $ua->request($req);
2378 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2382 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2383 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2386 # Try the list of urls for each single object. We keep a record
2387 # where we did get a file from
2388 my(@reordered,$last);
2389 $CPAN::Config->{urllist} ||= [];
2390 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2391 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2393 $last = $#{$CPAN::Config->{urllist}};
2394 if ($force & 2) { # local cpans probably out of date, don't reorder
2395 @reordered = (0..$last);
2399 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2401 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2412 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2414 @levels = qw/easy hard hardest/;
2416 @levels = qw/easy/ if $^O eq 'MacOS';
2418 for $levelno (0..$#levels) {
2419 my $level = $levels[$levelno];
2420 my $method = "host$level";
2421 my @host_seq = $level eq "easy" ?
2422 @reordered : 0..$last; # reordered has CDROM up front
2423 @host_seq = (0) unless @host_seq;
2424 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2426 $Themethod = $level;
2428 # utime $now, $now, $aslocal; # too bad, if we do that, we
2429 # might alter a local mirror
2430 $self->debug("level[$level]") if $CPAN::DEBUG;
2434 last if $CPAN::Signal; # need to cleanup
2437 unless ($CPAN::Signal) {
2440 qq{Please check, if the URLs I found in your configuration file \(}.
2441 join(", ", @{$CPAN::Config->{urllist}}).
2442 qq{\) are valid. The urllist can be edited.},
2443 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2444 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2446 $CPAN::Frontend->myprint("Could not fetch $file\n");
2449 rename "$aslocal.bak", $aslocal;
2450 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2451 $self->ls($aslocal));
2458 my($self,$host_seq,$file,$aslocal) = @_;
2460 HOSTEASY: for $i (@$host_seq) {
2461 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2462 $url .= "/" unless substr($url,-1) eq "/";
2464 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2465 if ($url =~ /^file:/) {
2467 if ($CPAN::META->has_inst('URI::URL')) {
2468 my $u = URI::URL->new($url);
2470 } else { # works only on Unix, is poorly constructed, but
2471 # hopefully better than nothing.
2472 # RFC 1738 says fileurl BNF is
2473 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2474 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2476 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2477 $l =~ s|^file:||; # assume they
2480 $l =~ s|^/||s unless -f $l; # e.g. /P:
2481 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2483 if ( -f $l && -r _) {
2487 # Maybe mirror has compressed it?
2489 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2490 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2497 if ($CPAN::META->has_usable('LWP')) {
2498 $CPAN::Frontend->myprint("Fetching with LWP:
2502 CPAN::LWP::UserAgent->config;
2503 eval { $Ua = CPAN::LWP::UserAgent->new; };
2505 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2508 my $res = $Ua->mirror($url, $aslocal);
2509 if ($res->is_success) {
2512 utime $now, $now, $aslocal; # download time is more
2513 # important than upload time
2515 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2516 my $gzurl = "$url.gz";
2517 $CPAN::Frontend->myprint("Fetching with LWP:
2520 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2521 if ($res->is_success &&
2522 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2528 $CPAN::Frontend->myprint(sprintf(
2529 "LWP failed with code[%s] message[%s]\n",
2533 # Alan Burlison informed me that in firewall environments
2534 # Net::FTP can still succeed where LWP fails. So we do not
2535 # skip Net::FTP anymore when LWP is available.
2538 $CPAN::Frontend->myprint("LWP not available\n");
2540 return if $CPAN::Signal;
2541 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2542 # that's the nice and easy way thanks to Graham
2543 my($host,$dir,$getfile) = ($1,$2,$3);
2544 if ($CPAN::META->has_usable('Net::FTP')) {
2546 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2549 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2550 "aslocal[$aslocal]") if $CPAN::DEBUG;
2551 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2555 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2556 my $gz = "$aslocal.gz";
2557 $CPAN::Frontend->myprint("Fetching with Net::FTP
2560 if (CPAN::FTP->ftp_get($host,
2564 CPAN::Tarzip->gunzip($gz,$aslocal)
2573 return if $CPAN::Signal;
2578 my($self,$host_seq,$file,$aslocal) = @_;
2580 # Came back if Net::FTP couldn't establish connection (or
2581 # failed otherwise) Maybe they are behind a firewall, but they
2582 # gave us a socksified (or other) ftp program...
2585 my($devnull) = $CPAN::Config->{devnull} || "";
2587 my($aslocal_dir) = File::Basename::dirname($aslocal);
2588 File::Path::mkpath($aslocal_dir);
2589 HOSTHARD: for $i (@$host_seq) {
2590 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2591 $url .= "/" unless substr($url,-1) eq "/";
2593 my($proto,$host,$dir,$getfile);
2595 # Courtesy Mark Conty mark_conty@cargill.com change from
2596 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2598 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2599 # proto not yet used
2600 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2602 next HOSTHARD; # who said, we could ftp anything except ftp?
2604 next HOSTHARD if $proto eq "file"; # file URLs would have had
2605 # success above. Likely a bogus URL
2607 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2610 # Try the most capable first (wget does HTTP, HTTPS and FTP) and
2611 # leave ncftp* for last as it only does FTP.
2612 for $f (qw(wget lynx ncftpget ncftp)) {
2613 next unless exists $CPAN::Config->{$f};
2614 $funkyftp = $CPAN::Config->{$f};
2615 next unless defined $funkyftp;
2616 next if $funkyftp =~ /^\s*$/;
2617 my($asl_ungz, $asl_gz);
2618 ($asl_ungz = $aslocal) =~ s/\.gz//;
2619 $asl_gz = "$asl_ungz.gz";
2620 my($src_switch) = "";
2622 $src_switch = " -source";
2623 } elsif ($f eq "ncftp"){
2624 $src_switch = " -c";
2625 } elsif ($f eq "wget"){
2626 $src_switch = " -O -";
2629 my($stdout_redir) = " > $asl_ungz";
2630 if ($f eq "ncftpget"){
2631 $chdir = "cd $aslocal_dir && ";
2634 $CPAN::Frontend->myprint(
2636 Trying with "$funkyftp$src_switch" to get
2640 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2641 $self->debug("system[$system]") if $CPAN::DEBUG;
2643 if (($wstatus = system($system)) == 0
2646 -s $asl_ungz # lynx returns 0 when it fails somewhere
2652 } elsif ($asl_ungz ne $aslocal) {
2653 # test gzip integrity
2654 if (CPAN::Tarzip->gtest($asl_ungz)) {
2655 # e.g. foo.tar is gzipped --> foo.tar.gz
2656 rename $asl_ungz, $aslocal;
2658 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2663 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2665 -f $asl_ungz && -s _ == 0;
2666 my $gz = "$aslocal.gz";
2667 my $gzurl = "$url.gz";
2668 $CPAN::Frontend->myprint(
2670 Trying with "$funkyftp$src_switch" to get
2673 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2674 $self->debug("system[$system]") if $CPAN::DEBUG;
2676 if (($wstatus = system($system)) == 0
2680 # test gzip integrity
2681 if (CPAN::Tarzip->gtest($asl_gz)) {
2682 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2684 # somebody uncompressed file for us?
2685 rename $asl_ungz, $aslocal;
2690 unlink $asl_gz if -f $asl_gz;
2693 my $estatus = $wstatus >> 8;
2694 my $size = -f $aslocal ?
2695 ", left\n$aslocal with size ".-s _ :
2696 "\nWarning: expected file [$aslocal] doesn't exist";
2697 $CPAN::Frontend->myprint(qq{
2698 System call "$system"
2699 returned status $estatus (wstat $wstatus)$size
2702 return if $CPAN::Signal;
2703 } # wget,lynx,ncftpget,ncftp
2708 my($self,$host_seq,$file,$aslocal) = @_;
2711 my($aslocal_dir) = File::Basename::dirname($aslocal);
2712 File::Path::mkpath($aslocal_dir);
2713 my $ftpbin = $CPAN::Config->{ftp};
2714 HOSTHARDEST: for $i (@$host_seq) {
2715 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2716 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2719 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2720 $url .= "/" unless substr($url,-1) eq "/";
2722 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2723 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2726 my($host,$dir,$getfile) = ($1,$2,$3);
2728 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2729 $ctime,$blksize,$blocks) = stat($aslocal);
2730 $timestamp = $mtime ||= 0;
2731 my($netrc) = CPAN::FTP::netrc->new;
2732 my($netrcfile) = $netrc->netrc;
2733 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2734 my $targetfile = File::Basename::basename($aslocal);
2740 map("cd $_", split /\//, $dir), # RFC 1738
2742 "get $getfile $targetfile",
2746 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2747 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2748 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2750 $netrc->contains($host))) if $CPAN::DEBUG;
2751 if ($netrc->protected) {
2752 $CPAN::Frontend->myprint(qq{
2753 Trying with external ftp to get
2755 As this requires some features that are not thoroughly tested, we\'re
2756 not sure, that we get it right....
2760 $self->talk_ftp("$ftpbin$verbose $host",
2762 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2763 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2765 if ($mtime > $timestamp) {
2766 $CPAN::Frontend->myprint("GOT $aslocal\n");
2770 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2772 return if $CPAN::Signal;
2774 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2775 qq{correctly protected.\n});
2778 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2779 nor does it have a default entry\n");
2782 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2783 # then and login manually to host, using e-mail as
2785 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2789 "user anonymous $Config::Config{'cf_email'}"
2791 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2792 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2793 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2795 if ($mtime > $timestamp) {
2796 $CPAN::Frontend->myprint("GOT $aslocal\n");
2800 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2802 return if $CPAN::Signal;
2803 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2809 my($self,$command,@dialog) = @_;
2810 my $fh = FileHandle->new;
2811 $fh->open("|$command") or die "Couldn't open ftp: $!";
2812 foreach (@dialog) { $fh->print("$_\n") }
2813 $fh->close; # Wait for process to complete
2815 my $estatus = $wstatus >> 8;
2816 $CPAN::Frontend->myprint(qq{
2817 Subprocess "|$command"
2818 returned status $estatus (wstat $wstatus)
2822 # find2perl needs modularization, too, all the following is stolen
2826 my($self,$name) = @_;
2827 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2828 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2830 my($perms,%user,%group);
2834 $blocks = int(($blocks + 1) / 2);
2837 $blocks = int(($sizemm + 1023) / 1024);
2840 if (-f _) { $perms = '-'; }
2841 elsif (-d _) { $perms = 'd'; }
2842 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2843 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2844 elsif (-p _) { $perms = 'p'; }
2845 elsif (-S _) { $perms = 's'; }
2846 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2848 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2849 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2850 my $tmpmode = $mode;
2851 my $tmp = $rwx[$tmpmode & 7];
2853 $tmp = $rwx[$tmpmode & 7] . $tmp;
2855 $tmp = $rwx[$tmpmode & 7] . $tmp;
2856 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2857 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2858 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2861 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2862 my $group = $group{$gid} || $gid;
2864 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2866 my($moname) = $moname[$mon];
2867 if (-M _ > 365.25 / 2) {
2868 $timeyear = $year + 1900;
2871 $timeyear = sprintf("%02d:%02d", $hour, $min);
2874 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2888 package CPAN::FTP::netrc;
2892 my $file = File::Spec->catfile($ENV{HOME},".netrc");
2894 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2895 $atime,$mtime,$ctime,$blksize,$blocks)
2900 my($fh,@machines,$hasdefault);
2902 $fh = FileHandle->new or die "Could not create a filehandle";
2904 if($fh->open($file)){
2905 $protected = ($mode & 077) == 0;
2907 NETRC: while (<$fh>) {
2908 my(@tokens) = split " ", $_;
2909 TOKEN: while (@tokens) {
2910 my($t) = shift @tokens;
2911 if ($t eq "default"){
2915 last TOKEN if $t eq "macdef";
2916 if ($t eq "machine") {
2917 push @machines, shift @tokens;
2922 $file = $hasdefault = $protected = "";
2926 'mach' => [@machines],
2928 'hasdefault' => $hasdefault,
2929 'protected' => $protected,
2933 # CPAN::FTP::hasdefault;
2934 sub hasdefault { shift->{'hasdefault'} }
2935 sub netrc { shift->{'netrc'} }
2936 sub protected { shift->{'protected'} }
2938 my($self,$mach) = @_;
2939 for ( @{$self->{'mach'}} ) {
2940 return 1 if $_ eq $mach;
2945 package CPAN::Complete;
2948 my($text, $line, $start, $end) = @_;
2949 my(@perlret) = cpl($text, $line, $start);
2950 # find longest common match. Can anybody show me how to peruse
2951 # T::R::Gnu to have this done automatically? Seems expensive.
2952 return () unless @perlret;
2953 my($newtext) = $text;
2954 for (my $i = length($text)+1;;$i++) {
2955 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2956 my $try = substr($perlret[0],0,$i);
2957 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2958 # warn "try[$try]tries[@tries]";
2959 if (@tries == @perlret) {
2965 ($newtext,@perlret);
2968 #-> sub CPAN::Complete::cpl ;
2970 my($word,$line,$pos) = @_;
2974 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2976 if ($line =~ s/^(force\s*)//) {
2981 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
2982 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2984 } elsif ($line =~ /^(a|ls)\s/) {
2985 @return = cplx('CPAN::Author',uc($word));
2986 } elsif ($line =~ /^b\s/) {
2987 CPAN::Shell->local_bundles;
2988 @return = cplx('CPAN::Bundle',$word);
2989 } elsif ($line =~ /^d\s/) {
2990 @return = cplx('CPAN::Distribution',$word);
2991 } elsif ($line =~ m/^(
2992 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2994 if ($word =~ /^Bundle::/) {
2995 CPAN::Shell->local_bundles;
2997 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2998 } elsif ($line =~ /^i\s/) {
2999 @return = cpl_any($word);
3000 } elsif ($line =~ /^reload\s/) {
3001 @return = cpl_reload($word,$line,$pos);
3002 } elsif ($line =~ /^o\s/) {
3003 @return = cpl_option($word,$line,$pos);
3004 } elsif ($line =~ m/^\S+\s/ ) {
3005 # fallback for future commands and what we have forgotten above
3006 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3013 #-> sub CPAN::Complete::cplx ;
3015 my($class, $word) = @_;
3016 # I believed for many years that this was sorted, today I
3017 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3018 # make it sorted again. Maybe sort was dropped when GNU-readline
3019 # support came in? The RCS file is difficult to read on that:-(
3020 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3023 #-> sub CPAN::Complete::cpl_any ;
3027 cplx('CPAN::Author',$word),
3028 cplx('CPAN::Bundle',$word),
3029 cplx('CPAN::Distribution',$word),
3030 cplx('CPAN::Module',$word),
3034 #-> sub CPAN::Complete::cpl_reload ;
3036 my($word,$line,$pos) = @_;
3038 my(@words) = split " ", $line;
3039 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3040 my(@ok) = qw(cpan index);
3041 return @ok if @words == 1;
3042 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3045 #-> sub CPAN::Complete::cpl_option ;
3047 my($word,$line,$pos) = @_;
3049 my(@words) = split " ", $line;
3050 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3051 my(@ok) = qw(conf debug);
3052 return @ok if @words == 1;
3053 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3055 } elsif ($words[1] eq 'index') {
3057 } elsif ($words[1] eq 'conf') {
3058 return CPAN::Config::cpl(@_);
3059 } elsif ($words[1] eq 'debug') {
3060 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
3064 package CPAN::Index;
3066 #-> sub CPAN::Index::force_reload ;
3069 $CPAN::Index::LAST_TIME = 0;
3073 #-> sub CPAN::Index::reload ;
3075 my($cl,$force) = @_;
3078 # XXX check if a newer one is available. (We currently read it
3079 # from time to time)
3080 for ($CPAN::Config->{index_expire}) {
3081 $_ = 0.001 unless $_ && $_ > 0.001;
3083 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3084 # debug here when CPAN doesn't seem to read the Metadata
3086 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3088 unless ($CPAN::META->{PROTOCOL}) {
3089 $cl->read_metadata_cache;
3090 $CPAN::META->{PROTOCOL} ||= "1.0";
3092 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3093 # warn "Setting last_time to 0";
3094 $LAST_TIME = 0; # No warning necessary
3096 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3099 # IFF we are developing, it helps to wipe out the memory
3100 # between reloads, otherwise it is not what a user expects.
3101 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3102 $CPAN::META = CPAN->new;
3106 local $LAST_TIME = $time;
3107 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3109 my $needshort = $^O eq "dos";
3111 $cl->rd_authindex($cl
3113 "authors/01mailrc.txt.gz",
3115 File::Spec->catfile('authors', '01mailrc.gz') :
3116 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3119 $debug = "timing reading 01[".($t2 - $time)."]";
3121 return if $CPAN::Signal; # this is sometimes lengthy
3122 $cl->rd_modpacks($cl
3124 "modules/02packages.details.txt.gz",
3126 File::Spec->catfile('modules', '02packag.gz') :
3127 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3130 $debug .= "02[".($t2 - $time)."]";
3132 return if $CPAN::Signal; # this is sometimes lengthy
3135 "modules/03modlist.data.gz",
3137 File::Spec->catfile('modules', '03mlist.gz') :
3138 File::Spec->catfile('modules', '03modlist.data.gz'),
3140 $cl->write_metadata_cache;
3142 $debug .= "03[".($t2 - $time)."]";
3144 CPAN->debug($debug) if $CPAN::DEBUG;
3147 $CPAN::META->{PROTOCOL} = PROTOCOL;
3150 #-> sub CPAN::Index::reload_x ;
3152 my($cl,$wanted,$localname,$force) = @_;
3153 $force |= 2; # means we're dealing with an index here
3154 CPAN::Config->load; # we should guarantee loading wherever we rely
3156 $localname ||= $wanted;
3157 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3161 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3164 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3165 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3166 qq{day$s. I\'ll use that.});
3169 $force |= 1; # means we're quite serious about it.
3171 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3174 #-> sub CPAN::Index::rd_authindex ;
3176 my($cl, $index_target) = @_;
3178 return unless defined $index_target;
3179 $CPAN::Frontend->myprint("Going to read $index_target\n");
3181 tie *FH, CPAN::Tarzip, $index_target;
3183 push @lines, split /\012/ while <FH>;
3185 my($userid,$fullname,$email) =
3186 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3187 next unless $userid && $fullname && $email;
3189 # instantiate an author object
3190 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3191 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3192 return if $CPAN::Signal;
3197 my($self,$dist) = @_;
3198 $dist = $self->{'id'} unless defined $dist;
3199 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3203 #-> sub CPAN::Index::rd_modpacks ;
3205 my($self, $index_target) = @_;
3207 return unless defined $index_target;
3208 $CPAN::Frontend->myprint("Going to read $index_target\n");
3209 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3211 while ($_ = $fh->READLINE) {
3213 my @ls = map {"$_\n"} split /\n/, $_;
3214 unshift @ls, "\n" x length($1) if /^(\n+)/;
3218 my($line_count,$last_updated);
3220 my $shift = shift(@lines);
3221 last if $shift =~ /^\s*$/;
3222 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3223 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3225 if (not defined $line_count) {
3227 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3228 Please check the validity of the index file by comparing it to more
3229 than one CPAN mirror. I'll continue but problems seem likely to
3234 } elsif ($line_count != scalar @lines) {
3236 warn sprintf qq{Warning: Your %s
3237 contains a Line-Count header of %d but I see %d lines there. Please
3238 check the validity of the index file by comparing it to more than one
3239 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3240 $index_target, $line_count, scalar(@lines);
3243 if (not defined $last_updated) {
3245 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3246 Please check the validity of the index file by comparing it to more
3247 than one CPAN mirror. I'll continue but problems seem likely to
3255 ->myprint(sprintf qq{ Database was generated on %s\n},
3257 $DATE_OF_02 = $last_updated;
3259 if ($CPAN::META->has_inst(HTTP::Date)) {
3261 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3266 qq{Warning: This index file is %d days old.
3267 Please check the host you chose as your CPAN mirror for staleness.
3268 I'll continue but problems seem likely to happen.\a\n},
3273 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3278 # A necessity since we have metadata_cache: delete what isn't
3280 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3281 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3285 # before 1.56 we split into 3 and discarded the rest. From
3286 # 1.57 we assign remaining text to $comment thus allowing to
3287 # influence isa_perl
3288 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3289 my($bundle,$id,$userid);
3291 if ($mod eq 'CPAN' &&
3293 CPAN::Queue->exists('Bundle::CPAN') ||
3294 CPAN::Queue->exists('CPAN')
3298 if ($version > $CPAN::VERSION){
3299 $CPAN::Frontend->myprint(qq{
3300 There's a new CPAN.pm version (v$version) available!
3301 [Current version is v$CPAN::VERSION]
3302 You might want to try
3303 install Bundle::CPAN
3305 without quitting the current session. It should be a seamless upgrade
3306 while we are running...
3309 $CPAN::Frontend->myprint(qq{\n});
3311 last if $CPAN::Signal;
3312 } elsif ($mod =~ /^Bundle::(.*)/) {
3317 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3318 # Let's make it a module too, because bundles have so much
3319 # in common with modules.
3321 # Changed in 1.57_63: seems like memory bloat now without
3322 # any value, so commented out
3324 # $CPAN::META->instance('CPAN::Module',$mod);
3328 # instantiate a module object
3329 $id = $CPAN::META->instance('CPAN::Module',$mod);
3333 if ($id->cpan_file ne $dist){ # update only if file is
3334 # different. CPAN prohibits same
3335 # name with different version
3336 $userid = $id->userid || $self->userid($dist);
3338 'CPAN_USERID' => $userid,
3339 'CPAN_VERSION' => $version,
3340 'CPAN_FILE' => $dist,
3344 # instantiate a distribution object
3345 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3346 # we do not need CONTAINSMODS unless we do something with
3347 # this dist, so we better produce it on demand.
3349 ## my $obj = $CPAN::META->instance(
3350 ## 'CPAN::Distribution' => $dist
3352 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3354 $CPAN::META->instance(
3355 'CPAN::Distribution' => $dist
3357 'CPAN_USERID' => $userid,
3358 'CPAN_COMMENT' => $comment,
3362 for my $name ($mod,$dist) {
3363 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3364 $exists{$name} = undef;
3367 return if $CPAN::Signal;
3371 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3372 for my $o ($CPAN::META->all_objects($class)) {
3373 next if exists $exists{$o->{ID}};
3374 $CPAN::META->delete($class,$o->{ID});
3375 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3382 #-> sub CPAN::Index::rd_modlist ;
3384 my($cl,$index_target) = @_;
3385 return unless defined $index_target;
3386 $CPAN::Frontend->myprint("Going to read $index_target\n");
3387 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3390 while ($_ = $fh->READLINE) {
3392 my @ls = map {"$_\n"} split /\n/, $_;
3393 unshift @ls, "\n" x length($1) if /^(\n+)/;
3397 my $shift = shift(@eval);
3398 if ($shift =~ /^Date:\s+(.*)/){
3399 return if $DATE_OF_03 eq $1;
3402 last if $shift =~ /^\s*$/;
3405 push @eval, q{CPAN::Modulelist->data;};
3407 my($comp) = Safe->new("CPAN::Safe1");
3408 my($eval) = join("", @eval);
3409 my $ret = $comp->reval($eval);
3410 Carp::confess($@) if $@;
3411 return if $CPAN::Signal;
3413 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3414 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3415 $obj->set(%{$ret->{$_}});
3416 return if $CPAN::Signal;
3420 #-> sub CPAN::Index::write_metadata_cache ;
3421 sub write_metadata_cache {
3423 return unless $CPAN::Config->{'cache_metadata'};
3424 return unless $CPAN::META->has_usable("Storable");
3426 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3427 CPAN::Distribution)) {
3428 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3430 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3431 $cache->{last_time} = $LAST_TIME;
3432 $cache->{DATE_OF_02} = $DATE_OF_02;
3433 $cache->{PROTOCOL} = PROTOCOL;
3434 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3435 eval { Storable::nstore($cache, $metadata_file) };
3436 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3439 #-> sub CPAN::Index::read_metadata_cache ;
3440 sub read_metadata_cache {
3442 return unless $CPAN::Config->{'cache_metadata'};
3443 return unless $CPAN::META->has_usable("Storable");
3444 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3445 return unless -r $metadata_file and -f $metadata_file;
3446 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3448 eval { $cache = Storable::retrieve($metadata_file) };
3449 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3450 if (!$cache || ref $cache ne 'HASH'){
3454 if (exists $cache->{PROTOCOL}) {
3455 if (PROTOCOL > $cache->{PROTOCOL}) {
3456 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3457 "with protocol v%s, requiring v%s\n",
3464 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3465 "with protocol v1.0\n");
3470 while(my($class,$v) = each %$cache) {
3471 next unless $class =~ /^CPAN::/;
3472 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3473 while (my($id,$ro) = each %$v) {
3474 $CPAN::META->{readwrite}{$class}{$id} ||=
3475 $class->new(ID=>$id, RO=>$ro);
3480 unless ($clcnt) { # sanity check
3481 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3484 if ($idcnt < 1000) {
3485 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3486 "in $metadata_file\n");
3489 $CPAN::META->{PROTOCOL} ||=
3490 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3491 # does initialize to some protocol
3492 $LAST_TIME = $cache->{last_time};
3493 $DATE_OF_02 = $cache->{DATE_OF_02};
3494 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3495 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3499 package CPAN::InfoObj;
3504 $self->{RO}{CPAN_USERID}
3507 sub id { shift->{ID}; }
3509 #-> sub CPAN::InfoObj::new ;
3511 my $this = bless {}, shift;
3516 # The set method may only be used by code that reads index data or
3517 # otherwise "objective" data from the outside world. All session
3518 # related material may do anything else with instance variables but
3519 # must not touch the hash under the RO attribute. The reason is that
3520 # the RO hash gets written to Metadata file and is thus persistent.
3522 #-> sub CPAN::InfoObj::set ;
3524 my($self,%att) = @_;
3525 my $class = ref $self;
3527 # This must be ||=, not ||, because only if we write an empty
3528 # reference, only then the set method will write into the readonly
3529 # area. But for Distributions that spring into existence, maybe
3530 # because of a typo, we do not like it that they are written into
3531 # the readonly area and made permanent (at least for a while) and
3532 # that is why we do not "allow" other places to call ->set.
3533 unless ($self->id) {
3534 CPAN->debug("Bug? Empty ID, rejecting");
3537 my $ro = $self->{RO} =
3538 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3540 while (my($k,$v) = each %att) {
3545 #-> sub CPAN::InfoObj::as_glimpse ;
3549 my $class = ref($self);
3550 $class =~ s/^CPAN:://;
3551 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3555 #-> sub CPAN::InfoObj::as_string ;
3559 my $class = ref($self);
3560 $class =~ s/^CPAN:://;
3561 push @m, $class, " id = $self->{ID}\n";
3562 for (sort keys %{$self->{RO}}) {
3563 # next if m/^(ID|RO)$/;
3565 if ($_ eq "CPAN_USERID") {
3566 $extra .= " (".$self->author;
3567 my $email; # old perls!
3568 if ($email = $CPAN::META->instance("CPAN::Author",
3571 $extra .= " <$email>";
3573 $extra .= " <no email>";
3576 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3577 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3580 next unless defined $self->{RO}{$_};
3581 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3583 for (sort keys %$self) {
3584 next if m/^(ID|RO)$/;
3585 if (ref($self->{$_}) eq "ARRAY") {
3586 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3587 } elsif (ref($self->{$_}) eq "HASH") {
3591 join(" ",keys %{$self->{$_}}),
3594 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3600 #-> sub CPAN::InfoObj::author ;
3603 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3606 #-> sub CPAN::InfoObj::dump ;
3609 require Data::Dumper;
3610 print Data::Dumper::Dumper($self);
3613 package CPAN::Author;
3615 #-> sub CPAN::Author::id
3618 my $id = $self->{ID};
3619 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3623 #-> sub CPAN::Author::as_glimpse ;
3627 my $class = ref($self);
3628 $class =~ s/^CPAN:://;
3629 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3637 #-> sub CPAN::Author::fullname ;
3639 shift->{RO}{FULLNAME};
3643 #-> sub CPAN::Author::email ;
3644 sub email { shift->{RO}{EMAIL}; }
3646 #-> sub CPAN::Author::ls ;
3651 # adapted from CPAN::Distribution::verifyMD5 ;
3652 my(@csf); # chksumfile
3653 @csf = $self->id =~ /(.)(.)(.*)/;
3654 $csf[1] = join "", @csf[0,1];
3655 $csf[2] = join "", @csf[1,2];
3657 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3658 unless (grep {$_->[2] eq $csf[1]} @dl) {
3659 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3662 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3663 unless (grep {$_->[2] eq $csf[2]} @dl) {
3664 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3667 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3668 $CPAN::Frontend->myprint(join "", map {
3669 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3670 } sort { $a->[2] cmp $b->[2] } @dl);
3673 # returns an array of arrays, the latter contain (size,mtime,filename)
3674 #-> sub CPAN::Author::dir_listing ;
3677 my $chksumfile = shift;
3678 my $recursive = shift;
3680 File::Spec->catfile($CPAN::Config->{keep_source_where},
3681 "authors", "id", @$chksumfile);
3683 # connect "force" argument with "index_expire".
3685 if (my @stat = stat $lc_want) {
3686 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3688 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3691 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3692 $chksumfile->[-1] .= ".gz";
3693 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3696 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3697 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3703 # adapted from CPAN::Distribution::MD5_check_file ;
3704 my $fh = FileHandle->new;
3706 if (open $fh, $lc_file){
3709 $eval =~ s/\015?\012/\n/g;
3711 my($comp) = Safe->new();
3712 $cksum = $comp->reval($eval);
3714 rename $lc_file, "$lc_file.bad";
3715 Carp::confess($@) if $@;
3718 Carp::carp "Could not open $lc_file for reading";
3721 for $f (sort keys %$cksum) {
3722 if (exists $cksum->{$f}{isdir}) {
3724 my(@dir) = @$chksumfile;
3726 push @dir, $f, "CHECKSUMS";
3728 [$_->[0], $_->[1], "$f/$_->[2]"]
3729 } $self->dir_listing(\@dir,1);
3731 push @result, [ 0, "-", $f ];
3735 ($cksum->{$f}{"size"}||0),
3736 $cksum->{$f}{"mtime"}||"---",
3744 package CPAN::Distribution;
3747 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3751 delete $self->{later};
3754 # CPAN::Distribution::normalize
3757 $s = $self->id unless defined $s;
3761 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3763 return $s if $s =~ m:^N/A|^Contact Author: ;
3764 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3765 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3766 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3771 #-> sub CPAN::Distribution::color_cmd_tmps ;
3772 sub color_cmd_tmps {
3774 my($depth) = shift || 0;
3775 my($color) = shift || 0;
3776 my($ancestors) = shift || [];
3777 # a distribution needs to recurse into its prereq_pms
3779 return if exists $self->{incommandcolor}
3780 && $self->{incommandcolor}==$color;
3782 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3784 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3785 my $prereq_pm = $self->prereq_pm;
3786 if (defined $prereq_pm) {
3787 for my $pre (keys %$prereq_pm) {
3788 my $premo = CPAN::Shell->expand("Module",$pre);
3789 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3793 delete $self->{sponsored_mods};
3794 delete $self->{badtestcnt};
3796 $self->{incommandcolor} = $color;
3799 #-> sub CPAN::Distribution::as_string ;
3802 $self->containsmods;
3803 $self->SUPER::as_string(@_);
3806 #-> sub CPAN::Distribution::containsmods ;
3809 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3810 my $dist_id = $self->{ID};
3811 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3812 my $mod_file = $mod->cpan_file or next;
3813 my $mod_id = $mod->{ID} or next;
3814 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3816 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3818 keys %{$self->{CONTAINSMODS}};
3821 #-> sub CPAN::Distribution::uptodate ;
3825 foreach $c ($self->containsmods) {
3826 my $obj = CPAN::Shell->expandany($c);
3827 return 0 unless $obj->uptodate;
3832 #-> sub CPAN::Distribution::called_for ;
3835 $self->{CALLED_FOR} = $id if defined $id;
3836 return $self->{CALLED_FOR};
3839 #-> sub CPAN::Distribution::safe_chdir ;
3841 my($self,$todir) = @_;
3842 # we die if we cannot chdir and we are debuggable
3843 Carp::confess("safe_chdir called without todir argument")
3844 unless defined $todir and length $todir;
3846 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3849 my $cwd = CPAN::anycwd();
3850 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3851 qq{to todir[$todir]: $!});
3855 #-> sub CPAN::Distribution::get ;
3860 exists $self->{'build_dir'} and push @e,
3861 "Is already unwrapped into directory $self->{'build_dir'}";
3862 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
3864 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3867 # Get the file on local disk
3872 File::Spec->catfile(
3873 $CPAN::Config->{keep_source_where},
3876 split(/\//,$self->id)
3879 $self->debug("Doing localize") if $CPAN::DEBUG;
3880 unless ($local_file =
3881 CPAN::FTP->localize("authors/id/$self->{ID}",
3884 if ($CPAN::Index::DATE_OF_02) {
3885 $note = "Note: Current database in memory was generated ".
3886 "on $CPAN::Index::DATE_OF_02\n";
3888 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3890 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3891 $self->{localfile} = $local_file;
3892 return if $CPAN::Signal;
3897 if ($CPAN::META->has_inst("Digest::MD5")) {
3898 $self->debug("Digest::MD5 is installed, verifying");
3901 $self->debug("Digest::MD5 is NOT installed");
3903 return if $CPAN::Signal;
3906 # Create a clean room and go there
3908 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3909 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3910 $self->safe_chdir($builddir);
3911 $self->debug("Removing tmp") if $CPAN::DEBUG;
3912 File::Path::rmtree("tmp");
3913 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3915 $self->safe_chdir($sub_wd);
3918 $self->safe_chdir("tmp");
3923 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3924 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3925 $self->untar_me($local_file);
3926 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3927 $self->unzip_me($local_file);
3928 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3929 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3930 $self->pm2dir_me($local_file);
3932 $self->{archived} = "NO";
3933 $self->safe_chdir($sub_wd);
3937 # we are still in the tmp directory!
3938 # Let's check if the package has its own directory.
3939 my $dh = DirHandle->new(File::Spec->curdir)
3940 or Carp::croak("Couldn't opendir .: $!");
3941 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3943 my ($distdir,$packagedir);
3944 if (@readdir == 1 && -d $readdir[0]) {
3945 $distdir = $readdir[0];
3946 $packagedir = File::Spec->catdir($builddir,$distdir);
3947 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3949 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3951 File::Path::rmtree($packagedir);
3952 File::Copy::move($distdir,$packagedir) or
3953 Carp::confess("Couldn't move $distdir to $packagedir: $!");
3954 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3961 my $userid = $self->cpan_userid;
3963 CPAN->debug("no userid? self[$self]");
3966 my $pragmatic_dir = $userid . '000';
3967 $pragmatic_dir =~ s/\W_//g;
3968 $pragmatic_dir++ while -d "../$pragmatic_dir";
3969 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3970 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3971 File::Path::mkpath($packagedir);
3973 for $f (@readdir) { # is already without "." and ".."
3974 my $to = File::Spec->catdir($packagedir,$f);
3975 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
3979 $self->safe_chdir($sub_wd);
3983 $self->{'build_dir'} = $packagedir;
3984 $self->safe_chdir($builddir);
3985 File::Path::rmtree("tmp");
3987 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3988 my($mpl_exists) = -f $mpl;
3989 unless ($mpl_exists) {
3990 # NFS has been reported to have racing problems after the
3991 # renaming of a directory in some environments.
3994 my $mpldh = DirHandle->new($packagedir)
3995 or Carp::croak("Couldn't opendir $packagedir: $!");
3996 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3999 unless ($mpl_exists) {
4000 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4004 my($configure) = File::Spec->catfile($packagedir,"Configure");
4005 if (-f $configure) {
4006 # do we have anything to do?
4007 $self->{'configure'} = $configure;
4008 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4009 $CPAN::Frontend->myprint(qq{
4010 Package comes with a Makefile and without a Makefile.PL.
4011 We\'ll try to build it with that Makefile then.
4013 $self->{writemakefile} = "YES";
4016 my $cf = $self->called_for || "unknown";
4021 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4022 $cf = "unknown" unless length($cf);
4023 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4024 (The test -f "$mpl" returned false.)
4025 Writing one on our own (setting NAME to $cf)\a\n});
4026 $self->{had_no_makefile_pl}++;
4029 # Writing our own Makefile.PL
4031 my $fh = FileHandle->new;
4033 or Carp::croak("Could not open >$mpl: $!");
4035 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4036 # because there was no Makefile.PL supplied.
4037 # Autogenerated on: }.scalar localtime().qq{
4039 use ExtUtils::MakeMaker;
4040 WriteMakefile(NAME => q[$cf]);
4050 # CPAN::Distribution::untar_me ;
4052 my($self,$local_file) = @_;
4053 $self->{archived} = "tar";
4054 if (CPAN::Tarzip->untar($local_file)) {
4055 $self->{unwrapped} = "YES";
4057 $self->{unwrapped} = "NO";
4061 # CPAN::Distribution::unzip_me ;
4063 my($self,$local_file) = @_;
4064 $self->{archived} = "zip";
4065 if (CPAN::Tarzip->unzip($local_file)) {
4066 $self->{unwrapped} = "YES";
4068 $self->{unwrapped} = "NO";
4074 my($self,$local_file) = @_;
4075 $self->{archived} = "pm";
4076 my $to = File::Basename::basename($local_file);
4077 $to =~ s/\.(gz|Z)(?!\n)\Z//;
4078 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4079 $self->{unwrapped} = "YES";
4081 $self->{unwrapped} = "NO";
4085 #-> sub CPAN::Distribution::new ;
4087 my($class,%att) = @_;
4089 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4091 my $this = { %att };
4092 return bless $this, $class;
4095 #-> sub CPAN::Distribution::look ;
4099 if ($^O eq 'MacOS') {
4100 $self->Mac::BuildTools::look;
4104 if ( $CPAN::Config->{'shell'} ) {
4105 $CPAN::Frontend->myprint(qq{
4106 Trying to open a subshell in the build directory...
4109 $CPAN::Frontend->myprint(qq{
4110 Your configuration does not define a value for subshells.
4111 Please define it with "o conf shell <your shell>"
4115 my $dist = $self->id;
4117 unless ($dir = $self->dir) {
4120 unless ($dir ||= $self->dir) {
4121 $CPAN::Frontend->mywarn(qq{
4122 Could not determine which directory to use for looking at $dist.
4126 my $pwd = CPAN::anycwd();
4127 $self->safe_chdir($dir);
4128 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4129 unless (system($CPAN::Config->{'shell'}) == 0) {
4131 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4133 $self->safe_chdir($pwd);
4136 # CPAN::Distribution::cvs_import ;
4140 my $dir = $self->dir;
4142 my $package = $self->called_for;
4143 my $module = $CPAN::META->instance('CPAN::Module', $package);
4144 my $version = $module->cpan_version;
4146 my $userid = $self->cpan_userid;
4148 my $cvs_dir = (split /\//, $dir)[-1];
4149 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4151 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4153 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4154 if ($cvs_site_perl) {
4155 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4157 my $cvs_log = qq{"imported $package $version sources"};
4158 $version =~ s/\./_/g;
4159 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4160 "$cvs_dir", $userid, "v$version");
4162 my $pwd = CPAN::anycwd();
4163 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4165 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4167 $CPAN::Frontend->myprint(qq{@cmd\n});
4168 system(@cmd) == 0 or
4169 $CPAN::Frontend->mydie("cvs import failed");
4170 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4173 #-> sub CPAN::Distribution::readme ;
4176 my($dist) = $self->id;
4177 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4178 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4181 File::Spec->catfile(
4182 $CPAN::Config->{keep_source_where},
4185 split(/\//,"$sans.readme"),
4187 $self->debug("Doing localize") if $CPAN::DEBUG;
4188 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4190 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4192 if ($^O eq 'MacOS') {
4193 Mac::BuildTools::launch_file($local_file);
4197 my $fh_pager = FileHandle->new;
4198 local($SIG{PIPE}) = "IGNORE";
4199 $fh_pager->open("|$CPAN::Config->{'pager'}")
4200 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4201 my $fh_readme = FileHandle->new;
4202 $fh_readme->open($local_file)
4203 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4204 $CPAN::Frontend->myprint(qq{
4207 with pager "$CPAN::Config->{'pager'}"
4210 $fh_pager->print(<$fh_readme>);
4213 #-> sub CPAN::Distribution::verifyMD5 ;
4218 $self->{MD5_STATUS} ||= "";
4219 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4220 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4222 my($lc_want,$lc_file,@local,$basename);
4223 @local = split(/\//,$self->id);
4225 push @local, "CHECKSUMS";
4227 File::Spec->catfile($CPAN::Config->{keep_source_where},
4228 "authors", "id", @local);
4233 $self->MD5_check_file($lc_want)
4235 return $self->{MD5_STATUS} = "OK";
4237 $lc_file = CPAN::FTP->localize("authors/id/@local",
4240 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4241 $local[-1] .= ".gz";
4242 $lc_file = CPAN::FTP->localize("authors/id/@local",
4245 $lc_file =~ s/\.gz(?!\n)\Z//;
4246 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4251 $self->MD5_check_file($lc_file);
4254 #-> sub CPAN::Distribution::MD5_check_file ;
4255 sub MD5_check_file {
4256 my($self,$chk_file) = @_;
4257 my($cksum,$file,$basename);
4258 $file = $self->{localfile};
4259 $basename = File::Basename::basename($file);
4260 my $fh = FileHandle->new;
4261 if (open $fh, $chk_file){
4264 $eval =~ s/\015?\012/\n/g;
4266 my($comp) = Safe->new();
4267 $cksum = $comp->reval($eval);
4269 rename $chk_file, "$chk_file.bad";
4270 Carp::confess($@) if $@;
4273 Carp::carp "Could not open $chk_file for reading";
4276 if (exists $cksum->{$basename}{md5}) {
4277 $self->debug("Found checksum for $basename:" .
4278 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4282 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4284 $fh = CPAN::Tarzip->TIEHANDLE($file);
4287 # had to inline it, when I tied it, the tiedness got lost on
4288 # the call to eq_MD5. (Jan 1998)
4289 my $md5 = Digest::MD5->new;
4292 while ($fh->READ($ref, 4096) > 0){
4295 my $hexdigest = $md5->hexdigest;
4296 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4300 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4301 return $self->{MD5_STATUS} = "OK";
4303 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4304 qq{distribution file. }.
4305 qq{Please investigate.\n\n}.
4307 $CPAN::META->instance(
4312 my $wrap = qq{I\'d recommend removing $file. Its MD5
4313 checksum is incorrect. Maybe you have configured your 'urllist' with
4314 a bad URL. Please check this array with 'o conf urllist', and
4317 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4319 # former versions just returned here but this seems a
4320 # serious threat that deserves a die
4322 # $CPAN::Frontend->myprint("\n\n");
4326 # close $fh if fileno($fh);
4328 $self->{MD5_STATUS} ||= "";
4329 if ($self->{MD5_STATUS} eq "NIL") {
4330 $CPAN::Frontend->mywarn(qq{
4331 Warning: No md5 checksum for $basename in $chk_file.
4333 The cause for this may be that the file is very new and the checksum
4334 has not yet been calculated, but it may also be that something is
4335 going awry right now.
4337 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4338 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4340 $self->{MD5_STATUS} = "NIL";
4345 #-> sub CPAN::Distribution::eq_MD5 ;
4347 my($self,$fh,$expectMD5) = @_;
4348 my $md5 = Digest::MD5->new;
4350 while (read($fh, $data, 4096)){
4353 # $md5->addfile($fh);
4354 my $hexdigest = $md5->hexdigest;
4355 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4356 $hexdigest eq $expectMD5;
4359 #-> sub CPAN::Distribution::force ;
4361 # Both modules and distributions know if "force" is in effect by
4362 # autoinspection, not by inspecting a global variable. One of the
4363 # reason why this was chosen to work that way was the treatment of
4364 # dependencies. They should not autpomatically inherit the force
4365 # status. But this has the downside that ^C and die() will return to
4366 # the prompt but will not be able to reset the force_update
4367 # attributes. We try to correct for it currently in the read_metadata
4368 # routine, and immediately before we check for a Signal. I hope this
4369 # works out in one of v1.57_53ff
4372 my($self, $method) = @_;
4374 MD5_STATUS archived build_dir localfile make install unwrapped
4377 delete $self->{$att};
4379 if ($method && $method eq "install") {
4380 $self->{"force_update"}++; # name should probably have been force_install
4384 #-> sub CPAN::Distribution::unforce ;
4387 delete $self->{'force_update'};
4390 #-> sub CPAN::Distribution::isa_perl ;
4393 my $file = File::Basename::basename($self->id);
4394 if ($file =~ m{ ^ perl
4407 } elsif ($self->cpan_comment
4409 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4414 #-> sub CPAN::Distribution::perl ;
4417 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4418 my $pwd = CPAN::anycwd();
4419 my $candidate = File::Spec->catfile($pwd,$^X);
4420 $perl ||= $candidate if MM->maybe_command($candidate);
4422 my ($component,$perl_name);
4423 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4424 PATH_COMPONENT: foreach $component (File::Spec->path(),
4425 $Config::Config{'binexp'}) {
4426 next unless defined($component) && $component;
4427 my($abs) = File::Spec->catfile($component,$perl_name);
4428 if (MM->maybe_command($abs)) {
4438 #-> sub CPAN::Distribution::make ;
4441 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4442 # Emergency brake if they said install Pippi and get newest perl
4443 if ($self->isa_perl) {
4445 $self->called_for ne $self->id &&
4446 ! $self->{force_update}
4448 # if we die here, we break bundles
4449 $CPAN::Frontend->mywarn(sprintf qq{
4450 The most recent version "%s" of the module "%s"
4451 comes with the current version of perl (%s).
4452 I\'ll build that only if you ask for something like
4457 $CPAN::META->instance(
4471 $self->{archived} eq "NO" and push @e,
4472 "Is neither a tar nor a zip archive.";
4474 $self->{unwrapped} eq "NO" and push @e,
4475 "had problems unarchiving. Please build manually";
4477 exists $self->{writemakefile} &&
4478 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4479 $1 || "Had some problem writing Makefile";
4481 defined $self->{'make'} and push @e,
4482 "Has already been processed within this session";
4484 exists $self->{later} and length($self->{later}) and
4485 push @e, $self->{later};
4487 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4489 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4490 my $builddir = $self->dir;
4491 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4492 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4494 if ($^O eq 'MacOS') {
4495 Mac::BuildTools::make($self);
4500 if ($self->{'configure'}) {
4501 $system = $self->{'configure'};
4503 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4505 # This needs a handler that can be turned on or off:
4506 # $switch = "-MExtUtils::MakeMaker ".
4507 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4509 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4511 unless (exists $self->{writemakefile}) {
4512 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4515 if ($CPAN::Config->{inactivity_timeout}) {
4517 alarm $CPAN::Config->{inactivity_timeout};
4518 local $SIG{CHLD}; # = sub { wait };
4519 if (defined($pid = fork)) {
4524 # note, this exec isn't necessary if
4525 # inactivity_timeout is 0. On the Mac I'd
4526 # suggest, we set it always to 0.
4530 $CPAN::Frontend->myprint("Cannot fork: $!");
4538 $CPAN::Frontend->myprint($@);
4539 $self->{writemakefile} = "NO $@";
4544 $ret = system($system);
4546 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4550 if (-f "Makefile") {
4551 $self->{writemakefile} = "YES";
4552 delete $self->{make_clean}; # if cleaned before, enable next
4554 $self->{writemakefile} =
4555 qq{NO Makefile.PL refused to write a Makefile.};
4556 # It's probably worth it to record the reason, so let's retry
4558 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4559 # $self->{writemakefile} .= <$fh>;
4563 delete $self->{force_update};
4566 if (my @prereq = $self->unsat_prereq){
4567 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4569 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4570 if (system($system) == 0) {
4571 $CPAN::Frontend->myprint(" $system -- OK\n");
4572 $self->{'make'} = "YES";
4574 $self->{writemakefile} ||= "YES";
4575 $self->{'make'} = "NO";
4576 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4580 sub follow_prereqs {
4584 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4585 "during [$id] -----\n");
4587 for my $p (@prereq) {
4588 $CPAN::Frontend->myprint(" $p\n");
4591 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4593 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4594 require ExtUtils::MakeMaker;
4595 my $answer = ExtUtils::MakeMaker::prompt(
4596 "Shall I follow them and prepend them to the queue
4597 of modules we are processing right now?", "yes");
4598 $follow = $answer =~ /^\s*y/i;
4602 myprint(" Ignoring dependencies on modules @prereq\n");
4605 # color them as dirty
4606 for my $p (@prereq) {
4607 # warn "calling color_cmd_tmps(0,1)";
4608 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4610 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4611 $self->{later} = "Delayed until after prerequisites";
4612 return 1; # signal success to the queuerunner
4616 #-> sub CPAN::Distribution::unsat_prereq ;
4619 my $prereq_pm = $self->prereq_pm or return;
4621 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4622 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4623 # we were too demanding:
4624 next if $nmo->uptodate;
4626 # if they have not specified a version, we accept any installed one
4627 if (not defined $need_version or
4628 $need_version == 0 or
4629 $need_version eq "undef") {
4630 next if defined $nmo->inst_file;
4633 # We only want to install prereqs if either they're not installed
4634 # or if the installed version is too old. We cannot omit this
4635 # check, because if 'force' is in effect, nobody else will check.
4639 defined $nmo->inst_file &&
4640 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4642 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4646 CPAN::Version->readable($need_version)
4652 if ($self->{sponsored_mods}{$need_module}++){
4653 # We have already sponsored it and for some reason it's still
4654 # not available. So we do nothing. Or what should we do?
4655 # if we push it again, we have a potential infinite loop
4658 push @need, $need_module;
4663 #-> sub CPAN::Distribution::prereq_pm ;
4666 return $self->{prereq_pm} if
4667 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4668 return unless $self->{writemakefile}; # no need to have succeeded
4669 # but we must have run it
4670 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4671 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4676 $fh = FileHandle->new("<$makefile\0")) {
4680 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4682 last if /MakeMaker post_initialize section/;
4684 \s+PREREQ_PM\s+=>\s+(.+)
4687 # warn "Found prereq expr[$p]";
4689 # Regexp modified by A.Speer to remember actual version of file
4690 # PREREQ_PM hash key wants, then add to
4691 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4692 # In case a prereq is mentioned twice, complain.
4693 if ( defined $p{$1} ) {
4694 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4701 $self->{prereq_pm_detected}++;
4702 return $self->{prereq_pm} = \%p;
4705 #-> sub CPAN::Distribution::test ;
4710 delete $self->{force_update};
4713 $CPAN::Frontend->myprint("Running make test\n");
4714 if (my @prereq = $self->unsat_prereq){
4715 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4719 exists $self->{make} or exists $self->{later} or push @e,
4720 "Make had some problems, maybe interrupted? Won't test";
4722 exists $self->{'make'} and
4723 $self->{'make'} eq 'NO' and
4724 push @e, "Can't test without successful make";
4726 exists $self->{build_dir} or push @e, "Has no own directory";
4727 $self->{badtestcnt} ||= 0;
4728 $self->{badtestcnt} > 0 and
4729 push @e, "Won't repeat unsuccessful test during this command";
4731 exists $self->{later} and length($self->{later}) and
4732 push @e, $self->{later};
4734 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4736 chdir $self->{'build_dir'} or
4737 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4738 $self->debug("Changed directory to $self->{'build_dir'}")
4741 if ($^O eq 'MacOS') {
4742 Mac::BuildTools::make_test($self);
4746 local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4747 $CPAN::META->set_perl5lib;
4748 my $system = join " ", $CPAN::Config->{'make'}, "test";
4749 if (system($system) == 0) {
4750 $CPAN::Frontend->myprint(" $system -- OK\n");
4751 $CPAN::META->is_tested($self->{'build_dir'});
4752 $self->{make_test} = "YES";
4754 $self->{make_test} = "NO";
4755 $self->{badtestcnt}++;
4756 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4760 #-> sub CPAN::Distribution::clean ;
4763 $CPAN::Frontend->myprint("Running make clean\n");
4766 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4767 push @e, "make clean already called once";
4768 exists $self->{build_dir} or push @e, "Has no own directory";
4769 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4771 chdir $self->{'build_dir'} or
4772 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4773 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4775 if ($^O eq 'MacOS') {
4776 Mac::BuildTools::make_clean($self);
4780 my $system = join " ", $CPAN::Config->{'make'}, "clean";
4781 if (system($system) == 0) {
4782 $CPAN::Frontend->myprint(" $system -- OK\n");
4786 # Jost Krieger pointed out that this "force" was wrong because
4787 # it has the effect that the next "install" on this distribution
4788 # will untar everything again. Instead we should bring the
4789 # object's state back to where it is after untarring.
4791 delete $self->{force_update};
4792 delete $self->{install};
4793 delete $self->{writemakefile};
4794 delete $self->{make};
4795 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4796 $self->{make_clean} = "YES";
4799 # Hmmm, what to do if make clean failed?
4801 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4803 make clean did not succeed, marking directory as unusable for further work.
4805 $self->force("make"); # so that this directory won't be used again
4810 #-> sub CPAN::Distribution::install ;
4815 delete $self->{force_update};
4818 $CPAN::Frontend->myprint("Running make install\n");
4821 exists $self->{build_dir} or push @e, "Has no own directory";
4823 exists $self->{make} or exists $self->{later} or push @e,
4824 "Make had some problems, maybe interrupted? Won't install";
4826 exists $self->{'make'} and
4827 $self->{'make'} eq 'NO' and
4828 push @e, "make had returned bad status, install seems impossible";
4830 push @e, "make test had returned bad status, ".
4831 "won't install without force"
4832 if exists $self->{'make_test'} and
4833 $self->{'make_test'} eq 'NO' and
4834 ! $self->{'force_update'};
4836 exists $self->{'install'} and push @e,
4837 $self->{'install'} eq "YES" ?
4838 "Already done" : "Already tried without success";
4840 exists $self->{later} and length($self->{later}) and
4841 push @e, $self->{later};
4843 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4845 chdir $self->{'build_dir'} or
4846 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4847 $self->debug("Changed directory to $self->{'build_dir'}")
4850 if ($^O eq 'MacOS') {
4851 Mac::BuildTools::make_install($self);
4855 my $system = join(" ", $CPAN::Config->{'make'},
4856 "install", $CPAN::Config->{make_install_arg});
4857 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4858 my($pipe) = FileHandle->new("$system $stderr |");
4861 $CPAN::Frontend->myprint($_);
4866 $CPAN::Frontend->myprint(" $system -- OK\n");
4867 $CPAN::META->is_installed($self->{'build_dir'});
4868 return $self->{'install'} = "YES";
4870 $self->{'install'} = "NO";
4871 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4872 if ($makeout =~ /permission/s && $> > 0) {
4873 $CPAN::Frontend->myprint(qq{ You may have to su }.
4874 qq{to root to install the package\n});
4877 delete $self->{force_update};
4880 #-> sub CPAN::Distribution::dir ;
4882 shift->{'build_dir'};
4885 package CPAN::Bundle;
4889 $CPAN::Frontend->myprint($self->as_string);
4894 delete $self->{later};
4895 for my $c ( $self->contains ) {
4896 my $obj = CPAN::Shell->expandany($c) or next;
4901 #-> sub CPAN::Bundle::color_cmd_tmps ;
4902 sub color_cmd_tmps {
4904 my($depth) = shift || 0;
4905 my($color) = shift || 0;
4906 my($ancestors) = shift || [];
4907 # a module needs to recurse to its cpan_file, a distribution needs
4908 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4910 return if exists $self->{incommandcolor}
4911 && $self->{incommandcolor}==$color;
4913 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4915 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4917 for my $c ( $self->contains ) {
4918 my $obj = CPAN::Shell->expandany($c) or next;
4919 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4920 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4923 delete $self->{badtestcnt};
4925 $self->{incommandcolor} = $color;
4928 #-> sub CPAN::Bundle::as_string ;
4932 # following line must be "=", not "||=" because we have a moving target
4933 $self->{INST_VERSION} = $self->inst_version;
4934 return $self->SUPER::as_string;
4937 #-> sub CPAN::Bundle::contains ;
4940 my($inst_file) = $self->inst_file || "";
4941 my($id) = $self->id;
4942 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4943 unless ($inst_file) {
4944 # Try to get at it in the cpan directory
4945 $self->debug("no inst_file") if $CPAN::DEBUG;
4947 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4948 $cpan_file = $self->cpan_file;
4949 if ($cpan_file eq "N/A") {
4950 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4951 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4953 my $dist = $CPAN::META->instance('CPAN::Distribution',
4956 $self->debug($dist->as_string) if $CPAN::DEBUG;
4957 my($todir) = $CPAN::Config->{'cpan_home'};
4958 my(@me,$from,$to,$me);
4959 @me = split /::/, $self->id;
4961 $me = File::Spec->catfile(@me);
4962 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4963 $to = File::Spec->catfile($todir,$me);
4964 File::Path::mkpath(File::Basename::dirname($to));
4965 File::Copy::copy($from, $to)
4966 or Carp::confess("Couldn't copy $from to $to: $!");
4970 my $fh = FileHandle->new;
4972 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4974 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4976 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4977 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4978 next unless $in_cont;
4983 push @result, (split " ", $_, 2)[0];
4986 delete $self->{STATUS};
4987 $self->{CONTAINS} = \@result;
4988 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4990 $CPAN::Frontend->mywarn(qq{
4991 The bundle file "$inst_file" may be a broken
4992 bundlefile. It seems not to contain any bundle definition.
4993 Please check the file and if it is bogus, please delete it.
4994 Sorry for the inconvenience.
5000 #-> sub CPAN::Bundle::find_bundle_file
5001 sub find_bundle_file {
5002 my($self,$where,$what) = @_;
5003 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5004 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5005 ### my $bu = File::Spec->catfile($where,$what);
5006 ### return $bu if -f $bu;
5007 my $manifest = File::Spec->catfile($where,"MANIFEST");
5008 unless (-f $manifest) {
5009 require ExtUtils::Manifest;
5010 my $cwd = CPAN::anycwd();
5011 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5012 ExtUtils::Manifest::mkmanifest();
5013 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5015 my $fh = FileHandle->new($manifest)
5016 or Carp::croak("Couldn't open $manifest: $!");
5019 if ($^O eq 'MacOS') {
5022 $what2 =~ s/:Bundle://;
5025 $what2 =~ s|Bundle[/\\]||;
5030 my($file) = /(\S+)/;
5031 if ($file =~ m|\Q$what\E$|) {
5033 # return File::Spec->catfile($where,$bu); # bad
5036 # retry if she managed to
5037 # have no Bundle directory
5038 $bu = $file if $file =~ m|\Q$what2\E$|;
5040 $bu =~ tr|/|:| if $^O eq 'MacOS';
5041 return File::Spec->catfile($where, $bu) if $bu;
5042 Carp::croak("Couldn't find a Bundle file in $where");
5045 # needs to work quite differently from Module::inst_file because of
5046 # cpan_home/Bundle/ directory and the possibility that we have
5047 # shadowing effect. As it makes no sense to take the first in @INC for
5048 # Bundles, we parse them all for $VERSION and take the newest.
5050 #-> sub CPAN::Bundle::inst_file ;
5055 @me = split /::/, $self->id;
5058 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5059 my $bfile = File::Spec->catfile($incdir, @me);
5060 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5061 next unless -f $bfile;
5062 my $foundv = MM->parse_version($bfile);
5063 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5064 $self->{INST_FILE} = $bfile;
5065 $self->{INST_VERSION} = $bestv = $foundv;
5071 #-> sub CPAN::Bundle::inst_version ;
5074 $self->inst_file; # finds INST_VERSION as side effect
5075 $self->{INST_VERSION};
5078 #-> sub CPAN::Bundle::rematein ;
5080 my($self,$meth) = @_;
5081 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5082 my($id) = $self->id;
5083 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5084 unless $self->inst_file || $self->cpan_file;
5086 for $s ($self->contains) {
5087 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5088 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5089 if ($type eq 'CPAN::Distribution') {
5090 $CPAN::Frontend->mywarn(qq{
5091 The Bundle }.$self->id.qq{ contains
5092 explicitly a file $s.
5096 # possibly noisy action:
5097 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5098 my $obj = $CPAN::META->instance($type,$s);
5100 if ($obj->isa(CPAN::Bundle)
5102 exists $obj->{install_failed}
5104 ref($obj->{install_failed}) eq "HASH"
5106 for (keys %{$obj->{install_failed}}) {
5107 $self->{install_failed}{$_} = undef; # propagate faiure up
5110 $fail{$s} = 1; # the bundle itself may have succeeded but
5115 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5116 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5118 delete $self->{install_failed}{$s};
5125 # recap with less noise
5126 if ( $meth eq "install" ) {
5129 my $raw = sprintf(qq{Bundle summary:
5130 The following items in bundle %s had installation problems:},
5133 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5134 $CPAN::Frontend->myprint("\n");
5137 for $s ($self->contains) {
5139 $paragraph .= "$s ";
5140 $self->{install_failed}{$s} = undef;
5141 $reported{$s} = undef;
5144 my $report_propagated;
5145 for $s (sort keys %{$self->{install_failed}}) {
5146 next if exists $reported{$s};
5147 $paragraph .= "and the following items had problems
5148 during recursive bundle calls: " unless $report_propagated++;
5149 $paragraph .= "$s ";
5151 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5152 $CPAN::Frontend->myprint("\n");
5154 $self->{'install'} = 'YES';
5159 #sub CPAN::Bundle::xs_file
5161 # If a bundle contains another that contains an xs_file we have
5162 # here, we just don't bother I suppose
5166 #-> sub CPAN::Bundle::force ;
5167 sub force { shift->rematein('force',@_); }
5168 #-> sub CPAN::Bundle::get ;
5169 sub get { shift->rematein('get',@_); }
5170 #-> sub CPAN::Bundle::make ;
5171 sub make { shift->rematein('make',@_); }
5172 #-> sub CPAN::Bundle::test ;
5175 $self->{badtestcnt} ||= 0;
5176 $self->rematein('test',@_);
5178 #-> sub CPAN::Bundle::install ;
5181 $self->rematein('install',@_);
5183 #-> sub CPAN::Bundle::clean ;
5184 sub clean { shift->rematein('clean',@_); }
5186 #-> sub CPAN::Bundle::uptodate ;
5189 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5191 foreach $c ($self->contains) {
5192 my $obj = CPAN::Shell->expandany($c);
5193 return 0 unless $obj->uptodate;
5198 #-> sub CPAN::Bundle::readme ;
5201 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5202 No File found for bundle } . $self->id . qq{\n}), return;
5203 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5204 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5207 package CPAN::Module;
5210 # sub CPAN::Module::userid
5213 return unless exists $self->{RO}; # should never happen
5214 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5216 # sub CPAN::Module::description
5217 sub description { shift->{RO}{description} }
5221 delete $self->{later};
5222 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5227 #-> sub CPAN::Module::color_cmd_tmps ;
5228 sub color_cmd_tmps {
5230 my($depth) = shift || 0;
5231 my($color) = shift || 0;
5232 my($ancestors) = shift || [];
5233 # a module needs to recurse to its cpan_file
5235 return if exists $self->{incommandcolor}
5236 && $self->{incommandcolor}==$color;
5238 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5240 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5242 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5243 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5246 delete $self->{badtestcnt};
5248 $self->{incommandcolor} = $color;
5251 #-> sub CPAN::Module::as_glimpse ;
5255 my $class = ref($self);
5256 $class =~ s/^CPAN:://;
5260 $CPAN::Shell::COLOR_REGISTERED
5262 $CPAN::META->has_inst("Term::ANSIColor")
5264 $self->{RO}{description}
5266 $color_on = Term::ANSIColor::color("green");
5267 $color_off = Term::ANSIColor::color("reset");
5269 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5278 #-> sub CPAN::Module::as_string ;
5282 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5283 my $class = ref($self);
5284 $class =~ s/^CPAN:://;
5286 push @m, $class, " id = $self->{ID}\n";
5287 my $sprintf = " %-12s %s\n";
5288 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5289 if $self->description;
5290 my $sprintf2 = " %-12s %s (%s)\n";
5292 $userid = $self->userid;
5295 if ($author = CPAN::Shell->expand('Author',$userid)) {
5298 if ($m = $author->email) {
5305 $author->fullname . $email
5309 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5310 if $self->cpan_version;
5311 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5312 if $self->cpan_file;
5313 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5314 my(%statd,%stats,%statl,%stati);
5315 @statd{qw,? i c a b R M S,} = qw,unknown idea
5316 pre-alpha alpha beta released mature standard,;
5317 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5318 developer comp.lang.perl.* none abandoned,;
5319 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5320 @stati{qw,? f r O h,} = qw,unknown functions
5321 references+ties object-oriented hybrid,;
5322 $statd{' '} = 'unknown';
5323 $stats{' '} = 'unknown';
5324 $statl{' '} = 'unknown';
5325 $stati{' '} = 'unknown';
5333 $statd{$self->{RO}{statd}},
5334 $stats{$self->{RO}{stats}},
5335 $statl{$self->{RO}{statl}},
5336 $stati{$self->{RO}{stati}}
5337 ) if $self->{RO}{statd};
5338 my $local_file = $self->inst_file;
5339 unless ($self->{MANPAGE}) {
5341 $self->{MANPAGE} = $self->manpage_headline($local_file);
5343 # If we have already untarred it, we should look there
5344 my $dist = $CPAN::META->instance('CPAN::Distribution',
5346 # warn "dist[$dist]";
5347 # mff=manifest file; mfh=manifest handle
5352 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5354 $mfh = FileHandle->new($mff)
5356 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5357 my $lfre = $self->id; # local file RE
5360 my($lfl); # local file file
5362 my(@mflines) = <$mfh>;
5367 while (length($lfre)>5 and !$lfl) {
5368 ($lfl) = grep /$lfre/, @mflines;
5369 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5372 $lfl =~ s/\s.*//; # remove comments
5373 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5374 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5375 # warn "lfl_abs[$lfl_abs]";
5377 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5383 for $item (qw/MANPAGE/) {
5384 push @m, sprintf($sprintf, $item, $self->{$item})
5385 if exists $self->{$item};
5387 for $item (qw/CONTAINS/) {
5388 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5389 if exists $self->{$item} && @{$self->{$item}};
5391 push @m, sprintf($sprintf, 'INST_FILE',
5392 $local_file || "(not installed)");
5393 push @m, sprintf($sprintf, 'INST_VERSION',
5394 $self->inst_version) if $local_file;
5398 sub manpage_headline {
5399 my($self,$local_file) = @_;
5400 my(@local_file) = $local_file;
5401 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5402 push @local_file, $local_file;
5404 for $locf (@local_file) {
5405 next unless -f $locf;
5406 my $fh = FileHandle->new($locf)
5407 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5411 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5412 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5425 #-> sub CPAN::Module::cpan_file ;
5426 # Note: also inherited by CPAN::Bundle
5429 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5430 unless (defined $self->{RO}{CPAN_FILE}) {
5431 CPAN::Index->reload;
5433 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5434 return $self->{RO}{CPAN_FILE};
5436 my $userid = $self->userid;
5438 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5439 my $author = $CPAN::META->instance("CPAN::Author",
5441 my $fullname = $author->fullname;
5442 my $email = $author->email;
5443 unless (defined $fullname && defined $email) {
5444 return sprintf("Contact Author %s",
5448 return "Contact Author $fullname <$email>";
5450 return "Contact Author $userid (Email address not available)";
5458 #-> sub CPAN::Module::cpan_version ;
5462 $self->{RO}{CPAN_VERSION} = 'undef'
5463 unless defined $self->{RO}{CPAN_VERSION};
5464 # I believe this is always a bug in the index and should be reported
5465 # as such, but usually I find out such an error and do not want to
5466 # provoke too many bugreports
5468 $self->{RO}{CPAN_VERSION};
5471 #-> sub CPAN::Module::force ;
5474 $self->{'force_update'}++;
5477 #-> sub CPAN::Module::rematein ;
5479 my($self,$meth) = @_;
5480 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5483 my $cpan_file = $self->cpan_file;
5484 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5485 $CPAN::Frontend->mywarn(sprintf qq{
5486 The module %s isn\'t available on CPAN.
5488 Either the module has not yet been uploaded to CPAN, or it is
5489 temporary unavailable. Please contact the author to find out
5490 more about the status. Try 'i %s'.
5497 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5498 $pack->called_for($self->id);
5499 $pack->force($meth) if exists $self->{'force_update'};
5501 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5502 delete $self->{'force_update'};
5505 #-> sub CPAN::Module::readme ;
5506 sub readme { shift->rematein('readme') }
5507 #-> sub CPAN::Module::look ;
5508 sub look { shift->rematein('look') }
5509 #-> sub CPAN::Module::cvs_import ;
5510 sub cvs_import { shift->rematein('cvs_import') }
5511 #-> sub CPAN::Module::get ;
5512 sub get { shift->rematein('get',@_); }
5513 #-> sub CPAN::Module::make ;
5516 $self->rematein('make');
5518 #-> sub CPAN::Module::test ;
5521 $self->{badtestcnt} ||= 0;
5522 $self->rematein('test',@_);
5524 #-> sub CPAN::Module::uptodate ;
5527 my($latest) = $self->cpan_version;
5529 my($inst_file) = $self->inst_file;
5531 if (defined $inst_file) {
5532 $have = $self->inst_version;
5537 ! CPAN::Version->vgt($latest, $have)
5539 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5540 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5545 #-> sub CPAN::Module::install ;
5551 not exists $self->{'force_update'}
5553 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5557 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
5558 $CPAN::Frontend->mywarn(qq{
5559 \n\n\n ***WARNING***
5560 The module $self->{ID} has no active maintainer.\n\n\n
5564 $self->rematein('install') if $doit;
5566 #-> sub CPAN::Module::clean ;
5567 sub clean { shift->rematein('clean') }
5569 #-> sub CPAN::Module::inst_file ;
5573 @packpath = split /::/, $self->{ID};
5574 $packpath[-1] .= ".pm";
5575 foreach $dir (@INC) {
5576 my $pmfile = File::Spec->catfile($dir,@packpath);
5584 #-> sub CPAN::Module::xs_file ;
5588 @packpath = split /::/, $self->{ID};
5589 push @packpath, $packpath[-1];
5590 $packpath[-1] .= "." . $Config::Config{'dlext'};
5591 foreach $dir (@INC) {
5592 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5600 #-> sub CPAN::Module::inst_version ;
5603 my $parsefile = $self->inst_file or return;
5604 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5607 # there was a bug in 5.6.0 that let lots of unini warnings out of
5608 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5609 # the following workaround after 5.6.1 is out.
5610 local($SIG{__WARN__}) = sub { my $w = shift;
5611 return if $w =~ /uninitialized/i;
5615 $have = MM->parse_version($parsefile) || "undef";
5616 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5617 $have =~ s/ $//; # trailing whitespace happens all the time
5619 # My thoughts about why %vd processing should happen here
5621 # Alt1 maintain it as string with leading v:
5622 # read index files do nothing
5623 # compare it use utility for compare
5624 # print it do nothing
5626 # Alt2 maintain it as what it is
5627 # read index files convert
5628 # compare it use utility because there's still a ">" vs "gt" issue
5629 # print it use CPAN::Version for print
5631 # Seems cleaner to hold it in memory as a string starting with a "v"
5633 # If the author of this module made a mistake and wrote a quoted
5634 # "v1.13" instead of v1.13, we simply leave it at that with the
5635 # effect that *we* will treat it like a v-tring while the rest of
5636 # perl won't. Seems sensible when we consider that any action we
5637 # could take now would just add complexity.
5639 $have = CPAN::Version->readable($have);
5641 $have =~ s/\s*//g; # stringify to float around floating point issues
5642 $have; # no stringify needed, \s* above matches always
5645 package CPAN::Tarzip;
5647 # CPAN::Tarzip::gzip
5649 my($class,$read,$write) = @_;
5650 if ($CPAN::META->has_inst("Compress::Zlib")) {
5652 $fhw = FileHandle->new($read)
5653 or $CPAN::Frontend->mydie("Could not open $read: $!");
5654 my $gz = Compress::Zlib::gzopen($write, "wb")
5655 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5656 $gz->gzwrite($buffer)
5657 while read($fhw,$buffer,4096) > 0 ;
5662 system("$CPAN::Config->{gzip} -c $read > $write")==0;
5667 # CPAN::Tarzip::gunzip
5669 my($class,$read,$write) = @_;
5670 if ($CPAN::META->has_inst("Compress::Zlib")) {
5672 $fhw = FileHandle->new(">$write")
5673 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5674 my $gz = Compress::Zlib::gzopen($read, "rb")
5675 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5676 $fhw->print($buffer)
5677 while $gz->gzread($buffer) > 0 ;
5678 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5679 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5684 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5689 # CPAN::Tarzip::gtest
5691 my($class,$read) = @_;
5692 # After I had reread the documentation in zlib.h, I discovered that
5693 # uncompressed files do not lead to an gzerror (anymore?).
5694 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5697 my $gz = Compress::Zlib::gzopen($read, "rb")
5698 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5700 $Compress::Zlib::gzerrno));
5701 while ($gz->gzread($buffer) > 0 ){
5702 $len += length($buffer);
5705 my $err = $gz->gzerror;
5706 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5707 if ($len == -s $read){
5709 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5712 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5715 return system("$CPAN::Config->{gzip} -dt $read")==0;
5720 # CPAN::Tarzip::TIEHANDLE
5722 my($class,$file) = @_;
5724 $class->debug("file[$file]");
5725 if ($CPAN::META->has_inst("Compress::Zlib")) {
5726 my $gz = Compress::Zlib::gzopen($file,"rb") or
5727 die "Could not gzopen $file";
5728 $ret = bless {GZ => $gz}, $class;
5730 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5731 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5733 $ret = bless {FH => $fh}, $class;
5739 # CPAN::Tarzip::READLINE
5742 if (exists $self->{GZ}) {
5743 my $gz = $self->{GZ};
5744 my($line,$bytesread);
5745 $bytesread = $gz->gzreadline($line);
5746 return undef if $bytesread <= 0;
5749 my $fh = $self->{FH};
5750 return scalar <$fh>;
5755 # CPAN::Tarzip::READ
5757 my($self,$ref,$length,$offset) = @_;
5758 die "read with offset not implemented" if defined $offset;
5759 if (exists $self->{GZ}) {
5760 my $gz = $self->{GZ};
5761 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5764 my $fh = $self->{FH};
5765 return read($fh,$$ref,$length);
5770 # CPAN::Tarzip::DESTROY
5773 if (exists $self->{GZ}) {
5774 my $gz = $self->{GZ};
5775 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5776 # to be undef ever. AK, 2000-09
5778 my $fh = $self->{FH};
5779 $fh->close if defined $fh;
5785 # CPAN::Tarzip::untar
5787 my($class,$file) = @_;
5790 if (0) { # makes changing order easier
5791 } elsif ($BUGHUNTING){
5793 } elsif (MM->maybe_command($CPAN::Config->{gzip})
5795 MM->maybe_command($CPAN::Config->{'tar'})) {
5796 # should be default until Archive::Tar is fixed
5799 $CPAN::META->has_inst("Archive::Tar")
5801 $CPAN::META->has_inst("Compress::Zlib") ) {
5804 $CPAN::Frontend->mydie(qq{
5805 CPAN.pm needs either both external programs tar and gzip installed or
5806 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5807 is available. Can\'t continue.
5810 if ($prefer==1) { # 1 => external gzip+tar
5812 my $is_compressed = $class->gtest($file);
5813 if ($is_compressed) {
5814 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5815 "< $file | $CPAN::Config->{tar} xvf -";
5817 $system = "$CPAN::Config->{tar} xvf $file";
5819 if (system($system) != 0) {
5820 # people find the most curious tar binaries that cannot handle
5822 if ($is_compressed) {
5823 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5824 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5825 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5827 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5831 $system = "$CPAN::Config->{tar} xvf $file";
5832 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5833 if (system($system)==0) {
5834 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5836 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5842 } elsif ($prefer==2) { # 2 => modules
5843 my $tar = Archive::Tar->new($file,1);
5844 my $af; # archive file
5847 # RCS 1.337 had this code, it turned out unacceptable slow but
5848 # it revealed a bug in Archive::Tar. Code is only here to hunt
5849 # the bug again. It should never be enabled in published code.
5850 # GDGraph3d-0.53 was an interesting case according to Larry
5852 warn(">>>Bughunting code enabled<<< " x 20);
5853 for $af ($tar->list_files) {
5854 if ($af =~ m!^(/|\.\./)!) {
5855 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5856 "illegal member [$af]");
5858 $CPAN::Frontend->myprint("$af\n");
5859 $tar->extract($af); # slow but effective for finding the bug
5860 return if $CPAN::Signal;
5863 for $af ($tar->list_files) {
5864 if ($af =~ m!^(/|\.\./)!) {
5865 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5866 "illegal member [$af]");
5868 $CPAN::Frontend->myprint("$af\n");
5870 return if $CPAN::Signal;
5875 Mac::BuildTools::convert_files([$tar->list_files], 1)
5876 if ($^O eq 'MacOS');
5883 my($class,$file) = @_;
5884 if ($CPAN::META->has_inst("Archive::Zip")) {
5885 # blueprint of the code from Archive::Zip::Tree::extractTree();
5886 my $zip = Archive::Zip->new();
5888 $status = $zip->read($file);
5889 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5890 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5891 my @members = $zip->members();
5892 for my $member ( @members ) {
5893 my $af = $member->fileName();
5894 if ($af =~ m!^(/|\.\./)!) {
5895 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5896 "illegal member [$af]");
5898 my $status = $member->extractToFileNamed( $af );
5899 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5900 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5901 $status != Archive::Zip::AZ_OK();
5902 return if $CPAN::Signal;
5906 my $unzip = $CPAN::Config->{unzip} or
5907 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5908 my @system = ($unzip, $file);
5909 return system(@system) == 0;
5914 package CPAN::Version;
5915 # CPAN::Version::vcmp courtesy Jost Krieger
5917 my($self,$l,$r) = @_;
5919 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5921 return 0 if $l eq $r; # short circuit for quicker success
5923 if ($l=~/^v/ <=> $r=~/^v/) {
5926 $_ = $self->float2vv($_);
5931 ($l ne "undef") <=> ($r ne "undef") ||
5935 $self->vstring($l) cmp $self->vstring($r)) ||
5941 my($self,$l,$r) = @_;
5942 $self->vcmp($l,$r) > 0;
5947 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5948 pack "U*", split /\./, $n;
5951 # vv => visible vstring
5956 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5957 # architecture influence
5959 $mantissa .= "0" while length($mantissa)%3;
5960 my $ret = "v" . $rev;
5962 $mantissa =~ s/(\d{1,3})// or
5963 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5964 $ret .= ".".int($1);
5966 # warn "n[$n]ret[$ret]";
5972 $n =~ /^([\w\-\+\.]+)/;
5974 return $1 if defined $1 && length($1)>0;
5975 # if the first user reaches version v43, he will be treated as "+".
5976 # We'll have to decide about a new rule here then, depending on what
5977 # will be the prevailing versioning behavior then.
5979 if ($] < 5.006) { # or whenever v-strings were introduced
5980 # we get them wrong anyway, whatever we do, because 5.005 will
5981 # have already interpreted 0.2.4 to be "0.24". So even if he
5982 # indexer sends us something like "v0.2.4" we compare wrongly.
5984 # And if they say v1.2, then the old perl takes it as "v12"
5986 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
5989 my $better = sprintf "v%vd", $n;
5990 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
6002 CPAN - query, download and build perl modules from CPAN sites
6008 perl -MCPAN -e shell;
6014 autobundle, clean, install, make, recompile, test
6018 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6019 of a modern rewrite from ground up with greater extensibility and more
6020 features but no full compatibility. If you're new to CPAN.pm, you
6021 probably should investigate if CPANPLUS is the better choice for you.
6022 If you're already used to CPAN.pm you're welcome to continue using it,
6023 if you accept that its development is mostly (though not completely)
6028 The CPAN module is designed to automate the make and install of perl
6029 modules and extensions. It includes some primitive searching capabilities and
6030 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6031 to fetch the raw data from the net.
6033 Modules are fetched from one or more of the mirrored CPAN
6034 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6037 The CPAN module also supports the concept of named and versioned
6038 I<bundles> of modules. Bundles simplify the handling of sets of
6039 related modules. See Bundles below.
6041 The package contains a session manager and a cache manager. There is
6042 no status retained between sessions. The session manager keeps track
6043 of what has been fetched, built and installed in the current
6044 session. The cache manager keeps track of the disk space occupied by
6045 the make processes and deletes excess space according to a simple FIFO
6048 For extended searching capabilities there's a plugin for CPAN available,
6049 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6050 that indexes all documents available in CPAN authors directories. If
6051 C<CPAN::WAIT> is installed on your system, the interactive shell of
6052 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6053 which send queries to the WAIT server that has been configured for your
6056 All other methods provided are accessible in a programmer style and in an
6057 interactive shell style.
6059 =head2 Interactive Mode
6061 The interactive mode is entered by running
6063 perl -MCPAN -e shell
6065 which puts you into a readline interface. You will have the most fun if
6066 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6069 Once you are on the command line, type 'h' and the rest should be
6072 The function call C<shell> takes two optional arguments, one is the
6073 prompt, the second is the default initial command line (the latter
6074 only works if a real ReadLine interface module is installed).
6076 The most common uses of the interactive modes are
6080 =item Searching for authors, bundles, distribution files and modules
6082 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6083 for each of the four categories and another, C<i> for any of the
6084 mentioned four. Each of the four entities is implemented as a class
6085 with slightly differing methods for displaying an object.
6087 Arguments you pass to these commands are either strings exactly matching
6088 the identification string of an object or regular expressions that are
6089 then matched case-insensitively against various attributes of the
6090 objects. The parser recognizes a regular expression only if you
6091 enclose it between two slashes.
6093 The principle is that the number of found objects influences how an
6094 item is displayed. If the search finds one item, the result is
6095 displayed with the rather verbose method C<as_string>, but if we find
6096 more than one, we display each object with the terse method
6099 =item make, test, install, clean modules or distributions
6101 These commands take any number of arguments and investigate what is
6102 necessary to perform the action. If the argument is a distribution
6103 file name (recognized by embedded slashes), it is processed. If it is
6104 a module, CPAN determines the distribution file in which this module
6105 is included and processes that, following any dependencies named in
6106 the module's Makefile.PL (this behavior is controlled by
6107 I<prerequisites_policy>.)
6109 Any C<make> or C<test> are run unconditionally. An
6111 install <distribution_file>
6113 also is run unconditionally. But for
6117 CPAN checks if an install is actually needed for it and prints
6118 I<module up to date> in the case that the distribution file containing
6119 the module doesn't need to be updated.
6121 CPAN also keeps track of what it has done within the current session
6122 and doesn't try to build a package a second time regardless if it
6123 succeeded or not. The C<force> command takes as a first argument the
6124 method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6125 command from scratch.
6129 cpan> install OpenGL
6130 OpenGL is up to date.
6131 cpan> force install OpenGL
6134 OpenGL-0.4/COPYRIGHT
6137 A C<clean> command results in a
6141 being executed within the distribution file's working directory.
6143 =item get, readme, look module or distribution
6145 C<get> downloads a distribution file without further action. C<readme>
6146 displays the README file of the associated distribution. C<Look> gets
6147 and untars (if not yet done) the distribution file, changes to the
6148 appropriate directory and opens a subshell process in that directory.
6152 C<ls> lists all distribution files in and below an author's CPAN
6153 directory. Only those files that contain modules are listed and if
6154 there is more than one for any given module, only the most recent one
6159 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6160 in the cpan-shell it is intended that you can press C<^C> anytime and
6161 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6162 to clean up and leave the shell loop. You can emulate the effect of a
6163 SIGTERM by sending two consecutive SIGINTs, which usually means by
6164 pressing C<^C> twice.
6166 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6167 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6173 The commands that are available in the shell interface are methods in
6174 the package CPAN::Shell. If you enter the shell command, all your
6175 input is split by the Text::ParseWords::shellwords() routine which
6176 acts like most shells do. The first word is being interpreted as the
6177 method to be called and the rest of the words are treated as arguments
6178 to this method. Continuation lines are supported if a line ends with a
6183 C<autobundle> writes a bundle file into the
6184 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6185 a list of all modules that are both available from CPAN and currently
6186 installed within @INC. The name of the bundle file is based on the
6187 current date and a counter.
6191 recompile() is a very special command in that it takes no argument and
6192 runs the make/test/install cycle with brute force over all installed
6193 dynamically loadable extensions (aka XS modules) with 'force' in
6194 effect. The primary purpose of this command is to finish a network
6195 installation. Imagine, you have a common source tree for two different
6196 architectures. You decide to do a completely independent fresh
6197 installation. You start on one architecture with the help of a Bundle
6198 file produced earlier. CPAN installs the whole Bundle for you, but
6199 when you try to repeat the job on the second architecture, CPAN
6200 responds with a C<"Foo up to date"> message for all modules. So you
6201 invoke CPAN's recompile on the second architecture and you're done.
6203 Another popular use for C<recompile> is to act as a rescue in case your
6204 perl breaks binary compatibility. If one of the modules that CPAN uses
6205 is in turn depending on binary compatibility (so you cannot run CPAN
6206 commands), then you should try the CPAN::Nox module for recovery.
6208 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6210 Although it may be considered internal, the class hierarchy does matter
6211 for both users and programmer. CPAN.pm deals with above mentioned four
6212 classes, and all those classes share a set of methods. A classical
6213 single polymorphism is in effect. A metaclass object registers all
6214 objects of all kinds and indexes them with a string. The strings
6215 referencing objects have a separated namespace (well, not completely
6220 words containing a "/" (slash) Distribution
6221 words starting with Bundle:: Bundle
6222 everything else Module or Author
6224 Modules know their associated Distribution objects. They always refer
6225 to the most recent official release. Developers may mark their releases
6226 as unstable development versions (by inserting an underbar into the
6227 module version number which will also be reflected in the distribution
6228 name when you run 'make dist'), so the really hottest and newest
6229 distribution is not always the default. If a module Foo circulates
6230 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6231 way to install version 1.23 by saying
6235 This would install the complete distribution file (say
6236 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6237 like to install version 1.23_90, you need to know where the
6238 distribution file resides on CPAN relative to the authors/id/
6239 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6240 so you would have to say
6242 install BAR/Foo-1.23_90.tar.gz
6244 The first example will be driven by an object of the class
6245 CPAN::Module, the second by an object of class CPAN::Distribution.
6247 =head2 Programmer's interface
6249 If you do not enter the shell, the available shell commands are both
6250 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6251 functions in the calling package (C<install(...)>).
6253 There's currently only one class that has a stable interface -
6254 CPAN::Shell. All commands that are available in the CPAN shell are
6255 methods of the class CPAN::Shell. Each of the commands that produce
6256 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6257 the IDs of all modules within the list.
6261 =item expand($type,@things)
6263 The IDs of all objects available within a program are strings that can
6264 be expanded to the corresponding real objects with the
6265 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6266 list of CPAN::Module objects according to the C<@things> arguments
6267 given. In scalar context it only returns the first element of the
6270 =item expandany(@things)
6272 Like expand, but returns objects of the appropriate type, i.e.
6273 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6274 CPAN::Distribution objects fro distributions.
6276 =item Programming Examples
6278 This enables the programmer to do operations that combine
6279 functionalities that are available in the shell.
6281 # install everything that is outdated on my disk:
6282 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6284 # install my favorite programs if necessary:
6285 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6286 my $obj = CPAN::Shell->expand('Module',$mod);
6290 # list all modules on my disk that have no VERSION number
6291 for $mod (CPAN::Shell->expand("Module","/./")){
6292 next unless $mod->inst_file;
6293 # MakeMaker convention for undefined $VERSION:
6294 next unless $mod->inst_version eq "undef";
6295 print "No VERSION in ", $mod->id, "\n";
6298 # find out which distribution on CPAN contains a module:
6299 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6301 Or if you want to write a cronjob to watch The CPAN, you could list
6302 all modules that need updating. First a quick and dirty way:
6304 perl -e 'use CPAN; CPAN::Shell->r;'
6306 If you don't want to get any output in the case that all modules are
6307 up to date, you can parse the output of above command for the regular
6308 expression //modules are up to date// and decide to mail the output
6309 only if it doesn't match. Ick?
6311 If you prefer to do it more in a programmer style in one single
6312 process, maybe something like this suits you better:
6314 # list all modules on my disk that have newer versions on CPAN
6315 for $mod (CPAN::Shell->expand("Module","/./")){
6316 next unless $mod->inst_file;
6317 next if $mod->uptodate;
6318 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6319 $mod->id, $mod->inst_version, $mod->cpan_version;
6322 If that gives you too much output every day, you maybe only want to
6323 watch for three modules. You can write
6325 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6327 as the first line instead. Or you can combine some of the above
6330 # watch only for a new mod_perl module
6331 $mod = CPAN::Shell->expand("Module","mod_perl");
6332 exit if $mod->uptodate;
6333 # new mod_perl arrived, let me know all update recommendations
6338 =head2 Methods in the other Classes
6340 The programming interface for the classes CPAN::Module,
6341 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6342 beta and partially even alpha. In the following paragraphs only those
6343 methods are documented that have proven useful over a longer time and
6344 thus are unlikely to change.
6348 =item CPAN::Author::as_glimpse()
6350 Returns a one-line description of the author
6352 =item CPAN::Author::as_string()
6354 Returns a multi-line description of the author
6356 =item CPAN::Author::email()
6358 Returns the author's email address
6360 =item CPAN::Author::fullname()
6362 Returns the author's name
6364 =item CPAN::Author::name()
6366 An alias for fullname
6368 =item CPAN::Bundle::as_glimpse()
6370 Returns a one-line description of the bundle
6372 =item CPAN::Bundle::as_string()
6374 Returns a multi-line description of the bundle
6376 =item CPAN::Bundle::clean()
6378 Recursively runs the C<clean> method on all items contained in the bundle.
6380 =item CPAN::Bundle::contains()
6382 Returns a list of objects' IDs contained in a bundle. The associated
6383 objects may be bundles, modules or distributions.
6385 =item CPAN::Bundle::force($method,@args)
6387 Forces CPAN to perform a task that normally would have failed. Force
6388 takes as arguments a method name to be called and any number of
6389 additional arguments that should be passed to the called method. The
6390 internals of the object get the needed changes so that CPAN.pm does
6391 not refuse to take the action. The C<force> is passed recursively to
6392 all contained objects.
6394 =item CPAN::Bundle::get()
6396 Recursively runs the C<get> method on all items contained in the bundle
6398 =item CPAN::Bundle::inst_file()
6400 Returns the highest installed version of the bundle in either @INC or
6401 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6402 CPAN::Module::inst_file.
6404 =item CPAN::Bundle::inst_version()
6406 Like CPAN::Bundle::inst_file, but returns the $VERSION
6408 =item CPAN::Bundle::uptodate()
6410 Returns 1 if the bundle itself and all its members are uptodate.
6412 =item CPAN::Bundle::install()
6414 Recursively runs the C<install> method on all items contained in the bundle
6416 =item CPAN::Bundle::make()
6418 Recursively runs the C<make> method on all items contained in the bundle
6420 =item CPAN::Bundle::readme()
6422 Recursively runs the C<readme> method on all items contained in the bundle
6424 =item CPAN::Bundle::test()
6426 Recursively runs the C<test> method on all items contained in the bundle
6428 =item CPAN::Distribution::as_glimpse()
6430 Returns a one-line description of the distribution
6432 =item CPAN::Distribution::as_string()
6434 Returns a multi-line description of the distribution
6436 =item CPAN::Distribution::clean()
6438 Changes to the directory where the distribution has been unpacked and
6439 runs C<make clean> there.
6441 =item CPAN::Distribution::containsmods()
6443 Returns a list of IDs of modules contained in a distribution file.
6444 Only works for distributions listed in the 02packages.details.txt.gz
6445 file. This typically means that only the most recent version of a
6446 distribution is covered.
6448 =item CPAN::Distribution::cvs_import()
6450 Changes to the directory where the distribution has been unpacked and
6453 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6457 =item CPAN::Distribution::dir()
6459 Returns the directory into which this distribution has been unpacked.
6461 =item CPAN::Distribution::force($method,@args)
6463 Forces CPAN to perform a task that normally would have failed. Force
6464 takes as arguments a method name to be called and any number of
6465 additional arguments that should be passed to the called method. The
6466 internals of the object get the needed changes so that CPAN.pm does
6467 not refuse to take the action.
6469 =item CPAN::Distribution::get()
6471 Downloads the distribution from CPAN and unpacks it. Does nothing if
6472 the distribution has already been downloaded and unpacked within the
6475 =item CPAN::Distribution::install()
6477 Changes to the directory where the distribution has been unpacked and
6478 runs the external command C<make install> there. If C<make> has not
6479 yet been run, it will be run first. A C<make test> will be issued in
6480 any case and if this fails, the install will be canceled. The
6481 cancellation can be avoided by letting C<force> run the C<install> for
6484 =item CPAN::Distribution::isa_perl()
6486 Returns 1 if this distribution file seems to be a perl distribution.
6487 Normally this is derived from the file name only, but the index from
6488 CPAN can contain a hint to achieve a return value of true for other
6491 =item CPAN::Distribution::look()
6493 Changes to the directory where the distribution has been unpacked and
6494 opens a subshell there. Exiting the subshell returns.
6496 =item CPAN::Distribution::make()
6498 First runs the C<get> method to make sure the distribution is
6499 downloaded and unpacked. Changes to the directory where the
6500 distribution has been unpacked and runs the external commands C<perl
6501 Makefile.PL> and C<make> there.
6503 =item CPAN::Distribution::prereq_pm()
6505 Returns the hash reference that has been announced by a distribution
6506 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6507 attempt has been made to C<make> the distribution. Returns undef
6510 =item CPAN::Distribution::readme()
6512 Downloads the README file associated with a distribution and runs it
6513 through the pager specified in C<$CPAN::Config->{pager}>.
6515 =item CPAN::Distribution::test()
6517 Changes to the directory where the distribution has been unpacked and
6518 runs C<make test> there.
6520 =item CPAN::Distribution::uptodate()
6522 Returns 1 if all the modules contained in the distribution are
6523 uptodate. Relies on containsmods.
6525 =item CPAN::Index::force_reload()
6527 Forces a reload of all indices.
6529 =item CPAN::Index::reload()
6531 Reloads all indices if they have been read more than
6532 C<$CPAN::Config->{index_expire}> days.
6534 =item CPAN::InfoObj::dump()
6536 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6537 inherit this method. It prints the data structure associated with an
6538 object. Useful for debugging. Note: the data structure is considered
6539 internal and thus subject to change without notice.
6541 =item CPAN::Module::as_glimpse()
6543 Returns a one-line description of the module
6545 =item CPAN::Module::as_string()
6547 Returns a multi-line description of the module
6549 =item CPAN::Module::clean()
6551 Runs a clean on the distribution associated with this module.
6553 =item CPAN::Module::cpan_file()
6555 Returns the filename on CPAN that is associated with the module.
6557 =item CPAN::Module::cpan_version()
6559 Returns the latest version of this module available on CPAN.
6561 =item CPAN::Module::cvs_import()
6563 Runs a cvs_import on the distribution associated with this module.
6565 =item CPAN::Module::description()
6567 Returns a 44 character description of this module. Only available for
6568 modules listed in The Module List (CPAN/modules/00modlist.long.html
6569 or 00modlist.long.txt.gz)
6571 =item CPAN::Module::force($method,@args)
6573 Forces CPAN to perform a task that normally would have failed. Force
6574 takes as arguments a method name to be called and any number of
6575 additional arguments that should be passed to the called method. The
6576 internals of the object get the needed changes so that CPAN.pm does
6577 not refuse to take the action.
6579 =item CPAN::Module::get()
6581 Runs a get on the distribution associated with this module.
6583 =item CPAN::Module::inst_file()
6585 Returns the filename of the module found in @INC. The first file found
6586 is reported just like perl itself stops searching @INC when it finds a
6589 =item CPAN::Module::inst_version()
6591 Returns the version number of the module in readable format.
6593 =item CPAN::Module::install()
6595 Runs an C<install> on the distribution associated with this module.
6597 =item CPAN::Module::look()
6599 Changes to the directory where the distribution associated with this
6600 module has been unpacked and opens a subshell there. Exiting the
6603 =item CPAN::Module::make()
6605 Runs a C<make> on the distribution associated with this module.
6607 =item CPAN::Module::manpage_headline()
6609 If module is installed, peeks into the module's manpage, reads the
6610 headline and returns it. Moreover, if the module has been downloaded
6611 within this session, does the equivalent on the downloaded module even
6612 if it is not installed.
6614 =item CPAN::Module::readme()
6616 Runs a C<readme> on the distribution associated with this module.
6618 =item CPAN::Module::test()
6620 Runs a C<test> on the distribution associated with this module.
6622 =item CPAN::Module::uptodate()
6624 Returns 1 if the module is installed and up-to-date.
6626 =item CPAN::Module::userid()
6628 Returns the author's ID of the module.
6632 =head2 Cache Manager
6634 Currently the cache manager only keeps track of the build directory
6635 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6636 deletes complete directories below C<build_dir> as soon as the size of
6637 all directories there gets bigger than $CPAN::Config->{build_cache}
6638 (in MB). The contents of this cache may be used for later
6639 re-installations that you intend to do manually, but will never be
6640 trusted by CPAN itself. This is due to the fact that the user might
6641 use these directories for building modules on different architectures.
6643 There is another directory ($CPAN::Config->{keep_source_where}) where
6644 the original distribution files are kept. This directory is not
6645 covered by the cache manager and must be controlled by the user. If
6646 you choose to have the same directory as build_dir and as
6647 keep_source_where directory, then your sources will be deleted with
6648 the same fifo mechanism.
6652 A bundle is just a perl module in the namespace Bundle:: that does not
6653 define any functions or methods. It usually only contains documentation.
6655 It starts like a perl module with a package declaration and a $VERSION
6656 variable. After that the pod section looks like any other pod with the
6657 only difference being that I<one special pod section> exists starting with
6662 In this pod section each line obeys the format
6664 Module_Name [Version_String] [- optional text]
6666 The only required part is the first field, the name of a module
6667 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6668 of the line is optional. The comment part is delimited by a dash just
6669 as in the man page header.
6671 The distribution of a bundle should follow the same convention as
6672 other distributions.
6674 Bundles are treated specially in the CPAN package. If you say 'install
6675 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6676 the modules in the CONTENTS section of the pod. You can install your
6677 own Bundles locally by placing a conformant Bundle file somewhere into
6678 your @INC path. The autobundle() command which is available in the
6679 shell interface does that for you by including all currently installed
6680 modules in a snapshot bundle file.
6682 =head2 Prerequisites
6684 If you have a local mirror of CPAN and can access all files with
6685 "file:" URLs, then you only need a perl better than perl5.003 to run
6686 this module. Otherwise Net::FTP is strongly recommended. LWP may be
6687 required for non-UNIX systems or if your nearest CPAN site is
6688 associated with a URL that is not C<ftp:>.
6690 If you have neither Net::FTP nor LWP, there is a fallback mechanism
6691 implemented for an external ftp command or for an external lynx
6694 =head2 Finding packages and VERSION
6696 This module presumes that all packages on CPAN
6702 declare their $VERSION variable in an easy to parse manner. This
6703 prerequisite can hardly be relaxed because it consumes far too much
6704 memory to load all packages into the running program just to determine
6705 the $VERSION variable. Currently all programs that are dealing with
6706 version use something like this
6708 perl -MExtUtils::MakeMaker -le \
6709 'print MM->parse_version(shift)' filename
6711 If you are author of a package and wonder if your $VERSION can be
6712 parsed, please try the above method.
6716 come as compressed or gzipped tarfiles or as zip files and contain a
6717 Makefile.PL (well, we try to handle a bit more, but without much
6724 The debugging of this module is a bit complex, because we have
6725 interferences of the software producing the indices on CPAN, of the
6726 mirroring process on CPAN, of packaging, of configuration, of
6727 synchronicity, and of bugs within CPAN.pm.
6729 For code debugging in interactive mode you can try "o debug" which
6730 will list options for debugging the various parts of the code. You
6731 should know that "o debug" has built-in completion support.
6733 For data debugging there is the C<dump> command which takes the same
6734 arguments as make/test/install and outputs the object's Data::Dumper
6737 =head2 Floppy, Zip, Offline Mode
6739 CPAN.pm works nicely without network too. If you maintain machines
6740 that are not networked at all, you should consider working with file:
6741 URLs. Of course, you have to collect your modules somewhere first. So
6742 you might use CPAN.pm to put together all you need on a networked
6743 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6744 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6745 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6746 with this floppy. See also below the paragraph about CD-ROM support.
6748 =head1 CONFIGURATION
6750 When the CPAN module is used for the first time, a configuration
6751 dialog tries to determine a couple of site specific options. The
6752 result of the dialog is stored in a hash reference C< $CPAN::Config >
6753 in a file CPAN/Config.pm.
6755 The default values defined in the CPAN/Config.pm file can be
6756 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6757 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6758 added to the search path of the CPAN module before the use() or
6759 require() statements.
6761 The configuration dialog can be started any time later again by
6762 issueing the command C< o conf init > in the CPAN shell.
6764 Currently the following keys in the hash reference $CPAN::Config are
6767 build_cache size of cache for directories to build modules
6768 build_dir locally accessible directory to build modules
6769 index_expire after this many days refetch index files
6770 cache_metadata use serializer to cache metadata
6771 cpan_home local directory reserved for this package
6772 dontload_hash anonymous hash: modules in the keys will not be
6773 loaded by the CPAN::has_inst() routine
6774 gzip location of external program gzip
6775 histfile file to maintain history between sessions
6776 histsize maximum number of lines to keep in histfile
6777 inactivity_timeout breaks interactive Makefile.PLs after this
6778 many seconds inactivity. Set to 0 to never break.
6779 inhibit_startup_message
6780 if true, does not print the startup message
6781 keep_source_where directory in which to keep the source (if we do)
6782 make location of external make program
6783 make_arg arguments that should always be passed to 'make'
6784 make_install_arg same as make_arg for 'make install'
6785 makepl_arg arguments passed to 'perl Makefile.PL'
6786 pager location of external program more (or any pager)
6787 prerequisites_policy
6788 what to do if you are missing module prerequisites
6789 ('follow' automatically, 'ask' me, or 'ignore')
6790 proxy_user username for accessing an authenticating proxy
6791 proxy_pass password for accessing an authenticating proxy
6792 scan_cache controls scanning of cache ('atstart' or 'never')
6793 tar location of external program tar
6794 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6795 (and nonsense for characters outside latin range)
6796 unzip location of external program unzip
6797 urllist arrayref to nearby CPAN sites (or equivalent locations)
6798 wait_list arrayref to a wait server to try (See CPAN::WAIT)
6799 ftp_proxy, } the three usual variables for configuring
6800 http_proxy, } proxy requests. Both as CPAN::Config variables
6801 no_proxy } and as environment variables configurable.
6803 You can set and query each of these options interactively in the cpan
6804 shell with the command set defined within the C<o conf> command:
6808 =item C<o conf E<lt>scalar optionE<gt>>
6810 prints the current value of the I<scalar option>
6812 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6814 Sets the value of the I<scalar option> to I<value>
6816 =item C<o conf E<lt>list optionE<gt>>
6818 prints the current value of the I<list option> in MakeMaker's
6821 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
6823 shifts or pops the array in the I<list option> variable
6825 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6827 works like the corresponding perl commands.
6831 =head2 Note on urllist parameter's format
6833 urllist parameters are URLs according to RFC 1738. We do a little
6834 guessing if your URL is not compliant, but if you have problems with
6835 file URLs, please try the correct format. Either:
6837 file://localhost/whatever/ftp/pub/CPAN/
6841 file:///home/ftp/pub/CPAN/
6843 =head2 urllist parameter has CD-ROM support
6845 The C<urllist> parameter of the configuration table contains a list of
6846 URLs that are to be used for downloading. If the list contains any
6847 C<file> URLs, CPAN always tries to get files from there first. This
6848 feature is disabled for index files. So the recommendation for the
6849 owner of a CD-ROM with CPAN contents is: include your local, possibly
6850 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6852 o conf urllist push file://localhost/CDROM/CPAN
6854 CPAN.pm will then fetch the index files from one of the CPAN sites
6855 that come at the beginning of urllist. It will later check for each
6856 module if there is a local copy of the most recent version.
6858 Another peculiarity of urllist is that the site that we could
6859 successfully fetch the last file from automatically gets a preference
6860 token and is tried as the first site for the next request. So if you
6861 add a new site at runtime it may happen that the previously preferred
6862 site will be tried another time. This means that if you want to disallow
6863 a site for the next transfer, it must be explicitly removed from
6868 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6869 install foreign, unmasked, unsigned code on your machine. We compare
6870 to a checksum that comes from the net just as the distribution file
6871 itself. If somebody has managed to tamper with the distribution file,
6872 they may have as well tampered with the CHECKSUMS file. Future
6873 development will go towards strong authentication.
6877 Most functions in package CPAN are exported per default. The reason
6878 for this is that the primary use is intended for the cpan shell or for
6881 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6883 Populating a freshly installed perl with my favorite modules is pretty
6884 easy if you maintain a private bundle definition file. To get a useful
6885 blueprint of a bundle definition file, the command autobundle can be used
6886 on the CPAN shell command line. This command writes a bundle definition
6887 file for all modules that are installed for the currently running perl
6888 interpreter. It's recommended to run this command only once and from then
6889 on maintain the file manually under a private name, say
6890 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6892 cpan> install Bundle::my_bundle
6894 then answer a few questions and then go out for a coffee.
6896 Maintaining a bundle definition file means keeping track of two
6897 things: dependencies and interactivity. CPAN.pm sometimes fails on
6898 calculating dependencies because not all modules define all MakeMaker
6899 attributes correctly, so a bundle definition file should specify
6900 prerequisites as early as possible. On the other hand, it's a bit
6901 annoying that many distributions need some interactive configuring. So
6902 what I try to accomplish in my private bundle file is to have the
6903 packages that need to be configured early in the file and the gentle
6904 ones later, so I can go out after a few minutes and leave CPAN.pm
6907 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6909 Thanks to Graham Barr for contributing the following paragraphs about
6910 the interaction between perl, and various firewall configurations. For
6911 further informations on firewalls, it is recommended to consult the
6912 documentation that comes with the ncftp program. If you are unable to
6913 go through the firewall with a simple Perl setup, it is very likely
6914 that you can configure ncftp so that it works for your firewall.
6916 =head2 Three basic types of firewalls
6918 Firewalls can be categorized into three basic types.
6924 This is where the firewall machine runs a web server and to access the
6925 outside world you must do it via the web server. If you set environment
6926 variables like http_proxy or ftp_proxy to a values beginning with http://
6927 or in your web browser you have to set proxy information then you know
6928 you are running an http firewall.
6930 To access servers outside these types of firewalls with perl (even for
6931 ftp) you will need to use LWP.
6935 This where the firewall machine runs an ftp server. This kind of
6936 firewall will only let you access ftp servers outside the firewall.
6937 This is usually done by connecting to the firewall with ftp, then
6938 entering a username like "user@outside.host.com"
6940 To access servers outside these type of firewalls with perl you
6941 will need to use Net::FTP.
6943 =item One way visibility
6945 I say one way visibility as these firewalls try to make themselves look
6946 invisible to the users inside the firewall. An FTP data connection is
6947 normally created by sending the remote server your IP address and then
6948 listening for the connection. But the remote server will not be able to
6949 connect to you because of the firewall. So for these types of firewall
6950 FTP connections need to be done in a passive mode.
6952 There are two that I can think off.
6958 If you are using a SOCKS firewall you will need to compile perl and link
6959 it with the SOCKS library, this is what is normally called a 'socksified'
6960 perl. With this executable you will be able to connect to servers outside
6961 the firewall as if it is not there.
6965 This is the firewall implemented in the Linux kernel, it allows you to
6966 hide a complete network behind one IP address. With this firewall no
6967 special compiling is needed as you can access hosts directly.
6969 For accessing ftp servers behind such firewalls you may need to set
6970 the environment variable C<FTP_PASSIVE> to a true value, e.g.
6972 env FTP_PASSIVE=1 perl -MCPAN -eshell
6976 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
6983 =head2 Configuring lynx or ncftp for going through a firewall
6985 If you can go through your firewall with e.g. lynx, presumably with a
6988 /usr/local/bin/lynx -pscott:tiger
6990 then you would configure CPAN.pm with the command
6992 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6994 That's all. Similarly for ncftp or ftp, you would configure something
6997 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6999 Your mileage may vary...
7007 I installed a new version of module X but CPAN keeps saying,
7008 I have the old version installed
7010 Most probably you B<do> have the old version installed. This can
7011 happen if a module installs itself into a different directory in the
7012 @INC path than it was previously installed. This is not really a
7013 CPAN.pm problem, you would have the same problem when installing the
7014 module manually. The easiest way to prevent this behaviour is to add
7015 the argument C<UNINST=1> to the C<make install> call, and that is why
7016 many people add this argument permanently by configuring
7018 o conf make_install_arg UNINST=1
7022 So why is UNINST=1 not the default?
7024 Because there are people who have their precise expectations about who
7025 may install where in the @INC path and who uses which @INC array. In
7026 fine tuned environments C<UNINST=1> can cause damage.
7030 I want to clean up my mess, and install a new perl along with
7031 all modules I have. How do I go about it?
7033 Run the autobundle command for your old perl and optionally rename the
7034 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7035 with the Configure option prefix, e.g.
7037 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7039 Install the bundle file you produced in the first step with something like
7041 cpan> install Bundle::mybundle
7047 When I install bundles or multiple modules with one command
7048 there is too much output to keep track of.
7050 You may want to configure something like
7052 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7053 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7055 so that STDOUT is captured in a file for later inspection.
7060 I am not root, how can I install a module in a personal directory?
7062 You will most probably like something like this:
7064 o conf makepl_arg "LIB=~/myperl/lib \
7065 INSTALLMAN1DIR=~/myperl/man/man1 \
7066 INSTALLMAN3DIR=~/myperl/man/man3"
7067 install Sybase::Sybperl
7069 You can make this setting permanent like all C<o conf> settings with
7072 You will have to add ~/myperl/man to the MANPATH environment variable
7073 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7076 use lib "$ENV{HOME}/myperl/lib";
7078 or setting the PERL5LIB environment variable.
7080 Another thing you should bear in mind is that the UNINST parameter
7081 should never be set if you are not root.
7085 How to get a package, unwrap it, and make a change before building it?
7087 look Sybase::Sybperl
7091 I installed a Bundle and had a couple of fails. When I
7092 retried, everything resolved nicely. Can this be fixed to work
7095 The reason for this is that CPAN does not know the dependencies of all
7096 modules when it starts out. To decide about the additional items to
7097 install, it just uses data found in the generated Makefile. An
7098 undetected missing piece breaks the process. But it may well be that
7099 your Bundle installs some prerequisite later than some depending item
7100 and thus your second try is able to resolve everything. Please note,
7101 CPAN.pm does not know the dependency tree in advance and cannot sort
7102 the queue of things to install in a topologically correct order. It
7103 resolves perfectly well IFF all modules declare the prerequisites
7104 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7105 fail and you need to install often, it is recommended sort the Bundle
7106 definition file manually. It is planned to improve the metadata
7107 situation for dependencies on CPAN in general, but this will still
7112 In our intranet we have many modules for internal use. How
7113 can I integrate these modules with CPAN.pm but without uploading
7114 the modules to CPAN?
7116 Have a look at the CPAN::Site module.
7120 When I run CPAN's shell, I get error msg about line 1 to 4,
7121 setting meta input/output via the /etc/inputrc file.
7123 Some versions of readline are picky about capitalization in the
7124 /etc/inputrc file and specifically RedHat 6.2 comes with a
7125 /etc/inputrc that contains the word C<on> in lowercase. Change the
7126 occurrences of C<on> to C<On> and the bug should disappear.
7130 Some authors have strange characters in their names.
7132 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7133 expecting ISO-8859-1 charset, a converter can be activated by setting
7134 term_is_latin to a true value in your config file. One way of doing so
7137 cpan> ! $CPAN::Config->{term_is_latin}=1
7139 Extended support for converters will be made available as soon as perl
7140 becomes stable with regard to charset issues.
7146 We should give coverage for B<all> of the CPAN and not just the PAUSE
7147 part, right? In this discussion CPAN and PAUSE have become equal --
7148 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7149 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7151 Future development should be directed towards a better integration of
7154 If a Makefile.PL requires special customization of libraries, prompts
7155 the user for special input, etc. then you may find CPAN is not able to
7156 build the distribution. In that case, you should attempt the
7157 traditional method of building a Perl module package from a shell.
7161 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7165 Kawai,Takanori provides a Japanese translation of this manpage at
7166 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7170 perl(1), CPAN::Nox(3)