1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
4 $VERSION = eval $VERSION;
12 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
13 use File::Basename ();
19 use Text::ParseWords ();
24 no lib "."; # we need to run chdir all over and we would get at wrong
27 require Mac::BuildTools if $^O eq 'MacOS';
29 END { $End++; &cleanup; }
52 $CPAN::Frontend ||= "CPAN::Shell";
53 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
54 $CPAN::Perl ||= CPAN::find_perl();
55 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
56 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
62 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
63 $Signal $End $Suppress_readline $Frontend
64 $Defaultsite $Have_warned $Defaultdocs $Defaultrecent
67 @CPAN::ISA = qw(CPAN::Debug Exporter);
70 autobundle bundle expand force notest get cvs_import
71 install make readme recompile shell test clean
75 #-> sub CPAN::AUTOLOAD ;
80 @EXPORT{@EXPORT} = '';
81 CPAN::Config->load unless $CPAN::Config_loaded++;
82 if (exists $EXPORT{$l}){
85 $CPAN::Frontend->mywarn(qq{Unknown CPAN command "$AUTOLOAD". }.
95 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
96 CPAN::Config->load unless $CPAN::Config_loaded++;
98 my $oprompt = shift || "cpan> ";
99 my $prompt = $oprompt;
100 my $commandline = shift || "";
103 unless ($Suppress_readline) {
104 require Term::ReadLine;
107 $term->ReadLine eq "Term::ReadLine::Stub"
109 $term = Term::ReadLine->new('CPAN Monitor');
111 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
112 my $attribs = $term->Attribs;
113 $attribs->{attempted_completion_function} = sub {
114 &CPAN::Complete::gnu_cpl;
117 $readline::rl_completion_function =
118 $readline::rl_completion_function = 'CPAN::Complete::cpl';
120 if (my $histfile = $CPAN::Config->{'histfile'}) {{
121 unless ($term->can("AddHistory")) {
122 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
125 my($fh) = FileHandle->new;
126 open $fh, "<$histfile" or last;
130 $term->AddHistory($_);
134 # $term->OUT is autoflushed anyway
135 my $odef = select STDERR;
142 # no strict; # I do not recall why no strict was here (2000-09-03)
144 my $cwd = CPAN::anycwd();
145 my $try_detect_readline;
146 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
147 my $rl_avail = $Suppress_readline ? "suppressed" :
148 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
149 "available (try 'install Bundle::CPAN')";
151 $CPAN::Frontend->myprint(
153 cpan shell -- CPAN exploration and modules installation (v%s)
160 unless $CPAN::Config->{'inhibit_startup_message'} ;
161 my($continuation) = "";
162 SHELLCOMMAND: while () {
163 if ($Suppress_readline) {
165 last SHELLCOMMAND unless defined ($_ = <> );
168 last SHELLCOMMAND unless
169 defined ($_ = $term->readline($prompt, $commandline));
171 $_ = "$continuation$_" if $continuation;
173 next SHELLCOMMAND if /^$/;
174 $_ = 'h' if /^\s*\?/;
175 if (/^(?:q(?:uit)?|bye|exit)$/i) {
185 use vars qw($import_done);
186 CPAN->import(':DEFAULT') unless $import_done++;
187 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
194 if ($] < 5.00322) { # parsewords had a bug until recently
197 eval { @line = Text::ParseWords::shellwords($_) };
198 warn($@), next SHELLCOMMAND if $@;
199 warn("Text::Parsewords could not parse the line [$_]"),
200 next SHELLCOMMAND unless @line;
202 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
203 my $command = shift @line;
204 eval { CPAN::Shell->$command(@line) };
206 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
207 $CPAN::Frontend->myprint("\n");
212 $commandline = ""; # I do want to be able to pass a default to
213 # shell, but on the second command I see no
216 CPAN::Queue->nullify_queue;
217 if ($try_detect_readline) {
218 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
220 $CPAN::META->has_inst("Term::ReadLine::Perl")
222 delete $INC{"Term/ReadLine.pm"};
224 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
225 require Term::ReadLine;
226 $CPAN::Frontend->myprint("\n$redef subroutines in ".
227 "Term::ReadLine redefined\n");
233 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
236 package CPAN::CacheMgr;
237 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
240 package CPAN::Config;
241 use vars qw(%can %keys $dot_cpan);
244 'commit' => "Commit changes to disk",
245 'defaults' => "Reload defaults from disk",
246 'init' => "Interactive setting of all options",
249 %keys = map { $_ => undef } qw(
250 build_cache build_dir
251 cache_metadata cpan_home curl
255 histfile histsize http_proxy
256 inactivity_timeout index_expire inhibit_startup_message
259 make make_arg make_install_arg make_install_make_command makepl_arg
260 ncftp ncftpget no_proxy pager
262 scan_cache shell show_upload_date
269 use vars qw($Ua $Thesite $Themethod);
270 @CPAN::FTP::ISA = qw(CPAN::Debug);
272 package CPAN::LWP::UserAgent;
273 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
274 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
276 package CPAN::Complete;
277 @CPAN::Complete::ISA = qw(CPAN::Debug);
278 @CPAN::Complete::COMMANDS = sort qw(
279 ! a b d h i m o q r u autobundle clean dump
280 make test install force readme reload look
281 cvs_import ls perldoc recent
282 ) unless @CPAN::Complete::COMMANDS;
285 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
286 @CPAN::Index::ISA = qw(CPAN::Debug);
289 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
292 package CPAN::InfoObj;
293 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
295 package CPAN::Author;
296 @CPAN::Author::ISA = qw(CPAN::InfoObj);
298 package CPAN::Distribution;
299 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
301 package CPAN::Bundle;
302 @CPAN::Bundle::ISA = qw(CPAN::Module);
304 package CPAN::Module;
305 @CPAN::Module::ISA = qw(CPAN::InfoObj);
307 package CPAN::Exception::RecursiveDependency;
308 use overload '""' => "as_string";
315 for my $dep (@$deps) {
317 last if $seen{$dep}++;
319 bless { deps => \@deps }, $class;
324 "\nRecursive dependency detected:\n " .
325 join("\n => ", @{$self->{deps}}) .
326 ".\nCannot continue.\n";
330 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
331 @CPAN::Shell::ISA = qw(CPAN::Debug);
332 $COLOR_REGISTERED ||= 0;
333 $PRINT_ORNAMENTING ||= 0;
335 #-> sub CPAN::Shell::AUTOLOAD ;
337 my($autoload) = $AUTOLOAD;
338 my $class = shift(@_);
339 # warn "autoload[$autoload] class[$class]";
340 $autoload =~ s/.*:://;
341 if ($autoload =~ /^w/) {
342 if ($CPAN::META->has_inst('CPAN::WAIT')) {
343 CPAN::WAIT->$autoload(@_);
345 $CPAN::Frontend->mywarn(qq{
346 Commands starting with "w" require CPAN::WAIT to be installed.
347 Please consider installing CPAN::WAIT to use the fulltext index.
348 For this you just need to type
353 $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload'. }.
359 package CPAN::Tarzip;
360 use vars qw($AUTOLOAD @ISA $BUGHUNTING);
361 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
362 $BUGHUNTING = 0; # released code must have turned off
366 # One use of the queue is to determine if we should or shouldn't
367 # announce the availability of a new CPAN module
369 # Now we try to use it for dependency tracking. For that to happen
370 # we need to draw a dependency tree and do the leaves first. This can
371 # easily be reached by running CPAN.pm recursively, but we don't want
372 # to waste memory and run into deep recursion. So what we can do is
375 # CPAN::Queue is the package where the queue is maintained. Dependencies
376 # often have high priority and must be brought to the head of the queue,
377 # possibly by jumping the queue if they are already there. My first code
378 # attempt tried to be extremely correct. Whenever a module needed
379 # immediate treatment, I either unshifted it to the front of the queue,
380 # or, if it was already in the queue, I spliced and let it bypass the
381 # others. This became a too correct model that made it impossible to put
382 # an item more than once into the queue. Why would you need that? Well,
383 # you need temporary duplicates as the manager of the queue is a loop
386 # (1) looks at the first item in the queue without shifting it off
388 # (2) cares for the item
390 # (3) removes the item from the queue, *even if its agenda failed and
391 # even if the item isn't the first in the queue anymore* (that way
392 # protecting against never ending queues)
394 # So if an item has prerequisites, the installation fails now, but we
395 # want to retry later. That's easy if we have it twice in the queue.
397 # I also expect insane dependency situations where an item gets more
398 # than two lives in the queue. Simplest example is triggered by 'install
399 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
400 # get in the way. I wanted the queue manager to be a dumb servant, not
401 # one that knows everything.
403 # Who would I tell in this model that the user wants to be asked before
404 # processing? I can't attach that information to the module object,
405 # because not modules are installed but distributions. So I'd have to
406 # tell the distribution object that it should ask the user before
407 # processing. Where would the question be triggered then? Most probably
408 # in CPAN::Distribution::rematein.
409 # Hope that makes sense, my head is a bit off:-) -- AK
416 my $self = bless { qmod => $s }, $class;
421 # CPAN::Queue::first ;
427 # CPAN::Queue::delete_first ;
429 my($class,$what) = @_;
431 for my $i (0..$#All) {
432 if ( $All[$i]->{qmod} eq $what ) {
439 # CPAN::Queue::jumpqueue ;
443 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
444 join(",",map {$_->{qmod}} @All),
447 WHAT: for my $what (reverse @what) {
449 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
450 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
451 if ($All[$i]->{qmod} eq $what){
453 if ($jumped > 100) { # one's OK if e.g. just
454 # processing now; more are OK if
455 # user typed it several times
456 $CPAN::Frontend->mywarn(
457 qq{Object [$what] queued more than 100 times, ignoring}
463 my $obj = bless { qmod => $what }, $class;
466 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
467 join(",",map {$_->{qmod}} @All),
472 # CPAN::Queue::exists ;
474 my($self,$what) = @_;
475 my @all = map { $_->{qmod} } @All;
476 my $exists = grep { $_->{qmod} eq $what } @All;
477 # warn "in exists what[$what] all[@all] exists[$exists]";
481 # CPAN::Queue::delete ;
484 @All = grep { $_->{qmod} ne $mod } @All;
487 # CPAN::Queue::nullify_queue ;
496 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
498 # from here on only subs.
499 ################################################################################
501 #-> sub CPAN::all_objects ;
503 my($mgr,$class) = @_;
504 CPAN::Config->load unless $CPAN::Config_loaded++;
505 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
507 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
509 *all = \&all_objects;
511 # Called by shell, not in batch mode. In batch mode I see no risk in
512 # having many processes updating something as installations are
513 # continually checked at runtime. In shell mode I suspect it is
514 # unintentional to open more than one shell at a time
516 #-> sub CPAN::checklock ;
519 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
520 if (-f $lockfile && -M _ > 0) {
521 my $fh = FileHandle->new($lockfile) or
522 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
523 my $otherpid = <$fh>;
524 my $otherhost = <$fh>;
526 if (defined $otherpid && $otherpid) {
529 if (defined $otherhost && $otherhost) {
532 my $thishost = hostname();
533 if (defined $otherhost && defined $thishost &&
534 $otherhost ne '' && $thishost ne '' &&
535 $otherhost ne $thishost) {
536 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
537 "reports other host $otherhost and other process $otherpid.\n".
538 "Cannot proceed.\n"));
540 elsif (defined $otherpid && $otherpid) {
541 return if $$ == $otherpid; # should never happen
542 $CPAN::Frontend->mywarn(
544 There seems to be running another CPAN process (pid $otherpid). Contacting...
546 if (kill 0, $otherpid) {
547 $CPAN::Frontend->mydie(qq{Other job is running.
548 You may want to kill it and delete the lockfile, maybe. On UNIX try:
552 } elsif (-w $lockfile) {
554 ExtUtils::MakeMaker::prompt
555 (qq{Other job not responding. Shall I overwrite }.
556 qq{the lockfile? (Y/N)},"y");
557 $CPAN::Frontend->myexit("Ok, bye\n")
558 unless $ans =~ /^y/i;
561 qq{Lockfile $lockfile not writeable by you. }.
562 qq{Cannot proceed.\n}.
565 qq{ and then rerun us.\n}
569 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
570 "reports other process with ID ".
571 "$otherpid. Cannot proceed.\n"));
574 my $dotcpan = $CPAN::Config->{cpan_home};
575 eval { File::Path::mkpath($dotcpan);};
577 # A special case at least for Jarkko.
582 $symlinkcpan = readlink $dotcpan;
583 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
584 eval { File::Path::mkpath($symlinkcpan); };
588 $CPAN::Frontend->mywarn(qq{
589 Working directory $symlinkcpan created.
593 unless (-d $dotcpan) {
595 Your configuration suggests "$dotcpan" as your
596 CPAN.pm working directory. I could not create this directory due
597 to this error: $firsterror\n};
599 As "$dotcpan" is a symlink to "$symlinkcpan",
600 I tried to create that, but I failed with this error: $seconderror
603 Please make sure the directory exists and is writable.
605 $CPAN::Frontend->mydie($diemess);
609 unless ($fh = FileHandle->new(">$lockfile")) {
610 if ($! =~ /Permission/) {
611 my $incc = $INC{'CPAN/Config.pm'};
612 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
613 $CPAN::Frontend->myprint(qq{
615 Your configuration suggests that CPAN.pm should use a working
617 $CPAN::Config->{cpan_home}
618 Unfortunately we could not create the lock file
620 due to permission problems.
622 Please make sure that the configuration variable
623 \$CPAN::Config->{cpan_home}
624 points to a directory where you can write a .lock file. You can set
625 this variable in either
632 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
634 $fh->print($$, "\n");
635 $fh->print(hostname(), "\n");
636 $self->{LOCK} = $lockfile;
640 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
645 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
646 print "Caught SIGINT\n";
650 # From: Larry Wall <larry@wall.org>
651 # Subject: Re: deprecating SIGDIE
652 # To: perl5-porters@perl.org
653 # Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
655 # The original intent of __DIE__ was only to allow you to substitute one
656 # kind of death for another on an application-wide basis without respect
657 # to whether you were in an eval or not. As a global backstop, it should
658 # not be used any more lightly (or any more heavily :-) than class
659 # UNIVERSAL. Any attempt to build a general exception model on it should
660 # be politely squashed. Any bug that causes every eval {} to have to be
661 # modified should be not so politely squashed.
663 # Those are my current opinions. It is also my optinion that polite
664 # arguments degenerate to personal arguments far too frequently, and that
665 # when they do, it's because both people wanted it to, or at least didn't
666 # sufficiently want it not to.
670 # global backstop to cleanup if we should really die
671 $SIG{__DIE__} = \&cleanup;
672 $self->debug("Signal handler set.") if $CPAN::DEBUG;
675 #-> sub CPAN::DESTROY ;
677 &cleanup; # need an eval?
680 #-> sub CPAN::anycwd ;
683 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
688 sub cwd {Cwd::cwd();}
690 #-> sub CPAN::getcwd ;
691 sub getcwd {Cwd::getcwd();}
693 #-> sub CPAN::find_perl ;
695 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
696 my $pwd = CPAN::anycwd();
697 my $candidate = File::Spec->catfile($pwd,$^X);
698 $perl ||= $candidate if MM->maybe_command($candidate);
701 my ($component,$perl_name);
702 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
703 PATH_COMPONENT: foreach $component (File::Spec->path(),
704 $Config::Config{'binexp'}) {
705 next unless defined($component) && $component;
706 my($abs) = File::Spec->catfile($component,$perl_name);
707 if (MM->maybe_command($abs)) {
719 #-> sub CPAN::exists ;
721 my($mgr,$class,$id) = @_;
722 CPAN::Config->load unless $CPAN::Config_loaded++;
724 ### Carp::croak "exists called without class argument" unless $class;
726 exists $META->{readonly}{$class}{$id} or
727 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
730 #-> sub CPAN::delete ;
732 my($mgr,$class,$id) = @_;
733 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
734 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
737 #-> sub CPAN::has_usable
738 # has_inst is sometimes too optimistic, we should replace it with this
739 # has_usable whenever a case is given
741 my($self,$mod,$message) = @_;
742 return 1 if $HAS_USABLE->{$mod};
743 my $has_inst = $self->has_inst($mod,$message);
744 return unless $has_inst;
747 LWP => [ # we frequently had "Can't locate object
748 # method "new" via package "LWP::UserAgent" at
749 # (eval 69) line 2006
751 sub {require LWP::UserAgent},
752 sub {require HTTP::Request},
753 sub {require URI::URL},
756 sub {require Net::FTP},
757 sub {require Net::Config},
760 if ($usable->{$mod}) {
761 for my $c (0..$#{$usable->{$mod}}) {
762 my $code = $usable->{$mod}[$c];
763 my $ret = eval { &$code() };
765 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
770 return $HAS_USABLE->{$mod} = 1;
773 #-> sub CPAN::has_inst
775 my($self,$mod,$message) = @_;
776 Carp::croak("CPAN->has_inst() called without an argument")
778 if (defined $message && $message eq "no"
780 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
782 exists $CPAN::Config->{dontload_hash}{$mod}
784 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
792 # checking %INC is wrong, because $INC{LWP} may be true
793 # although $INC{"URI/URL.pm"} may have failed. But as
794 # I really want to say "bla loaded OK", I have to somehow
796 ### warn "$file in %INC"; #debug
798 } elsif (eval { require $file }) {
799 # eval is good: if we haven't yet read the database it's
800 # perfect and if we have installed the module in the meantime,
801 # it tries again. The second require is only a NOOP returning
802 # 1 if we had success, otherwise it's retrying
804 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
805 if ($mod eq "CPAN::WAIT") {
806 push @CPAN::Shell::ISA, CPAN::WAIT;
809 } elsif ($mod eq "Net::FTP") {
810 $CPAN::Frontend->mywarn(qq{
811 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
813 install Bundle::libnet
815 }) unless $Have_warned->{"Net::FTP"}++;
817 } elsif ($mod eq "Digest::MD5"){
818 $CPAN::Frontend->myprint(qq{
819 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
820 Please consider installing the Digest::MD5 module.
824 } elsif ($mod eq "Module::Signature"){
825 unless ($Have_warned->{"Module::Signature"}++) {
826 # No point in complaining unless the user can
827 # reasonably install and use it.
828 if (eval { require Crypt::OpenPGP; 1 } ||
829 defined $CPAN::Config->{'gpg'}) {
830 $CPAN::Frontend->myprint(qq{
831 CPAN: Module::Signature security checks disabled because Module::Signature
832 not installed. Please consider installing the Module::Signature module.
833 You may also need to be able to connect over the Internet to the public
834 keyservers like pgp.mit.edu (port 11371).
841 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
846 #-> sub CPAN::instance ;
848 my($mgr,$class,$id) = @_;
851 # unsafe meta access, ok?
852 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
853 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
861 #-> sub CPAN::cleanup ;
863 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
864 local $SIG{__DIE__} = '';
869 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
871 $subroutine eq '(eval)';
873 return if $ineval && !$End;
874 return unless defined $META->{LOCK};
875 return unless -f $META->{LOCK};
877 unlink $META->{LOCK};
879 # Carp::cluck("DEBUGGING");
880 $CPAN::Frontend->mywarn("Lockfile removed.\n");
883 #-> sub CPAN::savehist
886 my($histfile,$histsize);
887 unless ($histfile = $CPAN::Config->{'histfile'}){
888 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
891 $histsize = $CPAN::Config->{'histsize'} || 100;
893 unless ($CPAN::term->can("GetHistory")) {
894 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
900 my @h = $CPAN::term->GetHistory;
901 splice @h, 0, @h-$histsize if @h>$histsize;
902 my($fh) = FileHandle->new;
903 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
904 local $\ = local $, = "\n";
910 my($self,$what) = @_;
911 $self->{is_tested}{$what} = 1;
915 my($self,$what) = @_;
916 delete $self->{is_tested}{$what};
921 $self->{is_tested} ||= {};
922 return unless %{$self->{is_tested}};
923 my $env = $ENV{PERL5LIB};
924 $env = $ENV{PERLLIB} unless defined $env;
926 push @env, $env if defined $env and length $env;
927 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
928 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
929 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
932 package CPAN::CacheMgr;
934 #-> sub CPAN::CacheMgr::as_string ;
936 eval { require Data::Dumper };
938 return shift->SUPER::as_string;
940 return Data::Dumper::Dumper(shift);
944 #-> sub CPAN::CacheMgr::cachesize ;
949 #-> sub CPAN::CacheMgr::tidyup ;
952 return unless -d $self->{ID};
953 while ($self->{DU} > $self->{'MAX'} ) {
954 my($toremove) = shift @{$self->{FIFO}};
955 $CPAN::Frontend->myprint(sprintf(
956 "Deleting from cache".
957 ": $toremove (%.1f>%.1f MB)\n",
958 $self->{DU}, $self->{'MAX'})
960 return if $CPAN::Signal;
961 $self->force_clean_cache($toremove);
962 return if $CPAN::Signal;
966 #-> sub CPAN::CacheMgr::dir ;
971 #-> sub CPAN::CacheMgr::entries ;
974 return unless defined $dir;
975 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
976 $dir ||= $self->{ID};
977 my($cwd) = CPAN::anycwd();
978 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
979 my $dh = DirHandle->new(File::Spec->curdir)
980 or Carp::croak("Couldn't opendir $dir: $!");
983 next if $_ eq "." || $_ eq "..";
985 push @entries, File::Spec->catfile($dir,$_);
987 push @entries, File::Spec->catdir($dir,$_);
989 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
992 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
993 sort { -M $b <=> -M $a} @entries;
996 #-> sub CPAN::CacheMgr::disk_usage ;
999 return if exists $self->{SIZE}{$dir};
1000 return if $CPAN::Signal;
1004 $File::Find::prune++ if $CPAN::Signal;
1006 if ($^O eq 'MacOS') {
1008 my $cat = Mac::Files::FSpGetCatInfo($_);
1009 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1016 return if $CPAN::Signal;
1017 $self->{SIZE}{$dir} = $Du/1024/1024;
1018 push @{$self->{FIFO}}, $dir;
1019 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1020 $self->{DU} += $Du/1024/1024;
1024 #-> sub CPAN::CacheMgr::force_clean_cache ;
1025 sub force_clean_cache {
1026 my($self,$dir) = @_;
1027 return unless -e $dir;
1028 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1030 File::Path::rmtree($dir);
1031 $self->{DU} -= $self->{SIZE}{$dir};
1032 delete $self->{SIZE}{$dir};
1035 #-> sub CPAN::CacheMgr::new ;
1042 ID => $CPAN::Config->{'build_dir'},
1043 MAX => $CPAN::Config->{'build_cache'},
1044 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1047 File::Path::mkpath($self->{ID});
1048 my $dh = DirHandle->new($self->{ID});
1049 bless $self, $class;
1052 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1054 CPAN->debug($debug) if $CPAN::DEBUG;
1058 #-> sub CPAN::CacheMgr::scan_cache ;
1061 return if $self->{SCAN} eq 'never';
1062 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1063 unless $self->{SCAN} eq 'atstart';
1064 $CPAN::Frontend->myprint(
1065 sprintf("Scanning cache %s for sizes\n",
1068 for $e ($self->entries($self->{ID})) {
1069 next if $e eq ".." || $e eq ".";
1070 $self->disk_usage($e);
1071 return if $CPAN::Signal;
1076 package CPAN::Debug;
1078 #-> sub CPAN::Debug::debug ;
1080 my($self,$arg) = @_;
1081 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
1082 # Complete, caller(1)
1084 ($caller) = caller(0);
1085 $caller =~ s/.*:://;
1086 $arg = "" unless defined $arg;
1087 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
1088 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
1089 if ($arg and ref $arg) {
1090 eval { require Data::Dumper };
1092 $CPAN::Frontend->myprint($arg->as_string);
1094 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
1097 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
1102 package CPAN::Config;
1104 #-> sub CPAN::Config::edit ;
1105 # returns true on successful action
1107 my($self,@args) = @_;
1108 return unless @args;
1109 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
1110 my($o,$str,$func,$args,$key_exists);
1116 CPAN->debug("o[$o]") if $CPAN::DEBUG;
1117 unless (exists $keys{$o}) {
1118 $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
1120 if ($o =~ /list$/) {
1121 $func = shift @args;
1123 CPAN->debug("func[$func]") if $CPAN::DEBUG;
1125 # Let's avoid eval, it's easier to comprehend without.
1126 if ($func eq "push") {
1127 push @{$CPAN::Config->{$o}}, @args;
1129 } elsif ($func eq "pop") {
1130 pop @{$CPAN::Config->{$o}};
1132 } elsif ($func eq "shift") {
1133 shift @{$CPAN::Config->{$o}};
1135 } elsif ($func eq "unshift") {
1136 unshift @{$CPAN::Config->{$o}}, @args;
1138 } elsif ($func eq "splice") {
1139 splice @{$CPAN::Config->{$o}}, @args;
1142 $CPAN::Config->{$o} = [@args];
1145 $self->prettyprint($o);
1147 if ($o eq "urllist" && $changed) {
1148 # reset the cached values
1149 undef $CPAN::FTP::Thesite;
1150 undef $CPAN::FTP::Themethod;
1154 $CPAN::Config->{$o} = $args[0] if defined $args[0];
1155 $self->prettyprint($o);
1162 my $v = $CPAN::Config->{$k};
1164 my(@report) = ref $v eq "ARRAY" ?
1166 map { sprintf(" %-18s => [%s]\n",
1168 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1170 $CPAN::Frontend->myprint(
1177 map {"\t[$_]\n"} @report
1180 } elsif (defined $v) {
1181 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1183 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, "UNDEFINED");
1187 #-> sub CPAN::Config::commit ;
1189 my($self,$configpm) = @_;
1190 unless (defined $configpm){
1191 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1192 $configpm ||= $INC{"CPAN/Config.pm"};
1193 $configpm || Carp::confess(q{
1194 CPAN::Config::commit called without an argument.
1195 Please specify a filename where to save the configuration or try
1196 "o conf init" to have an interactive course through configing.
1201 $mode = (stat $configpm)[2];
1202 if ($mode && ! -w _) {
1203 Carp::confess("$configpm is not writable");
1208 $msg = <<EOF unless $configpm =~ /MyConfig/;
1210 # This is CPAN.pm's systemwide configuration file. This file provides
1211 # defaults for users, and the values can be changed in a per-user
1212 # configuration file. The user-config file is being looked for as
1213 # ~/.cpan/CPAN/MyConfig.pm.
1217 my($fh) = FileHandle->new;
1218 rename $configpm, "$configpm~" if -f $configpm;
1219 open $fh, ">$configpm" or
1220 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1221 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1222 foreach (sort keys %$CPAN::Config) {
1225 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1230 $fh->print("};\n1;\n__END__\n");
1233 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1234 #chmod $mode, $configpm;
1235 ###why was that so? $self->defaults;
1236 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1240 *default = \&defaults;
1241 #-> sub CPAN::Config::defaults ;
1251 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1260 # This is a piece of repeated code that is abstracted here for
1261 # maintainability. RMB
1264 my($configpmdir, $configpmtest) = @_;
1265 if (-w $configpmtest) {
1266 return $configpmtest;
1267 } elsif (-w $configpmdir) {
1268 #_#_# following code dumped core on me with 5.003_11, a.k.
1269 my $configpm_bak = "$configpmtest.bak";
1270 unlink $configpm_bak if -f $configpm_bak;
1271 if( -f $configpmtest ) {
1272 if( rename $configpmtest, $configpm_bak ) {
1273 $CPAN::Frontend->mywarn(<<END);
1274 Old configuration file $configpmtest
1275 moved to $configpm_bak
1279 my $fh = FileHandle->new;
1280 if ($fh->open(">$configpmtest")) {
1282 return $configpmtest;
1284 # Should never happen
1285 Carp::confess("Cannot open >$configpmtest");
1290 #-> sub CPAN::Config::load ;
1292 my($self, %args) = [at]_;
1293 $CPAN::Be_Silent++ if $args{be_silent};
1297 eval {require CPAN::Config;}; # We eval because of some
1298 # MakeMaker problems
1299 unless ($dot_cpan++){
1300 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1301 eval {require CPAN::MyConfig;}; # where you can override
1302 # system wide settings
1305 return unless @miss = $self->missing_config_data;
1307 require CPAN::FirstTime;
1308 my($configpm,$fh,$redo,$theycalled);
1310 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1311 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1312 $configpm = $INC{"CPAN/Config.pm"};
1314 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1315 $configpm = $INC{"CPAN/MyConfig.pm"};
1318 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1319 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1320 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1321 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1322 $configpm = _configpmtest($configpmdir,$configpmtest);
1324 unless ($configpm) {
1325 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1326 File::Path::mkpath($configpmdir);
1327 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1328 $configpm = _configpmtest($configpmdir,$configpmtest);
1329 unless ($configpm) {
1330 my $text = qq{WARNING: CPAN.pm is unable to } .
1331 qq{create a configuration file.};
1332 output($text, 'confess');
1337 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1338 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1342 $CPAN::Frontend->myprint(qq{
1343 $configpm initialized.
1347 CPAN::FirstTime::init($configpm, %args);
1350 #-> sub CPAN::Config::missing_config_data ;
1351 sub missing_config_data {
1354 "cpan_home", "keep_source_where", "build_dir", "build_cache",
1355 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1357 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1358 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1359 "prerequisites_policy",
1362 push @miss, $_ unless defined $CPAN::Config->{$_};
1367 #-> sub CPAN::Config::unload ;
1369 delete $INC{'CPAN/MyConfig.pm'};
1370 delete $INC{'CPAN/Config.pm'};
1373 #-> sub CPAN::Config::help ;
1375 $CPAN::Frontend->myprint(q[
1377 defaults reload default config values from disk
1378 commit commit session changes to disk
1379 init go through a dialog to set all parameters
1381 You may edit key values in the follow fashion (the "o" is a literal
1384 o conf build_cache 15
1386 o conf build_dir "/foo/bar"
1388 o conf urllist shift
1390 o conf urllist unshift ftp://ftp.foo.bar/
1393 undef; #don't reprint CPAN::Config
1396 #-> sub CPAN::Config::cpl ;
1398 my($word,$line,$pos) = @_;
1400 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1401 my(@words) = split " ", substr($line,0,$pos+1);
1406 $words[2] =~ /list$/ && @words == 3
1408 $words[2] =~ /list$/ && @words == 4 && length($word)
1411 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1412 } elsif (@words >= 4) {
1416 my(@o_conf) = sort grep { !$seen{$_}++ }
1417 keys %CPAN::Config::can,
1418 keys %$CPAN::Config,
1419 keys %CPAN::Config::keys;
1420 return grep /^\Q$word\E/, @o_conf;
1423 package CPAN::Shell;
1425 #-> sub CPAN::Shell::h ;
1427 my($class,$about) = @_;
1428 if (defined $about) {
1429 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1431 $CPAN::Frontend->myprint(q{
1433 command argument description
1434 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1435 i WORD or /REGEXP/ about any of the above
1436 r NONE report updatable modules
1437 ls AUTHOR about files in the author's directory
1438 recent NONE latest CPAN uploads
1440 Download, Test, Make, Install...
1442 make make (implies get)
1443 test MODULES, make test (implies make)
1444 install DISTS, BUNDLES make install (implies test)
1446 look open subshell in these dists' directories
1447 readme display these dists' README files
1448 perldoc display module's POD documentation
1451 h,? display this menu ! perl-code eval a perl command
1452 o conf [opt] set and query options q quit the cpan shell
1453 reload cpan load CPAN.pm again reload index load newer indices
1454 autobundle Snapshot force cmd unconditionally do cmd});
1460 #-> sub CPAN::Shell::a ;
1462 my($self,@arg) = @_;
1463 # authors are always UPPERCASE
1465 $_ = uc $_ unless /=/;
1467 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1470 #-> sub CPAN::Shell::ls ;
1472 my($self,@arg) = @_;
1474 if ($arg[0] eq "*") {
1475 @arg = map { $_->id } $self->expand('Author','/./');
1478 unless (/^[A-Z0-9\-]+$/i) {
1479 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1482 push @accept, uc $_;
1484 my $silent = @accept>1;
1485 my $last_alpha = "";
1486 for my $a (@accept){
1487 my $author = $self->expand('Author',$a) or die "No author found for $a";
1488 $author->ls($silent); # silent if more than one author
1490 my $alphadot = substr $author->id, 0, 1;
1492 if ($alphadot eq $last_alpha) {
1496 $last_alpha = $alphadot;
1498 $CPAN::Frontend->myprint($ad);
1503 #-> sub CPAN::Shell::local_bundles ;
1505 my($self,@which) = @_;
1506 my($incdir,$bdir,$dh);
1507 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1508 my @bbase = "Bundle";
1509 while (my $bbase = shift @bbase) {
1510 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1511 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1512 if ($dh = DirHandle->new($bdir)) { # may fail
1514 for $entry ($dh->read) {
1515 next if $entry =~ /^\./;
1516 if (-d File::Spec->catdir($bdir,$entry)){
1517 push @bbase, "$bbase\::$entry";
1519 next unless $entry =~ s/\.pm(?!\n)\Z//;
1520 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1528 #-> sub CPAN::Shell::b ;
1530 my($self,@which) = @_;
1531 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1532 $self->local_bundles;
1533 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1536 #-> sub CPAN::Shell::d ;
1537 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1539 #-> sub CPAN::Shell::m ;
1540 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1542 $CPAN::Frontend->myprint($self->format_result('Module',@_));
1545 #-> sub CPAN::Shell::i ;
1549 @args = '/./' unless @args;
1551 for my $type (qw/Bundle Distribution Module/) {
1552 push @result, $self->expand($type,@args);
1554 # Authors are always uppercase.
1555 push @result, $self->expand("Author", map { uc $_ } @args);
1557 my $result = @result == 1 ?
1558 $result[0]->as_string :
1560 "No objects found of any type for argument @args\n" :
1562 (map {$_->as_glimpse} @result),
1563 scalar @result, " items found\n",
1565 $CPAN::Frontend->myprint($result);
1568 #-> sub CPAN::Shell::o ;
1570 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1571 # should have been called set and 'o debug' maybe 'set debug'
1573 my($self,$o_type,@o_what) = @_;
1575 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1576 if ($o_type eq 'conf') {
1577 shift @o_what if @o_what && $o_what[0] eq 'help';
1578 if (!@o_what) { # print all things, "o conf"
1580 $CPAN::Frontend->myprint("CPAN::Config options");
1581 if (exists $INC{'CPAN/Config.pm'}) {
1582 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1584 if (exists $INC{'CPAN/MyConfig.pm'}) {
1585 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1587 $CPAN::Frontend->myprint(":\n");
1588 for $k (sort keys %CPAN::Config::can) {
1589 $v = $CPAN::Config::can{$k};
1590 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
1592 $CPAN::Frontend->myprint("\n");
1593 for $k (sort keys %$CPAN::Config) {
1594 CPAN::Config->prettyprint($k);
1596 $CPAN::Frontend->myprint("\n");
1597 } elsif (!CPAN::Config->edit(@o_what)) {
1598 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1599 qq{edit options\n\n});
1601 } elsif ($o_type eq 'debug') {
1603 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1606 my($what) = shift @o_what;
1607 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1608 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1611 if ( exists $CPAN::DEBUG{$what} ) {
1612 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1613 } elsif ($what =~ /^\d/) {
1614 $CPAN::DEBUG = $what;
1615 } elsif (lc $what eq 'all') {
1617 for (values %CPAN::DEBUG) {
1620 $CPAN::DEBUG = $max;
1623 for (keys %CPAN::DEBUG) {
1624 next unless lc($_) eq lc($what);
1625 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1628 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1633 my $raw = "Valid options for debug are ".
1634 join(", ",sort(keys %CPAN::DEBUG), 'all').
1635 qq{ or a number. Completion works on the options. }.
1636 qq{Case is ignored.};
1638 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1639 $CPAN::Frontend->myprint("\n\n");
1642 $CPAN::Frontend->myprint("Options set for debugging:\n");
1644 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1645 $v = $CPAN::DEBUG{$k};
1646 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1647 if $v & $CPAN::DEBUG;
1650 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1653 $CPAN::Frontend->myprint(qq{
1655 conf set or get configuration variables
1656 debug set or get debugging options
1661 sub paintdots_onreload {
1664 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1668 # $CPAN::Frontend->myprint(".($subr)");
1669 $CPAN::Frontend->myprint(".");
1676 #-> sub CPAN::Shell::reload ;
1678 my($self,$command,@arg) = @_;
1680 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1681 if ($command =~ /cpan/i) {
1682 for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1683 next unless $INC{$f};
1684 CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$p
1687 my $fh = FileHandle->new($INC{$f});
1691 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1693 CPAN->debug("evaling '$eval'")
1697 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1699 } elsif ($command =~ /index/) {
1700 CPAN::Index->force_reload;
1702 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
1703 index re-reads the index files\n});
1707 #-> sub CPAN::Shell::_binary_extensions ;
1708 sub _binary_extensions {
1709 my($self) = shift @_;
1710 my(@result,$module,%seen,%need,$headerdone);
1711 for $module ($self->expand('Module','/./')) {
1712 my $file = $module->cpan_file;
1713 next if $file eq "N/A";
1714 next if $file =~ /^Contact Author/;
1715 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1716 next if $dist->isa_perl;
1717 next unless $module->xs_file;
1719 $CPAN::Frontend->myprint(".");
1720 push @result, $module;
1722 # print join " | ", @result;
1723 $CPAN::Frontend->myprint("\n");
1727 #-> sub CPAN::Shell::recompile ;
1729 my($self) = shift @_;
1730 my($module,@module,$cpan_file,%dist);
1731 @module = $self->_binary_extensions();
1732 for $module (@module){ # we force now and compile later, so we
1734 $cpan_file = $module->cpan_file;
1735 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1737 $dist{$cpan_file}++;
1739 for $cpan_file (sort keys %dist) {
1740 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
1741 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1743 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1744 # stop a package from recompiling,
1745 # e.g. IO-1.12 when we have perl5.003_10
1749 #-> sub CPAN::Shell::_u_r_common ;
1751 my($self) = shift @_;
1752 my($what) = shift @_;
1753 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1754 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1755 $what && $what =~ /^[aru]$/;
1757 @args = '/./' unless @args;
1758 my(@result,$module,%seen,%need,$headerdone,
1759 $version_undefs,$version_zeroes);
1760 $version_undefs = $version_zeroes = 0;
1761 my $sprintf = "%s%-25s%s %9s %9s %s\n";
1762 my @expand = $self->expand('Module',@args);
1763 my $expand = scalar @expand;
1764 if (0) { # Looks like noise to me, was very useful for debugging
1765 # for metadata cache
1766 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1768 MODULE: for $module (@expand) {
1769 my $file = $module->cpan_file;
1770 next MODULE unless defined $file; # ??
1771 my($latest) = $module->cpan_version;
1772 my($inst_file) = $module->inst_file;
1774 return if $CPAN::Signal;
1777 $have = $module->inst_version;
1778 } elsif ($what eq "r") {
1779 $have = $module->inst_version;
1781 if ($have eq "undef"){
1783 } elsif ($have == 0){
1786 next MODULE unless CPAN::Version->vgt($latest, $have);
1787 # to be pedantic we should probably say:
1788 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1789 # to catch the case where CPAN has a version 0 and we have a version undef
1790 } elsif ($what eq "u") {
1796 } elsif ($what eq "r") {
1798 } elsif ($what eq "u") {
1802 return if $CPAN::Signal; # this is sometimes lengthy
1805 push @result, sprintf "%s %s\n", $module->id, $have;
1806 } elsif ($what eq "r") {
1807 push @result, $module->id;
1808 next MODULE if $seen{$file}++;
1809 } elsif ($what eq "u") {
1810 push @result, $module->id;
1811 next MODULE if $seen{$file}++;
1812 next MODULE if $file =~ /^Contact/;
1814 unless ($headerdone++){
1815 $CPAN::Frontend->myprint("\n");
1816 $CPAN::Frontend->myprint(sprintf(
1819 "Package namespace",
1831 $CPAN::META->has_inst("Term::ANSIColor")
1833 $module->{RO}{description}
1835 $color_on = Term::ANSIColor::color("green");
1836 $color_off = Term::ANSIColor::color("reset");
1838 $CPAN::Frontend->myprint(sprintf $sprintf,
1845 $need{$module->id}++;
1849 $CPAN::Frontend->myprint("No modules found for @args\n");
1850 } elsif ($what eq "r") {
1851 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1855 if ($version_zeroes) {
1856 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1857 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1858 qq{a version number of 0\n});
1860 if ($version_undefs) {
1861 my $s_has = $version_undefs > 1 ? "s have" : " has";
1862 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1863 qq{parseable version number\n});
1869 #-> sub CPAN::Shell::r ;
1871 shift->_u_r_common("r",@_);
1874 #-> sub CPAN::Shell::u ;
1876 shift->_u_r_common("u",@_);
1879 #-> sub CPAN::Shell::autobundle ;
1882 CPAN::Config->load unless $CPAN::Config_loaded++;
1883 my(@bundle) = $self->_u_r_common("a",@_);
1884 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1885 File::Path::mkpath($todir);
1886 unless (-d $todir) {
1887 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1890 my($y,$m,$d) = (localtime)[5,4,3];
1894 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1895 my($to) = File::Spec->catfile($todir,"$me.pm");
1897 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1898 $to = File::Spec->catfile($todir,"$me.pm");
1900 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1902 "package Bundle::$me;\n\n",
1903 "\$VERSION = '0.01';\n\n",
1907 "Bundle::$me - Snapshot of installation on ",
1908 $Config::Config{'myhostname'},
1911 "\n\n=head1 SYNOPSIS\n\n",
1912 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1913 "=head1 CONTENTS\n\n",
1914 join("\n", @bundle),
1915 "\n\n=head1 CONFIGURATION\n\n",
1917 "\n\n=head1 AUTHOR\n\n",
1918 "This Bundle has been generated automatically ",
1919 "by the autobundle routine in CPAN.pm.\n",
1922 $CPAN::Frontend->myprint("\nWrote bundle file
1926 #-> sub CPAN::Shell::expandany ;
1929 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1930 if ($s =~ m|/|) { # looks like a file
1931 $s = CPAN::Distribution->normalize($s);
1932 return $CPAN::META->instance('CPAN::Distribution',$s);
1933 # Distributions spring into existence, not expand
1934 } elsif ($s =~ m|^Bundle::|) {
1935 $self->local_bundles; # scanning so late for bundles seems
1936 # both attractive and crumpy: always
1937 # current state but easy to forget
1939 return $self->expand('Bundle',$s);
1941 return $self->expand('Module',$s)
1942 if $CPAN::META->exists('CPAN::Module',$s);
1947 #-> sub CPAN::Shell::expand ;
1950 my($type,@args) = @_;
1952 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1954 my($regex,$command);
1955 if ($arg =~ m|^/(.*)/$|) {
1957 } elsif ($arg =~ m/=/) {
1960 my $class = "CPAN::$type";
1962 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1964 defined $regex ? $regex : "UNDEFINED",
1965 $command || "UNDEFINED",
1967 if (defined $regex) {
1971 $CPAN::META->all_objects($class)
1974 # BUG, we got an empty object somewhere
1975 require Data::Dumper;
1976 CPAN->debug(sprintf(
1977 "Bug in CPAN: Empty id on obj[%s][%s]",
1979 Data::Dumper::Dumper($obj)
1984 if $obj->id =~ /$regex/i
1988 $] < 5.00303 ### provide sort of
1989 ### compatibility with 5.003
1994 $obj->name =~ /$regex/i
1997 } elsif ($command) {
1998 die "equal sign in command disabled (immature interface), ".
2000 ! \$CPAN::Shell::ADVANCED_QUERY=1
2001 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2002 that may go away anytime.\n"
2003 unless $ADVANCED_QUERY;
2004 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2005 my($matchcrit) = $criterion =~ m/^~(.+)/;
2009 $CPAN::META->all_objects($class)
2011 my $lhs = $self->$method() or next; # () for 5.00503
2013 push @m, $self if $lhs =~ m/$matchcrit/;
2015 push @m, $self if $lhs eq $criterion;
2020 if ( $type eq 'Bundle' ) {
2021 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2022 } elsif ($type eq "Distribution") {
2023 $xarg = CPAN::Distribution->normalize($arg);
2025 if ($CPAN::META->exists($class,$xarg)) {
2026 $obj = $CPAN::META->instance($class,$xarg);
2027 } elsif ($CPAN::META->exists($class,$arg)) {
2028 $obj = $CPAN::META->instance($class,$arg);
2035 return wantarray ? @m : $m[0];
2038 #-> sub CPAN::Shell::format_result ;
2041 my($type,@args) = @_;
2042 @args = '/./' unless @args;
2043 my(@result) = $self->expand($type,@args);
2044 my $result = @result == 1 ?
2045 $result[0]->as_string :
2047 "No objects of type $type found for argument @args\n" :
2049 (map {$_->as_glimpse} @result),
2050 scalar @result, " items found\n",
2055 #-> sub CPAN::Shell::report_fh ;
2057 my $installation_report_fh;
2058 my $previously_noticed = 0;
2061 return $installation_report_fh if $installation_report_fh;
2062 $installation_report_fh = File::Temp->new(
2063 template => 'cpan_install_XXXX',
2067 unless ( $installation_report_fh ) {
2068 warn("Couldn't open installation report file; " .
2069 "no report file will be generated."
2070 ) unless $previously_noticed++;
2076 # The only reason for this method is currently to have a reliable
2077 # debugging utility that reveals which output is going through which
2078 # channel. No, I don't like the colors ;-)
2080 #-> sub CPAN::Shell::print_ornameted ;
2081 sub print_ornamented {
2082 my($self,$what,$ornament) = @_;
2084 return unless defined $what;
2086 local $| = 1; # Flush immediately
2087 if ( $CPAN::Be_Silent ) {
2088 print {report_fh()} $what;
2092 if ($CPAN::Config->{term_is_latin}){
2095 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2097 if ($PRINT_ORNAMENTING) {
2098 unless (defined &color) {
2099 if ($CPAN::META->has_inst("Term::ANSIColor")) {
2100 import Term::ANSIColor "color";
2102 *color = sub { return "" };
2106 for $line (split /\n/, $what) {
2107 $longest = length($line) if length($line) > $longest;
2109 my $sprintf = "%-" . $longest . "s";
2111 $what =~ s/(.*\n?)//m;
2114 my($nl) = chomp $line ? "\n" : "";
2115 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
2116 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
2120 # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
2126 my($self,$what) = @_;
2128 $self->print_ornamented($what, 'bold blue on_yellow');
2132 my($self,$what) = @_;
2133 $self->myprint($what);
2138 my($self,$what) = @_;
2139 $self->print_ornamented($what, 'bold red on_yellow');
2143 my($self,$what) = @_;
2144 $self->print_ornamented($what, 'bold red on_white');
2145 Carp::confess "died";
2149 my($self,$what) = @_;
2150 $self->print_ornamented($what, 'bold red on_white');
2155 return if -t STDOUT;
2156 my $odef = select STDERR;
2163 #-> sub CPAN::Shell::rematein ;
2164 # RE-adme||MA-ke||TE-st||IN-stall
2167 my($meth,@some) = @_;
2169 if ($meth =~ /^(force|notest)$/) {
2170 push @pragma, $meth;
2171 $meth = shift @some;
2174 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2176 # Here is the place to set "test_count" on all involved parties to
2177 # 0. We then can pass this counter on to the involved
2178 # distributions and those can refuse to test if test_count > X. In
2179 # the first stab at it we could use a 1 for "X".
2181 # But when do I reset the distributions to start with 0 again?
2182 # Jost suggested to have a random or cycling interaction ID that
2183 # we pass through. But the ID is something that is just left lying
2184 # around in addition to the counter, so I'd prefer to set the
2185 # counter to 0 now, and repeat at the end of the loop. But what
2186 # about dependencies? They appear later and are not reset, they
2187 # enter the queue but not its copy. How do they get a sensible
2190 # construct the queue
2192 foreach $s (@some) {
2195 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2197 } elsif ($s =~ m|^/|) { # looks like a regexp
2198 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2203 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2204 $obj = CPAN::Shell->expandany($s);
2207 $obj->color_cmd_tmps(0,1);
2208 CPAN::Queue->new($obj->id);
2210 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2211 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2212 if ($meth =~ /^(dump|ls)$/) {
2215 $CPAN::Frontend->myprint(
2217 "Don't be silly, you can't $meth ",
2225 ->myprint(qq{Warning: Cannot $meth $s, }.
2226 qq{don\'t know what it is.
2231 to find objects with matching identifiers.
2237 # queuerunner (please be warned: when I started to change the
2238 # queue to hold objects instead of names, I made one or two
2239 # mistakes and never found which. I reverted back instead)
2240 while ($s = CPAN::Queue->first) {
2243 $obj = $s; # I do not believe, we would survive if this happened
2245 $obj = CPAN::Shell->expandany($s);
2247 for my $pragma (@pragma) {
2250 ($] < 5.00303 || $obj->can($pragma))){
2251 ### compatibility with 5.003
2252 $obj->$pragma($meth); # the pragma "force" in
2253 # "CPAN::Distribution" must know
2254 # what we are intending
2257 if ($]>=5.00303 && $obj->can('called_for')) {
2258 $obj->called_for($s);
2261 qq{pragma[@pragma]meth[$meth]obj[$obj]as_string\[}.
2267 CPAN::Queue->delete($s);
2269 CPAN->debug("failed");
2273 CPAN::Queue->delete_first($s);
2275 for my $obj (@qcopy) {
2276 $obj->color_cmd_tmps(0,0);
2280 #-> sub CPAN::Shell::recent ;
2284 CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2289 # set up the dispatching methods
2291 for my $command (qw(
2292 clean cvs_import dump force get install look
2293 make notest perldoc readme test
2295 *$command = sub { shift->rematein($command, @_); };
2299 package CPAN::LWP::UserAgent;
2302 return if $SETUPDONE;
2303 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2304 require LWP::UserAgent;
2305 @ISA = qw(Exporter LWP::UserAgent);
2308 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2312 sub get_basic_credentials {
2313 my($self, $realm, $uri, $proxy) = @_;
2314 return unless $proxy;
2315 if ($USER && $PASSWD) {
2316 } elsif (defined $CPAN::Config->{proxy_user} &&
2317 defined $CPAN::Config->{proxy_pass}) {
2318 $USER = $CPAN::Config->{proxy_user};
2319 $PASSWD = $CPAN::Config->{proxy_pass};
2321 require ExtUtils::MakeMaker;
2322 ExtUtils::MakeMaker->import(qw(prompt));
2323 $USER = prompt("Proxy authentication needed!
2324 (Note: to permanently configure username and password run
2325 o conf proxy_user your_username
2326 o conf proxy_pass your_password
2328 if ($CPAN::META->has_inst("Term::ReadKey")) {
2329 Term::ReadKey::ReadMode("noecho");
2331 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2333 $PASSWD = prompt("Password:");
2334 if ($CPAN::META->has_inst("Term::ReadKey")) {
2335 Term::ReadKey::ReadMode("restore");
2337 $CPAN::Frontend->myprint("\n\n");
2339 return($USER,$PASSWD);
2342 # mirror(): Its purpose is to deal with proxy authentication. When we
2343 # call SUPER::mirror, we relly call the mirror method in
2344 # LWP::UserAgent. LWP::UserAgent will then call
2345 # $self->get_basic_credentials or some equivalent and this will be
2346 # $self->dispatched to our own get_basic_credentials method.
2348 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2350 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2351 # although we have gone through our get_basic_credentials, the proxy
2352 # server refuses to connect. This could be a case where the username or
2353 # password has changed in the meantime, so I'm trying once again without
2354 # $USER and $PASSWD to give the get_basic_credentials routine another
2355 # chance to set $USER and $PASSWD.
2357 # mirror(): Its purpose is to deal with proxy authentication. When we
2358 # call SUPER::mirror, we relly call the mirror method in
2359 # LWP::UserAgent. LWP::UserAgent will then call
2360 # $self->get_basic_credentials or some equivalent and this will be
2361 # $self->dispatched to our own get_basic_credentials method.
2363 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2365 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2366 # although we have gone through our get_basic_credentials, the proxy
2367 # server refuses to connect. This could be a case where the username or
2368 # password has changed in the meantime, so I'm trying once again without
2369 # $USER and $PASSWD to give the get_basic_credentials routine another
2370 # chance to set $USER and $PASSWD.
2373 my($self,$url,$aslocal) = @_;
2374 my $result = $self->SUPER::mirror($url,$aslocal);
2375 if ($result->code == 407) {
2378 $result = $self->SUPER::mirror($url,$aslocal);
2385 #-> sub CPAN::FTP::ftp_get ;
2387 my($class,$host,$dir,$file,$target) = @_;
2389 qq[Going to fetch file [$file] from dir [$dir]
2390 on host [$host] as local [$target]\n]
2392 my $ftp = Net::FTP->new($host);
2393 return 0 unless defined $ftp;
2394 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2395 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2396 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2397 warn "Couldn't login on $host";
2400 unless ( $ftp->cwd($dir) ){
2401 warn "Couldn't cwd $dir";
2405 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2406 unless ( $ftp->get($file,$target) ){
2407 warn "Couldn't fetch $file from $host\n";
2410 $ftp->quit; # it's ok if this fails
2414 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2416 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2417 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2419 # > *** 1562,1567 ****
2420 # > --- 1562,1580 ----
2421 # > return 1 if substr($url,0,4) eq "file";
2422 # > return 1 unless $url =~ m|://([^/]+)|;
2424 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2426 # > + $proxy =~ m|://([^/:]+)|;
2428 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2429 # > + if ($noproxy) {
2430 # > + if ($host !~ /$noproxy$/) {
2431 # > + $host = $proxy;
2434 # > + $host = $proxy;
2437 # > require Net::Ping;
2438 # > return 1 unless $Net::Ping::VERSION >= 2;
2442 #-> sub CPAN::FTP::localize ;
2444 my($self,$file,$aslocal,$force) = @_;
2446 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2447 unless defined $aslocal;
2448 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2451 if ($^O eq 'MacOS') {
2452 # Comment by AK on 2000-09-03: Uniq short filenames would be
2453 # available in CHECKSUMS file
2454 my($name, $path) = File::Basename::fileparse($aslocal, '');
2455 if (length($name) > 31) {
2466 my $size = 31 - length($suf);
2467 while (length($name) > $size) {
2471 $aslocal = File::Spec->catfile($path, $name);
2475 return $aslocal if -f $aslocal && -r _ && !($force & 1);
2478 rename $aslocal, "$aslocal.bak";
2482 my($aslocal_dir) = File::Basename::dirname($aslocal);
2483 File::Path::mkpath($aslocal_dir);
2484 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2485 qq{directory "$aslocal_dir".
2486 I\'ll continue, but if you encounter problems, they may be due
2487 to insufficient permissions.\n}) unless -w $aslocal_dir;
2489 # Inheritance is not easier to manage than a few if/else branches
2490 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2492 CPAN::LWP::UserAgent->config;
2493 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2495 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2499 $Ua->proxy('ftp', $var)
2500 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2501 $Ua->proxy('http', $var)
2502 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2505 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2507 # > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2508 # > use ones that require basic autorization.
2510 # > Example of when I use it manually in my own stuff:
2512 # > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2513 # > $req->proxy_authorization_basic("username","password");
2514 # > $res = $ua->request($req);
2518 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2522 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2523 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2526 # Try the list of urls for each single object. We keep a record
2527 # where we did get a file from
2528 my(@reordered,$last);
2529 $CPAN::Config->{urllist} ||= [];
2530 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2531 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2533 $last = $#{$CPAN::Config->{urllist}};
2534 if ($force & 2) { # local cpans probably out of date, don't reorder
2535 @reordered = (0..$last);
2539 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2541 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2552 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2554 @levels = qw/easy hard hardest/;
2556 @levels = qw/easy/ if $^O eq 'MacOS';
2558 for $levelno (0..$#levels) {
2559 my $level = $levels[$levelno];
2560 my $method = "host$level";
2561 my @host_seq = $level eq "easy" ?
2562 @reordered : 0..$last; # reordered has CDROM up front
2563 @host_seq = (0) unless @host_seq;
2564 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2566 $Themethod = $level;
2568 # utime $now, $now, $aslocal; # too bad, if we do that, we
2569 # might alter a local mirror
2570 $self->debug("level[$level]") if $CPAN::DEBUG;
2574 last if $CPAN::Signal; # need to cleanup
2577 unless ($CPAN::Signal) {
2580 qq{Please check, if the URLs I found in your configuration file \(}.
2581 join(", ", @{$CPAN::Config->{urllist}}).
2582 qq{\) are valid. The urllist can be edited.},
2583 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2584 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2586 $CPAN::Frontend->myprint("Could not fetch $file\n");
2589 rename "$aslocal.bak", $aslocal;
2590 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2591 $self->ls($aslocal));
2598 my($self,$host_seq,$file,$aslocal) = @_;
2600 HOSTEASY: for $i (@$host_seq) {
2601 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2602 $url .= "/" unless substr($url,-1) eq "/";
2604 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2605 if ($url =~ /^file:/) {
2607 if ($CPAN::META->has_inst('URI::URL')) {
2608 my $u = URI::URL->new($url);
2610 } else { # works only on Unix, is poorly constructed, but
2611 # hopefully better than nothing.
2612 # RFC 1738 says fileurl BNF is
2613 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2614 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2616 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2617 $l =~ s|^file:||; # assume they
2620 $l =~ s|^/||s unless -f $l; # e.g. /P:
2621 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2623 if ( -f $l && -r _) {
2627 # Maybe mirror has compressed it?
2629 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2630 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2637 if ($CPAN::META->has_usable('LWP')) {
2638 $CPAN::Frontend->myprint("Fetching with LWP:
2642 CPAN::LWP::UserAgent->config;
2643 eval { $Ua = CPAN::LWP::UserAgent->new; };
2645 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2648 my $res = $Ua->mirror($url, $aslocal);
2649 if ($res->is_success) {
2652 utime $now, $now, $aslocal; # download time is more
2653 # important than upload time
2655 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2656 my $gzurl = "$url.gz";
2657 $CPAN::Frontend->myprint("Fetching with LWP:
2660 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2661 if ($res->is_success &&
2662 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2668 $CPAN::Frontend->myprint(sprintf(
2669 "LWP failed with code[%s] message[%s]\n",
2673 # Alan Burlison informed me that in firewall environments
2674 # Net::FTP can still succeed where LWP fails. So we do not
2675 # skip Net::FTP anymore when LWP is available.
2678 $CPAN::Frontend->myprint("LWP not available\n");
2680 return if $CPAN::Signal;
2681 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2682 # that's the nice and easy way thanks to Graham
2683 my($host,$dir,$getfile) = ($1,$2,$3);
2684 if ($CPAN::META->has_usable('Net::FTP')) {
2686 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2689 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2690 "aslocal[$aslocal]") if $CPAN::DEBUG;
2691 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2695 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2696 my $gz = "$aslocal.gz";
2697 $CPAN::Frontend->myprint("Fetching with Net::FTP
2700 if (CPAN::FTP->ftp_get($host,
2704 CPAN::Tarzip->gunzip($gz,$aslocal)
2713 return if $CPAN::Signal;
2718 my($self,$host_seq,$file,$aslocal) = @_;
2720 # Came back if Net::FTP couldn't establish connection (or
2721 # failed otherwise) Maybe they are behind a firewall, but they
2722 # gave us a socksified (or other) ftp program...
2725 my($devnull) = $CPAN::Config->{devnull} || "";
2727 my($aslocal_dir) = File::Basename::dirname($aslocal);
2728 File::Path::mkpath($aslocal_dir);
2729 HOSTHARD: for $i (@$host_seq) {
2730 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2731 $url .= "/" unless substr($url,-1) eq "/";
2733 my($proto,$host,$dir,$getfile);
2735 # Courtesy Mark Conty mark_conty@cargill.com change from
2736 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2738 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2739 # proto not yet used
2740 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2742 next HOSTHARD; # who said, we could ftp anything except ftp?
2744 next HOSTHARD if $proto eq "file"; # file URLs would have had
2745 # success above. Likely a bogus URL
2747 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2749 # Try the most capable first and leave ncftp* for last as it only
2751 for my $f (qw(curl wget lynx ncftpget ncftp)) {
2752 my $funkyftp = $CPAN::Config->{$f};
2753 next unless defined $funkyftp;
2754 next if $funkyftp =~ /^\s*$/;
2756 my($asl_ungz, $asl_gz);
2757 ($asl_ungz = $aslocal) =~ s/\.gz//;
2758 $asl_gz = "$asl_ungz.gz";
2760 my($src_switch) = "";
2762 my($stdout_redir) = " > $asl_ungz";
2764 $src_switch = " -source";
2765 } elsif ($f eq "ncftp"){
2766 $src_switch = " -c";
2767 } elsif ($f eq "wget"){
2768 $src_switch = " -O $asl_ungz";
2770 } elsif ($f eq 'curl'){
2771 $src_switch = ' -L';
2774 if ($f eq "ncftpget"){
2775 $chdir = "cd $aslocal_dir && ";
2778 $CPAN::Frontend->myprint(
2780 Trying with "$funkyftp$src_switch" to get
2784 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2785 $self->debug("system[$system]") if $CPAN::DEBUG;
2787 if (($wstatus = system($system)) == 0
2790 -s $asl_ungz # lynx returns 0 when it fails somewhere
2796 } elsif ($asl_ungz ne $aslocal) {
2797 # test gzip integrity
2798 if (CPAN::Tarzip->gtest($asl_ungz)) {
2799 # e.g. foo.tar is gzipped --> foo.tar.gz
2800 rename $asl_ungz, $aslocal;
2802 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2807 } elsif ($url !~ /\.gz(?!\n)\Z/) {
2809 -f $asl_ungz && -s _ == 0;
2810 my $gz = "$aslocal.gz";
2811 my $gzurl = "$url.gz";
2812 $CPAN::Frontend->myprint(
2814 Trying with "$funkyftp$src_switch" to get
2817 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2818 $self->debug("system[$system]") if $CPAN::DEBUG;
2820 if (($wstatus = system($system)) == 0
2824 # test gzip integrity
2825 if (CPAN::Tarzip->gtest($asl_gz)) {
2826 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2828 # somebody uncompressed file for us?
2829 rename $asl_ungz, $aslocal;
2834 unlink $asl_gz if -f $asl_gz;
2837 my $estatus = $wstatus >> 8;
2838 my $size = -f $aslocal ?
2839 ", left\n$aslocal with size ".-s _ :
2840 "\nWarning: expected file [$aslocal] doesn't exist";
2841 $CPAN::Frontend->myprint(qq{
2842 System call "$system"
2843 returned status $estatus (wstat $wstatus)$size
2846 return if $CPAN::Signal;
2847 } # transfer programs
2852 my($self,$host_seq,$file,$aslocal) = @_;
2855 my($aslocal_dir) = File::Basename::dirname($aslocal);
2856 File::Path::mkpath($aslocal_dir);
2857 my $ftpbin = $CPAN::Config->{ftp};
2858 HOSTHARDEST: for $i (@$host_seq) {
2859 unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2860 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2863 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2864 $url .= "/" unless substr($url,-1) eq "/";
2866 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2867 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2870 my($host,$dir,$getfile) = ($1,$2,$3);
2872 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2873 $ctime,$blksize,$blocks) = stat($aslocal);
2874 $timestamp = $mtime ||= 0;
2875 my($netrc) = CPAN::FTP::netrc->new;
2876 my($netrcfile) = $netrc->netrc;
2877 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2878 my $targetfile = File::Basename::basename($aslocal);
2884 map("cd $_", split /\//, $dir), # RFC 1738
2886 "get $getfile $targetfile",
2890 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2891 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2892 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2894 $netrc->contains($host))) if $CPAN::DEBUG;
2895 if ($netrc->protected) {
2896 $CPAN::Frontend->myprint(qq{
2897 Trying with external ftp to get
2899 As this requires some features that are not thoroughly tested, we\'re
2900 not sure, that we get it right....
2904 $self->talk_ftp("$ftpbin$verbose $host",
2906 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2907 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2909 if ($mtime > $timestamp) {
2910 $CPAN::Frontend->myprint("GOT $aslocal\n");
2914 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2916 return if $CPAN::Signal;
2918 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2919 qq{correctly protected.\n});
2922 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2923 nor does it have a default entry\n");
2926 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2927 # then and login manually to host, using e-mail as
2929 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2933 "user anonymous $Config::Config{'cf_email'}"
2935 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
2936 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2937 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2939 if ($mtime > $timestamp) {
2940 $CPAN::Frontend->myprint("GOT $aslocal\n");
2944 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2946 return if $CPAN::Signal;
2947 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2953 my($self,$command,@dialog) = @_;
2954 my $fh = FileHandle->new;
2955 $fh->open("|$command") or die "Couldn't open ftp: $!";
2956 foreach (@dialog) { $fh->print("$_\n") }
2957 $fh->close; # Wait for process to complete
2959 my $estatus = $wstatus >> 8;
2960 $CPAN::Frontend->myprint(qq{
2961 Subprocess "|$command"
2962 returned status $estatus (wstat $wstatus)
2966 # find2perl needs modularization, too, all the following is stolen
2970 my($self,$name) = @_;
2971 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2972 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2974 my($perms,%user,%group);
2978 $blocks = int(($blocks + 1) / 2);
2981 $blocks = int(($sizemm + 1023) / 1024);
2984 if (-f _) { $perms = '-'; }
2985 elsif (-d _) { $perms = 'd'; }
2986 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2987 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2988 elsif (-p _) { $perms = 'p'; }
2989 elsif (-S _) { $perms = 's'; }
2990 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2992 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2993 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2994 my $tmpmode = $mode;
2995 my $tmp = $rwx[$tmpmode & 7];
2997 $tmp = $rwx[$tmpmode & 7] . $tmp;
2999 $tmp = $rwx[$tmpmode & 7] . $tmp;
3000 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3001 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3002 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3005 my $user = $user{$uid} || $uid; # too lazy to implement lookup
3006 my $group = $group{$gid} || $gid;
3008 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3010 my($moname) = $moname[$mon];
3011 if (-M _ > 365.25 / 2) {
3012 $timeyear = $year + 1900;
3015 $timeyear = sprintf("%02d:%02d", $hour, $min);
3018 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3032 package CPAN::FTP::netrc;
3036 my $file = File::Spec->catfile($ENV{HOME},".netrc");
3038 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3039 $atime,$mtime,$ctime,$blksize,$blocks)
3044 my($fh,@machines,$hasdefault);
3046 $fh = FileHandle->new or die "Could not create a filehandle";
3048 if($fh->open($file)){
3049 $protected = ($mode & 077) == 0;
3051 NETRC: while (<$fh>) {
3052 my(@tokens) = split " ", $_;
3053 TOKEN: while (@tokens) {
3054 my($t) = shift @tokens;
3055 if ($t eq "default"){
3059 last TOKEN if $t eq "macdef";
3060 if ($t eq "machine") {
3061 push @machines, shift @tokens;
3066 $file = $hasdefault = $protected = "";
3070 'mach' => [@machines],
3072 'hasdefault' => $hasdefault,
3073 'protected' => $protected,
3077 # CPAN::FTP::hasdefault;
3078 sub hasdefault { shift->{'hasdefault'} }
3079 sub netrc { shift->{'netrc'} }
3080 sub protected { shift->{'protected'} }
3082 my($self,$mach) = @_;
3083 for ( @{$self->{'mach'}} ) {
3084 return 1 if $_ eq $mach;
3089 package CPAN::Complete;
3092 my($text, $line, $start, $end) = @_;
3093 my(@perlret) = cpl($text, $line, $start);
3094 # find longest common match. Can anybody show me how to peruse
3095 # T::R::Gnu to have this done automatically? Seems expensive.
3096 return () unless @perlret;
3097 my($newtext) = $text;
3098 for (my $i = length($text)+1;;$i++) {
3099 last unless length($perlret[0]) && length($perlret[0]) >= $i;
3100 my $try = substr($perlret[0],0,$i);
3101 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3102 # warn "try[$try]tries[@tries]";
3103 if (@tries == @perlret) {
3109 ($newtext,@perlret);
3112 #-> sub CPAN::Complete::cpl ;
3114 my($word,$line,$pos) = @_;
3118 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3120 if ($line =~ s/^(force\s*)//) {
3125 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3126 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3128 } elsif ($line =~ /^(a|ls)\s/) {
3129 @return = cplx('CPAN::Author',uc($word));
3130 } elsif ($line =~ /^b\s/) {
3131 CPAN::Shell->local_bundles;
3132 @return = cplx('CPAN::Bundle',$word);
3133 } elsif ($line =~ /^d\s/) {
3134 @return = cplx('CPAN::Distribution',$word);
3135 } elsif ($line =~ m/^(
3136 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3138 if ($word =~ /^Bundle::/) {
3139 CPAN::Shell->local_bundles;
3141 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3142 } elsif ($line =~ /^i\s/) {
3143 @return = cpl_any($word);
3144 } elsif ($line =~ /^reload\s/) {
3145 @return = cpl_reload($word,$line,$pos);
3146 } elsif ($line =~ /^o\s/) {
3147 @return = cpl_option($word,$line,$pos);
3148 } elsif ($line =~ m/^\S+\s/ ) {
3149 # fallback for future commands and what we have forgotten above
3150 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3157 #-> sub CPAN::Complete::cplx ;
3159 my($class, $word) = @_;
3160 # I believed for many years that this was sorted, today I
3161 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3162 # make it sorted again. Maybe sort was dropped when GNU-readline
3163 # support came in? The RCS file is difficult to read on that:-(
3164 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3167 #-> sub CPAN::Complete::cpl_any ;
3171 cplx('CPAN::Author',$word),
3172 cplx('CPAN::Bundle',$word),
3173 cplx('CPAN::Distribution',$word),
3174 cplx('CPAN::Module',$word),
3178 #-> sub CPAN::Complete::cpl_reload ;
3180 my($word,$line,$pos) = @_;
3182 my(@words) = split " ", $line;
3183 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3184 my(@ok) = qw(cpan index);
3185 return @ok if @words == 1;
3186 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3189 #-> sub CPAN::Complete::cpl_option ;
3191 my($word,$line,$pos) = @_;
3193 my(@words) = split " ", $line;
3194 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3195 my(@ok) = qw(conf debug);
3196 return @ok if @words == 1;
3197 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3199 } elsif ($words[1] eq 'index') {
3201 } elsif ($words[1] eq 'conf') {
3202 return CPAN::Config::cpl(@_);
3203 } elsif ($words[1] eq 'debug') {
3204 return sort grep /^\Q$word\E/,
3205 sort keys %CPAN::DEBUG, 'all';
3209 package CPAN::Index;
3211 #-> sub CPAN::Index::force_reload ;
3214 $CPAN::Index::LAST_TIME = 0;
3218 #-> sub CPAN::Index::reload ;
3220 my($cl,$force) = @_;
3223 # XXX check if a newer one is available. (We currently read it
3224 # from time to time)
3225 for ($CPAN::Config->{index_expire}) {
3226 $_ = 0.001 unless $_ && $_ > 0.001;
3228 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3229 # debug here when CPAN doesn't seem to read the Metadata
3231 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3233 unless ($CPAN::META->{PROTOCOL}) {
3234 $cl->read_metadata_cache;
3235 $CPAN::META->{PROTOCOL} ||= "1.0";
3237 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3238 # warn "Setting last_time to 0";
3239 $LAST_TIME = 0; # No warning necessary
3241 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3244 # IFF we are developing, it helps to wipe out the memory
3245 # between reloads, otherwise it is not what a user expects.
3246 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3247 $CPAN::META = CPAN->new;
3251 local $LAST_TIME = $time;
3252 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3254 my $needshort = $^O eq "dos";
3256 $cl->rd_authindex($cl
3258 "authors/01mailrc.txt.gz",
3260 File::Spec->catfile('authors', '01mailrc.gz') :
3261 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3264 $debug = "timing reading 01[".($t2 - $time)."]";
3266 return if $CPAN::Signal; # this is sometimes lengthy
3267 $cl->rd_modpacks($cl
3269 "modules/02packages.details.txt.gz",
3271 File::Spec->catfile('modules', '02packag.gz') :
3272 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3275 $debug .= "02[".($t2 - $time)."]";
3277 return if $CPAN::Signal; # this is sometimes lengthy
3280 "modules/03modlist.data.gz",
3282 File::Spec->catfile('modules', '03mlist.gz') :
3283 File::Spec->catfile('modules', '03modlist.data.gz'),
3285 $cl->write_metadata_cache;
3287 $debug .= "03[".($t2 - $time)."]";
3289 CPAN->debug($debug) if $CPAN::DEBUG;
3292 $CPAN::META->{PROTOCOL} = PROTOCOL;
3295 #-> sub CPAN::Index::reload_x ;
3297 my($cl,$wanted,$localname,$force) = @_;
3298 $force |= 2; # means we're dealing with an index here
3299 CPAN::Config->load; # we should guarantee loading wherever we rely
3301 $localname ||= $wanted;
3302 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3306 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3309 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3310 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3311 qq{day$s. I\'ll use that.});
3314 $force |= 1; # means we're quite serious about it.
3316 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3319 #-> sub CPAN::Index::rd_authindex ;
3321 my($cl, $index_target) = @_;
3323 return unless defined $index_target;
3324 $CPAN::Frontend->myprint("Going to read $index_target\n");
3326 tie *FH, CPAN::Tarzip, $index_target;
3328 push @lines, split /\012/ while <FH>;
3330 my($userid,$fullname,$email) =
3331 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3332 next unless $userid && $fullname && $email;
3334 # instantiate an author object
3335 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3336 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3337 return if $CPAN::Signal;
3342 my($self,$dist) = @_;
3343 $dist = $self->{'id'} unless defined $dist;
3344 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3348 #-> sub CPAN::Index::rd_modpacks ;
3350 my($self, $index_target) = @_;
3352 return unless defined $index_target;
3353 $CPAN::Frontend->myprint("Going to read $index_target\n");
3354 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3356 while ($_ = $fh->READLINE) {
3358 my @ls = map {"$_\n"} split /\n/, $_;
3359 unshift @ls, "\n" x length($1) if /^(\n+)/;
3363 my($line_count,$last_updated);
3365 my $shift = shift(@lines);
3366 last if $shift =~ /^\s*$/;
3367 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3368 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3370 if (not defined $line_count) {
3372 warn qq{Warning: Your $index_target does not contain a Line-Count header.
3373 Please check the validity of the index file by comparing it to more
3374 than one CPAN mirror. I'll continue but problems seem likely to
3379 } elsif ($line_count != scalar @lines) {
3381 warn sprintf qq{Warning: Your %s
3382 contains a Line-Count header of %d but I see %d lines there. Please
3383 check the validity of the index file by comparing it to more than one
3384 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3385 $index_target, $line_count, scalar(@lines);
3388 if (not defined $last_updated) {
3390 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3391 Please check the validity of the index file by comparing it to more
3392 than one CPAN mirror. I'll continue but problems seem likely to
3400 ->myprint(sprintf qq{ Database was generated on %s\n},
3402 $DATE_OF_02 = $last_updated;
3404 if ($CPAN::META->has_inst(HTTP::Date)) {
3406 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3411 qq{Warning: This index file is %d days old.
3412 Please check the host you chose as your CPAN mirror for staleness.
3413 I'll continue but problems seem likely to happen.\a\n},
3418 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3423 # A necessity since we have metadata_cache: delete what isn't
3425 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3426 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3430 # before 1.56 we split into 3 and discarded the rest. From
3431 # 1.57 we assign remaining text to $comment thus allowing to
3432 # influence isa_perl
3433 my($mod,$version,$dist,$comment) = split " ", $_, 4;
3434 my($bundle,$id,$userid);
3436 if ($mod eq 'CPAN' &&
3438 CPAN::Queue->exists('Bundle::CPAN') ||
3439 CPAN::Queue->exists('CPAN')
3443 if ($version > $CPAN::VERSION){
3444 $CPAN::Frontend->myprint(qq{
3445 There's a new CPAN.pm version (v$version) available!
3446 [Current version is v$CPAN::VERSION]
3447 You might want to try
3448 install Bundle::CPAN
3450 without quitting the current session. It should be a seamless upgrade
3451 while we are running...
3454 $CPAN::Frontend->myprint(qq{\n});
3456 last if $CPAN::Signal;
3457 } elsif ($mod =~ /^Bundle::(.*)/) {
3462 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
3463 # Let's make it a module too, because bundles have so much
3464 # in common with modules.
3466 # Changed in 1.57_63: seems like memory bloat now without
3467 # any value, so commented out
3469 # $CPAN::META->instance('CPAN::Module',$mod);
3473 # instantiate a module object
3474 $id = $CPAN::META->instance('CPAN::Module',$mod);
3478 if ($id->cpan_file ne $dist){ # update only if file is
3479 # different. CPAN prohibits same
3480 # name with different version
3481 $userid = $id->userid || $self->userid($dist);
3483 'CPAN_USERID' => $userid,
3484 'CPAN_VERSION' => $version,
3485 'CPAN_FILE' => $dist,
3489 # instantiate a distribution object
3490 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3491 # we do not need CONTAINSMODS unless we do something with
3492 # this dist, so we better produce it on demand.
3494 ## my $obj = $CPAN::META->instance(
3495 ## 'CPAN::Distribution' => $dist
3497 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3499 $CPAN::META->instance(
3500 'CPAN::Distribution' => $dist
3502 'CPAN_USERID' => $userid,
3503 'CPAN_COMMENT' => $comment,
3507 for my $name ($mod,$dist) {
3508 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3509 $exists{$name} = undef;
3512 return if $CPAN::Signal;
3516 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3517 for my $o ($CPAN::META->all_objects($class)) {
3518 next if exists $exists{$o->{ID}};
3519 $CPAN::META->delete($class,$o->{ID});
3520 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3527 #-> sub CPAN::Index::rd_modlist ;
3529 my($cl,$index_target) = @_;
3530 return unless defined $index_target;
3531 $CPAN::Frontend->myprint("Going to read $index_target\n");
3532 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3535 while ($_ = $fh->READLINE) {
3537 my @ls = map {"$_\n"} split /\n/, $_;
3538 unshift @ls, "\n" x length($1) if /^(\n+)/;
3542 my $shift = shift(@eval);
3543 if ($shift =~ /^Date:\s+(.*)/){
3544 return if $DATE_OF_03 eq $1;
3547 last if $shift =~ /^\s*$/;
3550 push @eval, q{CPAN::Modulelist->data;};
3552 my($comp) = Safe->new("CPAN::Safe1");
3553 my($eval) = join("", @eval);
3554 my $ret = $comp->reval($eval);
3555 Carp::confess($@) if $@;
3556 return if $CPAN::Signal;
3558 my $obj = $CPAN::META->instance("CPAN::Module",$_);
3559 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3560 $obj->set(%{$ret->{$_}});
3561 return if $CPAN::Signal;
3565 #-> sub CPAN::Index::write_metadata_cache ;
3566 sub write_metadata_cache {
3568 return unless $CPAN::Config->{'cache_metadata'};
3569 return unless $CPAN::META->has_usable("Storable");
3571 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3572 CPAN::Distribution)) {
3573 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3575 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3576 $cache->{last_time} = $LAST_TIME;
3577 $cache->{DATE_OF_02} = $DATE_OF_02;
3578 $cache->{PROTOCOL} = PROTOCOL;
3579 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3580 eval { Storable::nstore($cache, $metadata_file) };
3581 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3584 #-> sub CPAN::Index::read_metadata_cache ;
3585 sub read_metadata_cache {
3587 return unless $CPAN::Config->{'cache_metadata'};
3588 return unless $CPAN::META->has_usable("Storable");
3589 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3590 return unless -r $metadata_file and -f $metadata_file;
3591 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3593 eval { $cache = Storable::retrieve($metadata_file) };
3594 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3595 if (!$cache || ref $cache ne 'HASH'){
3599 if (exists $cache->{PROTOCOL}) {
3600 if (PROTOCOL > $cache->{PROTOCOL}) {
3601 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3602 "with protocol v%s, requiring v%s\n",
3609 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3610 "with protocol v1.0\n");
3615 while(my($class,$v) = each %$cache) {
3616 next unless $class =~ /^CPAN::/;
3617 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3618 while (my($id,$ro) = each %$v) {
3619 $CPAN::META->{readwrite}{$class}{$id} ||=
3620 $class->new(ID=>$id, RO=>$ro);
3625 unless ($clcnt) { # sanity check
3626 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3629 if ($idcnt < 1000) {
3630 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3631 "in $metadata_file\n");
3634 $CPAN::META->{PROTOCOL} ||=
3635 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3636 # does initialize to some protocol
3637 $LAST_TIME = $cache->{last_time};
3638 $DATE_OF_02 = $cache->{DATE_OF_02};
3639 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3640 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3644 package CPAN::InfoObj;
3649 $self->{RO}{CPAN_USERID}
3652 sub id { shift->{ID}; }
3654 #-> sub CPAN::InfoObj::new ;
3656 my $this = bless {}, shift;
3661 # The set method may only be used by code that reads index data or
3662 # otherwise "objective" data from the outside world. All session
3663 # related material may do anything else with instance variables but
3664 # must not touch the hash under the RO attribute. The reason is that
3665 # the RO hash gets written to Metadata file and is thus persistent.
3667 #-> sub CPAN::InfoObj::set ;
3669 my($self,%att) = @_;
3670 my $class = ref $self;
3672 # This must be ||=, not ||, because only if we write an empty
3673 # reference, only then the set method will write into the readonly
3674 # area. But for Distributions that spring into existence, maybe
3675 # because of a typo, we do not like it that they are written into
3676 # the readonly area and made permanent (at least for a while) and
3677 # that is why we do not "allow" other places to call ->set.
3678 unless ($self->id) {
3679 CPAN->debug("Bug? Empty ID, rejecting");
3682 my $ro = $self->{RO} =
3683 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3685 while (my($k,$v) = each %att) {
3690 #-> sub CPAN::InfoObj::as_glimpse ;
3694 my $class = ref($self);
3695 $class =~ s/^CPAN:://;
3696 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3700 #-> sub CPAN::InfoObj::as_string ;
3704 my $class = ref($self);
3705 $class =~ s/^CPAN:://;
3706 push @m, $class, " id = $self->{ID}\n";
3707 for (sort keys %{$self->{RO}}) {
3708 # next if m/^(ID|RO)$/;
3710 if ($_ eq "CPAN_USERID") {
3711 $extra .= " (".$self->author;
3712 my $email; # old perls!
3713 if ($email = $CPAN::META->instance("CPAN::Author",
3716 $extra .= " <$email>";
3718 $extra .= " <no email>";
3721 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3722 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3725 next unless defined $self->{RO}{$_};
3726 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3728 for (sort keys %$self) {
3729 next if m/^(ID|RO)$/;
3730 if (ref($self->{$_}) eq "ARRAY") {
3731 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
3732 } elsif (ref($self->{$_}) eq "HASH") {
3736 join(" ",keys %{$self->{$_}}),
3739 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
3745 #-> sub CPAN::InfoObj::author ;
3748 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3751 #-> sub CPAN::InfoObj::dump ;
3754 require Data::Dumper;
3755 print Data::Dumper::Dumper($self);
3758 package CPAN::Author;
3760 #-> sub CPAN::Author::id
3763 my $id = $self->{ID};
3764 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3768 #-> sub CPAN::Author::as_glimpse ;
3772 my $class = ref($self);
3773 $class =~ s/^CPAN:://;
3774 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3782 #-> sub CPAN::Author::fullname ;
3784 shift->{RO}{FULLNAME};
3788 #-> sub CPAN::Author::email ;
3789 sub email { shift->{RO}{EMAIL}; }
3791 #-> sub CPAN::Author::ls ;
3794 my $silent = shift || 0;
3797 # adapted from CPAN::Distribution::verifyMD5 ;
3798 my(@csf); # chksumfile
3799 @csf = $self->id =~ /(.)(.)(.*)/;
3800 $csf[1] = join "", @csf[0,1];
3801 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
3803 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
3804 unless (grep {$_->[2] eq $csf[1]} @dl) {
3805 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless
3809 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
3810 unless (grep {$_->[2] eq $csf[2]} @dl) {
3811 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $sil
3815 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
3816 $CPAN::Frontend->myprint(join "", map {
3817 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3818 } sort { $a->[2] cmp $b->[2] } @dl) unless $silent;
3821 # returns an array of arrays, the latter contain (size,mtime,filename)
3822 #-> sub CPAN::Author::dir_listing ;
3825 my $chksumfile = shift;
3826 my $recursive = shift;
3827 my $may_ftp = shift;
3829 File::Spec->catfile($CPAN::Config->{keep_source_where},
3830 "authors", "id", @$chksumfile);
3834 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
3835 # hazard. (Without GPG installed they are not that much better,
3837 $fh = FileHandle->new;
3838 if (open($fh, $lc_want)) {
3839 my $line = <$fh>; close $fh;
3840 unlink($lc_want) unless $line =~ /PGP/;
3843 # connect "force" argument with "index_expire".
3845 if (my @stat = stat $lc_want) {
3846 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3850 $lc_file = CPAN::FTP->localize(
3851 "authors/id/@$chksumfile",
3856 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3857 $chksumfile->[-1] .= ".gz";
3858 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3861 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3862 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3868 $lc_file = $lc_want;
3869 # we *could* second-guess and if the user has a file: URL,
3870 # then we could look there. But on the other hand, if they do
3871 # have a file: URL, wy did they choose to set
3872 # $CPAN::Config->{show_upload_date} to false?
3875 # adapted from CPAN::Distribution::MD5_check_file ;
3876 $fh = FileHandle->new;
3878 if (open $fh, $lc_file){
3881 $eval =~ s/\015?\012/\n/g;
3883 my($comp) = Safe->new();
3884 $cksum = $comp->reval($eval);
3886 rename $lc_file, "$lc_file.bad";
3887 Carp::confess($@) if $@;
3889 } elsif ($may_ftp) {
3890 Carp::carp "Could not open $lc_file for reading.";
3892 # Maybe should warn: "You may want to set show_upload_date to a true value"
3896 for $f (sort keys %$cksum) {
3897 if (exists $cksum->{$f}{isdir}) {
3899 my(@dir) = @$chksumfile;
3901 push @dir, $f, "CHECKSUMS";
3903 [$_->[0], $_->[1], "$f/$_->[2]"]
3904 } $self->dir_listing(\@dir,1,$may_ftp);
3906 push @result, [ 0, "-", $f ];
3910 ($cksum->{$f}{"size"}||0),
3911 $cksum->{$f}{"mtime"}||"---",
3919 package CPAN::Distribution;
3922 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3926 delete $self->{later};
3929 # CPAN::Distribution::normalize
3932 $s = $self->id unless defined $s;
3936 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3938 return $s if $s =~ m:^N/A|^Contact Author: ;
3939 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3940 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3941 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3946 #-> sub CPAN::Distribution::color_cmd_tmps ;
3947 sub color_cmd_tmps {
3949 my($depth) = shift || 0;
3950 my($color) = shift || 0;
3951 my($ancestors) = shift || [];
3952 # a distribution needs to recurse into its prereq_pms
3954 return if exists $self->{incommandcolor}
3955 && $self->{incommandcolor}==$color;
3957 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3959 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3960 my $prereq_pm = $self->prereq_pm;
3961 if (defined $prereq_pm) {
3962 for my $pre (keys %$prereq_pm) {
3963 my $premo = CPAN::Shell->expand("Module",$pre);
3964 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3968 delete $self->{sponsored_mods};
3969 delete $self->{badtestcnt};
3971 $self->{incommandcolor} = $color;
3974 #-> sub CPAN::Distribution::as_string ;
3977 $self->containsmods;
3979 $self->SUPER::as_string(@_);
3982 #-> sub CPAN::Distribution::containsmods ;
3985 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3986 my $dist_id = $self->{ID};
3987 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3988 my $mod_file = $mod->cpan_file or next;
3989 my $mod_id = $mod->{ID} or next;
3990 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3992 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3994 keys %{$self->{CONTAINSMODS}};
3997 #-> sub CPAN::Distribution::upload_date ;
4000 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4001 my(@local_wanted) = split(/\//,$self->id);
4002 my $filename = pop [at]local_wanted;
4003 push [at]local_wanted, "CHECKSUMS";
4004 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4005 return unless $author;
4006 my [at]dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4007 return unless [at]dl;
4008 my($dirent) = grep { $_->[2] eq $filename } [at]dl;
4009 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4010 return unless $dirent->[1];
4011 return $self->{UPLOAD_DATE} = $dirent->[1];
4014 #-> sub CPAN::Distribution::uptodate ;
4018 foreach $c ($self->containsmods) {
4019 my $obj = CPAN::Shell->expandany($c);
4020 return 0 unless $obj->uptodate;
4025 #-> sub CPAN::Distribution::called_for ;
4028 $self->{CALLED_FOR} = $id if defined $id;
4029 return $self->{CALLED_FOR};
4032 #-> sub CPAN::Distribution::safe_chdir ;
4034 my($self,$todir) = @_;
4035 # we die if we cannot chdir and we are debuggable
4036 Carp::confess("safe_chdir called without todir argument")
4037 unless defined $todir and length $todir;
4039 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4042 my $cwd = CPAN::anycwd();
4043 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4044 qq{to todir[$todir]: $!});
4048 #-> sub CPAN::Distribution::get ;
4053 exists $self->{'build_dir'} and push @e,
4054 "Is already unwrapped into directory $self->{'build_dir'}";
4055 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4057 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4060 # Get the file on local disk
4065 File::Spec->catfile(
4066 $CPAN::Config->{keep_source_where},
4069 split(/\//,$self->id)
4072 $self->debug("Doing localize") if $CPAN::DEBUG;
4073 unless ($local_file =
4074 CPAN::FTP->localize("authors/id/$self->{ID}",
4077 if ($CPAN::Index::DATE_OF_02) {
4078 $note = "Note: Current database in memory was generated ".
4079 "on $CPAN::Index::DATE_OF_02\n";
4081 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4083 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4084 $self->{localfile} = $local_file;
4085 return if $CPAN::Signal;
4090 if ($CPAN::META->has_inst("Digest::MD5")) {
4091 $self->debug("Digest::MD5 is installed, verifying");
4094 $self->debug("Digest::MD5 is NOT installed");
4096 return if $CPAN::Signal;
4099 # Create a clean room and go there
4101 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4102 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4103 $self->safe_chdir($builddir);
4104 $self->debug("Removing tmp") if $CPAN::DEBUG;
4105 File::Path::rmtree("tmp");
4106 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
4108 $self->safe_chdir($sub_wd);
4111 $self->safe_chdir("tmp");
4116 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4117 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
4118 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
4119 $self->untar_me($local_file);
4120 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4121 $self->unzip_me($local_file);
4122 } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
4123 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
4124 $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
4125 $self->pm2dir_me($local_file);
4127 $self->{archived} = "NO";
4128 $self->safe_chdir($sub_wd);
4132 # we are still in the tmp directory!
4133 # Let's check if the package has its own directory.
4134 my $dh = DirHandle->new(File::Spec->curdir)
4135 or Carp::croak("Couldn't opendir .: $!");
4136 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4138 my ($distdir,$packagedir);
4139 if (@readdir == 1 && -d $readdir[0]) {
4140 $distdir = $readdir[0];
4141 $packagedir = File::Spec->catdir($builddir,$distdir);
4142 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4144 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4146 File::Path::rmtree($packagedir);
4147 File::Copy::move($distdir,$packagedir) or
4148 Carp::confess("Couldn't move $distdir to $packagedir: $!");
4149 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4156 my $userid = $self->cpan_userid;
4158 CPAN->debug("no userid? self[$self]");
4161 my $pragmatic_dir = $userid . '000';
4162 $pragmatic_dir =~ s/\W_//g;
4163 $pragmatic_dir++ while -d "../$pragmatic_dir";
4164 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4165 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4166 File::Path::mkpath($packagedir);
4168 for $f (@readdir) { # is already without "." and ".."
4169 my $to = File::Spec->catdir($packagedir,$f);
4170 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4174 $self->safe_chdir($sub_wd);
4178 $self->{'build_dir'} = $packagedir;
4179 $self->safe_chdir($builddir);
4180 File::Path::rmtree("tmp");
4182 $self->safe_chdir($packagedir);
4183 if ($CPAN::META->has_inst("Module::Signature")) {
4184 if (-f "SIGNATURE") {
4185 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4186 my $rv = Module::Signature::verify();
4187 if ($rv != Module::Signature::SIGNATURE_OK() and
4188 $rv != Module::Signature::SIGNATURE_MISSING()) {
4189 $CPAN::Frontend->myprint(
4190 qq{\nSignature invalid for }.
4191 qq{distribution file. }.
4192 qq{Please investigate.\n\n}.
4194 $CPAN::META->instance(
4200 my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
4201 is invalid. Maybe you have configured your 'urllist' with
4202 a bad URL. Please check this array with 'o conf urllist', and
4204 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4207 $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
4210 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4212 $self->safe_chdir($builddir);
4213 return if $CPAN::Signal;
4217 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4218 my($mpl_exists) = -f $mpl;
4219 unless ($mpl_exists) {
4220 # NFS has been reported to have racing problems after the
4221 # renaming of a directory in some environments.
4224 my $mpldh = DirHandle->new($packagedir)
4225 or Carp::croak("Couldn't opendir $packagedir: $!");
4226 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4229 unless ($mpl_exists) {
4230 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4234 my($configure) = File::Spec->catfile($packagedir,"Configure");
4235 if (-f $configure) {
4236 # do we have anything to do?
4237 $self->{'configure'} = $configure;
4238 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4239 $CPAN::Frontend->myprint(qq{
4240 Package comes with a Makefile and without a Makefile.PL.
4241 We\'ll try to build it with that Makefile then.
4243 $self->{writemakefile} = "YES";
4246 my $cf = $self->called_for || "unknown";
4251 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4252 $cf = "unknown" unless length($cf);
4253 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4254 (The test -f "$mpl" returned false.)
4255 Writing one on our own (setting NAME to $cf)\a\n});
4256 $self->{had_no_makefile_pl}++;
4259 # Writing our own Makefile.PL
4261 my $fh = FileHandle->new;
4263 or Carp::croak("Could not open >$mpl: $!");
4265 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4266 # because there was no Makefile.PL supplied.
4267 # Autogenerated on: }.scalar localtime().qq{
4269 use ExtUtils::MakeMaker;
4270 WriteMakefile(NAME => q[$cf]);
4280 # CPAN::Distribution::untar_me ;
4282 my($self,$local_file) = @_;
4283 $self->{archived} = "tar";
4284 if (CPAN::Tarzip->untar($local_file)) {
4285 $self->{unwrapped} = "YES";
4287 $self->{unwrapped} = "NO";
4291 # CPAN::Distribution::unzip_me ;
4293 my($self,$local_file) = @_;
4294 $self->{archived} = "zip";
4295 if (CPAN::Tarzip->unzip($local_file)) {
4296 $self->{unwrapped} = "YES";
4298 $self->{unwrapped} = "NO";
4304 my($self,$local_file) = @_;
4305 $self->{archived} = "pm";
4306 my $to = File::Basename::basename($local_file);
4307 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4308 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4309 $self->{unwrapped} = "YES";
4311 $self->{unwrapped} = "NO";
4314 File::Copy::cp($local_file,".");
4315 $self->{unwrapped} = "YES";
4319 #-> sub CPAN::Distribution::new ;
4321 my($class,%att) = @_;
4323 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4325 my $this = { %att };
4326 return bless $this, $class;
4329 #-> sub CPAN::Distribution::look ;
4333 if ($^O eq 'MacOS') {
4334 $self->Mac::BuildTools::look;
4338 if ( $CPAN::Config->{'shell'} ) {
4339 $CPAN::Frontend->myprint(qq{
4340 Trying to open a subshell in the build directory...
4343 $CPAN::Frontend->myprint(qq{
4344 Your configuration does not define a value for subshells.
4345 Please define it with "o conf shell <your shell>"
4349 my $dist = $self->id;
4351 unless ($dir = $self->dir) {
4354 unless ($dir ||= $self->dir) {
4355 $CPAN::Frontend->mywarn(qq{
4356 Could not determine which directory to use for looking at $dist.
4360 my $pwd = CPAN::anycwd();
4361 $self->safe_chdir($dir);
4362 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4363 unless (system($CPAN::Config->{'shell'}) == 0) {
4365 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4367 $self->safe_chdir($pwd);
4370 # CPAN::Distribution::cvs_import ;
4374 my $dir = $self->dir;
4376 my $package = $self->called_for;
4377 my $module = $CPAN::META->instance('CPAN::Module', $package);
4378 my $version = $module->cpan_version;
4380 my $userid = $self->cpan_userid;
4382 my $cvs_dir = (split /\//, $dir)[-1];
4383 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4385 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4387 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4388 if ($cvs_site_perl) {
4389 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4391 my $cvs_log = qq{"imported $package $version sources"};
4392 $version =~ s/\./_/g;
4393 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4394 "$cvs_dir", $userid, "v$version");
4396 my $pwd = CPAN::anycwd();
4397 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4399 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4401 $CPAN::Frontend->myprint(qq{@cmd\n});
4402 system(@cmd) == 0 or
4403 $CPAN::Frontend->mydie("cvs import failed");
4404 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4407 #-> sub CPAN::Distribution::readme ;
4410 my($dist) = $self->id;
4411 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4412 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4415 File::Spec->catfile(
4416 $CPAN::Config->{keep_source_where},
4419 split(/\//,"$sans.readme"),
4421 $self->debug("Doing localize") if $CPAN::DEBUG;
4422 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4424 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4426 if ($^O eq 'MacOS') {
4427 Mac::BuildTools::launch_file($local_file);
4431 my $fh_pager = FileHandle->new;
4432 local($SIG{PIPE}) = "IGNORE";
4433 $fh_pager->open("|$CPAN::Config->{'pager'}")
4434 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4435 my $fh_readme = FileHandle->new;
4436 $fh_readme->open($local_file)
4437 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4438 $CPAN::Frontend->myprint(qq{
4441 with pager "$CPAN::Config->{'pager'}"
4444 $fh_pager->print(<$fh_readme>);
4448 #-> sub CPAN::Distribution::verifyMD5 ;
4453 $self->{MD5_STATUS} ||= "";
4454 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4455 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4457 my($lc_want,$lc_file,@local,$basename);
4458 @local = split(/\//,$self->id);
4460 push @local, "CHECKSUMS";
4462 File::Spec->catfile($CPAN::Config->{keep_source_where},
4463 "authors", "id", @local);
4468 $self->MD5_check_file($lc_want)
4470 return $self->{MD5_STATUS} = "OK";
4472 $lc_file = CPAN::FTP->localize("authors/id/@local",
4475 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4476 $local[-1] .= ".gz";
4477 $lc_file = CPAN::FTP->localize("authors/id/@local",
4480 $lc_file =~ s/\.gz(?!\n)\Z//;
4481 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4486 $self->MD5_check_file($lc_file);
4489 sub SIG_check_file {
4490 my($self,$chk_file) = @_;
4491 my $rv = eval { Module::Signature::_verify($chk_file) };
4493 if ($rv == Module::Signature::SIGNATURE_OK()) {
4494 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
4495 return $self->{SIG_STATUS} = "OK";
4497 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
4498 qq{distribution file. }.
4499 qq{Please investigate.\n\n}.
4501 $CPAN::META->instance(
4506 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
4507 is invalid. Maybe you have configured your 'urllist' with
4508 a bad URL. Please check this array with 'o conf urllist', and
4511 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4515 #-> sub CPAN::Distribution::MD5_check_file ;
4516 sub MD5_check_file {
4517 my($self,$chk_file) = @_;
4518 my($cksum,$file,$basename);
4520 if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
4521 $self->debug("Module::Signature is installed, verifying");
4522 $self->SIG_check_file($chk_file);
4524 $self->debug("Module::Signature is NOT installed");
4527 $file = $self->{localfile};
4528 $basename = File::Basename::basename($file);
4529 my $fh = FileHandle->new;
4530 if (open $fh, $chk_file){
4533 $eval =~ s/\015?\012/\n/g;
4535 my($comp) = Safe->new();
4536 $cksum = $comp->reval($eval);
4538 rename $chk_file, "$chk_file.bad";
4539 Carp::confess($@) if $@;
4542 Carp::carp "Could not open $chk_file for reading";
4545 if (exists $cksum->{$basename}{md5}) {
4546 $self->debug("Found checksum for $basename:" .
4547 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4551 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4553 $fh = CPAN::Tarzip->TIEHANDLE($file);
4556 # had to inline it, when I tied it, the tiedness got lost on
4557 # the call to eq_MD5. (Jan 1998)
4558 my $md5 = Digest::MD5->new;
4561 while ($fh->READ($ref, 4096) > 0){
4564 my $hexdigest = $md5->hexdigest;
4565 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4569 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4570 return $self->{MD5_STATUS} = "OK";
4572 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4573 qq{distribution file. }.
4574 qq{Please investigate.\n\n}.
4576 $CPAN::META->instance(
4581 my $wrap = qq{I\'d recommend removing $file. Its MD5
4582 checksum is incorrect. Maybe you have configured your 'urllist' with
4583 a bad URL. Please check this array with 'o conf urllist', and
4586 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4588 # former versions just returned here but this seems a
4589 # serious threat that deserves a die
4591 # $CPAN::Frontend->myprint("\n\n");
4595 # close $fh if fileno($fh);
4597 $self->{MD5_STATUS} ||= "";
4598 if ($self->{MD5_STATUS} eq "NIL") {
4599 $CPAN::Frontend->mywarn(qq{
4600 Warning: No md5 checksum for $basename in $chk_file.
4602 The cause for this may be that the file is very new and the checksum
4603 has not yet been calculated, but it may also be that something is
4604 going awry right now.
4606 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4607 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4609 $self->{MD5_STATUS} = "NIL";
4614 #-> sub CPAN::Distribution::eq_MD5 ;
4616 my($self,$fh,$expectMD5) = @_;
4617 my $md5 = Digest::MD5->new;
4619 while (read($fh, $data, 4096)){
4622 # $md5->addfile($fh);
4623 my $hexdigest = $md5->hexdigest;
4624 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4625 $hexdigest eq $expectMD5;
4628 #-> sub CPAN::Distribution::force ;
4630 # Both modules and distributions know if "force" is in effect by
4631 # autoinspection, not by inspecting a global variable. One of the
4632 # reason why this was chosen to work that way was the treatment of
4633 # dependencies. They should not autpomatically inherit the force
4634 # status. But this has the downside that ^C and die() will return to
4635 # the prompt but will not be able to reset the force_update
4636 # attributes. We try to correct for it currently in the read_metadata
4637 # routine, and immediately before we check for a Signal. I hope this
4638 # works out in one of v1.57_53ff
4641 my($self, $method) = @_;
4643 MD5_STATUS archived build_dir localfile make install unwrapped
4646 delete $self->{$att};
4648 if ($method && $method eq "install") {
4649 $self->{"force_update"}++; # name should probably have been force_install
4654 my($self, $method) = [at]_;
4655 # warn "XDEBUG: set notest for $self $method";
4656 $self->{"notest"}++; # name should probably have been force_install
4661 # warn "XDEBUG: deleting notest";
4662 delete $self->{'notest'};
4665 #-> sub CPAN::Distribution::unforce ;
4668 delete $self->{'force_update'};
4671 #-> sub CPAN::Distribution::isa_perl ;
4674 my $file = File::Basename::basename($self->id);
4675 if ($file =~ m{ ^ perl
4688 } elsif ($self->cpan_comment
4690 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4696 #-> sub CPAN::Distribution::perl ;
4702 #-> sub CPAN::Distribution::make ;
4705 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4706 # Emergency brake if they said install Pippi and get newest perl
4707 if ($self->isa_perl) {
4709 $self->called_for ne $self->id &&
4710 ! $self->{force_update}
4712 # if we die here, we break bundles
4713 $CPAN::Frontend->mywarn(sprintf qq{
4714 The most recent version "%s" of the module "%s"
4715 comes with the current version of perl (%s).
4716 I\'ll build that only if you ask for something like
4721 $CPAN::META->instance(
4735 $self->{archived} eq "NO" and push @e,
4736 "Is neither a tar nor a zip archive.";
4738 $self->{unwrapped} eq "NO" and push @e,
4739 "had problems unarchiving. Please build manually";
4741 exists $self->{writemakefile} &&
4742 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4743 $1 || "Had some problem writing Makefile";
4745 defined $self->{'make'} and push @e,
4746 "Has already been processed within this session";
4748 exists $self->{later} and length($self->{later}) and
4749 push @e, $self->{later};
4751 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4753 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4754 my $builddir = $self->dir;
4755 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4756 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4758 if ($^O eq 'MacOS') {
4759 Mac::BuildTools::make($self);
4764 if ($self->{'configure'}) {
4765 $system = $self->{'configure'};
4767 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4769 # This needs a handler that can be turned on or off:
4770 # $switch = "-MExtUtils::MakeMaker ".
4771 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4773 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4775 unless (exists $self->{writemakefile}) {
4776 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4779 if ($CPAN::Config->{inactivity_timeout}) {
4781 alarm $CPAN::Config->{inactivity_timeout};
4782 local $SIG{CHLD}; # = sub { wait };
4783 if (defined($pid = fork)) {
4788 # note, this exec isn't necessary if
4789 # inactivity_timeout is 0. On the Mac I'd
4790 # suggest, we set it always to 0.
4794 $CPAN::Frontend->myprint("Cannot fork: $!");
4802 $CPAN::Frontend->myprint($@);
4803 $self->{writemakefile} = "NO $@";
4808 $ret = system($system);
4810 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4814 if (-f "Makefile") {
4815 $self->{writemakefile} = "YES";
4816 delete $self->{make_clean}; # if cleaned before, enable next
4818 $self->{writemakefile} =
4819 qq{NO Makefile.PL refused to write a Makefile.};
4820 # It's probably worth it to record the reason, so let's retry
4822 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4823 # $self->{writemakefile} .= <$fh>;
4827 delete $self->{force_update};
4830 if (my @prereq = $self->unsat_prereq){
4831 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4833 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4834 if (system($system) == 0) {
4835 $CPAN::Frontend->myprint(" $system -- OK\n");
4836 $self->{'make'} = "YES";
4838 $self->{writemakefile} ||= "YES";
4839 $self->{'make'} = "NO";
4840 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4844 sub follow_prereqs {
4848 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4849 "during [$id] -----\n");
4851 for my $p (@prereq) {
4852 $CPAN::Frontend->myprint(" $p\n");
4855 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4857 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4858 require ExtUtils::MakeMaker;
4859 my $answer = ExtUtils::MakeMaker::prompt(
4860 "Shall I follow them and prepend them to the queue
4861 of modules we are processing right now?", "yes");
4862 $follow = $answer =~ /^\s*y/i;
4866 myprint(" Ignoring dependencies on modules @prereq\n");
4869 # color them as dirty
4870 for my $p (@prereq) {
4871 # warn "calling color_cmd_tmps(0,1)";
4872 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4874 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4875 $self->{later} = "Delayed until after prerequisites";
4876 return 1; # signal success to the queuerunner
4880 #-> sub CPAN::Distribution::unsat_prereq ;
4883 my $prereq_pm = $self->prereq_pm or return;
4885 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4886 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4887 # we were too demanding:
4888 next if $nmo->uptodate;
4890 # if they have not specified a version, we accept any installed one
4891 if (not defined $need_version or
4892 $need_version == 0 or
4893 $need_version eq "undef") {
4894 next if defined $nmo->inst_file;
4897 # We only want to install prereqs if either they're not installed
4898 # or if the installed version is too old. We cannot omit this
4899 # check, because if 'force' is in effect, nobody else will check.
4903 defined $nmo->inst_file &&
4904 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4906 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4910 CPAN::Version->readable($need_version)
4916 if ($self->{sponsored_mods}{$need_module}++){
4917 # We have already sponsored it and for some reason it's still
4918 # not available. So we do nothing. Or what should we do?
4919 # if we push it again, we have a potential infinite loop
4922 push @need, $need_module;
4927 #-> sub CPAN::Distribution::prereq_pm ;
4930 return $self->{prereq_pm} if
4931 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4932 return unless $self->{writemakefile}; # no need to have succeeded
4933 # but we must have run it
4934 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4935 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4940 $fh = FileHandle->new("<$makefile\0")) {
4944 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4946 last if /MakeMaker post_initialize section/;
4948 \s+PREREQ_PM\s+=>\s+(.+)
4951 # warn "Found prereq expr[$p]";
4953 # Regexp modified by A.Speer to remember actual version of file
4954 # PREREQ_PM hash key wants, then add to
4955 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4956 # In case a prereq is mentioned twice, complain.
4957 if ( defined $p{$1} ) {
4958 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4965 $self->{prereq_pm_detected}++;
4966 return $self->{prereq_pm} = \%p;
4969 #-> sub CPAN::Distribution::test ;
4974 delete $self->{force_update};
4977 # warn "XDEBUG: checking for notest: $self->{notest} $self";
4978 if ($self->{notest}) {
4979 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
4983 $CPAN::Frontend->myprint("Running make test\n");
4984 if (my @prereq = $self->unsat_prereq){
4985 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4989 exists $self->{make} or exists $self->{later} or push @e,
4990 "Make had some problems, maybe interrupted? Won't test";
4992 exists $self->{'make'} and
4993 $self->{'make'} eq 'NO' and
4994 push @e, "Can't test without successful make";
4996 exists $self->{build_dir} or push @e, "Has no own directory";
4997 $self->{badtestcnt} ||= 0;
4998 $self->{badtestcnt} > 0 and
4999 push @e, "Won't repeat unsuccessful test during this command";
5001 exists $self->{later} and length($self->{later}) and
5002 push @e, $self->{later};
5004 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5006 chdir $self->{'build_dir'} or
5007 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5008 $self->debug("Changed directory to $self->{'build_dir'}")
5011 if ($^O eq 'MacOS') {
5012 Mac::BuildTools::make_test($self);
5016 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5018 : ($ENV{PERLLIB} || "");
5020 $CPAN::META->set_perl5lib;
5021 my $system = join " ", $CPAN::Config->{'make'}, "test";
5022 if (system($system) == 0) {
5023 $CPAN::Frontend->myprint(" $system -- OK\n");
5024 $CPAN::META->is_tested($self->{'build_dir'});
5025 $self->{make_test} = "YES";
5027 $self->{make_test} = "NO";
5028 $self->{badtestcnt}++;
5029 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
5033 #-> sub CPAN::Distribution::clean ;
5036 $CPAN::Frontend->myprint("Running make clean\n");
5039 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
5040 push @e, "make clean already called once";
5041 exists $self->{build_dir} or push @e, "Has no own directory";
5042 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5044 chdir $self->{'build_dir'} or
5045 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5046 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
5048 if ($^O eq 'MacOS') {
5049 Mac::BuildTools::make_clean($self);
5053 my $system = join " ", $CPAN::Config->{'make'}, "clean";
5054 if (system($system) == 0) {
5055 $CPAN::Frontend->myprint(" $system -- OK\n");
5059 # Jost Krieger pointed out that this "force" was wrong because
5060 # it has the effect that the next "install" on this distribution
5061 # will untar everything again. Instead we should bring the
5062 # object's state back to where it is after untarring.
5064 delete $self->{force_update};
5065 delete $self->{install};
5066 delete $self->{writemakefile};
5067 delete $self->{make};
5068 delete $self->{make_test}; # no matter if yes or no, tests must be redone
5069 $self->{make_clean} = "YES";
5072 # Hmmm, what to do if make clean failed?
5074 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
5076 make clean did not succeed, marking directory as unusable for further work.
5078 $self->force("make"); # so that this directory won't be used again
5083 #-> sub CPAN::Distribution::install ;
5088 delete $self->{force_update};
5091 $CPAN::Frontend->myprint("Running make install\n");
5094 exists $self->{build_dir} or push @e, "Has no own directory";
5096 exists $self->{make} or exists $self->{later} or push @e,
5097 "Make had some problems, maybe interrupted? Won't install";
5099 exists $self->{'make'} and
5100 $self->{'make'} eq 'NO' and
5101 push @e, "make had returned bad status, install seems impossible";
5103 push @e, "make test had returned bad status, ".
5104 "won't install without force"
5105 if exists $self->{'make_test'} and
5106 $self->{'make_test'} eq 'NO' and
5107 ! $self->{'force_update'};
5109 exists $self->{'install'} and push @e,
5110 $self->{'install'} eq "YES" ?
5111 "Already done" : "Already tried without success";
5113 exists $self->{later} and length($self->{later}) and
5114 push @e, $self->{later};
5116 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5118 chdir $self->{'build_dir'} or
5119 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5120 $self->debug("Changed directory to $self->{'build_dir'}")
5123 if ($^O eq 'MacOS') {
5124 Mac::BuildTools::make_install($self);
5128 my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
5129 $CPAN::Config->{'make'};
5131 my($system) = join(" ",
5132 $make_install_make_command,
5134 $CPAN::Config->{make_install_arg},
5136 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
5137 my($pipe) = FileHandle->new("$system $stderr |");
5140 $CPAN::Frontend->myprint($_);
5145 $CPAN::Frontend->myprint(" $system -- OK\n");
5146 $CPAN::META->is_installed($self->{'build_dir'});
5147 return $self->{'install'} = "YES";
5149 $self->{'install'} = "NO";
5150 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
5152 $makeout =~ /permission/s
5155 ! $CPAN::Config->{make_install_make_command}
5156 || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
5159 $CPAN::Frontend->myprint(
5161 qq{ You may have to su }.
5162 qq{to root to install the package\n}.
5163 qq{ (Or you may want to run something like\n}.
5164 qq{ o conf make_install_make_command 'sudo make'\n}.
5165 qq{ to raise your permissions.}
5169 delete $self->{force_update};
5172 #-> sub CPAN::Distribution::dir ;
5174 shift->{'build_dir'};
5177 #-> sub CPAN::Distribution::perldoc ;
5181 my($dist) = $self->id;
5182 my $package = $self->called_for;
5184 $self->_display_url( $CPAN::Defaultdocs . $package );
5187 #-> sub CPAN::Distribution::_check_binary ;
5189 my ($dist,$shell,$binary) = [at]_;
5190 my ($pid,$readme,$out);
5192 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
5195 $pid = open $readme, "-|", "which", $binary
5196 or $CPAN::Frontend->mydie(qq{Could not fork $binary: $!});
5202 $CPAN::Frontend->myprint(qq{ + $out \n})
5203 if $CPAN::DEBUG && $out;
5208 #-> sub CPAN::Distribution::_display_url ;
5210 my($self,$url) = [at]_;
5211 my($res,$saved_file,$pid,$readme,$out);
5213 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
5216 # should we define it in the config instead?
5217 my $html_converter = "html2text";
5219 my $web_browser = $CPAN::Config->{'lynx'} || undef;
5220 my $web_browser_out = $web_browser
5221 ? CPAN::Distribution->_check_binary($self,$web_browser)
5224 my ($tmpout,$tmperr);
5225 if (not $web_browser_out) {
5226 # web browser not found, let's try text only
5227 my $html_converter_out =
5228 CPAN::Distribution->_check_binary($self,$html_converter);
5230 if ($html_converter_out ) {
5231 # html2text found, run it
5232 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
5233 $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
5234 unless defined($saved_file);
5236 $pid = open $readme, "-|", $html_converter, $saved_file
5237 or $CPAN::Frontend->mydie(qq{
5238 Could not fork $html_converter $saved_file: $!});
5239 my $fh = File::Temp->new(
5240 template => 'cpan_htmlconvert_XXXX',
5248 or $CPAN::Frontend->mydie(qq{Could not close file handle: $!});
5249 my $tmpin = $fh->filename;
5250 $CPAN::Frontend->myprint(sprintf(qq{
5252 saved output to %s\n},
5257 close $fh; undef $fh;
5259 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
5260 my $fh_pager = FileHandle->new;
5261 local($SIG{PIPE}) = "IGNORE";
5262 $fh_pager->open("|$CPAN::Config->{'pager'}")
5263 or $CPAN::Frontend->mydie(qq{
5264 Could not open pager $CPAN::Config->{'pager'}: $!});
5265 $CPAN::Frontend->myprint(qq{
5268 with pager "$CPAN::Config->{'pager'}"
5271 $fh_pager->print(<$fh>);
5274 # coldn't find the web browser or html converter
5275 $CPAN::Frontend->myprint(qq{
5276 You need to install lynx or $html_converter to use this feature.});
5279 # web browser found, run the action
5280 my $browser = $CPAN::Config->{'lynx'};
5281 $CPAN::Frontend->myprint(qq{system[$browser $url]})
5283 $CPAN::Frontend->myprint(qq{
5286 with browser $browser
5289 system("$browser $url");
5290 if ($saved_file) { 1 while unlink($saved_file) }
5294 #-> sub CPAN::Distribution::_getsave_url ;
5296 my($dist, $shell, $url) = [at]_;
5298 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
5301 my $fh = File::Temp->new(
5302 template => "cpan_getsave_url_XXXX",
5306 my $tmpin = $fh->filename;
5307 if ($CPAN::META->has_usable('LWP')) {
5308 $CPAN::Frontend->myprint("Fetching with LWP:
5312 CPAN::LWP::UserAgent->config;
5313 eval { $Ua = CPAN::LWP::UserAgent->new; };
5315 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
5319 $Ua->proxy('http', $var)
5320 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
5322 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
5325 my $req = HTTP::Request->new(GET => $url);
5326 $req->header('Accept' => 'text/html');
5327 my $res = $Ua->request($req);
5328 if ($res->is_success) {
5329 $CPAN::Frontend->myprint(" + request successful.\n")
5331 print $fh $res->content;
5333 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
5337 $CPAN::Frontend->myprint(sprintf(
5338 "LWP failed with code[%s], message[%s]\n",
5345 $CPAN::Frontend->myprint("LWP not available\n");
5350 package CPAN::Bundle;
5354 $CPAN::Frontend->myprint($self->as_string);
5359 delete $self->{later};
5360 for my $c ( $self->contains ) {
5361 my $obj = CPAN::Shell->expandany($c) or next;
5366 #-> sub CPAN::Bundle::color_cmd_tmps ;
5367 sub color_cmd_tmps {
5369 my($depth) = shift || 0;
5370 my($color) = shift || 0;
5371 my($ancestors) = shift || [];
5372 # a module needs to recurse to its cpan_file, a distribution needs
5373 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
5375 return if exists $self->{incommandcolor}
5376 && $self->{incommandcolor}==$color;
5378 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5380 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5382 for my $c ( $self->contains ) {
5383 my $obj = CPAN::Shell->expandany($c) or next;
5384 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
5385 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5388 delete $self->{badtestcnt};
5390 $self->{incommandcolor} = $color;
5393 #-> sub CPAN::Bundle::as_string ;
5397 # following line must be "=", not "||=" because we have a moving target
5398 $self->{INST_VERSION} = $self->inst_version;
5399 return $self->SUPER::as_string;
5402 #-> sub CPAN::Bundle::contains ;
5405 my($inst_file) = $self->inst_file || "";
5406 my($id) = $self->id;
5407 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
5408 unless ($inst_file) {
5409 # Try to get at it in the cpan directory
5410 $self->debug("no inst_file") if $CPAN::DEBUG;
5412 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
5413 $cpan_file = $self->cpan_file;
5414 if ($cpan_file eq "N/A") {
5415 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
5416 Maybe stale symlink? Maybe removed during session? Giving up.\n");
5418 my $dist = $CPAN::META->instance('CPAN::Distribution',
5421 $self->debug($dist->as_string) if $CPAN::DEBUG;
5422 my($todir) = $CPAN::Config->{'cpan_home'};
5423 my(@me,$from,$to,$me);
5424 @me = split /::/, $self->id;
5426 $me = File::Spec->catfile(@me);
5427 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5428 $to = File::Spec->catfile($todir,$me);
5429 File::Path::mkpath(File::Basename::dirname($to));
5430 File::Copy::copy($from, $to)
5431 or Carp::confess("Couldn't copy $from to $to: $!");
5435 my $fh = FileHandle->new;
5437 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
5439 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
5441 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
5442 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
5443 next unless $in_cont;
5448 push @result, (split " ", $_, 2)[0];
5451 delete $self->{STATUS};
5452 $self->{CONTAINS} = \@result;
5453 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5455 $CPAN::Frontend->mywarn(qq{
5456 The bundle file "$inst_file" may be a broken
5457 bundlefile. It seems not to contain any bundle definition.
5458 Please check the file and if it is bogus, please delete it.
5459 Sorry for the inconvenience.
5465 #-> sub CPAN::Bundle::find_bundle_file
5466 sub find_bundle_file {
5467 my($self,$where,$what) = @_;
5468 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5469 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5470 ### my $bu = File::Spec->catfile($where,$what);
5471 ### return $bu if -f $bu;
5472 my $manifest = File::Spec->catfile($where,"MANIFEST");
5473 unless (-f $manifest) {
5474 require ExtUtils::Manifest;
5475 my $cwd = CPAN::anycwd();
5476 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5477 ExtUtils::Manifest::mkmanifest();
5478 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5480 my $fh = FileHandle->new($manifest)
5481 or Carp::croak("Couldn't open $manifest: $!");
5484 if ($^O eq 'MacOS') {
5487 $what2 =~ s/:Bundle://;
5490 $what2 =~ s|Bundle[/\\]||;
5495 my($file) = /(\S+)/;
5496 if ($file =~ m|\Q$what\E$|) {
5498 # return File::Spec->catfile($where,$bu); # bad
5501 # retry if she managed to
5502 # have no Bundle directory
5503 $bu = $file if $file =~ m|\Q$what2\E$|;
5505 $bu =~ tr|/|:| if $^O eq 'MacOS';
5506 return File::Spec->catfile($where, $bu) if $bu;
5507 Carp::croak("Couldn't find a Bundle file in $where");
5510 # needs to work quite differently from Module::inst_file because of
5511 # cpan_home/Bundle/ directory and the possibility that we have
5512 # shadowing effect. As it makes no sense to take the first in @INC for
5513 # Bundles, we parse them all for $VERSION and take the newest.
5515 #-> sub CPAN::Bundle::inst_file ;
5520 @me = split /::/, $self->id;
5523 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5524 my $bfile = File::Spec->catfile($incdir, @me);
5525 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5526 next unless -f $bfile;
5527 my $foundv = MM->parse_version($bfile);
5528 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5529 $self->{INST_FILE} = $bfile;
5530 $self->{INST_VERSION} = $bestv = $foundv;
5536 #-> sub CPAN::Bundle::inst_version ;
5539 $self->inst_file; # finds INST_VERSION as side effect
5540 $self->{INST_VERSION};
5543 #-> sub CPAN::Bundle::rematein ;
5545 my($self,$meth) = @_;
5546 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5547 my($id) = $self->id;
5548 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5549 unless $self->inst_file || $self->cpan_file;
5551 for $s ($self->contains) {
5552 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5553 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5554 if ($type eq 'CPAN::Distribution') {
5555 $CPAN::Frontend->mywarn(qq{
5556 The Bundle }.$self->id.qq{ contains
5557 explicitly a file $s.
5561 # possibly noisy action:
5562 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5563 my $obj = $CPAN::META->instance($type,$s);
5565 if ($obj->isa(CPAN::Bundle)
5567 exists $obj->{install_failed}
5569 ref($obj->{install_failed}) eq "HASH"
5571 for (keys %{$obj->{install_failed}}) {
5572 $self->{install_failed}{$_} = undef; # propagate faiure up
5575 $fail{$s} = 1; # the bundle itself may have succeeded but
5580 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5581 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5583 delete $self->{install_failed}{$s};
5590 # recap with less noise
5591 if ( $meth eq "install" ) {
5594 my $raw = sprintf(qq{Bundle summary:
5595 The following items in bundle %s had installation problems:},
5598 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5599 $CPAN::Frontend->myprint("\n");
5602 for $s ($self->contains) {
5604 $paragraph .= "$s ";
5605 $self->{install_failed}{$s} = undef;
5606 $reported{$s} = undef;
5609 my $report_propagated;
5610 for $s (sort keys %{$self->{install_failed}}) {
5611 next if exists $reported{$s};
5612 $paragraph .= "and the following items had problems
5613 during recursive bundle calls: " unless $report_propagated++;
5614 $paragraph .= "$s ";
5616 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5617 $CPAN::Frontend->myprint("\n");
5619 $self->{'install'} = 'YES';
5624 #sub CPAN::Bundle::xs_file
5626 # If a bundle contains another that contains an xs_file we have
5627 # here, we just don't bother I suppose
5631 #-> sub CPAN::Bundle::force ;
5632 sub force { shift->rematein('force',@_); }
5633 #-> sub CPAN::Bundle::notest ;
5634 sub notest { shift->rematein('notest',@_); }
5635 #-> sub CPAN::Bundle::get ;
5636 sub get { shift->rematein('get',@_); }
5637 #-> sub CPAN::Bundle::make ;
5638 sub make { shift->rematein('make',@_); }
5639 #-> sub CPAN::Bundle::test ;
5642 $self->{badtestcnt} ||= 0;
5643 $self->rematein('test',@_);
5645 #-> sub CPAN::Bundle::install ;
5648 $self->rematein('install',@_);
5650 #-> sub CPAN::Bundle::clean ;
5651 sub clean { shift->rematein('clean',@_); }
5653 #-> sub CPAN::Bundle::uptodate ;
5656 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5658 foreach $c ($self->contains) {
5659 my $obj = CPAN::Shell->expandany($c);
5660 return 0 unless $obj->uptodate;
5665 #-> sub CPAN::Bundle::readme ;
5668 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5669 No File found for bundle } . $self->id . qq{\n}), return;
5670 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5671 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5674 package CPAN::Module;
5677 # sub CPAN::Module::userid
5680 return unless exists $self->{RO}; # should never happen
5681 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5683 # sub CPAN::Module::description
5684 sub description { shift->{RO}{description} }
5688 delete $self->{later};
5689 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5694 #-> sub CPAN::Module::color_cmd_tmps ;
5695 sub color_cmd_tmps {
5697 my($depth) = shift || 0;
5698 my($color) = shift || 0;
5699 my($ancestors) = shift || [];
5700 # a module needs to recurse to its cpan_file
5702 return if exists $self->{incommandcolor}
5703 && $self->{incommandcolor}==$color;
5705 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5707 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5709 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5710 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5713 delete $self->{badtestcnt};
5715 $self->{incommandcolor} = $color;
5718 #-> sub CPAN::Module::as_glimpse ;
5722 my $class = ref($self);
5723 $class =~ s/^CPAN:://;
5727 $CPAN::Shell::COLOR_REGISTERED
5729 $CPAN::META->has_inst("Term::ANSIColor")
5731 $self->{RO}{description}
5733 $color_on = Term::ANSIColor::color("green");
5734 $color_off = Term::ANSIColor::color("reset");
5736 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5745 #-> sub CPAN::Module::as_string ;
5749 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5750 my $class = ref($self);
5751 $class =~ s/^CPAN:://;
5753 push @m, $class, " id = $self->{ID}\n";
5754 my $sprintf = " %-12s %s\n";
5755 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5756 if $self->description;
5757 my $sprintf2 = " %-12s %s (%s)\n";
5759 $userid = $self->userid;
5762 if ($author = CPAN::Shell->expand('Author',$userid)) {
5765 if ($m = $author->email) {
5772 $author->fullname . $email
5776 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5777 if $self->cpan_version;
5778 if (my $cpan_file = $self->cpan_file){
5779 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
5780 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
5781 my $upload_date = $dist->upload_date;
5783 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
5787 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5788 my(%statd,%stats,%statl,%stati);
5789 @statd{qw,? i c a b R M S,} = qw,unknown idea
5790 pre-alpha alpha beta released mature standard,;
5791 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5792 developer comp.lang.perl.* none abandoned,;
5793 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5794 @stati{qw,? f r O h,} = qw,unknown functions
5795 references+ties object-oriented hybrid,;
5796 $statd{' '} = 'unknown';
5797 $stats{' '} = 'unknown';
5798 $statl{' '} = 'unknown';
5799 $stati{' '} = 'unknown';
5807 $statd{$self->{RO}{statd}},
5808 $stats{$self->{RO}{stats}},
5809 $statl{$self->{RO}{statl}},
5810 $stati{$self->{RO}{stati}}
5811 ) if $self->{RO}{statd};
5812 my $local_file = $self->inst_file;
5813 unless ($self->{MANPAGE}) {
5815 $self->{MANPAGE} = $self->manpage_headline($local_file);
5817 # If we have already untarred it, we should look there
5818 my $dist = $CPAN::META->instance('CPAN::Distribution',
5820 # warn "dist[$dist]";
5821 # mff=manifest file; mfh=manifest handle
5826 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5828 $mfh = FileHandle->new($mff)
5830 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5831 my $lfre = $self->id; # local file RE
5834 my($lfl); # local file file
5836 my(@mflines) = <$mfh>;
5841 while (length($lfre)>5 and !$lfl) {
5842 ($lfl) = grep /$lfre/, @mflines;
5843 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5846 $lfl =~ s/\s.*//; # remove comments
5847 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5848 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5849 # warn "lfl_abs[$lfl_abs]";
5851 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5857 for $item (qw/MANPAGE/) {
5858 push @m, sprintf($sprintf, $item, $self->{$item})
5859 if exists $self->{$item};
5861 for $item (qw/CONTAINS/) {
5862 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5863 if exists $self->{$item} && @{$self->{$item}};
5865 push @m, sprintf($sprintf, 'INST_FILE',
5866 $local_file || "(not installed)");
5867 push @m, sprintf($sprintf, 'INST_VERSION',
5868 $self->inst_version) if $local_file;
5872 sub manpage_headline {
5873 my($self,$local_file) = @_;
5874 my(@local_file) = $local_file;
5875 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5876 push @local_file, $local_file;
5878 for $locf (@local_file) {
5879 next unless -f $locf;
5880 my $fh = FileHandle->new($locf)
5881 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5885 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5886 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5899 #-> sub CPAN::Module::cpan_file ;
5900 # Note: also inherited by CPAN::Bundle
5903 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5904 unless (defined $self->{RO}{CPAN_FILE}) {
5905 CPAN::Index->reload;
5907 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5908 return $self->{RO}{CPAN_FILE};
5910 my $userid = $self->userid;
5912 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5913 my $author = $CPAN::META->instance("CPAN::Author",
5915 my $fullname = $author->fullname;
5916 my $email = $author->email;
5917 unless (defined $fullname && defined $email) {
5918 return sprintf("Contact Author %s",
5922 return "Contact Author $fullname <$email>";
5924 return "Contact Author $userid (Email address not available)";
5932 #-> sub CPAN::Module::cpan_version ;
5936 $self->{RO}{CPAN_VERSION} = 'undef'
5937 unless defined $self->{RO}{CPAN_VERSION};
5938 # I believe this is always a bug in the index and should be reported
5939 # as such, but usually I find out such an error and do not want to
5940 # provoke too many bugreports
5942 $self->{RO}{CPAN_VERSION};
5945 #-> sub CPAN::Module::force ;
5948 $self->{'force_update'}++;
5953 # warn "XDEBUG: set notest for Module";
5954 $self->{'notest'}++;
5957 #-> sub CPAN::Module::rematein ;
5959 my($self,$meth) = @_;
5960 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5963 my $cpan_file = $self->cpan_file;
5964 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5965 $CPAN::Frontend->mywarn(sprintf qq{
5966 The module %s isn\'t available on CPAN.
5968 Either the module has not yet been uploaded to CPAN, or it is
5969 temporary unavailable. Please contact the author to find out
5970 more about the status. Try 'i %s'.
5977 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5978 $pack->called_for($self->id);
5979 $pack->force($meth) if exists $self->{'force_update'};
5980 $pack->notest($meth) if exists $self->{'notest'};
5985 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5986 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
5987 delete $self->{'force_update'};
5988 delete $self->{'notest'};
5994 #-> sub CPAN::Module::perldoc ;
5995 sub perldoc { shift->rematein('perldoc') }
5996 #-> sub CPAN::Module::readme ;
5997 sub readme { shift->rematein('readme') }
5998 #-> sub CPAN::Module::look ;
5999 sub look { shift->rematein('look') }
6000 #-> sub CPAN::Module::cvs_import ;
6001 sub cvs_import { shift->rematein('cvs_import') }
6002 #-> sub CPAN::Module::get ;
6003 sub get { shift->rematein('get',@_) }
6004 #-> sub CPAN::Module::make ;
6005 sub make { shift->rematein('make') }
6006 #-> sub CPAN::Module::test ;
6009 $self->{badtestcnt} ||= 0;
6010 $self->rematein('test',@_);
6012 #-> sub CPAN::Module::uptodate ;
6015 my($latest) = $self->cpan_version;
6017 my($inst_file) = $self->inst_file;
6019 if (defined $inst_file) {
6020 $have = $self->inst_version;
6025 ! CPAN::Version->vgt($latest, $have)
6027 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
6028 "latest[$latest] have[$have]") if $CPAN::DEBUG;
6033 #-> sub CPAN::Module::install ;
6039 not exists $self->{'force_update'}
6041 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
6045 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
6046 $CPAN::Frontend->mywarn(qq{
6047 \n\n\n ***WARNING***
6048 The module $self->{ID} has no active maintainer.\n\n\n
6052 $self->rematein('install') if $doit;
6054 #-> sub CPAN::Module::clean ;
6055 sub clean { shift->rematein('clean') }
6057 #-> sub CPAN::Module::inst_file ;
6061 @packpath = split /::/, $self->{ID};
6062 $packpath[-1] .= ".pm";
6063 foreach $dir (@INC) {
6064 my $pmfile = File::Spec->catfile($dir,@packpath);
6072 #-> sub CPAN::Module::xs_file ;
6076 @packpath = split /::/, $self->{ID};
6077 push @packpath, $packpath[-1];
6078 $packpath[-1] .= "." . $Config::Config{'dlext'};
6079 foreach $dir (@INC) {
6080 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
6088 #-> sub CPAN::Module::inst_version ;
6091 my $parsefile = $self->inst_file or return;
6092 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
6095 # there was a bug in 5.6.0 that let lots of unini warnings out of
6096 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
6097 # the following workaround after 5.6.1 is out.
6098 local($SIG{__WARN__}) = sub { my $w = shift;
6099 return if $w =~ /uninitialized/i;
6103 $have = MM->parse_version($parsefile) || "undef";
6104 $have =~ s/^ //; # since the %vd hack these two lines here are needed
6105 $have =~ s/ $//; # trailing whitespace happens all the time
6107 # My thoughts about why %vd processing should happen here
6109 # Alt1 maintain it as string with leading v:
6110 # read index files do nothing
6111 # compare it use utility for compare
6112 # print it do nothing
6114 # Alt2 maintain it as what it is
6115 # read index files convert
6116 # compare it use utility because there's still a ">" vs "gt" issue
6117 # print it use CPAN::Version for print
6119 # Seems cleaner to hold it in memory as a string starting with a "v"
6121 # If the author of this module made a mistake and wrote a quoted
6122 # "v1.13" instead of v1.13, we simply leave it at that with the
6123 # effect that *we* will treat it like a v-tring while the rest of
6124 # perl won't. Seems sensible when we consider that any action we
6125 # could take now would just add complexity.
6127 $have = CPAN::Version->readable($have);
6129 $have =~ s/\s*//g; # stringify to float around floating point issues
6130 $have; # no stringify needed, \s* above matches always
6133 package CPAN::Tarzip;
6135 # CPAN::Tarzip::gzip
6137 my($class,$read,$write) = @_;
6138 if ($CPAN::META->has_inst("Compress::Zlib")) {
6140 $fhw = FileHandle->new($read)
6141 or $CPAN::Frontend->mydie("Could not open $read: $!");
6143 my $gz = Compress::Zlib::gzopen($write, "wb")
6144 or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
6145 $gz->gzwrite($buffer)
6146 while read($fhw,$buffer,4096) > 0 ;
6151 system("$CPAN::Config->{gzip} -c $read > $write")==0;
6156 # CPAN::Tarzip::gunzip
6158 my($class,$read,$write) = @_;
6159 if ($CPAN::META->has_inst("Compress::Zlib")) {
6161 $fhw = FileHandle->new(">$write")
6162 or $CPAN::Frontend->mydie("Could not open >$write: $!");
6163 my $gz = Compress::Zlib::gzopen($read, "rb")
6164 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
6165 $fhw->print($buffer)
6166 while $gz->gzread($buffer) > 0 ;
6167 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
6168 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
6173 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
6178 # CPAN::Tarzip::gtest
6180 my($class,$read) = @_;
6181 # After I had reread the documentation in zlib.h, I discovered that
6182 # uncompressed files do not lead to an gzerror (anymore?).
6183 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
6186 my $gz = Compress::Zlib::gzopen($read, "rb")
6187 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
6189 $Compress::Zlib::gzerrno));
6190 while ($gz->gzread($buffer) > 0 ){
6191 $len += length($buffer);
6194 my $err = $gz->gzerror;
6195 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
6196 if ($len == -s $read){
6198 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
6201 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
6204 return system("$CPAN::Config->{gzip} -dt $read")==0;
6209 # CPAN::Tarzip::TIEHANDLE
6211 my($class,$file) = @_;
6213 $class->debug("file[$file]");
6214 if ($CPAN::META->has_inst("Compress::Zlib")) {
6215 my $gz = Compress::Zlib::gzopen($file,"rb") or
6216 die "Could not gzopen $file";
6217 $ret = bless {GZ => $gz}, $class;
6219 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
6220 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
6222 $ret = bless {FH => $fh}, $class;
6228 # CPAN::Tarzip::READLINE
6231 if (exists $self->{GZ}) {
6232 my $gz = $self->{GZ};
6233 my($line,$bytesread);
6234 $bytesread = $gz->gzreadline($line);
6235 return undef if $bytesread <= 0;
6238 my $fh = $self->{FH};
6239 return scalar <$fh>;
6244 # CPAN::Tarzip::READ
6246 my($self,$ref,$length,$offset) = @_;
6247 die "read with offset not implemented" if defined $offset;
6248 if (exists $self->{GZ}) {
6249 my $gz = $self->{GZ};
6250 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
6253 my $fh = $self->{FH};
6254 return read($fh,$$ref,$length);
6259 # CPAN::Tarzip::DESTROY
6262 if (exists $self->{GZ}) {
6263 my $gz = $self->{GZ};
6264 $gz->gzclose() if defined $gz; # hard to say if it is allowed
6265 # to be undef ever. AK, 2000-09
6267 my $fh = $self->{FH};
6268 $fh->close if defined $fh;
6274 # CPAN::Tarzip::untar
6276 my($class,$file) = @_;
6279 if (0) { # makes changing order easier
6280 } elsif ($BUGHUNTING){
6282 } elsif (MM->maybe_command($CPAN::Config->{gzip})
6284 MM->maybe_command($CPAN::Config->{'tar'})) {
6285 # should be default until Archive::Tar is fixed
6288 $CPAN::META->has_inst("Archive::Tar")
6290 $CPAN::META->has_inst("Compress::Zlib") ) {
6293 $CPAN::Frontend->mydie(qq{
6294 CPAN.pm needs either both external programs tar and gzip installed or
6295 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
6296 is available. Can\'t continue.
6299 if ($prefer==1) { # 1 => external gzip+tar
6301 my $is_compressed = $class->gtest($file);
6302 if ($is_compressed) {
6303 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
6304 "< $file | $CPAN::Config->{tar} xvf -";
6306 $system = "$CPAN::Config->{tar} xvf $file";
6308 if (system($system) != 0) {
6309 # people find the most curious tar binaries that cannot handle
6311 if ($is_compressed) {
6312 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
6313 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
6314 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
6316 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
6320 $system = "$CPAN::Config->{tar} xvf $file";
6321 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
6322 if (system($system)==0) {
6323 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
6325 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
6331 } elsif ($prefer==2) { # 2 => modules
6332 my $tar = Archive::Tar->new($file,1);
6333 my $af; # archive file
6336 # RCS 1.337 had this code, it turned out unacceptable slow but
6337 # it revealed a bug in Archive::Tar. Code is only here to hunt
6338 # the bug again. It should never be enabled in published code.
6339 # GDGraph3d-0.53 was an interesting case according to Larry
6341 warn(">>>Bughunting code enabled<<< " x 20);
6342 for $af ($tar->list_files) {
6343 if ($af =~ m!^(/|\.\./)!) {
6344 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6345 "illegal member [$af]");
6347 $CPAN::Frontend->myprint("$af\n");
6348 $tar->extract($af); # slow but effective for finding the bug
6349 return if $CPAN::Signal;
6352 for $af ($tar->list_files) {
6353 if ($af =~ m!^(/|\.\./)!) {
6354 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6355 "illegal member [$af]");
6357 $CPAN::Frontend->myprint("$af\n");
6359 return if $CPAN::Signal;
6364 Mac::BuildTools::convert_files([$tar->list_files], 1)
6365 if ($^O eq 'MacOS');
6372 my($class,$file) = @_;
6373 if ($CPAN::META->has_inst("Archive::Zip")) {
6374 # blueprint of the code from Archive::Zip::Tree::extractTree();
6375 my $zip = Archive::Zip->new();
6377 $status = $zip->read($file);
6378 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
6379 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
6380 my @members = $zip->members();
6381 for my $member ( @members ) {
6382 my $af = $member->fileName();
6383 if ($af =~ m!^(/|\.\./)!) {
6384 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6385 "illegal member [$af]");
6387 my $status = $member->extractToFileNamed( $af );
6388 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
6389 die "Extracting of file[$af] from zipfile[$file] failed\n" if
6390 $status != Archive::Zip::AZ_OK();
6391 return if $CPAN::Signal;
6395 my $unzip = $CPAN::Config->{unzip} or
6396 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
6397 my @system = ($unzip, $file);
6398 return system(@system) == 0;
6410 CPAN - query, download and build perl modules from CPAN sites
6416 perl -MCPAN -e shell;
6422 autobundle, clean, install, make, recompile, test
6426 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6427 of a modern rewrite from ground up with greater extensibility and more
6428 features but no full compatibility. If you're new to CPAN.pm, you
6429 probably should investigate if CPANPLUS is the better choice for you.
6430 If you're already used to CPAN.pm you're welcome to continue using it,
6431 if you accept that its development is mostly (though not completely)
6436 The CPAN module is designed to automate the make and install of perl
6437 modules and extensions. It includes some primitive searching capabilities and
6438 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6439 to fetch the raw data from the net.
6441 Modules are fetched from one or more of the mirrored CPAN
6442 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6445 The CPAN module also supports the concept of named and versioned
6446 I<bundles> of modules. Bundles simplify the handling of sets of
6447 related modules. See Bundles below.
6449 The package contains a session manager and a cache manager. There is
6450 no status retained between sessions. The session manager keeps track
6451 of what has been fetched, built and installed in the current
6452 session. The cache manager keeps track of the disk space occupied by
6453 the make processes and deletes excess space according to a simple FIFO
6456 For extended searching capabilities there's a plugin for CPAN available,
6457 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6458 that indexes all documents available in CPAN authors directories. If
6459 C<CPAN::WAIT> is installed on your system, the interactive shell of
6460 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6461 which send queries to the WAIT server that has been configured for your
6464 All other methods provided are accessible in a programmer style and in an
6465 interactive shell style.
6467 =head2 Interactive Mode
6469 The interactive mode is entered by running
6471 perl -MCPAN -e shell
6473 which puts you into a readline interface. You will have the most fun if
6474 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6477 Once you are on the command line, type 'h' and the rest should be
6480 The function call C<shell> takes two optional arguments, one is the
6481 prompt, the second is the default initial command line (the latter
6482 only works if a real ReadLine interface module is installed).
6484 The most common uses of the interactive modes are
6488 =item Searching for authors, bundles, distribution files and modules
6490 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6491 for each of the four categories and another, C<i> for any of the
6492 mentioned four. Each of the four entities is implemented as a class
6493 with slightly differing methods for displaying an object.
6495 Arguments you pass to these commands are either strings exactly matching
6496 the identification string of an object or regular expressions that are
6497 then matched case-insensitively against various attributes of the
6498 objects. The parser recognizes a regular expression only if you
6499 enclose it between two slashes.
6501 The principle is that the number of found objects influences how an
6502 item is displayed. If the search finds one item, the result is
6503 displayed with the rather verbose method C<as_string>, but if we find
6504 more than one, we display each object with the terse method
6507 =item make, test, install, clean modules or distributions
6509 These commands take any number of arguments and investigate what is
6510 necessary to perform the action. If the argument is a distribution
6511 file name (recognized by embedded slashes), it is processed. If it is
6512 a module, CPAN determines the distribution file in which this module
6513 is included and processes that, following any dependencies named in
6514 the module's Makefile.PL (this behavior is controlled by
6515 I<prerequisites_policy>.)
6517 Any C<make> or C<test> are run unconditionally. An
6519 install <distribution_file>
6521 also is run unconditionally. But for
6525 CPAN checks if an install is actually needed for it and prints
6526 I<module up to date> in the case that the distribution file containing
6527 the module doesn't need to be updated.
6529 CPAN also keeps track of what it has done within the current session
6530 and doesn't try to build a package a second time regardless if it
6531 succeeded or not. The C<force> pragma may precede another command
6532 (currently: C<make>, C<test>, or C<install>) and executes the
6533 command from scratch.
6537 cpan> install OpenGL
6538 OpenGL is up to date.
6539 cpan> force install OpenGL
6542 OpenGL-0.4/COPYRIGHT
6545 The C<notest> pragma may be set to skip the test part in the build
6550 cpan> notest install Tk
6552 A C<clean> command results in a
6556 being executed within the distribution file's working directory.
6558 =item get, readme, perldoc, look module or distribution
6560 C<get> downloads a distribution file without further action. C<readme>
6561 displays the README file of the associated distribution. C<Look> gets
6562 and untars (if not yet done) the distribution file, changes to the
6563 appropriate directory and opens a subshell process in that directory.
6564 C<perldoc> displays the pod documentation of the module in html or
6569 C<ls> lists all distribution files in and below an author's CPAN
6570 directory. Only those files that contain modules are listed and if
6571 there is more than one for any given module, only the most recent one
6576 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6577 in the cpan-shell it is intended that you can press C<^C> anytime and
6578 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6579 to clean up and leave the shell loop. You can emulate the effect of a
6580 SIGTERM by sending two consecutive SIGINTs, which usually means by
6581 pressing C<^C> twice.
6583 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6584 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6590 The commands that are available in the shell interface are methods in
6591 the package CPAN::Shell. If you enter the shell command, all your
6592 input is split by the Text::ParseWords::shellwords() routine which
6593 acts like most shells do. The first word is being interpreted as the
6594 method to be called and the rest of the words are treated as arguments
6595 to this method. Continuation lines are supported if a line ends with a
6600 C<autobundle> writes a bundle file into the
6601 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6602 a list of all modules that are both available from CPAN and currently
6603 installed within @INC. The name of the bundle file is based on the
6604 current date and a counter.
6608 recompile() is a very special command in that it takes no argument and
6609 runs the make/test/install cycle with brute force over all installed
6610 dynamically loadable extensions (aka XS modules) with 'force' in
6611 effect. The primary purpose of this command is to finish a network
6612 installation. Imagine, you have a common source tree for two different
6613 architectures. You decide to do a completely independent fresh
6614 installation. You start on one architecture with the help of a Bundle
6615 file produced earlier. CPAN installs the whole Bundle for you, but
6616 when you try to repeat the job on the second architecture, CPAN
6617 responds with a C<"Foo up to date"> message for all modules. So you
6618 invoke CPAN's recompile on the second architecture and you're done.
6620 Another popular use for C<recompile> is to act as a rescue in case your
6621 perl breaks binary compatibility. If one of the modules that CPAN uses
6622 is in turn depending on binary compatibility (so you cannot run CPAN
6623 commands), then you should try the CPAN::Nox module for recovery.
6625 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6627 Although it may be considered internal, the class hierarchy does matter
6628 for both users and programmer. CPAN.pm deals with above mentioned four
6629 classes, and all those classes share a set of methods. A classical
6630 single polymorphism is in effect. A metaclass object registers all
6631 objects of all kinds and indexes them with a string. The strings
6632 referencing objects have a separated namespace (well, not completely
6637 words containing a "/" (slash) Distribution
6638 words starting with Bundle:: Bundle
6639 everything else Module or Author
6641 Modules know their associated Distribution objects. They always refer
6642 to the most recent official release. Developers may mark their releases
6643 as unstable development versions (by inserting an underbar into the
6644 module version number which will also be reflected in the distribution
6645 name when you run 'make dist'), so the really hottest and newest
6646 distribution is not always the default. If a module Foo circulates
6647 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6648 way to install version 1.23 by saying
6652 This would install the complete distribution file (say
6653 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6654 like to install version 1.23_90, you need to know where the
6655 distribution file resides on CPAN relative to the authors/id/
6656 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6657 so you would have to say
6659 install BAR/Foo-1.23_90.tar.gz
6661 The first example will be driven by an object of the class
6662 CPAN::Module, the second by an object of class CPAN::Distribution.
6664 =head2 Programmer's interface
6666 If you do not enter the shell, the available shell commands are both
6667 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6668 functions in the calling package (C<install(...)>).
6670 There's currently only one class that has a stable interface -
6671 CPAN::Shell. All commands that are available in the CPAN shell are
6672 methods of the class CPAN::Shell. Each of the commands that produce
6673 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6674 the IDs of all modules within the list.
6678 =item expand($type,@things)
6680 The IDs of all objects available within a program are strings that can
6681 be expanded to the corresponding real objects with the
6682 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6683 list of CPAN::Module objects according to the C<@things> arguments
6684 given. In scalar context it only returns the first element of the
6687 =item expandany(@things)
6689 Like expand, but returns objects of the appropriate type, i.e.
6690 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6691 CPAN::Distribution objects fro distributions.
6693 =item Programming Examples
6695 This enables the programmer to do operations that combine
6696 functionalities that are available in the shell.
6698 # install everything that is outdated on my disk:
6699 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6701 # install my favorite programs if necessary:
6702 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6703 my $obj = CPAN::Shell->expand('Module',$mod);
6707 # list all modules on my disk that have no VERSION number
6708 for $mod (CPAN::Shell->expand("Module","/./")){
6709 next unless $mod->inst_file;
6710 # MakeMaker convention for undefined $VERSION:
6711 next unless $mod->inst_version eq "undef";
6712 print "No VERSION in ", $mod->id, "\n";
6715 # find out which distribution on CPAN contains a module:
6716 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6718 Or if you want to write a cronjob to watch The CPAN, you could list
6719 all modules that need updating. First a quick and dirty way:
6721 perl -e 'use CPAN; CPAN::Shell->r;'
6723 If you don't want to get any output in the case that all modules are
6724 up to date, you can parse the output of above command for the regular
6725 expression //modules are up to date// and decide to mail the output
6726 only if it doesn't match. Ick?
6728 If you prefer to do it more in a programmer style in one single
6729 process, maybe something like this suits you better:
6731 # list all modules on my disk that have newer versions on CPAN
6732 for $mod (CPAN::Shell->expand("Module","/./")){
6733 next unless $mod->inst_file;
6734 next if $mod->uptodate;
6735 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6736 $mod->id, $mod->inst_version, $mod->cpan_version;
6739 If that gives you too much output every day, you maybe only want to
6740 watch for three modules. You can write
6742 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6744 as the first line instead. Or you can combine some of the above
6747 # watch only for a new mod_perl module
6748 $mod = CPAN::Shell->expand("Module","mod_perl");
6749 exit if $mod->uptodate;
6750 # new mod_perl arrived, let me know all update recommendations
6755 =head2 Methods in the other Classes
6757 The programming interface for the classes CPAN::Module,
6758 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6759 beta and partially even alpha. In the following paragraphs only those
6760 methods are documented that have proven useful over a longer time and
6761 thus are unlikely to change.
6765 =item CPAN::Author::as_glimpse()
6767 Returns a one-line description of the author
6769 =item CPAN::Author::as_string()
6771 Returns a multi-line description of the author
6773 =item CPAN::Author::email()
6775 Returns the author's email address
6777 =item CPAN::Author::fullname()
6779 Returns the author's name
6781 =item CPAN::Author::name()
6783 An alias for fullname
6785 =item CPAN::Bundle::as_glimpse()
6787 Returns a one-line description of the bundle
6789 =item CPAN::Bundle::as_string()
6791 Returns a multi-line description of the bundle
6793 =item CPAN::Bundle::clean()
6795 Recursively runs the C<clean> method on all items contained in the bundle.
6797 =item CPAN::Bundle::contains()
6799 Returns a list of objects' IDs contained in a bundle. The associated
6800 objects may be bundles, modules or distributions.
6802 =item CPAN::Bundle::force($method,@args)
6804 Forces CPAN to perform a task that normally would have failed. Force
6805 takes as arguments a method name to be called and any number of
6806 additional arguments that should be passed to the called method. The
6807 internals of the object get the needed changes so that CPAN.pm does
6808 not refuse to take the action. The C<force> is passed recursively to
6809 all contained objects.
6811 =item CPAN::Bundle::get()
6813 Recursively runs the C<get> method on all items contained in the bundle
6815 =item CPAN::Bundle::inst_file()
6817 Returns the highest installed version of the bundle in either @INC or
6818 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6819 CPAN::Module::inst_file.
6821 =item CPAN::Bundle::inst_version()
6823 Like CPAN::Bundle::inst_file, but returns the $VERSION
6825 =item CPAN::Bundle::uptodate()
6827 Returns 1 if the bundle itself and all its members are uptodate.
6829 =item CPAN::Bundle::install()
6831 Recursively runs the C<install> method on all items contained in the bundle
6833 =item CPAN::Bundle::make()
6835 Recursively runs the C<make> method on all items contained in the bundle
6837 =item CPAN::Bundle::readme()
6839 Recursively runs the C<readme> method on all items contained in the bundle
6841 =item CPAN::Bundle::test()
6843 Recursively runs the C<test> method on all items contained in the bundle
6845 =item CPAN::Distribution::as_glimpse()
6847 Returns a one-line description of the distribution
6849 =item CPAN::Distribution::as_string()
6851 Returns a multi-line description of the distribution
6853 =item CPAN::Distribution::clean()
6855 Changes to the directory where the distribution has been unpacked and
6856 runs C<make clean> there.
6858 =item CPAN::Distribution::containsmods()
6860 Returns a list of IDs of modules contained in a distribution file.
6861 Only works for distributions listed in the 02packages.details.txt.gz
6862 file. This typically means that only the most recent version of a
6863 distribution is covered.
6865 =item CPAN::Distribution::cvs_import()
6867 Changes to the directory where the distribution has been unpacked and
6870 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6874 =item CPAN::Distribution::dir()
6876 Returns the directory into which this distribution has been unpacked.
6878 =item CPAN::Distribution::force($method,@args)
6880 Forces CPAN to perform a task that normally would have failed. Force
6881 takes as arguments a method name to be called and any number of
6882 additional arguments that should be passed to the called method. The
6883 internals of the object get the needed changes so that CPAN.pm does
6884 not refuse to take the action.
6886 =item CPAN::Distribution::get()
6888 Downloads the distribution from CPAN and unpacks it. Does nothing if
6889 the distribution has already been downloaded and unpacked within the
6892 =item CPAN::Distribution::install()
6894 Changes to the directory where the distribution has been unpacked and
6895 runs the external command C<make install> there. If C<make> has not
6896 yet been run, it will be run first. A C<make test> will be issued in
6897 any case and if this fails, the install will be canceled. The
6898 cancellation can be avoided by letting C<force> run the C<install> for
6901 =item CPAN::Distribution::isa_perl()
6903 Returns 1 if this distribution file seems to be a perl distribution.
6904 Normally this is derived from the file name only, but the index from
6905 CPAN can contain a hint to achieve a return value of true for other
6908 =item CPAN::Distribution::look()
6910 Changes to the directory where the distribution has been unpacked and
6911 opens a subshell there. Exiting the subshell returns.
6913 =item CPAN::Distribution::make()
6915 First runs the C<get> method to make sure the distribution is
6916 downloaded and unpacked. Changes to the directory where the
6917 distribution has been unpacked and runs the external commands C<perl
6918 Makefile.PL> and C<make> there.
6920 =item CPAN::Distribution::prereq_pm()
6922 Returns the hash reference that has been announced by a distribution
6923 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6924 attempt has been made to C<make> the distribution. Returns undef
6927 =item CPAN::Distribution::readme()
6929 Downloads the README file associated with a distribution and runs it
6930 through the pager specified in C<$CPAN::Config->{pager}>.
6932 =item CPAN::Distribution::perldoc()
6934 Downloads the pod documentation of the file associated with a
6935 distribution (in html format) and runs it through the external
6936 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
6937 isn't available, it converts it to plain text with external
6938 command html2text and runs it through the pager specified
6939 in C<$CPAN::Config->{pager}>
6941 =item CPAN::Distribution::test()
6943 Changes to the directory where the distribution has been unpacked and
6944 runs C<make test> there.
6946 =item CPAN::Distribution::uptodate()
6948 Returns 1 if all the modules contained in the distribution are
6949 uptodate. Relies on containsmods.
6951 =item CPAN::Index::force_reload()
6953 Forces a reload of all indices.
6955 =item CPAN::Index::reload()
6957 Reloads all indices if they have been read more than
6958 C<$CPAN::Config->{index_expire}> days.
6960 =item CPAN::InfoObj::dump()
6962 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6963 inherit this method. It prints the data structure associated with an
6964 object. Useful for debugging. Note: the data structure is considered
6965 internal and thus subject to change without notice.
6967 =item CPAN::Module::as_glimpse()
6969 Returns a one-line description of the module
6971 =item CPAN::Module::as_string()
6973 Returns a multi-line description of the module
6975 =item CPAN::Module::clean()
6977 Runs a clean on the distribution associated with this module.
6979 =item CPAN::Module::cpan_file()
6981 Returns the filename on CPAN that is associated with the module.
6983 =item CPAN::Module::cpan_version()
6985 Returns the latest version of this module available on CPAN.
6987 =item CPAN::Module::cvs_import()
6989 Runs a cvs_import on the distribution associated with this module.
6991 =item CPAN::Module::description()
6993 Returns a 44 character description of this module. Only available for
6994 modules listed in The Module List (CPAN/modules/00modlist.long.html
6995 or 00modlist.long.txt.gz)
6997 =item CPAN::Module::force($method,@args)
6999 Forces CPAN to perform a task that normally would have failed. Force
7000 takes as arguments a method name to be called and any number of
7001 additional arguments that should be passed to the called method. The
7002 internals of the object get the needed changes so that CPAN.pm does
7003 not refuse to take the action.
7005 =item CPAN::Module::get()
7007 Runs a get on the distribution associated with this module.
7009 =item CPAN::Module::inst_file()
7011 Returns the filename of the module found in @INC. The first file found
7012 is reported just like perl itself stops searching @INC when it finds a
7015 =item CPAN::Module::inst_version()
7017 Returns the version number of the module in readable format.
7019 =item CPAN::Module::install()
7021 Runs an C<install> on the distribution associated with this module.
7023 =item CPAN::Module::look()
7025 Changes to the directory where the distribution associated with this
7026 module has been unpacked and opens a subshell there. Exiting the
7029 =item CPAN::Module::make()
7031 Runs a C<make> on the distribution associated with this module.
7033 =item CPAN::Module::manpage_headline()
7035 If module is installed, peeks into the module's manpage, reads the
7036 headline and returns it. Moreover, if the module has been downloaded
7037 within this session, does the equivalent on the downloaded module even
7038 if it is not installed.
7040 =item CPAN::Module::readme()
7042 Runs a C<readme> on the distribution associated with this module.
7044 =item CPAN::Module::perldoc()
7046 Runs a C<perldoc> on this module.
7048 =item CPAN::Module::test()
7050 Runs a C<test> on the distribution associated with this module.
7052 =item CPAN::Module::uptodate()
7054 Returns 1 if the module is installed and up-to-date.
7056 =item CPAN::Module::userid()
7058 Returns the author's ID of the module.
7062 =head2 Cache Manager
7064 Currently the cache manager only keeps track of the build directory
7065 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
7066 deletes complete directories below C<build_dir> as soon as the size of
7067 all directories there gets bigger than $CPAN::Config->{build_cache}
7068 (in MB). The contents of this cache may be used for later
7069 re-installations that you intend to do manually, but will never be
7070 trusted by CPAN itself. This is due to the fact that the user might
7071 use these directories for building modules on different architectures.
7073 There is another directory ($CPAN::Config->{keep_source_where}) where
7074 the original distribution files are kept. This directory is not
7075 covered by the cache manager and must be controlled by the user. If
7076 you choose to have the same directory as build_dir and as
7077 keep_source_where directory, then your sources will be deleted with
7078 the same fifo mechanism.
7082 A bundle is just a perl module in the namespace Bundle:: that does not
7083 define any functions or methods. It usually only contains documentation.
7085 It starts like a perl module with a package declaration and a $VERSION
7086 variable. After that the pod section looks like any other pod with the
7087 only difference being that I<one special pod section> exists starting with
7092 In this pod section each line obeys the format
7094 Module_Name [Version_String] [- optional text]
7096 The only required part is the first field, the name of a module
7097 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
7098 of the line is optional. The comment part is delimited by a dash just
7099 as in the man page header.
7101 The distribution of a bundle should follow the same convention as
7102 other distributions.
7104 Bundles are treated specially in the CPAN package. If you say 'install
7105 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
7106 the modules in the CONTENTS section of the pod. You can install your
7107 own Bundles locally by placing a conformant Bundle file somewhere into
7108 your @INC path. The autobundle() command which is available in the
7109 shell interface does that for you by including all currently installed
7110 modules in a snapshot bundle file.
7112 =head2 Prerequisites
7114 If you have a local mirror of CPAN and can access all files with
7115 "file:" URLs, then you only need a perl better than perl5.003 to run
7116 this module. Otherwise Net::FTP is strongly recommended. LWP may be
7117 required for non-UNIX systems or if your nearest CPAN site is
7118 associated with a URL that is not C<ftp:>.
7120 If you have neither Net::FTP nor LWP, there is a fallback mechanism
7121 implemented for an external ftp command or for an external lynx
7124 =head2 Finding packages and VERSION
7126 This module presumes that all packages on CPAN
7132 declare their $VERSION variable in an easy to parse manner. This
7133 prerequisite can hardly be relaxed because it consumes far too much
7134 memory to load all packages into the running program just to determine
7135 the $VERSION variable. Currently all programs that are dealing with
7136 version use something like this
7138 perl -MExtUtils::MakeMaker -le \
7139 'print MM->parse_version(shift)' filename
7141 If you are author of a package and wonder if your $VERSION can be
7142 parsed, please try the above method.
7146 come as compressed or gzipped tarfiles or as zip files and contain a
7147 Makefile.PL (well, we try to handle a bit more, but without much
7154 The debugging of this module is a bit complex, because we have
7155 interferences of the software producing the indices on CPAN, of the
7156 mirroring process on CPAN, of packaging, of configuration, of
7157 synchronicity, and of bugs within CPAN.pm.
7159 For code debugging in interactive mode you can try "o debug" which
7160 will list options for debugging the various parts of the code. You
7161 should know that "o debug" has built-in completion support.
7163 For data debugging there is the C<dump> command which takes the same
7164 arguments as make/test/install and outputs the object's Data::Dumper
7167 =head2 Floppy, Zip, Offline Mode
7169 CPAN.pm works nicely without network too. If you maintain machines
7170 that are not networked at all, you should consider working with file:
7171 URLs. Of course, you have to collect your modules somewhere first. So
7172 you might use CPAN.pm to put together all you need on a networked
7173 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
7174 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
7175 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
7176 with this floppy. See also below the paragraph about CD-ROM support.
7178 =head1 CONFIGURATION
7180 When the CPAN module is used for the first time, a configuration
7181 dialog tries to determine a couple of site specific options. The
7182 result of the dialog is stored in a hash reference C< $CPAN::Config >
7183 in a file CPAN/Config.pm.
7185 The default values defined in the CPAN/Config.pm file can be
7186 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
7187 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
7188 added to the search path of the CPAN module before the use() or
7189 require() statements.
7191 The configuration dialog can be started any time later again by
7192 issuing the command C< o conf init > in the CPAN shell.
7194 Currently the following keys in the hash reference $CPAN::Config are
7197 build_cache size of cache for directories to build modules
7198 build_dir locally accessible directory to build modules
7199 index_expire after this many days refetch index files
7200 cache_metadata use serializer to cache metadata
7201 cpan_home local directory reserved for this package
7202 dontload_hash anonymous hash: modules in the keys will not be
7203 loaded by the CPAN::has_inst() routine
7204 gzip location of external program gzip
7205 histfile file to maintain history between sessions
7206 histsize maximum number of lines to keep in histfile
7207 inactivity_timeout breaks interactive Makefile.PLs after this
7208 many seconds inactivity. Set to 0 to never break.
7209 inhibit_startup_message
7210 if true, does not print the startup message
7211 keep_source_where directory in which to keep the source (if we do)
7212 make location of external make program
7213 make_arg arguments that should always be passed to 'make'
7214 make_install_make_command
7215 the make command for running 'make install', for
7217 make_install_arg same as make_arg for 'make install'
7218 makepl_arg arguments passed to 'perl Makefile.PL'
7219 pager location of external program more (or any pager)
7220 prerequisites_policy
7221 what to do if you are missing module prerequisites
7222 ('follow' automatically, 'ask' me, or 'ignore')
7223 proxy_user username for accessing an authenticating proxy
7224 proxy_pass password for accessing an authenticating proxy
7225 scan_cache controls scanning of cache ('atstart' or 'never')
7226 tar location of external program tar
7227 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
7228 (and nonsense for characters outside latin range)
7229 unzip location of external program unzip
7230 urllist arrayref to nearby CPAN sites (or equivalent locations)
7231 wait_list arrayref to a wait server to try (See CPAN::WAIT)
7232 ftp_proxy, } the three usual variables for configuring
7233 http_proxy, } proxy requests. Both as CPAN::Config variables
7234 no_proxy } and as environment variables configurable.
7236 You can set and query each of these options interactively in the cpan
7237 shell with the command set defined within the C<o conf> command:
7241 =item C<o conf E<lt>scalar optionE<gt>>
7243 prints the current value of the I<scalar option>
7245 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
7247 Sets the value of the I<scalar option> to I<value>
7249 =item C<o conf E<lt>list optionE<gt>>
7251 prints the current value of the I<list option> in MakeMaker's
7254 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
7256 shifts or pops the array in the I<list option> variable
7258 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
7260 works like the corresponding perl commands.
7264 =head2 Note on urllist parameter's format
7266 urllist parameters are URLs according to RFC 1738. We do a little
7267 guessing if your URL is not compliant, but if you have problems with
7268 file URLs, please try the correct format. Either:
7270 file://localhost/whatever/ftp/pub/CPAN/
7274 file:///home/ftp/pub/CPAN/
7276 =head2 urllist parameter has CD-ROM support
7278 The C<urllist> parameter of the configuration table contains a list of
7279 URLs that are to be used for downloading. If the list contains any
7280 C<file> URLs, CPAN always tries to get files from there first. This
7281 feature is disabled for index files. So the recommendation for the
7282 owner of a CD-ROM with CPAN contents is: include your local, possibly
7283 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
7285 o conf urllist push file://localhost/CDROM/CPAN
7287 CPAN.pm will then fetch the index files from one of the CPAN sites
7288 that come at the beginning of urllist. It will later check for each
7289 module if there is a local copy of the most recent version.
7291 Another peculiarity of urllist is that the site that we could
7292 successfully fetch the last file from automatically gets a preference
7293 token and is tried as the first site for the next request. So if you
7294 add a new site at runtime it may happen that the previously preferred
7295 site will be tried another time. This means that if you want to disallow
7296 a site for the next transfer, it must be explicitly removed from
7301 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
7302 install foreign, unmasked, unsigned code on your machine. We compare
7303 to a checksum that comes from the net just as the distribution file
7304 itself. If somebody has managed to tamper with the distribution file,
7305 they may have as well tampered with the CHECKSUMS file. Future
7306 development will go towards strong authentication.
7310 Most functions in package CPAN are exported per default. The reason
7311 for this is that the primary use is intended for the cpan shell or for
7314 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
7316 Populating a freshly installed perl with my favorite modules is pretty
7317 easy if you maintain a private bundle definition file. To get a useful
7318 blueprint of a bundle definition file, the command autobundle can be used
7319 on the CPAN shell command line. This command writes a bundle definition
7320 file for all modules that are installed for the currently running perl
7321 interpreter. It's recommended to run this command only once and from then
7322 on maintain the file manually under a private name, say
7323 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
7325 cpan> install Bundle::my_bundle
7327 then answer a few questions and then go out for a coffee.
7329 Maintaining a bundle definition file means keeping track of two
7330 things: dependencies and interactivity. CPAN.pm sometimes fails on
7331 calculating dependencies because not all modules define all MakeMaker
7332 attributes correctly, so a bundle definition file should specify
7333 prerequisites as early as possible. On the other hand, it's a bit
7334 annoying that many distributions need some interactive configuring. So
7335 what I try to accomplish in my private bundle file is to have the
7336 packages that need to be configured early in the file and the gentle
7337 ones later, so I can go out after a few minutes and leave CPAN.pm
7340 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
7342 Thanks to Graham Barr for contributing the following paragraphs about
7343 the interaction between perl, and various firewall configurations. For
7344 further information on firewalls, it is recommended to consult the
7345 documentation that comes with the ncftp program. If you are unable to
7346 go through the firewall with a simple Perl setup, it is very likely
7347 that you can configure ncftp so that it works for your firewall.
7349 =head2 Three basic types of firewalls
7351 Firewalls can be categorized into three basic types.
7357 This is where the firewall machine runs a web server and to access the
7358 outside world you must do it via the web server. If you set environment
7359 variables like http_proxy or ftp_proxy to a values beginning with http://
7360 or in your web browser you have to set proxy information then you know
7361 you are running an http firewall.
7363 To access servers outside these types of firewalls with perl (even for
7364 ftp) you will need to use LWP.
7368 This where the firewall machine runs an ftp server. This kind of
7369 firewall will only let you access ftp servers outside the firewall.
7370 This is usually done by connecting to the firewall with ftp, then
7371 entering a username like "user@outside.host.com"
7373 To access servers outside these type of firewalls with perl you
7374 will need to use Net::FTP.
7376 =item One way visibility
7378 I say one way visibility as these firewalls try to make themselves look
7379 invisible to the users inside the firewall. An FTP data connection is
7380 normally created by sending the remote server your IP address and then
7381 listening for the connection. But the remote server will not be able to
7382 connect to you because of the firewall. So for these types of firewall
7383 FTP connections need to be done in a passive mode.
7385 There are two that I can think off.
7391 If you are using a SOCKS firewall you will need to compile perl and link
7392 it with the SOCKS library, this is what is normally called a 'socksified'
7393 perl. With this executable you will be able to connect to servers outside
7394 the firewall as if it is not there.
7398 This is the firewall implemented in the Linux kernel, it allows you to
7399 hide a complete network behind one IP address. With this firewall no
7400 special compiling is needed as you can access hosts directly.
7402 For accessing ftp servers behind such firewalls you may need to set
7403 the environment variable C<FTP_PASSIVE> to a true value, e.g.
7405 env FTP_PASSIVE=1 perl -MCPAN -eshell
7409 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
7416 =head2 Configuring lynx or ncftp for going through a firewall
7418 If you can go through your firewall with e.g. lynx, presumably with a
7421 /usr/local/bin/lynx -pscott:tiger
7423 then you would configure CPAN.pm with the command
7425 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7427 That's all. Similarly for ncftp or ftp, you would configure something
7430 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7432 Your mileage may vary...
7434 =head1 Cryptographically signed modules
7436 Since release 1.77 CPAN.pm has been able to verify cryptographically
7437 signed module distributions using Module::Signature. The CPAN modules
7438 can be signed by their authors, thus giving more security. The simple
7439 unsigned MD5 checksums that were used before by CPAN protect mainly
7440 against accidental file corruption.
7442 You will need to have Module::Signature installed, which in turn
7443 requires that you have at least one of Crypt::OpenPGP module or the
7444 command-line F<gpg> tool installed.
7446 You will also need to be able to connect over the Internet to the public
7447 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
7455 I installed a new version of module X but CPAN keeps saying,
7456 I have the old version installed
7458 Most probably you B<do> have the old version installed. This can
7459 happen if a module installs itself into a different directory in the
7460 @INC path than it was previously installed. This is not really a
7461 CPAN.pm problem, you would have the same problem when installing the
7462 module manually. The easiest way to prevent this behaviour is to add
7463 the argument C<UNINST=1> to the C<make install> call, and that is why
7464 many people add this argument permanently by configuring
7466 o conf make_install_arg UNINST=1
7470 So why is UNINST=1 not the default?
7472 Because there are people who have their precise expectations about who
7473 may install where in the @INC path and who uses which @INC array. In
7474 fine tuned environments C<UNINST=1> can cause damage.
7478 I want to clean up my mess, and install a new perl along with
7479 all modules I have. How do I go about it?
7481 Run the autobundle command for your old perl and optionally rename the
7482 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7483 with the Configure option prefix, e.g.
7485 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7487 Install the bundle file you produced in the first step with something like
7489 cpan> install Bundle::mybundle
7495 When I install bundles or multiple modules with one command
7496 there is too much output to keep track of.
7498 You may want to configure something like
7500 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7501 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7503 so that STDOUT is captured in a file for later inspection.
7508 I am not root, how can I install a module in a personal directory?
7510 First of all, you will want to use your own configuration, not the one
7511 that your root user installed. The following command sequence is a
7514 % mkdir -p $HOME/.cpan/CPAN
7515 % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
7517 [...answer all questions...]
7519 You will most probably like something like this:
7521 o conf makepl_arg "LIB=~/myperl/lib \
7522 INSTALLMAN1DIR=~/myperl/man/man1 \
7523 INSTALLMAN3DIR=~/myperl/man/man3"
7525 You can make this setting permanent like all C<o conf> settings with
7528 You will have to add ~/myperl/man to the MANPATH environment variable
7529 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7532 use lib "$ENV{HOME}/myperl/lib";
7534 or setting the PERL5LIB environment variable.
7536 Another thing you should bear in mind is that the UNINST parameter
7537 should never be set if you are not root.
7541 How to get a package, unwrap it, and make a change before building it?
7543 look Sybase::Sybperl
7547 I installed a Bundle and had a couple of fails. When I
7548 retried, everything resolved nicely. Can this be fixed to work
7551 The reason for this is that CPAN does not know the dependencies of all
7552 modules when it starts out. To decide about the additional items to
7553 install, it just uses data found in the generated Makefile. An
7554 undetected missing piece breaks the process. But it may well be that
7555 your Bundle installs some prerequisite later than some depending item
7556 and thus your second try is able to resolve everything. Please note,
7557 CPAN.pm does not know the dependency tree in advance and cannot sort
7558 the queue of things to install in a topologically correct order. It
7559 resolves perfectly well IFF all modules declare the prerequisites
7560 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7561 fail and you need to install often, it is recommended to sort the Bundle
7562 definition file manually. It is planned to improve the metadata
7563 situation for dependencies on CPAN in general, but this will still
7568 In our intranet we have many modules for internal use. How
7569 can I integrate these modules with CPAN.pm but without uploading
7570 the modules to CPAN?
7572 Have a look at the CPAN::Site module.
7576 When I run CPAN's shell, I get error msg about line 1 to 4,
7577 setting meta input/output via the /etc/inputrc file.
7579 Some versions of readline are picky about capitalization in the
7580 /etc/inputrc file and specifically RedHat 6.2 comes with a
7581 /etc/inputrc that contains the word C<on> in lowercase. Change the
7582 occurrences of C<on> to C<On> and the bug should disappear.
7586 Some authors have strange characters in their names.
7588 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7589 expecting ISO-8859-1 charset, a converter can be activated by setting
7590 term_is_latin to a true value in your config file. One way of doing so
7593 cpan> ! $CPAN::Config->{term_is_latin}=1
7595 Extended support for converters will be made available as soon as perl
7596 becomes stable with regard to charset issues.
7600 When an install fails for some reason and then I correct the error
7601 condition and retry, CPAN.pm refuses to install the module, saying
7602 C<Already tried without success>.
7604 Use the force pragma like so
7606 force install Foo::Bar
7608 This does a bit more than really needed because it untars the
7609 distribution again and runs make and test and only then install.
7615 and then 'make install' directly in the subshell.
7617 Or you leave the CPAN shell and start it again.
7619 For the really curious, by accessing internals directly, you I<could>
7621 ! delete CPAN::Shell->expand("Distribution", \
7622 CPAN::Shell->expand("Module","Foo::Bar") \
7623 ->{RO}{CPAN_FILE})->{install}
7625 but this is neither guaranteed to work in the future nor is it a
7632 We should give coverage for B<all> of the CPAN and not just the PAUSE
7633 part, right? In this discussion CPAN and PAUSE have become equal --
7634 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7635 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7637 Future development should be directed towards a better integration of
7640 If a Makefile.PL requires special customization of libraries, prompts
7641 the user for special input, etc. then you may find CPAN is not able to
7642 build the distribution. In that case, you should attempt the
7643 traditional method of building a Perl module package from a shell.
7647 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7651 Kawai,Takanori provides a Japanese translation of this manpage at
7652 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7656 perl(1), CPAN::Nox(3)