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) = @_;
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 my $pwd = CPAN::anycwd();
1685 CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
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 while($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 $silent ;
3808 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
3809 unless (grep {$_->[2] eq $csf[2]} @dl) {
3810 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
3813 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
3814 $CPAN::Frontend->myprint(join "", map {
3815 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3816 } sort { $a->[2] cmp $b->[2] } @dl) unless $silent;
3819 # returns an array of arrays, the latter contain (size,mtime,filename)
3820 #-> sub CPAN::Author::dir_listing ;
3823 my $chksumfile = shift;
3824 my $recursive = shift;
3825 my $may_ftp = shift;
3827 File::Spec->catfile($CPAN::Config->{keep_source_where},
3828 "authors", "id", @$chksumfile);
3832 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
3833 # hazard. (Without GPG installed they are not that much better,
3835 $fh = FileHandle->new;
3836 if (open($fh, $lc_want)) {
3837 my $line = <$fh>; close $fh;
3838 unlink($lc_want) unless $line =~ /PGP/;
3842 # connect "force" argument with "index_expire".
3844 if (my @stat = stat $lc_want) {
3845 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3849 $lc_file = CPAN::FTP->localize(
3850 "authors/id/@$chksumfile",
3855 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3856 $chksumfile->[-1] .= ".gz";
3857 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3860 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3861 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3867 $lc_file = $lc_want;
3868 # we *could* second-guess and if the user has a file: URL,
3869 # then we could look there. But on the other hand, if they do
3870 # have a file: URL, wy did they choose to set
3871 # $CPAN::Config->{show_upload_date} to false?
3874 # adapted from CPAN::Distribution::MD5_check_file ;
3875 $fh = FileHandle->new;
3877 if (open $fh, $lc_file){
3880 $eval =~ s/\015?\012/\n/g;
3882 my($comp) = Safe->new();
3883 $cksum = $comp->reval($eval);
3885 rename $lc_file, "$lc_file.bad";
3886 Carp::confess($@) if $@;
3888 } elsif ($may_ftp) {
3889 Carp::carp "Could not open $lc_file for reading.";
3891 # Maybe should warn: "You may want to set show_upload_date to a true value"
3895 for $f (sort keys %$cksum) {
3896 if (exists $cksum->{$f}{isdir}) {
3898 my(@dir) = @$chksumfile;
3900 push @dir, $f, "CHECKSUMS";
3902 [$_->[0], $_->[1], "$f/$_->[2]"]
3903 } $self->dir_listing(\@dir,1,$may_ftp);
3905 push @result, [ 0, "-", $f ];
3909 ($cksum->{$f}{"size"}||0),
3910 $cksum->{$f}{"mtime"}||"---",
3918 package CPAN::Distribution;
3921 sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3925 delete $self->{later};
3928 # CPAN::Distribution::normalize
3931 $s = $self->id unless defined $s;
3935 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3937 return $s if $s =~ m:^N/A|^Contact Author: ;
3938 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3939 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3940 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3945 #-> sub CPAN::Distribution::color_cmd_tmps ;
3946 sub color_cmd_tmps {
3948 my($depth) = shift || 0;
3949 my($color) = shift || 0;
3950 my($ancestors) = shift || [];
3951 # a distribution needs to recurse into its prereq_pms
3953 return if exists $self->{incommandcolor}
3954 && $self->{incommandcolor}==$color;
3956 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3958 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3959 my $prereq_pm = $self->prereq_pm;
3960 if (defined $prereq_pm) {
3961 for my $pre (keys %$prereq_pm) {
3962 my $premo = CPAN::Shell->expand("Module",$pre);
3963 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3967 delete $self->{sponsored_mods};
3968 delete $self->{badtestcnt};
3970 $self->{incommandcolor} = $color;
3973 #-> sub CPAN::Distribution::as_string ;
3976 $self->containsmods;
3978 $self->SUPER::as_string(@_);
3981 #-> sub CPAN::Distribution::containsmods ;
3984 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3985 my $dist_id = $self->{ID};
3986 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3987 my $mod_file = $mod->cpan_file or next;
3988 my $mod_id = $mod->{ID} or next;
3989 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3991 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3993 keys %{$self->{CONTAINSMODS}};
3996 #-> sub CPAN::Distribution::upload_date ;
3999 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
4000 my(@local_wanted) = split(/\//,$self->id);
4001 my $filename = pop @local_wanted;
4002 push @local_wanted, "CHECKSUMS";
4003 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
4004 return unless $author;
4005 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
4007 my($dirent) = grep { $_->[2] eq $filename } @dl;
4008 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
4009 return unless $dirent->[1];
4010 return $self->{UPLOAD_DATE} = $dirent->[1];
4013 #-> sub CPAN::Distribution::uptodate ;
4017 foreach $c ($self->containsmods) {
4018 my $obj = CPAN::Shell->expandany($c);
4019 return 0 unless $obj->uptodate;
4024 #-> sub CPAN::Distribution::called_for ;
4027 $self->{CALLED_FOR} = $id if defined $id;
4028 return $self->{CALLED_FOR};
4031 #-> sub CPAN::Distribution::safe_chdir ;
4033 my($self,$todir) = @_;
4034 # we die if we cannot chdir and we are debuggable
4035 Carp::confess("safe_chdir called without todir argument")
4036 unless defined $todir and length $todir;
4038 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4041 my $cwd = CPAN::anycwd();
4042 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4043 qq{to todir[$todir]: $!});
4047 #-> sub CPAN::Distribution::get ;
4052 exists $self->{'build_dir'} and push @e,
4053 "Is already unwrapped into directory $self->{'build_dir'}";
4054 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4056 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
4059 # Get the file on local disk
4064 File::Spec->catfile(
4065 $CPAN::Config->{keep_source_where},
4068 split(/\//,$self->id)
4071 $self->debug("Doing localize") if $CPAN::DEBUG;
4072 unless ($local_file =
4073 CPAN::FTP->localize("authors/id/$self->{ID}",
4076 if ($CPAN::Index::DATE_OF_02) {
4077 $note = "Note: Current database in memory was generated ".
4078 "on $CPAN::Index::DATE_OF_02\n";
4080 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
4082 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4083 $self->{localfile} = $local_file;
4084 return if $CPAN::Signal;
4089 if ($CPAN::META->has_inst("Digest::MD5")) {
4090 $self->debug("Digest::MD5 is installed, verifying");
4093 $self->debug("Digest::MD5 is NOT installed");
4095 return if $CPAN::Signal;
4098 # Create a clean room and go there
4100 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
4101 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
4102 $self->safe_chdir($builddir);
4103 $self->debug("Removing tmp") if $CPAN::DEBUG;
4104 File::Path::rmtree("tmp");
4105 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
4107 $self->safe_chdir($sub_wd);
4110 $self->safe_chdir("tmp");
4115 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
4116 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
4117 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
4118 $self->untar_me($local_file);
4119 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
4120 $self->unzip_me($local_file);
4121 } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
4122 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
4123 $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
4124 $self->pm2dir_me($local_file);
4126 $self->{archived} = "NO";
4127 $self->safe_chdir($sub_wd);
4131 # we are still in the tmp directory!
4132 # Let's check if the package has its own directory.
4133 my $dh = DirHandle->new(File::Spec->curdir)
4134 or Carp::croak("Couldn't opendir .: $!");
4135 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
4137 my ($distdir,$packagedir);
4138 if (@readdir == 1 && -d $readdir[0]) {
4139 $distdir = $readdir[0];
4140 $packagedir = File::Spec->catdir($builddir,$distdir);
4141 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
4143 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
4145 File::Path::rmtree($packagedir);
4146 File::Copy::move($distdir,$packagedir) or
4147 Carp::confess("Couldn't move $distdir to $packagedir: $!");
4148 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
4155 my $userid = $self->cpan_userid;
4157 CPAN->debug("no userid? self[$self]");
4160 my $pragmatic_dir = $userid . '000';
4161 $pragmatic_dir =~ s/\W_//g;
4162 $pragmatic_dir++ while -d "../$pragmatic_dir";
4163 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
4164 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
4165 File::Path::mkpath($packagedir);
4167 for $f (@readdir) { # is already without "." and ".."
4168 my $to = File::Spec->catdir($packagedir,$f);
4169 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
4173 $self->safe_chdir($sub_wd);
4177 $self->{'build_dir'} = $packagedir;
4178 $self->safe_chdir($builddir);
4179 File::Path::rmtree("tmp");
4181 $self->safe_chdir($packagedir);
4182 if ($CPAN::META->has_inst("Module::Signature")) {
4183 if (-f "SIGNATURE") {
4184 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
4185 my $rv = Module::Signature::verify();
4186 if ($rv != Module::Signature::SIGNATURE_OK() and
4187 $rv != Module::Signature::SIGNATURE_MISSING()) {
4188 $CPAN::Frontend->myprint(
4189 qq{\nSignature invalid for }.
4190 qq{distribution file. }.
4191 qq{Please investigate.\n\n}.
4193 $CPAN::META->instance(
4199 my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
4200 is invalid. Maybe you have configured your 'urllist' with
4201 a bad URL. Please check this array with 'o conf urllist', and
4203 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4206 $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
4209 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
4211 $self->safe_chdir($builddir);
4212 return if $CPAN::Signal;
4216 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
4217 my($mpl_exists) = -f $mpl;
4218 unless ($mpl_exists) {
4219 # NFS has been reported to have racing problems after the
4220 # renaming of a directory in some environments.
4223 my $mpldh = DirHandle->new($packagedir)
4224 or Carp::croak("Couldn't opendir $packagedir: $!");
4225 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
4228 unless ($mpl_exists) {
4229 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
4233 my($configure) = File::Spec->catfile($packagedir,"Configure");
4234 if (-f $configure) {
4235 # do we have anything to do?
4236 $self->{'configure'} = $configure;
4237 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4238 $CPAN::Frontend->myprint(qq{
4239 Package comes with a Makefile and without a Makefile.PL.
4240 We\'ll try to build it with that Makefile then.
4242 $self->{writemakefile} = "YES";
4245 my $cf = $self->called_for || "unknown";
4250 $cf =~ s|[/\\:]||g; # risk of filesystem damage
4251 $cf = "unknown" unless length($cf);
4252 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4253 (The test -f "$mpl" returned false.)
4254 Writing one on our own (setting NAME to $cf)\a\n});
4255 $self->{had_no_makefile_pl}++;
4258 # Writing our own Makefile.PL
4260 my $fh = FileHandle->new;
4262 or Carp::croak("Could not open >$mpl: $!");
4264 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4265 # because there was no Makefile.PL supplied.
4266 # Autogenerated on: }.scalar localtime().qq{
4268 use ExtUtils::MakeMaker;
4269 WriteMakefile(NAME => q[$cf]);
4279 # CPAN::Distribution::untar_me ;
4281 my($self,$local_file) = @_;
4282 $self->{archived} = "tar";
4283 if (CPAN::Tarzip->untar($local_file)) {
4284 $self->{unwrapped} = "YES";
4286 $self->{unwrapped} = "NO";
4290 # CPAN::Distribution::unzip_me ;
4292 my($self,$local_file) = @_;
4293 $self->{archived} = "zip";
4294 if (CPAN::Tarzip->unzip($local_file)) {
4295 $self->{unwrapped} = "YES";
4297 $self->{unwrapped} = "NO";
4303 my($self,$local_file) = @_;
4304 $self->{archived} = "pm";
4305 my $to = File::Basename::basename($local_file);
4306 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
4307 if (CPAN::Tarzip->gunzip($local_file,$to)) {
4308 $self->{unwrapped} = "YES";
4310 $self->{unwrapped} = "NO";
4313 File::Copy::cp($local_file,".");
4314 $self->{unwrapped} = "YES";
4318 #-> sub CPAN::Distribution::new ;
4320 my($class,%att) = @_;
4322 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4324 my $this = { %att };
4325 return bless $this, $class;
4328 #-> sub CPAN::Distribution::look ;
4332 if ($^O eq 'MacOS') {
4333 $self->Mac::BuildTools::look;
4337 if ( $CPAN::Config->{'shell'} ) {
4338 $CPAN::Frontend->myprint(qq{
4339 Trying to open a subshell in the build directory...
4342 $CPAN::Frontend->myprint(qq{
4343 Your configuration does not define a value for subshells.
4344 Please define it with "o conf shell <your shell>"
4348 my $dist = $self->id;
4350 unless ($dir = $self->dir) {
4353 unless ($dir ||= $self->dir) {
4354 $CPAN::Frontend->mywarn(qq{
4355 Could not determine which directory to use for looking at $dist.
4359 my $pwd = CPAN::anycwd();
4360 $self->safe_chdir($dir);
4361 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4362 unless (system($CPAN::Config->{'shell'}) == 0) {
4364 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4366 $self->safe_chdir($pwd);
4369 # CPAN::Distribution::cvs_import ;
4373 my $dir = $self->dir;
4375 my $package = $self->called_for;
4376 my $module = $CPAN::META->instance('CPAN::Module', $package);
4377 my $version = $module->cpan_version;
4379 my $userid = $self->cpan_userid;
4381 my $cvs_dir = (split /\//, $dir)[-1];
4382 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4384 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4386 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4387 if ($cvs_site_perl) {
4388 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4390 my $cvs_log = qq{"imported $package $version sources"};
4391 $version =~ s/\./_/g;
4392 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4393 "$cvs_dir", $userid, "v$version");
4395 my $pwd = CPAN::anycwd();
4396 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4398 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4400 $CPAN::Frontend->myprint(qq{@cmd\n});
4401 system(@cmd) == 0 or
4402 $CPAN::Frontend->mydie("cvs import failed");
4403 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4406 #-> sub CPAN::Distribution::readme ;
4409 my($dist) = $self->id;
4410 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4411 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4414 File::Spec->catfile(
4415 $CPAN::Config->{keep_source_where},
4418 split(/\//,"$sans.readme"),
4420 $self->debug("Doing localize") if $CPAN::DEBUG;
4421 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4423 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4425 if ($^O eq 'MacOS') {
4426 Mac::BuildTools::launch_file($local_file);
4430 my $fh_pager = FileHandle->new;
4431 local($SIG{PIPE}) = "IGNORE";
4432 $fh_pager->open("|$CPAN::Config->{'pager'}")
4433 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4434 my $fh_readme = FileHandle->new;
4435 $fh_readme->open($local_file)
4436 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4437 $CPAN::Frontend->myprint(qq{
4440 with pager "$CPAN::Config->{'pager'}"
4443 $fh_pager->print(<$fh_readme>);
4447 #-> sub CPAN::Distribution::verifyMD5 ;
4452 $self->{MD5_STATUS} ||= "";
4453 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4454 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4456 my($lc_want,$lc_file,@local,$basename);
4457 @local = split(/\//,$self->id);
4459 push @local, "CHECKSUMS";
4461 File::Spec->catfile($CPAN::Config->{keep_source_where},
4462 "authors", "id", @local);
4467 $self->MD5_check_file($lc_want)
4469 return $self->{MD5_STATUS} = "OK";
4471 $lc_file = CPAN::FTP->localize("authors/id/@local",
4474 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4475 $local[-1] .= ".gz";
4476 $lc_file = CPAN::FTP->localize("authors/id/@local",
4479 $lc_file =~ s/\.gz(?!\n)\Z//;
4480 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4485 $self->MD5_check_file($lc_file);
4488 sub SIG_check_file {
4489 my($self,$chk_file) = @_;
4490 my $rv = eval { Module::Signature::_verify($chk_file) };
4492 if ($rv == Module::Signature::SIGNATURE_OK()) {
4493 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
4494 return $self->{SIG_STATUS} = "OK";
4496 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
4497 qq{distribution file. }.
4498 qq{Please investigate.\n\n}.
4500 $CPAN::META->instance(
4505 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
4506 is invalid. Maybe you have configured your 'urllist' with
4507 a bad URL. Please check this array with 'o conf urllist', and
4510 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4514 #-> sub CPAN::Distribution::MD5_check_file ;
4515 sub MD5_check_file {
4516 my($self,$chk_file) = @_;
4517 my($cksum,$file,$basename);
4519 if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
4520 $self->debug("Module::Signature is installed, verifying");
4521 $self->SIG_check_file($chk_file);
4523 $self->debug("Module::Signature is NOT installed");
4526 $file = $self->{localfile};
4527 $basename = File::Basename::basename($file);
4528 my $fh = FileHandle->new;
4529 if (open $fh, $chk_file){
4532 $eval =~ s/\015?\012/\n/g;
4534 my($comp) = Safe->new();
4535 $cksum = $comp->reval($eval);
4537 rename $chk_file, "$chk_file.bad";
4538 Carp::confess($@) if $@;
4541 Carp::carp "Could not open $chk_file for reading";
4544 if (exists $cksum->{$basename}{md5}) {
4545 $self->debug("Found checksum for $basename:" .
4546 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4550 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4552 $fh = CPAN::Tarzip->TIEHANDLE($file);
4555 # had to inline it, when I tied it, the tiedness got lost on
4556 # the call to eq_MD5. (Jan 1998)
4557 my $md5 = Digest::MD5->new;
4560 while ($fh->READ($ref, 4096) > 0){
4563 my $hexdigest = $md5->hexdigest;
4564 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4568 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4569 return $self->{MD5_STATUS} = "OK";
4571 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4572 qq{distribution file. }.
4573 qq{Please investigate.\n\n}.
4575 $CPAN::META->instance(
4580 my $wrap = qq{I\'d recommend removing $file. Its MD5
4581 checksum is incorrect. Maybe you have configured your 'urllist' with
4582 a bad URL. Please check this array with 'o conf urllist', and
4585 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4587 # former versions just returned here but this seems a
4588 # serious threat that deserves a die
4590 # $CPAN::Frontend->myprint("\n\n");
4594 # close $fh if fileno($fh);
4596 $self->{MD5_STATUS} ||= "";
4597 if ($self->{MD5_STATUS} eq "NIL") {
4598 $CPAN::Frontend->mywarn(qq{
4599 Warning: No md5 checksum for $basename in $chk_file.
4601 The cause for this may be that the file is very new and the checksum
4602 has not yet been calculated, but it may also be that something is
4603 going awry right now.
4605 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4606 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4608 $self->{MD5_STATUS} = "NIL";
4613 #-> sub CPAN::Distribution::eq_MD5 ;
4615 my($self,$fh,$expectMD5) = @_;
4616 my $md5 = Digest::MD5->new;
4618 while (read($fh, $data, 4096)){
4621 # $md5->addfile($fh);
4622 my $hexdigest = $md5->hexdigest;
4623 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4624 $hexdigest eq $expectMD5;
4627 #-> sub CPAN::Distribution::force ;
4629 # Both modules and distributions know if "force" is in effect by
4630 # autoinspection, not by inspecting a global variable. One of the
4631 # reason why this was chosen to work that way was the treatment of
4632 # dependencies. They should not autpomatically inherit the force
4633 # status. But this has the downside that ^C and die() will return to
4634 # the prompt but will not be able to reset the force_update
4635 # attributes. We try to correct for it currently in the read_metadata
4636 # routine, and immediately before we check for a Signal. I hope this
4637 # works out in one of v1.57_53ff
4640 my($self, $method) = @_;
4642 MD5_STATUS archived build_dir localfile make install unwrapped
4645 delete $self->{$att};
4647 if ($method && $method eq "install") {
4648 $self->{"force_update"}++; # name should probably have been force_install
4653 my($self, $method) = @_;
4654 # warn "XDEBUG: set notest for $self $method";
4655 $self->{"notest"}++; # name should probably have been force_install
4660 # warn "XDEBUG: deleting notest";
4661 delete $self->{'notest'};
4664 #-> sub CPAN::Distribution::unforce ;
4667 delete $self->{'force_update'};
4670 #-> sub CPAN::Distribution::isa_perl ;
4673 my $file = File::Basename::basename($self->id);
4674 if ($file =~ m{ ^ perl
4687 } elsif ($self->cpan_comment
4689 $self->cpan_comment =~ /isa_perl\(.+?\)/){
4695 #-> sub CPAN::Distribution::perl ;
4701 #-> sub CPAN::Distribution::make ;
4704 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4705 # Emergency brake if they said install Pippi and get newest perl
4706 if ($self->isa_perl) {
4708 $self->called_for ne $self->id &&
4709 ! $self->{force_update}
4711 # if we die here, we break bundles
4712 $CPAN::Frontend->mywarn(sprintf qq{
4713 The most recent version "%s" of the module "%s"
4714 comes with the current version of perl (%s).
4715 I\'ll build that only if you ask for something like
4720 $CPAN::META->instance(
4734 $self->{archived} eq "NO" and push @e,
4735 "Is neither a tar nor a zip archive.";
4737 $self->{unwrapped} eq "NO" and push @e,
4738 "had problems unarchiving. Please build manually";
4740 exists $self->{writemakefile} &&
4741 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4742 $1 || "Had some problem writing Makefile";
4744 defined $self->{'make'} and push @e,
4745 "Has already been processed within this session";
4747 exists $self->{later} and length($self->{later}) and
4748 push @e, $self->{later};
4750 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
4752 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
4753 my $builddir = $self->dir;
4754 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4755 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4757 if ($^O eq 'MacOS') {
4758 Mac::BuildTools::make($self);
4763 if ($self->{'configure'}) {
4764 $system = $self->{'configure'};
4766 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4768 # This needs a handler that can be turned on or off:
4769 # $switch = "-MExtUtils::MakeMaker ".
4770 # "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4772 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4774 unless (exists $self->{writemakefile}) {
4775 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4778 if ($CPAN::Config->{inactivity_timeout}) {
4780 alarm $CPAN::Config->{inactivity_timeout};
4781 local $SIG{CHLD}; # = sub { wait };
4782 if (defined($pid = fork)) {
4787 # note, this exec isn't necessary if
4788 # inactivity_timeout is 0. On the Mac I'd
4789 # suggest, we set it always to 0.
4793 $CPAN::Frontend->myprint("Cannot fork: $!");
4801 $CPAN::Frontend->myprint($@);
4802 $self->{writemakefile} = "NO $@";
4807 $ret = system($system);
4809 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4813 if (-f "Makefile") {
4814 $self->{writemakefile} = "YES";
4815 delete $self->{make_clean}; # if cleaned before, enable next
4817 $self->{writemakefile} =
4818 qq{NO Makefile.PL refused to write a Makefile.};
4819 # It's probably worth it to record the reason, so let's retry
4821 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4822 # $self->{writemakefile} .= <$fh>;
4826 delete $self->{force_update};
4829 if (my @prereq = $self->unsat_prereq){
4830 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4832 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4833 if (system($system) == 0) {
4834 $CPAN::Frontend->myprint(" $system -- OK\n");
4835 $self->{'make'} = "YES";
4837 $self->{writemakefile} ||= "YES";
4838 $self->{'make'} = "NO";
4839 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4843 sub follow_prereqs {
4847 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4848 "during [$id] -----\n");
4850 for my $p (@prereq) {
4851 $CPAN::Frontend->myprint(" $p\n");
4854 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4856 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4857 require ExtUtils::MakeMaker;
4858 my $answer = ExtUtils::MakeMaker::prompt(
4859 "Shall I follow them and prepend them to the queue
4860 of modules we are processing right now?", "yes");
4861 $follow = $answer =~ /^\s*y/i;
4865 myprint(" Ignoring dependencies on modules @prereq\n");
4868 # color them as dirty
4869 for my $p (@prereq) {
4870 # warn "calling color_cmd_tmps(0,1)";
4871 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4873 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4874 $self->{later} = "Delayed until after prerequisites";
4875 return 1; # signal success to the queuerunner
4879 #-> sub CPAN::Distribution::unsat_prereq ;
4882 my $prereq_pm = $self->prereq_pm or return;
4884 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4885 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4886 # we were too demanding:
4887 next if $nmo->uptodate;
4889 # if they have not specified a version, we accept any installed one
4890 if (not defined $need_version or
4891 $need_version == 0 or
4892 $need_version eq "undef") {
4893 next if defined $nmo->inst_file;
4896 # We only want to install prereqs if either they're not installed
4897 # or if the installed version is too old. We cannot omit this
4898 # check, because if 'force' is in effect, nobody else will check.
4902 defined $nmo->inst_file &&
4903 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4905 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4909 CPAN::Version->readable($need_version)
4915 if ($self->{sponsored_mods}{$need_module}++){
4916 # We have already sponsored it and for some reason it's still
4917 # not available. So we do nothing. Or what should we do?
4918 # if we push it again, we have a potential infinite loop
4921 push @need, $need_module;
4926 #-> sub CPAN::Distribution::prereq_pm ;
4929 return $self->{prereq_pm} if
4930 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4931 return unless $self->{writemakefile}; # no need to have succeeded
4932 # but we must have run it
4933 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4934 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4939 $fh = FileHandle->new("<$makefile\0")) {
4943 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4945 last if /MakeMaker post_initialize section/;
4947 \s+PREREQ_PM\s+=>\s+(.+)
4950 # warn "Found prereq expr[$p]";
4952 # Regexp modified by A.Speer to remember actual version of file
4953 # PREREQ_PM hash key wants, then add to
4954 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4955 # In case a prereq is mentioned twice, complain.
4956 if ( defined $p{$1} ) {
4957 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4964 $self->{prereq_pm_detected}++;
4965 return $self->{prereq_pm} = \%p;
4968 #-> sub CPAN::Distribution::test ;
4973 delete $self->{force_update};
4976 # warn "XDEBUG: checking for notest: $self->{notest} $self";
4977 if ($self->{notest}) {
4978 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
4982 $CPAN::Frontend->myprint("Running make test\n");
4983 if (my @prereq = $self->unsat_prereq){
4984 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4988 exists $self->{make} or exists $self->{later} or push @e,
4989 "Make had some problems, maybe interrupted? Won't test";
4991 exists $self->{'make'} and
4992 $self->{'make'} eq 'NO' and
4993 push @e, "Can't test without successful make";
4995 exists $self->{build_dir} or push @e, "Has no own directory";
4996 $self->{badtestcnt} ||= 0;
4997 $self->{badtestcnt} > 0 and
4998 push @e, "Won't repeat unsuccessful test during this command";
5000 exists $self->{later} and length($self->{later}) and
5001 push @e, $self->{later};
5003 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5005 chdir $self->{'build_dir'} or
5006 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5007 $self->debug("Changed directory to $self->{'build_dir'}")
5010 if ($^O eq 'MacOS') {
5011 Mac::BuildTools::make_test($self);
5015 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5017 : ($ENV{PERLLIB} || "");
5019 $CPAN::META->set_perl5lib;
5020 my $system = join " ", $CPAN::Config->{'make'}, "test";
5021 if (system($system) == 0) {
5022 $CPAN::Frontend->myprint(" $system -- OK\n");
5023 $CPAN::META->is_tested($self->{'build_dir'});
5024 $self->{make_test} = "YES";
5026 $self->{make_test} = "NO";
5027 $self->{badtestcnt}++;
5028 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
5032 #-> sub CPAN::Distribution::clean ;
5035 $CPAN::Frontend->myprint("Running make clean\n");
5038 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
5039 push @e, "make clean already called once";
5040 exists $self->{build_dir} or push @e, "Has no own directory";
5041 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5043 chdir $self->{'build_dir'} or
5044 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5045 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
5047 if ($^O eq 'MacOS') {
5048 Mac::BuildTools::make_clean($self);
5052 my $system = join " ", $CPAN::Config->{'make'}, "clean";
5053 if (system($system) == 0) {
5054 $CPAN::Frontend->myprint(" $system -- OK\n");
5058 # Jost Krieger pointed out that this "force" was wrong because
5059 # it has the effect that the next "install" on this distribution
5060 # will untar everything again. Instead we should bring the
5061 # object's state back to where it is after untarring.
5063 delete $self->{force_update};
5064 delete $self->{install};
5065 delete $self->{writemakefile};
5066 delete $self->{make};
5067 delete $self->{make_test}; # no matter if yes or no, tests must be redone
5068 $self->{make_clean} = "YES";
5071 # Hmmm, what to do if make clean failed?
5073 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
5075 make clean did not succeed, marking directory as unusable for further work.
5077 $self->force("make"); # so that this directory won't be used again
5082 #-> sub CPAN::Distribution::install ;
5087 delete $self->{force_update};
5090 $CPAN::Frontend->myprint("Running make install\n");
5093 exists $self->{build_dir} or push @e, "Has no own directory";
5095 exists $self->{make} or exists $self->{later} or push @e,
5096 "Make had some problems, maybe interrupted? Won't install";
5098 exists $self->{'make'} and
5099 $self->{'make'} eq 'NO' and
5100 push @e, "make had returned bad status, install seems impossible";
5102 push @e, "make test had returned bad status, ".
5103 "won't install without force"
5104 if exists $self->{'make_test'} and
5105 $self->{'make_test'} eq 'NO' and
5106 ! $self->{'force_update'};
5108 exists $self->{'install'} and push @e,
5109 $self->{'install'} eq "YES" ?
5110 "Already done" : "Already tried without success";
5112 exists $self->{later} and length($self->{later}) and
5113 push @e, $self->{later};
5115 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5117 chdir $self->{'build_dir'} or
5118 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
5119 $self->debug("Changed directory to $self->{'build_dir'}")
5122 if ($^O eq 'MacOS') {
5123 Mac::BuildTools::make_install($self);
5127 my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
5128 $CPAN::Config->{'make'};
5130 my($system) = join(" ",
5131 $make_install_make_command,
5133 $CPAN::Config->{make_install_arg},
5135 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
5136 my($pipe) = FileHandle->new("$system $stderr |");
5139 $CPAN::Frontend->myprint($_);
5144 $CPAN::Frontend->myprint(" $system -- OK\n");
5145 $CPAN::META->is_installed($self->{'build_dir'});
5146 return $self->{'install'} = "YES";
5148 $self->{'install'} = "NO";
5149 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
5151 $makeout =~ /permission/s
5154 ! $CPAN::Config->{make_install_make_command}
5155 || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
5158 $CPAN::Frontend->myprint(
5160 qq{ You may have to su }.
5161 qq{to root to install the package\n}.
5162 qq{ (Or you may want to run something like\n}.
5163 qq{ o conf make_install_make_command 'sudo make'\n}.
5164 qq{ to raise your permissions.}
5168 delete $self->{force_update};
5171 #-> sub CPAN::Distribution::dir ;
5173 shift->{'build_dir'};
5176 #-> sub CPAN::Distribution::perldoc ;
5180 my($dist) = $self->id;
5181 my $package = $self->called_for;
5183 $self->_display_url( $CPAN::Defaultdocs . $package );
5186 #-> sub CPAN::Distribution::_check_binary ;
5188 my ($dist,$shell,$binary) = @_;
5189 my ($pid,$readme,$out);
5191 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
5194 $pid = open $readme, "-|", "which", $binary
5195 or $CPAN::Frontend->mydie(qq{Could not fork $binary: $!});
5201 $CPAN::Frontend->myprint(qq{ + $out \n})
5202 if $CPAN::DEBUG && $out;
5207 #-> sub CPAN::Distribution::_display_url ;
5209 my($self,$url) = @_;
5210 my($res,$saved_file,$pid,$readme,$out);
5212 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
5215 # should we define it in the config instead?
5216 my $html_converter = "html2text";
5218 my $web_browser = $CPAN::Config->{'lynx'} || undef;
5219 my $web_browser_out = $web_browser
5220 ? CPAN::Distribution->_check_binary($self,$web_browser)
5223 my ($tmpout,$tmperr);
5224 if (not $web_browser_out) {
5225 # web browser not found, let's try text only
5226 my $html_converter_out =
5227 CPAN::Distribution->_check_binary($self,$html_converter);
5229 if ($html_converter_out ) {
5230 # html2text found, run it
5231 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
5232 $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
5233 unless defined($saved_file);
5235 $pid = open $readme, "-|", $html_converter, $saved_file
5236 or $CPAN::Frontend->mydie(qq{
5237 Could not fork $html_converter $saved_file: $!});
5238 my $fh = File::Temp->new(
5239 template => 'cpan_htmlconvert_XXXX',
5247 or $CPAN::Frontend->mydie(qq{Could not close file handle: $!});
5248 my $tmpin = $fh->filename;
5249 $CPAN::Frontend->myprint(sprintf(qq{
5251 saved output to %s\n},
5256 close $fh; undef $fh;
5258 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
5259 my $fh_pager = FileHandle->new;
5260 local($SIG{PIPE}) = "IGNORE";
5261 $fh_pager->open("|$CPAN::Config->{'pager'}")
5262 or $CPAN::Frontend->mydie(qq{
5263 Could not open pager $CPAN::Config->{'pager'}: $!});
5264 $CPAN::Frontend->myprint(qq{
5267 with pager "$CPAN::Config->{'pager'}"
5270 $fh_pager->print(<$fh>);
5273 # coldn't find the web browser or html converter
5274 $CPAN::Frontend->myprint(qq{
5275 You need to install lynx or $html_converter to use this feature.});
5278 # web browser found, run the action
5279 my $browser = $CPAN::Config->{'lynx'};
5280 $CPAN::Frontend->myprint(qq{system[$browser $url]})
5282 $CPAN::Frontend->myprint(qq{
5285 with browser $browser
5288 system("$browser $url");
5289 if ($saved_file) { 1 while unlink($saved_file) }
5293 #-> sub CPAN::Distribution::_getsave_url ;
5295 my($dist, $shell, $url) = @_;
5297 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
5300 my $fh = File::Temp->new(
5301 template => "cpan_getsave_url_XXXX",
5305 my $tmpin = $fh->filename;
5306 if ($CPAN::META->has_usable('LWP')) {
5307 $CPAN::Frontend->myprint("Fetching with LWP:
5311 CPAN::LWP::UserAgent->config;
5312 eval { $Ua = CPAN::LWP::UserAgent->new; };
5314 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
5318 $Ua->proxy('http', $var)
5319 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
5321 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
5324 my $req = HTTP::Request->new(GET => $url);
5325 $req->header('Accept' => 'text/html');
5326 my $res = $Ua->request($req);
5327 if ($res->is_success) {
5328 $CPAN::Frontend->myprint(" + request successful.\n")
5330 print $fh $res->content;
5332 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
5336 $CPAN::Frontend->myprint(sprintf(
5337 "LWP failed with code[%s], message[%s]\n",
5344 $CPAN::Frontend->myprint("LWP not available\n");
5349 package CPAN::Bundle;
5353 $CPAN::Frontend->myprint($self->as_string);
5358 delete $self->{later};
5359 for my $c ( $self->contains ) {
5360 my $obj = CPAN::Shell->expandany($c) or next;
5365 #-> sub CPAN::Bundle::color_cmd_tmps ;
5366 sub color_cmd_tmps {
5368 my($depth) = shift || 0;
5369 my($color) = shift || 0;
5370 my($ancestors) = shift || [];
5371 # a module needs to recurse to its cpan_file, a distribution needs
5372 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
5374 return if exists $self->{incommandcolor}
5375 && $self->{incommandcolor}==$color;
5377 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5379 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5381 for my $c ( $self->contains ) {
5382 my $obj = CPAN::Shell->expandany($c) or next;
5383 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
5384 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5387 delete $self->{badtestcnt};
5389 $self->{incommandcolor} = $color;
5392 #-> sub CPAN::Bundle::as_string ;
5396 # following line must be "=", not "||=" because we have a moving target
5397 $self->{INST_VERSION} = $self->inst_version;
5398 return $self->SUPER::as_string;
5401 #-> sub CPAN::Bundle::contains ;
5404 my($inst_file) = $self->inst_file || "";
5405 my($id) = $self->id;
5406 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
5407 unless ($inst_file) {
5408 # Try to get at it in the cpan directory
5409 $self->debug("no inst_file") if $CPAN::DEBUG;
5411 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
5412 $cpan_file = $self->cpan_file;
5413 if ($cpan_file eq "N/A") {
5414 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
5415 Maybe stale symlink? Maybe removed during session? Giving up.\n");
5417 my $dist = $CPAN::META->instance('CPAN::Distribution',
5420 $self->debug($dist->as_string) if $CPAN::DEBUG;
5421 my($todir) = $CPAN::Config->{'cpan_home'};
5422 my(@me,$from,$to,$me);
5423 @me = split /::/, $self->id;
5425 $me = File::Spec->catfile(@me);
5426 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5427 $to = File::Spec->catfile($todir,$me);
5428 File::Path::mkpath(File::Basename::dirname($to));
5429 File::Copy::copy($from, $to)
5430 or Carp::confess("Couldn't copy $from to $to: $!");
5434 my $fh = FileHandle->new;
5436 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
5438 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
5440 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
5441 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
5442 next unless $in_cont;
5447 push @result, (split " ", $_, 2)[0];
5450 delete $self->{STATUS};
5451 $self->{CONTAINS} = \@result;
5452 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
5454 $CPAN::Frontend->mywarn(qq{
5455 The bundle file "$inst_file" may be a broken
5456 bundlefile. It seems not to contain any bundle definition.
5457 Please check the file and if it is bogus, please delete it.
5458 Sorry for the inconvenience.
5464 #-> sub CPAN::Bundle::find_bundle_file
5465 sub find_bundle_file {
5466 my($self,$where,$what) = @_;
5467 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
5468 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5469 ### my $bu = File::Spec->catfile($where,$what);
5470 ### return $bu if -f $bu;
5471 my $manifest = File::Spec->catfile($where,"MANIFEST");
5472 unless (-f $manifest) {
5473 require ExtUtils::Manifest;
5474 my $cwd = CPAN::anycwd();
5475 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5476 ExtUtils::Manifest::mkmanifest();
5477 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5479 my $fh = FileHandle->new($manifest)
5480 or Carp::croak("Couldn't open $manifest: $!");
5483 if ($^O eq 'MacOS') {
5486 $what2 =~ s/:Bundle://;
5489 $what2 =~ s|Bundle[/\\]||;
5494 my($file) = /(\S+)/;
5495 if ($file =~ m|\Q$what\E$|) {
5497 # return File::Spec->catfile($where,$bu); # bad
5500 # retry if she managed to
5501 # have no Bundle directory
5502 $bu = $file if $file =~ m|\Q$what2\E$|;
5504 $bu =~ tr|/|:| if $^O eq 'MacOS';
5505 return File::Spec->catfile($where, $bu) if $bu;
5506 Carp::croak("Couldn't find a Bundle file in $where");
5509 # needs to work quite differently from Module::inst_file because of
5510 # cpan_home/Bundle/ directory and the possibility that we have
5511 # shadowing effect. As it makes no sense to take the first in @INC for
5512 # Bundles, we parse them all for $VERSION and take the newest.
5514 #-> sub CPAN::Bundle::inst_file ;
5519 @me = split /::/, $self->id;
5522 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5523 my $bfile = File::Spec->catfile($incdir, @me);
5524 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5525 next unless -f $bfile;
5526 my $foundv = MM->parse_version($bfile);
5527 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5528 $self->{INST_FILE} = $bfile;
5529 $self->{INST_VERSION} = $bestv = $foundv;
5535 #-> sub CPAN::Bundle::inst_version ;
5538 $self->inst_file; # finds INST_VERSION as side effect
5539 $self->{INST_VERSION};
5542 #-> sub CPAN::Bundle::rematein ;
5544 my($self,$meth) = @_;
5545 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5546 my($id) = $self->id;
5547 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5548 unless $self->inst_file || $self->cpan_file;
5550 for $s ($self->contains) {
5551 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5552 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5553 if ($type eq 'CPAN::Distribution') {
5554 $CPAN::Frontend->mywarn(qq{
5555 The Bundle }.$self->id.qq{ contains
5556 explicitly a file $s.
5560 # possibly noisy action:
5561 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5562 my $obj = $CPAN::META->instance($type,$s);
5564 if ($obj->isa(CPAN::Bundle)
5566 exists $obj->{install_failed}
5568 ref($obj->{install_failed}) eq "HASH"
5570 for (keys %{$obj->{install_failed}}) {
5571 $self->{install_failed}{$_} = undef; # propagate faiure up
5574 $fail{$s} = 1; # the bundle itself may have succeeded but
5579 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5580 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5582 delete $self->{install_failed}{$s};
5589 # recap with less noise
5590 if ( $meth eq "install" ) {
5593 my $raw = sprintf(qq{Bundle summary:
5594 The following items in bundle %s had installation problems:},
5597 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5598 $CPAN::Frontend->myprint("\n");
5601 for $s ($self->contains) {
5603 $paragraph .= "$s ";
5604 $self->{install_failed}{$s} = undef;
5605 $reported{$s} = undef;
5608 my $report_propagated;
5609 for $s (sort keys %{$self->{install_failed}}) {
5610 next if exists $reported{$s};
5611 $paragraph .= "and the following items had problems
5612 during recursive bundle calls: " unless $report_propagated++;
5613 $paragraph .= "$s ";
5615 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5616 $CPAN::Frontend->myprint("\n");
5618 $self->{'install'} = 'YES';
5623 #sub CPAN::Bundle::xs_file
5625 # If a bundle contains another that contains an xs_file we have
5626 # here, we just don't bother I suppose
5630 #-> sub CPAN::Bundle::force ;
5631 sub force { shift->rematein('force',@_); }
5632 #-> sub CPAN::Bundle::notest ;
5633 sub notest { shift->rematein('notest',@_); }
5634 #-> sub CPAN::Bundle::get ;
5635 sub get { shift->rematein('get',@_); }
5636 #-> sub CPAN::Bundle::make ;
5637 sub make { shift->rematein('make',@_); }
5638 #-> sub CPAN::Bundle::test ;
5641 $self->{badtestcnt} ||= 0;
5642 $self->rematein('test',@_);
5644 #-> sub CPAN::Bundle::install ;
5647 $self->rematein('install',@_);
5649 #-> sub CPAN::Bundle::clean ;
5650 sub clean { shift->rematein('clean',@_); }
5652 #-> sub CPAN::Bundle::uptodate ;
5655 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5657 foreach $c ($self->contains) {
5658 my $obj = CPAN::Shell->expandany($c);
5659 return 0 unless $obj->uptodate;
5664 #-> sub CPAN::Bundle::readme ;
5667 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5668 No File found for bundle } . $self->id . qq{\n}), return;
5669 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5670 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5673 package CPAN::Module;
5676 # sub CPAN::Module::userid
5679 return unless exists $self->{RO}; # should never happen
5680 return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5682 # sub CPAN::Module::description
5683 sub description { shift->{RO}{description} }
5687 delete $self->{later};
5688 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5693 #-> sub CPAN::Module::color_cmd_tmps ;
5694 sub color_cmd_tmps {
5696 my($depth) = shift || 0;
5697 my($color) = shift || 0;
5698 my($ancestors) = shift || [];
5699 # a module needs to recurse to its cpan_file
5701 return if exists $self->{incommandcolor}
5702 && $self->{incommandcolor}==$color;
5704 $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5706 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5708 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5709 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5712 delete $self->{badtestcnt};
5714 $self->{incommandcolor} = $color;
5717 #-> sub CPAN::Module::as_glimpse ;
5721 my $class = ref($self);
5722 $class =~ s/^CPAN:://;
5726 $CPAN::Shell::COLOR_REGISTERED
5728 $CPAN::META->has_inst("Term::ANSIColor")
5730 $self->{RO}{description}
5732 $color_on = Term::ANSIColor::color("green");
5733 $color_off = Term::ANSIColor::color("reset");
5735 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5744 #-> sub CPAN::Module::as_string ;
5748 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5749 my $class = ref($self);
5750 $class =~ s/^CPAN:://;
5752 push @m, $class, " id = $self->{ID}\n";
5753 my $sprintf = " %-12s %s\n";
5754 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5755 if $self->description;
5756 my $sprintf2 = " %-12s %s (%s)\n";
5758 $userid = $self->userid;
5761 if ($author = CPAN::Shell->expand('Author',$userid)) {
5764 if ($m = $author->email) {
5771 $author->fullname . $email
5775 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5776 if $self->cpan_version;
5777 if (my $cpan_file = $self->cpan_file){
5778 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
5779 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
5780 my $upload_date = $dist->upload_date;
5782 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
5786 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5787 my(%statd,%stats,%statl,%stati);
5788 @statd{qw,? i c a b R M S,} = qw,unknown idea
5789 pre-alpha alpha beta released mature standard,;
5790 @stats{qw,? m d u n a,} = qw,unknown mailing-list
5791 developer comp.lang.perl.* none abandoned,;
5792 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5793 @stati{qw,? f r O h,} = qw,unknown functions
5794 references+ties object-oriented hybrid,;
5795 $statd{' '} = 'unknown';
5796 $stats{' '} = 'unknown';
5797 $statl{' '} = 'unknown';
5798 $stati{' '} = 'unknown';
5806 $statd{$self->{RO}{statd}},
5807 $stats{$self->{RO}{stats}},
5808 $statl{$self->{RO}{statl}},
5809 $stati{$self->{RO}{stati}}
5810 ) if $self->{RO}{statd};
5811 my $local_file = $self->inst_file;
5812 unless ($self->{MANPAGE}) {
5814 $self->{MANPAGE} = $self->manpage_headline($local_file);
5816 # If we have already untarred it, we should look there
5817 my $dist = $CPAN::META->instance('CPAN::Distribution',
5819 # warn "dist[$dist]";
5820 # mff=manifest file; mfh=manifest handle
5825 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5827 $mfh = FileHandle->new($mff)
5829 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5830 my $lfre = $self->id; # local file RE
5833 my($lfl); # local file file
5835 my(@mflines) = <$mfh>;
5840 while (length($lfre)>5 and !$lfl) {
5841 ($lfl) = grep /$lfre/, @mflines;
5842 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5845 $lfl =~ s/\s.*//; # remove comments
5846 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5847 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5848 # warn "lfl_abs[$lfl_abs]";
5850 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5856 for $item (qw/MANPAGE/) {
5857 push @m, sprintf($sprintf, $item, $self->{$item})
5858 if exists $self->{$item};
5860 for $item (qw/CONTAINS/) {
5861 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5862 if exists $self->{$item} && @{$self->{$item}};
5864 push @m, sprintf($sprintf, 'INST_FILE',
5865 $local_file || "(not installed)");
5866 push @m, sprintf($sprintf, 'INST_VERSION',
5867 $self->inst_version) if $local_file;
5871 sub manpage_headline {
5872 my($self,$local_file) = @_;
5873 my(@local_file) = $local_file;
5874 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5875 push @local_file, $local_file;
5877 for $locf (@local_file) {
5878 next unless -f $locf;
5879 my $fh = FileHandle->new($locf)
5880 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5884 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5885 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5898 #-> sub CPAN::Module::cpan_file ;
5899 # Note: also inherited by CPAN::Bundle
5902 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5903 unless (defined $self->{RO}{CPAN_FILE}) {
5904 CPAN::Index->reload;
5906 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5907 return $self->{RO}{CPAN_FILE};
5909 my $userid = $self->userid;
5911 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5912 my $author = $CPAN::META->instance("CPAN::Author",
5914 my $fullname = $author->fullname;
5915 my $email = $author->email;
5916 unless (defined $fullname && defined $email) {
5917 return sprintf("Contact Author %s",
5921 return "Contact Author $fullname <$email>";
5923 return "Contact Author $userid (Email address not available)";
5931 #-> sub CPAN::Module::cpan_version ;
5935 $self->{RO}{CPAN_VERSION} = 'undef'
5936 unless defined $self->{RO}{CPAN_VERSION};
5937 # I believe this is always a bug in the index and should be reported
5938 # as such, but usually I find out such an error and do not want to
5939 # provoke too many bugreports
5941 $self->{RO}{CPAN_VERSION};
5944 #-> sub CPAN::Module::force ;
5947 $self->{'force_update'}++;
5952 # warn "XDEBUG: set notest for Module";
5953 $self->{'notest'}++;
5956 #-> sub CPAN::Module::rematein ;
5958 my($self,$meth) = @_;
5959 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5962 my $cpan_file = $self->cpan_file;
5963 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5964 $CPAN::Frontend->mywarn(sprintf qq{
5965 The module %s isn\'t available on CPAN.
5967 Either the module has not yet been uploaded to CPAN, or it is
5968 temporary unavailable. Please contact the author to find out
5969 more about the status. Try 'i %s'.
5976 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5977 $pack->called_for($self->id);
5978 $pack->force($meth) if exists $self->{'force_update'};
5979 $pack->notest($meth) if exists $self->{'notest'};
5984 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5985 $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
5986 delete $self->{'force_update'};
5987 delete $self->{'notest'};
5993 #-> sub CPAN::Module::perldoc ;
5994 sub perldoc { shift->rematein('perldoc') }
5995 #-> sub CPAN::Module::readme ;
5996 sub readme { shift->rematein('readme') }
5997 #-> sub CPAN::Module::look ;
5998 sub look { shift->rematein('look') }
5999 #-> sub CPAN::Module::cvs_import ;
6000 sub cvs_import { shift->rematein('cvs_import') }
6001 #-> sub CPAN::Module::get ;
6002 sub get { shift->rematein('get',@_) }
6003 #-> sub CPAN::Module::make ;
6004 sub make { shift->rematein('make') }
6005 #-> sub CPAN::Module::test ;
6008 $self->{badtestcnt} ||= 0;
6009 $self->rematein('test',@_);
6011 #-> sub CPAN::Module::uptodate ;
6014 my($latest) = $self->cpan_version;
6016 my($inst_file) = $self->inst_file;
6018 if (defined $inst_file) {
6019 $have = $self->inst_version;
6024 ! CPAN::Version->vgt($latest, $have)
6026 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
6027 "latest[$latest] have[$have]") if $CPAN::DEBUG;
6032 #-> sub CPAN::Module::install ;
6038 not exists $self->{'force_update'}
6040 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
6044 if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
6045 $CPAN::Frontend->mywarn(qq{
6046 \n\n\n ***WARNING***
6047 The module $self->{ID} has no active maintainer.\n\n\n
6051 $self->rematein('install') if $doit;
6053 #-> sub CPAN::Module::clean ;
6054 sub clean { shift->rematein('clean') }
6056 #-> sub CPAN::Module::inst_file ;
6060 @packpath = split /::/, $self->{ID};
6061 $packpath[-1] .= ".pm";
6062 foreach $dir (@INC) {
6063 my $pmfile = File::Spec->catfile($dir,@packpath);
6071 #-> sub CPAN::Module::xs_file ;
6075 @packpath = split /::/, $self->{ID};
6076 push @packpath, $packpath[-1];
6077 $packpath[-1] .= "." . $Config::Config{'dlext'};
6078 foreach $dir (@INC) {
6079 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
6087 #-> sub CPAN::Module::inst_version ;
6090 my $parsefile = $self->inst_file or return;
6091 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
6094 # there was a bug in 5.6.0 that let lots of unini warnings out of
6095 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
6096 # the following workaround after 5.6.1 is out.
6097 local($SIG{__WARN__}) = sub { my $w = shift;
6098 return if $w =~ /uninitialized/i;
6102 $have = MM->parse_version($parsefile) || "undef";
6103 $have =~ s/^ //; # since the %vd hack these two lines here are needed
6104 $have =~ s/ $//; # trailing whitespace happens all the time
6106 # My thoughts about why %vd processing should happen here
6108 # Alt1 maintain it as string with leading v:
6109 # read index files do nothing
6110 # compare it use utility for compare
6111 # print it do nothing
6113 # Alt2 maintain it as what it is
6114 # read index files convert
6115 # compare it use utility because there's still a ">" vs "gt" issue
6116 # print it use CPAN::Version for print
6118 # Seems cleaner to hold it in memory as a string starting with a "v"
6120 # If the author of this module made a mistake and wrote a quoted
6121 # "v1.13" instead of v1.13, we simply leave it at that with the
6122 # effect that *we* will treat it like a v-tring while the rest of
6123 # perl won't. Seems sensible when we consider that any action we
6124 # could take now would just add complexity.
6126 $have = CPAN::Version->readable($have);
6128 $have =~ s/\s*//g; # stringify to float around floating point issues
6129 $have; # no stringify needed, \s* above matches always
6132 package CPAN::Tarzip;
6134 # CPAN::Tarzip::gzip
6136 my($class,$read,$write) = @_;
6137 if ($CPAN::META->has_inst("Compress::Zlib")) {
6139 $fhw = FileHandle->new($read)
6140 or $CPAN::Frontend->mydie("Could not open $read: $!");
6142 my $gz = Compress::Zlib::gzopen($write, "wb")
6143 or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
6144 $gz->gzwrite($buffer)
6145 while read($fhw,$buffer,4096) > 0 ;
6150 system("$CPAN::Config->{gzip} -c $read > $write")==0;
6155 # CPAN::Tarzip::gunzip
6157 my($class,$read,$write) = @_;
6158 if ($CPAN::META->has_inst("Compress::Zlib")) {
6160 $fhw = FileHandle->new(">$write")
6161 or $CPAN::Frontend->mydie("Could not open >$write: $!");
6162 my $gz = Compress::Zlib::gzopen($read, "rb")
6163 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
6164 $fhw->print($buffer)
6165 while $gz->gzread($buffer) > 0 ;
6166 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
6167 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
6172 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
6177 # CPAN::Tarzip::gtest
6179 my($class,$read) = @_;
6180 # After I had reread the documentation in zlib.h, I discovered that
6181 # uncompressed files do not lead to an gzerror (anymore?).
6182 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
6185 my $gz = Compress::Zlib::gzopen($read, "rb")
6186 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
6188 $Compress::Zlib::gzerrno));
6189 while ($gz->gzread($buffer) > 0 ){
6190 $len += length($buffer);
6193 my $err = $gz->gzerror;
6194 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
6195 if ($len == -s $read){
6197 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
6200 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
6203 return system("$CPAN::Config->{gzip} -dt $read")==0;
6208 # CPAN::Tarzip::TIEHANDLE
6210 my($class,$file) = @_;
6212 $class->debug("file[$file]");
6213 if ($CPAN::META->has_inst("Compress::Zlib")) {
6214 my $gz = Compress::Zlib::gzopen($file,"rb") or
6215 die "Could not gzopen $file";
6216 $ret = bless {GZ => $gz}, $class;
6218 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
6219 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
6221 $ret = bless {FH => $fh}, $class;
6227 # CPAN::Tarzip::READLINE
6230 if (exists $self->{GZ}) {
6231 my $gz = $self->{GZ};
6232 my($line,$bytesread);
6233 $bytesread = $gz->gzreadline($line);
6234 return undef if $bytesread <= 0;
6237 my $fh = $self->{FH};
6238 return scalar <$fh>;
6243 # CPAN::Tarzip::READ
6245 my($self,$ref,$length,$offset) = @_;
6246 die "read with offset not implemented" if defined $offset;
6247 if (exists $self->{GZ}) {
6248 my $gz = $self->{GZ};
6249 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
6252 my $fh = $self->{FH};
6253 return read($fh,$$ref,$length);
6258 # CPAN::Tarzip::DESTROY
6261 if (exists $self->{GZ}) {
6262 my $gz = $self->{GZ};
6263 $gz->gzclose() if defined $gz; # hard to say if it is allowed
6264 # to be undef ever. AK, 2000-09
6266 my $fh = $self->{FH};
6267 $fh->close if defined $fh;
6273 # CPAN::Tarzip::untar
6275 my($class,$file) = @_;
6278 if (0) { # makes changing order easier
6279 } elsif ($BUGHUNTING){
6281 } elsif (MM->maybe_command($CPAN::Config->{gzip})
6283 MM->maybe_command($CPAN::Config->{'tar'})) {
6284 # should be default until Archive::Tar is fixed
6287 $CPAN::META->has_inst("Archive::Tar")
6289 $CPAN::META->has_inst("Compress::Zlib") ) {
6292 $CPAN::Frontend->mydie(qq{
6293 CPAN.pm needs either both external programs tar and gzip installed or
6294 both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
6295 is available. Can\'t continue.
6298 if ($prefer==1) { # 1 => external gzip+tar
6300 my $is_compressed = $class->gtest($file);
6301 if ($is_compressed) {
6302 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
6303 "< $file | $CPAN::Config->{tar} xvf -";
6305 $system = "$CPAN::Config->{tar} xvf $file";
6307 if (system($system) != 0) {
6308 # people find the most curious tar binaries that cannot handle
6310 if ($is_compressed) {
6311 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
6312 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
6313 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
6315 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
6319 $system = "$CPAN::Config->{tar} xvf $file";
6320 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
6321 if (system($system)==0) {
6322 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
6324 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
6330 } elsif ($prefer==2) { # 2 => modules
6331 my $tar = Archive::Tar->new($file,1);
6332 my $af; # archive file
6335 # RCS 1.337 had this code, it turned out unacceptable slow but
6336 # it revealed a bug in Archive::Tar. Code is only here to hunt
6337 # the bug again. It should never be enabled in published code.
6338 # GDGraph3d-0.53 was an interesting case according to Larry
6340 warn(">>>Bughunting code enabled<<< " x 20);
6341 for $af ($tar->list_files) {
6342 if ($af =~ m!^(/|\.\./)!) {
6343 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6344 "illegal member [$af]");
6346 $CPAN::Frontend->myprint("$af\n");
6347 $tar->extract($af); # slow but effective for finding the bug
6348 return if $CPAN::Signal;
6351 for $af ($tar->list_files) {
6352 if ($af =~ m!^(/|\.\./)!) {
6353 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6354 "illegal member [$af]");
6356 $CPAN::Frontend->myprint("$af\n");
6358 return if $CPAN::Signal;
6363 Mac::BuildTools::convert_files([$tar->list_files], 1)
6364 if ($^O eq 'MacOS');
6371 my($class,$file) = @_;
6372 if ($CPAN::META->has_inst("Archive::Zip")) {
6373 # blueprint of the code from Archive::Zip::Tree::extractTree();
6374 my $zip = Archive::Zip->new();
6376 $status = $zip->read($file);
6377 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
6378 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
6379 my @members = $zip->members();
6380 for my $member ( @members ) {
6381 my $af = $member->fileName();
6382 if ($af =~ m!^(/|\.\./)!) {
6383 $CPAN::Frontend->mydie("ALERT: Archive contains ".
6384 "illegal member [$af]");
6386 my $status = $member->extractToFileNamed( $af );
6387 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
6388 die "Extracting of file[$af] from zipfile[$file] failed\n" if
6389 $status != Archive::Zip::AZ_OK();
6390 return if $CPAN::Signal;
6394 my $unzip = $CPAN::Config->{unzip} or
6395 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
6396 my @system = ($unzip, $file);
6397 return system(@system) == 0;
6409 CPAN - query, download and build perl modules from CPAN sites
6415 perl -MCPAN -e shell;
6421 autobundle, clean, install, make, recompile, test
6425 This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6426 of a modern rewrite from ground up with greater extensibility and more
6427 features but no full compatibility. If you're new to CPAN.pm, you
6428 probably should investigate if CPANPLUS is the better choice for you.
6429 If you're already used to CPAN.pm you're welcome to continue using it,
6430 if you accept that its development is mostly (though not completely)
6435 The CPAN module is designed to automate the make and install of perl
6436 modules and extensions. It includes some primitive searching capabilities and
6437 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6438 to fetch the raw data from the net.
6440 Modules are fetched from one or more of the mirrored CPAN
6441 (Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6444 The CPAN module also supports the concept of named and versioned
6445 I<bundles> of modules. Bundles simplify the handling of sets of
6446 related modules. See Bundles below.
6448 The package contains a session manager and a cache manager. There is
6449 no status retained between sessions. The session manager keeps track
6450 of what has been fetched, built and installed in the current
6451 session. The cache manager keeps track of the disk space occupied by
6452 the make processes and deletes excess space according to a simple FIFO
6455 For extended searching capabilities there's a plugin for CPAN available,
6456 L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6457 that indexes all documents available in CPAN authors directories. If
6458 C<CPAN::WAIT> is installed on your system, the interactive shell of
6459 CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6460 which send queries to the WAIT server that has been configured for your
6463 All other methods provided are accessible in a programmer style and in an
6464 interactive shell style.
6466 =head2 Interactive Mode
6468 The interactive mode is entered by running
6470 perl -MCPAN -e shell
6472 which puts you into a readline interface. You will have the most fun if
6473 you install Term::ReadKey and Term::ReadLine to enjoy both history and
6476 Once you are on the command line, type 'h' and the rest should be
6479 The function call C<shell> takes two optional arguments, one is the
6480 prompt, the second is the default initial command line (the latter
6481 only works if a real ReadLine interface module is installed).
6483 The most common uses of the interactive modes are
6487 =item Searching for authors, bundles, distribution files and modules
6489 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6490 for each of the four categories and another, C<i> for any of the
6491 mentioned four. Each of the four entities is implemented as a class
6492 with slightly differing methods for displaying an object.
6494 Arguments you pass to these commands are either strings exactly matching
6495 the identification string of an object or regular expressions that are
6496 then matched case-insensitively against various attributes of the
6497 objects. The parser recognizes a regular expression only if you
6498 enclose it between two slashes.
6500 The principle is that the number of found objects influences how an
6501 item is displayed. If the search finds one item, the result is
6502 displayed with the rather verbose method C<as_string>, but if we find
6503 more than one, we display each object with the terse method
6506 =item make, test, install, clean modules or distributions
6508 These commands take any number of arguments and investigate what is
6509 necessary to perform the action. If the argument is a distribution
6510 file name (recognized by embedded slashes), it is processed. If it is
6511 a module, CPAN determines the distribution file in which this module
6512 is included and processes that, following any dependencies named in
6513 the module's Makefile.PL (this behavior is controlled by
6514 I<prerequisites_policy>.)
6516 Any C<make> or C<test> are run unconditionally. An
6518 install <distribution_file>
6520 also is run unconditionally. But for
6524 CPAN checks if an install is actually needed for it and prints
6525 I<module up to date> in the case that the distribution file containing
6526 the module doesn't need to be updated.
6528 CPAN also keeps track of what it has done within the current session
6529 and doesn't try to build a package a second time regardless if it
6530 succeeded or not. The C<force> pragma may precede another command
6531 (currently: C<make>, C<test>, or C<install>) and executes the
6532 command from scratch.
6536 cpan> install OpenGL
6537 OpenGL is up to date.
6538 cpan> force install OpenGL
6541 OpenGL-0.4/COPYRIGHT
6544 The C<notest> pragma may be set to skip the test part in the build
6549 cpan> notest install Tk
6551 A C<clean> command results in a
6555 being executed within the distribution file's working directory.
6557 =item get, readme, perldoc, look module or distribution
6559 C<get> downloads a distribution file without further action. C<readme>
6560 displays the README file of the associated distribution. C<Look> gets
6561 and untars (if not yet done) the distribution file, changes to the
6562 appropriate directory and opens a subshell process in that directory.
6563 C<perldoc> displays the pod documentation of the module in html or
6568 C<ls> lists all distribution files in and below an author's CPAN
6569 directory. Only those files that contain modules are listed and if
6570 there is more than one for any given module, only the most recent one
6575 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6576 in the cpan-shell it is intended that you can press C<^C> anytime and
6577 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6578 to clean up and leave the shell loop. You can emulate the effect of a
6579 SIGTERM by sending two consecutive SIGINTs, which usually means by
6580 pressing C<^C> twice.
6582 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6583 SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6589 The commands that are available in the shell interface are methods in
6590 the package CPAN::Shell. If you enter the shell command, all your
6591 input is split by the Text::ParseWords::shellwords() routine which
6592 acts like most shells do. The first word is being interpreted as the
6593 method to be called and the rest of the words are treated as arguments
6594 to this method. Continuation lines are supported if a line ends with a
6599 C<autobundle> writes a bundle file into the
6600 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6601 a list of all modules that are both available from CPAN and currently
6602 installed within @INC. The name of the bundle file is based on the
6603 current date and a counter.
6607 recompile() is a very special command in that it takes no argument and
6608 runs the make/test/install cycle with brute force over all installed
6609 dynamically loadable extensions (aka XS modules) with 'force' in
6610 effect. The primary purpose of this command is to finish a network
6611 installation. Imagine, you have a common source tree for two different
6612 architectures. You decide to do a completely independent fresh
6613 installation. You start on one architecture with the help of a Bundle
6614 file produced earlier. CPAN installs the whole Bundle for you, but
6615 when you try to repeat the job on the second architecture, CPAN
6616 responds with a C<"Foo up to date"> message for all modules. So you
6617 invoke CPAN's recompile on the second architecture and you're done.
6619 Another popular use for C<recompile> is to act as a rescue in case your
6620 perl breaks binary compatibility. If one of the modules that CPAN uses
6621 is in turn depending on binary compatibility (so you cannot run CPAN
6622 commands), then you should try the CPAN::Nox module for recovery.
6624 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6626 Although it may be considered internal, the class hierarchy does matter
6627 for both users and programmer. CPAN.pm deals with above mentioned four
6628 classes, and all those classes share a set of methods. A classical
6629 single polymorphism is in effect. A metaclass object registers all
6630 objects of all kinds and indexes them with a string. The strings
6631 referencing objects have a separated namespace (well, not completely
6636 words containing a "/" (slash) Distribution
6637 words starting with Bundle:: Bundle
6638 everything else Module or Author
6640 Modules know their associated Distribution objects. They always refer
6641 to the most recent official release. Developers may mark their releases
6642 as unstable development versions (by inserting an underbar into the
6643 module version number which will also be reflected in the distribution
6644 name when you run 'make dist'), so the really hottest and newest
6645 distribution is not always the default. If a module Foo circulates
6646 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6647 way to install version 1.23 by saying
6651 This would install the complete distribution file (say
6652 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6653 like to install version 1.23_90, you need to know where the
6654 distribution file resides on CPAN relative to the authors/id/
6655 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6656 so you would have to say
6658 install BAR/Foo-1.23_90.tar.gz
6660 The first example will be driven by an object of the class
6661 CPAN::Module, the second by an object of class CPAN::Distribution.
6663 =head2 Programmer's interface
6665 If you do not enter the shell, the available shell commands are both
6666 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6667 functions in the calling package (C<install(...)>).
6669 There's currently only one class that has a stable interface -
6670 CPAN::Shell. All commands that are available in the CPAN shell are
6671 methods of the class CPAN::Shell. Each of the commands that produce
6672 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6673 the IDs of all modules within the list.
6677 =item expand($type,@things)
6679 The IDs of all objects available within a program are strings that can
6680 be expanded to the corresponding real objects with the
6681 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6682 list of CPAN::Module objects according to the C<@things> arguments
6683 given. In scalar context it only returns the first element of the
6686 =item expandany(@things)
6688 Like expand, but returns objects of the appropriate type, i.e.
6689 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6690 CPAN::Distribution objects fro distributions.
6692 =item Programming Examples
6694 This enables the programmer to do operations that combine
6695 functionalities that are available in the shell.
6697 # install everything that is outdated on my disk:
6698 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6700 # install my favorite programs if necessary:
6701 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6702 my $obj = CPAN::Shell->expand('Module',$mod);
6706 # list all modules on my disk that have no VERSION number
6707 for $mod (CPAN::Shell->expand("Module","/./")){
6708 next unless $mod->inst_file;
6709 # MakeMaker convention for undefined $VERSION:
6710 next unless $mod->inst_version eq "undef";
6711 print "No VERSION in ", $mod->id, "\n";
6714 # find out which distribution on CPAN contains a module:
6715 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6717 Or if you want to write a cronjob to watch The CPAN, you could list
6718 all modules that need updating. First a quick and dirty way:
6720 perl -e 'use CPAN; CPAN::Shell->r;'
6722 If you don't want to get any output in the case that all modules are
6723 up to date, you can parse the output of above command for the regular
6724 expression //modules are up to date// and decide to mail the output
6725 only if it doesn't match. Ick?
6727 If you prefer to do it more in a programmer style in one single
6728 process, maybe something like this suits you better:
6730 # list all modules on my disk that have newer versions on CPAN
6731 for $mod (CPAN::Shell->expand("Module","/./")){
6732 next unless $mod->inst_file;
6733 next if $mod->uptodate;
6734 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6735 $mod->id, $mod->inst_version, $mod->cpan_version;
6738 If that gives you too much output every day, you maybe only want to
6739 watch for three modules. You can write
6741 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6743 as the first line instead. Or you can combine some of the above
6746 # watch only for a new mod_perl module
6747 $mod = CPAN::Shell->expand("Module","mod_perl");
6748 exit if $mod->uptodate;
6749 # new mod_perl arrived, let me know all update recommendations
6754 =head2 Methods in the other Classes
6756 The programming interface for the classes CPAN::Module,
6757 CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6758 beta and partially even alpha. In the following paragraphs only those
6759 methods are documented that have proven useful over a longer time and
6760 thus are unlikely to change.
6764 =item CPAN::Author::as_glimpse()
6766 Returns a one-line description of the author
6768 =item CPAN::Author::as_string()
6770 Returns a multi-line description of the author
6772 =item CPAN::Author::email()
6774 Returns the author's email address
6776 =item CPAN::Author::fullname()
6778 Returns the author's name
6780 =item CPAN::Author::name()
6782 An alias for fullname
6784 =item CPAN::Bundle::as_glimpse()
6786 Returns a one-line description of the bundle
6788 =item CPAN::Bundle::as_string()
6790 Returns a multi-line description of the bundle
6792 =item CPAN::Bundle::clean()
6794 Recursively runs the C<clean> method on all items contained in the bundle.
6796 =item CPAN::Bundle::contains()
6798 Returns a list of objects' IDs contained in a bundle. The associated
6799 objects may be bundles, modules or distributions.
6801 =item CPAN::Bundle::force($method,@args)
6803 Forces CPAN to perform a task that normally would have failed. Force
6804 takes as arguments a method name to be called and any number of
6805 additional arguments that should be passed to the called method. The
6806 internals of the object get the needed changes so that CPAN.pm does
6807 not refuse to take the action. The C<force> is passed recursively to
6808 all contained objects.
6810 =item CPAN::Bundle::get()
6812 Recursively runs the C<get> method on all items contained in the bundle
6814 =item CPAN::Bundle::inst_file()
6816 Returns the highest installed version of the bundle in either @INC or
6817 C<$CPAN::Config->{cpan_home}>. Note that this is different from
6818 CPAN::Module::inst_file.
6820 =item CPAN::Bundle::inst_version()
6822 Like CPAN::Bundle::inst_file, but returns the $VERSION
6824 =item CPAN::Bundle::uptodate()
6826 Returns 1 if the bundle itself and all its members are uptodate.
6828 =item CPAN::Bundle::install()
6830 Recursively runs the C<install> method on all items contained in the bundle
6832 =item CPAN::Bundle::make()
6834 Recursively runs the C<make> method on all items contained in the bundle
6836 =item CPAN::Bundle::readme()
6838 Recursively runs the C<readme> method on all items contained in the bundle
6840 =item CPAN::Bundle::test()
6842 Recursively runs the C<test> method on all items contained in the bundle
6844 =item CPAN::Distribution::as_glimpse()
6846 Returns a one-line description of the distribution
6848 =item CPAN::Distribution::as_string()
6850 Returns a multi-line description of the distribution
6852 =item CPAN::Distribution::clean()
6854 Changes to the directory where the distribution has been unpacked and
6855 runs C<make clean> there.
6857 =item CPAN::Distribution::containsmods()
6859 Returns a list of IDs of modules contained in a distribution file.
6860 Only works for distributions listed in the 02packages.details.txt.gz
6861 file. This typically means that only the most recent version of a
6862 distribution is covered.
6864 =item CPAN::Distribution::cvs_import()
6866 Changes to the directory where the distribution has been unpacked and
6869 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6873 =item CPAN::Distribution::dir()
6875 Returns the directory into which this distribution has been unpacked.
6877 =item CPAN::Distribution::force($method,@args)
6879 Forces CPAN to perform a task that normally would have failed. Force
6880 takes as arguments a method name to be called and any number of
6881 additional arguments that should be passed to the called method. The
6882 internals of the object get the needed changes so that CPAN.pm does
6883 not refuse to take the action.
6885 =item CPAN::Distribution::get()
6887 Downloads the distribution from CPAN and unpacks it. Does nothing if
6888 the distribution has already been downloaded and unpacked within the
6891 =item CPAN::Distribution::install()
6893 Changes to the directory where the distribution has been unpacked and
6894 runs the external command C<make install> there. If C<make> has not
6895 yet been run, it will be run first. A C<make test> will be issued in
6896 any case and if this fails, the install will be canceled. The
6897 cancellation can be avoided by letting C<force> run the C<install> for
6900 =item CPAN::Distribution::isa_perl()
6902 Returns 1 if this distribution file seems to be a perl distribution.
6903 Normally this is derived from the file name only, but the index from
6904 CPAN can contain a hint to achieve a return value of true for other
6907 =item CPAN::Distribution::look()
6909 Changes to the directory where the distribution has been unpacked and
6910 opens a subshell there. Exiting the subshell returns.
6912 =item CPAN::Distribution::make()
6914 First runs the C<get> method to make sure the distribution is
6915 downloaded and unpacked. Changes to the directory where the
6916 distribution has been unpacked and runs the external commands C<perl
6917 Makefile.PL> and C<make> there.
6919 =item CPAN::Distribution::prereq_pm()
6921 Returns the hash reference that has been announced by a distribution
6922 as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6923 attempt has been made to C<make> the distribution. Returns undef
6926 =item CPAN::Distribution::readme()
6928 Downloads the README file associated with a distribution and runs it
6929 through the pager specified in C<$CPAN::Config->{pager}>.
6931 =item CPAN::Distribution::perldoc()
6933 Downloads the pod documentation of the file associated with a
6934 distribution (in html format) and runs it through the external
6935 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
6936 isn't available, it converts it to plain text with external
6937 command html2text and runs it through the pager specified
6938 in C<$CPAN::Config->{pager}>
6940 =item CPAN::Distribution::test()
6942 Changes to the directory where the distribution has been unpacked and
6943 runs C<make test> there.
6945 =item CPAN::Distribution::uptodate()
6947 Returns 1 if all the modules contained in the distribution are
6948 uptodate. Relies on containsmods.
6950 =item CPAN::Index::force_reload()
6952 Forces a reload of all indices.
6954 =item CPAN::Index::reload()
6956 Reloads all indices if they have been read more than
6957 C<$CPAN::Config->{index_expire}> days.
6959 =item CPAN::InfoObj::dump()
6961 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6962 inherit this method. It prints the data structure associated with an
6963 object. Useful for debugging. Note: the data structure is considered
6964 internal and thus subject to change without notice.
6966 =item CPAN::Module::as_glimpse()
6968 Returns a one-line description of the module
6970 =item CPAN::Module::as_string()
6972 Returns a multi-line description of the module
6974 =item CPAN::Module::clean()
6976 Runs a clean on the distribution associated with this module.
6978 =item CPAN::Module::cpan_file()
6980 Returns the filename on CPAN that is associated with the module.
6982 =item CPAN::Module::cpan_version()
6984 Returns the latest version of this module available on CPAN.
6986 =item CPAN::Module::cvs_import()
6988 Runs a cvs_import on the distribution associated with this module.
6990 =item CPAN::Module::description()
6992 Returns a 44 character description of this module. Only available for
6993 modules listed in The Module List (CPAN/modules/00modlist.long.html
6994 or 00modlist.long.txt.gz)
6996 =item CPAN::Module::force($method,@args)
6998 Forces CPAN to perform a task that normally would have failed. Force
6999 takes as arguments a method name to be called and any number of
7000 additional arguments that should be passed to the called method. The
7001 internals of the object get the needed changes so that CPAN.pm does
7002 not refuse to take the action.
7004 =item CPAN::Module::get()
7006 Runs a get on the distribution associated with this module.
7008 =item CPAN::Module::inst_file()
7010 Returns the filename of the module found in @INC. The first file found
7011 is reported just like perl itself stops searching @INC when it finds a
7014 =item CPAN::Module::inst_version()
7016 Returns the version number of the module in readable format.
7018 =item CPAN::Module::install()
7020 Runs an C<install> on the distribution associated with this module.
7022 =item CPAN::Module::look()
7024 Changes to the directory where the distribution associated with this
7025 module has been unpacked and opens a subshell there. Exiting the
7028 =item CPAN::Module::make()
7030 Runs a C<make> on the distribution associated with this module.
7032 =item CPAN::Module::manpage_headline()
7034 If module is installed, peeks into the module's manpage, reads the
7035 headline and returns it. Moreover, if the module has been downloaded
7036 within this session, does the equivalent on the downloaded module even
7037 if it is not installed.
7039 =item CPAN::Module::readme()
7041 Runs a C<readme> on the distribution associated with this module.
7043 =item CPAN::Module::perldoc()
7045 Runs a C<perldoc> on this module.
7047 =item CPAN::Module::test()
7049 Runs a C<test> on the distribution associated with this module.
7051 =item CPAN::Module::uptodate()
7053 Returns 1 if the module is installed and up-to-date.
7055 =item CPAN::Module::userid()
7057 Returns the author's ID of the module.
7061 =head2 Cache Manager
7063 Currently the cache manager only keeps track of the build directory
7064 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
7065 deletes complete directories below C<build_dir> as soon as the size of
7066 all directories there gets bigger than $CPAN::Config->{build_cache}
7067 (in MB). The contents of this cache may be used for later
7068 re-installations that you intend to do manually, but will never be
7069 trusted by CPAN itself. This is due to the fact that the user might
7070 use these directories for building modules on different architectures.
7072 There is another directory ($CPAN::Config->{keep_source_where}) where
7073 the original distribution files are kept. This directory is not
7074 covered by the cache manager and must be controlled by the user. If
7075 you choose to have the same directory as build_dir and as
7076 keep_source_where directory, then your sources will be deleted with
7077 the same fifo mechanism.
7081 A bundle is just a perl module in the namespace Bundle:: that does not
7082 define any functions or methods. It usually only contains documentation.
7084 It starts like a perl module with a package declaration and a $VERSION
7085 variable. After that the pod section looks like any other pod with the
7086 only difference being that I<one special pod section> exists starting with
7091 In this pod section each line obeys the format
7093 Module_Name [Version_String] [- optional text]
7095 The only required part is the first field, the name of a module
7096 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
7097 of the line is optional. The comment part is delimited by a dash just
7098 as in the man page header.
7100 The distribution of a bundle should follow the same convention as
7101 other distributions.
7103 Bundles are treated specially in the CPAN package. If you say 'install
7104 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
7105 the modules in the CONTENTS section of the pod. You can install your
7106 own Bundles locally by placing a conformant Bundle file somewhere into
7107 your @INC path. The autobundle() command which is available in the
7108 shell interface does that for you by including all currently installed
7109 modules in a snapshot bundle file.
7111 =head2 Prerequisites
7113 If you have a local mirror of CPAN and can access all files with
7114 "file:" URLs, then you only need a perl better than perl5.003 to run
7115 this module. Otherwise Net::FTP is strongly recommended. LWP may be
7116 required for non-UNIX systems or if your nearest CPAN site is
7117 associated with a URL that is not C<ftp:>.
7119 If you have neither Net::FTP nor LWP, there is a fallback mechanism
7120 implemented for an external ftp command or for an external lynx
7123 =head2 Finding packages and VERSION
7125 This module presumes that all packages on CPAN
7131 declare their $VERSION variable in an easy to parse manner. This
7132 prerequisite can hardly be relaxed because it consumes far too much
7133 memory to load all packages into the running program just to determine
7134 the $VERSION variable. Currently all programs that are dealing with
7135 version use something like this
7137 perl -MExtUtils::MakeMaker -le \
7138 'print MM->parse_version(shift)' filename
7140 If you are author of a package and wonder if your $VERSION can be
7141 parsed, please try the above method.
7145 come as compressed or gzipped tarfiles or as zip files and contain a
7146 Makefile.PL (well, we try to handle a bit more, but without much
7153 The debugging of this module is a bit complex, because we have
7154 interferences of the software producing the indices on CPAN, of the
7155 mirroring process on CPAN, of packaging, of configuration, of
7156 synchronicity, and of bugs within CPAN.pm.
7158 For code debugging in interactive mode you can try "o debug" which
7159 will list options for debugging the various parts of the code. You
7160 should know that "o debug" has built-in completion support.
7162 For data debugging there is the C<dump> command which takes the same
7163 arguments as make/test/install and outputs the object's Data::Dumper
7166 =head2 Floppy, Zip, Offline Mode
7168 CPAN.pm works nicely without network too. If you maintain machines
7169 that are not networked at all, you should consider working with file:
7170 URLs. Of course, you have to collect your modules somewhere first. So
7171 you might use CPAN.pm to put together all you need on a networked
7172 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
7173 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
7174 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
7175 with this floppy. See also below the paragraph about CD-ROM support.
7177 =head1 CONFIGURATION
7179 When the CPAN module is used for the first time, a configuration
7180 dialog tries to determine a couple of site specific options. The
7181 result of the dialog is stored in a hash reference C< $CPAN::Config >
7182 in a file CPAN/Config.pm.
7184 The default values defined in the CPAN/Config.pm file can be
7185 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
7186 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
7187 added to the search path of the CPAN module before the use() or
7188 require() statements.
7190 The configuration dialog can be started any time later again by
7191 issuing the command C< o conf init > in the CPAN shell.
7193 Currently the following keys in the hash reference $CPAN::Config are
7196 build_cache size of cache for directories to build modules
7197 build_dir locally accessible directory to build modules
7198 index_expire after this many days refetch index files
7199 cache_metadata use serializer to cache metadata
7200 cpan_home local directory reserved for this package
7201 dontload_hash anonymous hash: modules in the keys will not be
7202 loaded by the CPAN::has_inst() routine
7203 gzip location of external program gzip
7204 histfile file to maintain history between sessions
7205 histsize maximum number of lines to keep in histfile
7206 inactivity_timeout breaks interactive Makefile.PLs after this
7207 many seconds inactivity. Set to 0 to never break.
7208 inhibit_startup_message
7209 if true, does not print the startup message
7210 keep_source_where directory in which to keep the source (if we do)
7211 make location of external make program
7212 make_arg arguments that should always be passed to 'make'
7213 make_install_make_command
7214 the make command for running 'make install', for
7216 make_install_arg same as make_arg for 'make install'
7217 makepl_arg arguments passed to 'perl Makefile.PL'
7218 pager location of external program more (or any pager)
7219 prerequisites_policy
7220 what to do if you are missing module prerequisites
7221 ('follow' automatically, 'ask' me, or 'ignore')
7222 proxy_user username for accessing an authenticating proxy
7223 proxy_pass password for accessing an authenticating proxy
7224 scan_cache controls scanning of cache ('atstart' or 'never')
7225 tar location of external program tar
7226 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
7227 (and nonsense for characters outside latin range)
7228 unzip location of external program unzip
7229 urllist arrayref to nearby CPAN sites (or equivalent locations)
7230 wait_list arrayref to a wait server to try (See CPAN::WAIT)
7231 ftp_proxy, } the three usual variables for configuring
7232 http_proxy, } proxy requests. Both as CPAN::Config variables
7233 no_proxy } and as environment variables configurable.
7235 You can set and query each of these options interactively in the cpan
7236 shell with the command set defined within the C<o conf> command:
7240 =item C<o conf E<lt>scalar optionE<gt>>
7242 prints the current value of the I<scalar option>
7244 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
7246 Sets the value of the I<scalar option> to I<value>
7248 =item C<o conf E<lt>list optionE<gt>>
7250 prints the current value of the I<list option> in MakeMaker's
7253 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
7255 shifts or pops the array in the I<list option> variable
7257 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
7259 works like the corresponding perl commands.
7263 =head2 Note on urllist parameter's format
7265 urllist parameters are URLs according to RFC 1738. We do a little
7266 guessing if your URL is not compliant, but if you have problems with
7267 file URLs, please try the correct format. Either:
7269 file://localhost/whatever/ftp/pub/CPAN/
7273 file:///home/ftp/pub/CPAN/
7275 =head2 urllist parameter has CD-ROM support
7277 The C<urllist> parameter of the configuration table contains a list of
7278 URLs that are to be used for downloading. If the list contains any
7279 C<file> URLs, CPAN always tries to get files from there first. This
7280 feature is disabled for index files. So the recommendation for the
7281 owner of a CD-ROM with CPAN contents is: include your local, possibly
7282 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
7284 o conf urllist push file://localhost/CDROM/CPAN
7286 CPAN.pm will then fetch the index files from one of the CPAN sites
7287 that come at the beginning of urllist. It will later check for each
7288 module if there is a local copy of the most recent version.
7290 Another peculiarity of urllist is that the site that we could
7291 successfully fetch the last file from automatically gets a preference
7292 token and is tried as the first site for the next request. So if you
7293 add a new site at runtime it may happen that the previously preferred
7294 site will be tried another time. This means that if you want to disallow
7295 a site for the next transfer, it must be explicitly removed from
7300 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
7301 install foreign, unmasked, unsigned code on your machine. We compare
7302 to a checksum that comes from the net just as the distribution file
7303 itself. If somebody has managed to tamper with the distribution file,
7304 they may have as well tampered with the CHECKSUMS file. Future
7305 development will go towards strong authentication.
7309 Most functions in package CPAN are exported per default. The reason
7310 for this is that the primary use is intended for the cpan shell or for
7313 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
7315 Populating a freshly installed perl with my favorite modules is pretty
7316 easy if you maintain a private bundle definition file. To get a useful
7317 blueprint of a bundle definition file, the command autobundle can be used
7318 on the CPAN shell command line. This command writes a bundle definition
7319 file for all modules that are installed for the currently running perl
7320 interpreter. It's recommended to run this command only once and from then
7321 on maintain the file manually under a private name, say
7322 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
7324 cpan> install Bundle::my_bundle
7326 then answer a few questions and then go out for a coffee.
7328 Maintaining a bundle definition file means keeping track of two
7329 things: dependencies and interactivity. CPAN.pm sometimes fails on
7330 calculating dependencies because not all modules define all MakeMaker
7331 attributes correctly, so a bundle definition file should specify
7332 prerequisites as early as possible. On the other hand, it's a bit
7333 annoying that many distributions need some interactive configuring. So
7334 what I try to accomplish in my private bundle file is to have the
7335 packages that need to be configured early in the file and the gentle
7336 ones later, so I can go out after a few minutes and leave CPAN.pm
7339 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
7341 Thanks to Graham Barr for contributing the following paragraphs about
7342 the interaction between perl, and various firewall configurations. For
7343 further information on firewalls, it is recommended to consult the
7344 documentation that comes with the ncftp program. If you are unable to
7345 go through the firewall with a simple Perl setup, it is very likely
7346 that you can configure ncftp so that it works for your firewall.
7348 =head2 Three basic types of firewalls
7350 Firewalls can be categorized into three basic types.
7356 This is where the firewall machine runs a web server and to access the
7357 outside world you must do it via the web server. If you set environment
7358 variables like http_proxy or ftp_proxy to a values beginning with http://
7359 or in your web browser you have to set proxy information then you know
7360 you are running an http firewall.
7362 To access servers outside these types of firewalls with perl (even for
7363 ftp) you will need to use LWP.
7367 This where the firewall machine runs an ftp server. This kind of
7368 firewall will only let you access ftp servers outside the firewall.
7369 This is usually done by connecting to the firewall with ftp, then
7370 entering a username like "user@outside.host.com"
7372 To access servers outside these type of firewalls with perl you
7373 will need to use Net::FTP.
7375 =item One way visibility
7377 I say one way visibility as these firewalls try to make themselves look
7378 invisible to the users inside the firewall. An FTP data connection is
7379 normally created by sending the remote server your IP address and then
7380 listening for the connection. But the remote server will not be able to
7381 connect to you because of the firewall. So for these types of firewall
7382 FTP connections need to be done in a passive mode.
7384 There are two that I can think off.
7390 If you are using a SOCKS firewall you will need to compile perl and link
7391 it with the SOCKS library, this is what is normally called a 'socksified'
7392 perl. With this executable you will be able to connect to servers outside
7393 the firewall as if it is not there.
7397 This is the firewall implemented in the Linux kernel, it allows you to
7398 hide a complete network behind one IP address. With this firewall no
7399 special compiling is needed as you can access hosts directly.
7401 For accessing ftp servers behind such firewalls you may need to set
7402 the environment variable C<FTP_PASSIVE> to a true value, e.g.
7404 env FTP_PASSIVE=1 perl -MCPAN -eshell
7408 perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
7415 =head2 Configuring lynx or ncftp for going through a firewall
7417 If you can go through your firewall with e.g. lynx, presumably with a
7420 /usr/local/bin/lynx -pscott:tiger
7422 then you would configure CPAN.pm with the command
7424 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
7426 That's all. Similarly for ncftp or ftp, you would configure something
7429 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
7431 Your mileage may vary...
7433 =head1 Cryptographically signed modules
7435 Since release 1.77 CPAN.pm has been able to verify cryptographically
7436 signed module distributions using Module::Signature. The CPAN modules
7437 can be signed by their authors, thus giving more security. The simple
7438 unsigned MD5 checksums that were used before by CPAN protect mainly
7439 against accidental file corruption.
7441 You will need to have Module::Signature installed, which in turn
7442 requires that you have at least one of Crypt::OpenPGP module or the
7443 command-line F<gpg> tool installed.
7445 You will also need to be able to connect over the Internet to the public
7446 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
7454 I installed a new version of module X but CPAN keeps saying,
7455 I have the old version installed
7457 Most probably you B<do> have the old version installed. This can
7458 happen if a module installs itself into a different directory in the
7459 @INC path than it was previously installed. This is not really a
7460 CPAN.pm problem, you would have the same problem when installing the
7461 module manually. The easiest way to prevent this behaviour is to add
7462 the argument C<UNINST=1> to the C<make install> call, and that is why
7463 many people add this argument permanently by configuring
7465 o conf make_install_arg UNINST=1
7469 So why is UNINST=1 not the default?
7471 Because there are people who have their precise expectations about who
7472 may install where in the @INC path and who uses which @INC array. In
7473 fine tuned environments C<UNINST=1> can cause damage.
7477 I want to clean up my mess, and install a new perl along with
7478 all modules I have. How do I go about it?
7480 Run the autobundle command for your old perl and optionally rename the
7481 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7482 with the Configure option prefix, e.g.
7484 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7486 Install the bundle file you produced in the first step with something like
7488 cpan> install Bundle::mybundle
7494 When I install bundles or multiple modules with one command
7495 there is too much output to keep track of.
7497 You may want to configure something like
7499 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7500 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7502 so that STDOUT is captured in a file for later inspection.
7507 I am not root, how can I install a module in a personal directory?
7509 First of all, you will want to use your own configuration, not the one
7510 that your root user installed. The following command sequence is a
7513 % mkdir -p $HOME/.cpan/CPAN
7514 % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
7516 [...answer all questions...]
7518 You will most probably like something like this:
7520 o conf makepl_arg "LIB=~/myperl/lib \
7521 INSTALLMAN1DIR=~/myperl/man/man1 \
7522 INSTALLMAN3DIR=~/myperl/man/man3"
7524 You can make this setting permanent like all C<o conf> settings with
7527 You will have to add ~/myperl/man to the MANPATH environment variable
7528 and also tell your perl programs to look into ~/myperl/lib, e.g. by
7531 use lib "$ENV{HOME}/myperl/lib";
7533 or setting the PERL5LIB environment variable.
7535 Another thing you should bear in mind is that the UNINST parameter
7536 should never be set if you are not root.
7540 How to get a package, unwrap it, and make a change before building it?
7542 look Sybase::Sybperl
7546 I installed a Bundle and had a couple of fails. When I
7547 retried, everything resolved nicely. Can this be fixed to work
7550 The reason for this is that CPAN does not know the dependencies of all
7551 modules when it starts out. To decide about the additional items to
7552 install, it just uses data found in the generated Makefile. An
7553 undetected missing piece breaks the process. But it may well be that
7554 your Bundle installs some prerequisite later than some depending item
7555 and thus your second try is able to resolve everything. Please note,
7556 CPAN.pm does not know the dependency tree in advance and cannot sort
7557 the queue of things to install in a topologically correct order. It
7558 resolves perfectly well IFF all modules declare the prerequisites
7559 correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7560 fail and you need to install often, it is recommended to sort the Bundle
7561 definition file manually. It is planned to improve the metadata
7562 situation for dependencies on CPAN in general, but this will still
7567 In our intranet we have many modules for internal use. How
7568 can I integrate these modules with CPAN.pm but without uploading
7569 the modules to CPAN?
7571 Have a look at the CPAN::Site module.
7575 When I run CPAN's shell, I get error msg about line 1 to 4,
7576 setting meta input/output via the /etc/inputrc file.
7578 Some versions of readline are picky about capitalization in the
7579 /etc/inputrc file and specifically RedHat 6.2 comes with a
7580 /etc/inputrc that contains the word C<on> in lowercase. Change the
7581 occurrences of C<on> to C<On> and the bug should disappear.
7585 Some authors have strange characters in their names.
7587 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7588 expecting ISO-8859-1 charset, a converter can be activated by setting
7589 term_is_latin to a true value in your config file. One way of doing so
7592 cpan> ! $CPAN::Config->{term_is_latin}=1
7594 Extended support for converters will be made available as soon as perl
7595 becomes stable with regard to charset issues.
7599 When an install fails for some reason and then I correct the error
7600 condition and retry, CPAN.pm refuses to install the module, saying
7601 C<Already tried without success>.
7603 Use the force pragma like so
7605 force install Foo::Bar
7607 This does a bit more than really needed because it untars the
7608 distribution again and runs make and test and only then install.
7614 and then 'make install' directly in the subshell.
7616 Or you leave the CPAN shell and start it again.
7618 For the really curious, by accessing internals directly, you I<could>
7620 ! delete CPAN::Shell->expand("Distribution", \
7621 CPAN::Shell->expand("Module","Foo::Bar") \
7622 ->{RO}{CPAN_FILE})->{install}
7624 but this is neither guaranteed to work in the future nor is it a
7631 We should give coverage for B<all> of the CPAN and not just the PAUSE
7632 part, right? In this discussion CPAN and PAUSE have become equal --
7633 but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7634 PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7636 Future development should be directed towards a better integration of
7639 If a Makefile.PL requires special customization of libraries, prompts
7640 the user for special input, etc. then you may find CPAN is not able to
7641 build the distribution. In that case, you should attempt the
7642 traditional method of building a Perl module package from a shell.
7646 Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7650 Kawai,Takanori provides a Japanese translation of this manpage at
7651 http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7655 perl(1), CPAN::Nox(3)