1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2package CPAN;
3$VERSION = '1.76_02';
4$VERSION = eval $VERSION;
5# $Id: CPAN.pm,v 1.7 2006/03/28 19:23:05 millert Exp $
6
7# only used during development:
8$Revision = "";
9# $Revision = "[".substr(q$Revision: 1.7 $, 10)."]";
10
11use Carp ();
12use Config ();
13use Cwd ();
14use DirHandle;
15use Exporter ();
16use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
17use File::Basename ();
18use File::Copy ();
19use File::Find;
20use File::Path ();
21use FileHandle ();
22use Safe ();
23use Text::ParseWords ();
24use Text::Wrap;
25use File::Spec;
26use Sys::Hostname;
27no lib "."; # we need to run chdir all over and we would get at wrong
28            # libraries there
29
30require Mac::BuildTools if $^O eq 'MacOS';
31
32END { $End++; &cleanup; }
33
34%CPAN::DEBUG = qw[
35		  CPAN              1
36		  Index             2
37		  InfoObj           4
38		  Author            8
39		  Distribution     16
40		  Bundle           32
41		  Module           64
42		  CacheMgr        128
43		  Complete        256
44		  FTP             512
45		  Shell          1024
46		  Eval           2048
47		  Config         4096
48		  Tarzip         8192
49		  Version       16384
50		  Queue         32768
51];
52
53$CPAN::DEBUG ||= 0;
54$CPAN::Signal ||= 0;
55$CPAN::Frontend ||= "CPAN::Shell";
56$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
57
58package CPAN;
59use strict qw(vars);
60
61use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
62            $Revision $Signal $End $Suppress_readline $Frontend
63            $Defaultsite $Have_warned);
64
65@CPAN::ISA = qw(CPAN::Debug Exporter);
66
67@EXPORT = qw(
68	     autobundle bundle expand force get cvs_import
69	     install make readme recompile shell test clean
70	    );
71
72#-> sub CPAN::AUTOLOAD ;
73sub AUTOLOAD {
74    my($l) = $AUTOLOAD;
75    $l =~ s/.*:://;
76    my(%EXPORT);
77    @EXPORT{@EXPORT} = '';
78    CPAN::Config->load unless $CPAN::Config_loaded++;
79    if (exists $EXPORT{$l}){
80	CPAN::Shell->$l(@_);
81    } else {
82	$CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
83				qq{Type ? for help.
84});
85    }
86}
87
88#-> sub CPAN::shell ;
89sub shell {
90    my($self) = @_;
91    $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
92    CPAN::Config->load unless $CPAN::Config_loaded++;
93
94    my $oprompt = shift || "cpan> ";
95    my $prompt = $oprompt;
96    my $commandline = shift || "";
97
98    local($^W) = 1;
99    unless ($Suppress_readline) {
100	require Term::ReadLine;
101        if (! $term
102            or
103            $term->ReadLine eq "Term::ReadLine::Stub"
104           ) {
105            $term = Term::ReadLine->new('CPAN Monitor');
106        }
107	if ($term->ReadLine eq "Term::ReadLine::Gnu") {
108	    my $attribs = $term->Attribs;
109	     $attribs->{attempted_completion_function} = sub {
110		 &CPAN::Complete::gnu_cpl;
111	     }
112	} else {
113	    $readline::rl_completion_function =
114		$readline::rl_completion_function = 'CPAN::Complete::cpl';
115	}
116        if (my $histfile = $CPAN::Config->{'histfile'}) {{
117            unless ($term->can("AddHistory")) {
118                $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
119                last;
120            }
121            my($fh) = FileHandle->new;
122            open $fh, "<$histfile" or last;
123            local $/ = "\n";
124            while (<$fh>) {
125                chomp;
126                $term->AddHistory($_);
127            }
128            close $fh;
129        }}
130	# $term->OUT is autoflushed anyway
131	my $odef = select STDERR;
132	$| = 1;
133	select STDOUT;
134	$| = 1;
135	select $odef;
136    }
137
138    # no strict; # I do not recall why no strict was here (2000-09-03)
139    $META->checklock();
140    my $cwd = CPAN::anycwd();
141    my $try_detect_readline;
142    $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
143    my $rl_avail = $Suppress_readline ? "suppressed" :
144	($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
145	    "available (try 'install Bundle::CPAN')";
146
147    $CPAN::Frontend->myprint(
148			     sprintf qq{
149cpan shell -- CPAN exploration and modules installation (v%s%s)
150ReadLine support %s
151
152},
153                             $CPAN::VERSION,
154                             $CPAN::Revision,
155                             $rl_avail
156                            )
157        unless $CPAN::Config->{'inhibit_startup_message'} ;
158    my($continuation) = "";
159  SHELLCOMMAND: while () {
160	if ($Suppress_readline) {
161	    print $prompt;
162	    last SHELLCOMMAND unless defined ($_ = <> );
163	    chomp;
164	} else {
165	    last SHELLCOMMAND unless
166                defined ($_ = $term->readline($prompt, $commandline));
167	}
168	$_ = "$continuation$_" if $continuation;
169	s/^\s+//;
170	next SHELLCOMMAND if /^$/;
171	$_ = 'h' if /^\s*\?/;
172	if (/^(?:q(?:uit)?|bye|exit)$/i) {
173	    last SHELLCOMMAND;
174	} elsif (s/\\$//s) {
175	    chomp;
176	    $continuation = $_;
177	    $prompt = "    > ";
178	} elsif (/^\!/) {
179	    s/^\!//;
180	    my($eval) = $_;
181	    package CPAN::Eval;
182	    use vars qw($import_done);
183	    CPAN->import(':DEFAULT') unless $import_done++;
184	    CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
185	    eval($eval);
186	    warn $@ if $@;
187	    $continuation = "";
188	    $prompt = $oprompt;
189	} elsif (/./) {
190	    my(@line);
191	    if ($] < 5.00322) { # parsewords had a bug until recently
192		@line = split;
193	    } else {
194		eval { @line = Text::ParseWords::shellwords($_) };
195		warn($@), next SHELLCOMMAND if $@;
196                warn("Text::Parsewords could not parse the line [$_]"),
197                    next SHELLCOMMAND unless @line;
198	    }
199	    $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
200	    my $command = shift @line;
201	    eval { CPAN::Shell->$command(@line) };
202	    warn $@ if $@;
203	    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
204	    $CPAN::Frontend->myprint("\n");
205	    $continuation = "";
206	    $prompt = $oprompt;
207	}
208    } continue {
209      $commandline = ""; # I do want to be able to pass a default to
210                         # shell, but on the second command I see no
211                         # use in that
212      $Signal=0;
213      CPAN::Queue->nullify_queue;
214      if ($try_detect_readline) {
215	if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
216	    ||
217	    $CPAN::META->has_inst("Term::ReadLine::Perl")
218	   ) {
219	    delete $INC{"Term/ReadLine.pm"};
220	    my $redef = 0;
221	    local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
222	    require Term::ReadLine;
223	    $CPAN::Frontend->myprint("\n$redef subroutines in ".
224				     "Term::ReadLine redefined\n");
225            @_ = ($oprompt,"");
226	    goto &shell;
227	}
228      }
229    }
230    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
231}
232
233package CPAN::CacheMgr;
234@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
235use File::Find;
236
237package CPAN::Config;
238use vars qw(%can $dot_cpan);
239
240%can = (
241  'commit' => "Commit changes to disk",
242  'defaults' => "Reload defaults from disk",
243  'init'   => "Interactive setting of all options",
244);
245
246package CPAN::FTP;
247use vars qw($Ua $Thesite $Themethod);
248@CPAN::FTP::ISA = qw(CPAN::Debug);
249
250package CPAN::LWP::UserAgent;
251use vars qw(@ISA $USER $PASSWD $SETUPDONE);
252# we delay requiring LWP::UserAgent and setting up inheritence until we need it
253
254package CPAN::Complete;
255@CPAN::Complete::ISA = qw(CPAN::Debug);
256@CPAN::Complete::COMMANDS = sort qw(
257		       ! a b d h i m o q r u autobundle clean dump
258		       make test install force readme reload look
259                       cvs_import ls
260) unless @CPAN::Complete::COMMANDS;
261
262package CPAN::Index;
263use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
264@CPAN::Index::ISA = qw(CPAN::Debug);
265$LAST_TIME ||= 0;
266$DATE_OF_03 ||= 0;
267# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
268sub PROTOCOL { 2.0 }
269
270package CPAN::InfoObj;
271@CPAN::InfoObj::ISA = qw(CPAN::Debug);
272
273package CPAN::Author;
274@CPAN::Author::ISA = qw(CPAN::InfoObj);
275
276package CPAN::Distribution;
277@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
278
279package CPAN::Bundle;
280@CPAN::Bundle::ISA = qw(CPAN::Module);
281
282package CPAN::Module;
283@CPAN::Module::ISA = qw(CPAN::InfoObj);
284
285package CPAN::Exception::RecursiveDependency;
286use overload '""' => "as_string";
287
288sub new {
289    my($class) = shift;
290    my($deps) = shift;
291    my @deps;
292    my %seen;
293    for my $dep (@$deps) {
294        push @deps, $dep;
295        last if $seen{$dep}++;
296    }
297    bless { deps => \@deps }, $class;
298}
299
300sub as_string {
301    my($self) = shift;
302    "\nRecursive dependency detected:\n    " .
303        join("\n => ", @{$self->{deps}}) .
304            ".\nCannot continue.\n";
305}
306
307package CPAN::Shell;
308use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
309@CPAN::Shell::ISA = qw(CPAN::Debug);
310$COLOR_REGISTERED ||= 0;
311$PRINT_ORNAMENTING ||= 0;
312
313#-> sub CPAN::Shell::AUTOLOAD ;
314sub AUTOLOAD {
315    my($autoload) = $AUTOLOAD;
316    my $class = shift(@_);
317    # warn "autoload[$autoload] class[$class]";
318    $autoload =~ s/.*:://;
319    if ($autoload =~ /^w/) {
320	if ($CPAN::META->has_inst('CPAN::WAIT')) {
321	    CPAN::WAIT->$autoload(@_);
322	} else {
323	    $CPAN::Frontend->mywarn(qq{
324Commands starting with "w" require CPAN::WAIT to be installed.
325Please consider installing CPAN::WAIT to use the fulltext index.
326For this you just need to type
327    install CPAN::WAIT
328});
329	}
330    } else {
331	$CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
332				qq{Type ? for help.
333});
334    }
335}
336
337package CPAN::Tarzip;
338use vars qw($AUTOLOAD @ISA $BUGHUNTING);
339@CPAN::Tarzip::ISA = qw(CPAN::Debug);
340$BUGHUNTING = 0; # released code must have turned off
341
342package CPAN::Queue;
343
344# One use of the queue is to determine if we should or shouldn't
345# announce the availability of a new CPAN module
346
347# Now we try to use it for dependency tracking. For that to happen
348# we need to draw a dependency tree and do the leaves first. This can
349# easily be reached by running CPAN.pm recursively, but we don't want
350# to waste memory and run into deep recursion. So what we can do is
351# this:
352
353# CPAN::Queue is the package where the queue is maintained. Dependencies
354# often have high priority and must be brought to the head of the queue,
355# possibly by jumping the queue if they are already there. My first code
356# attempt tried to be extremely correct. Whenever a module needed
357# immediate treatment, I either unshifted it to the front of the queue,
358# or, if it was already in the queue, I spliced and let it bypass the
359# others. This became a too correct model that made it impossible to put
360# an item more than once into the queue. Why would you need that? Well,
361# you need temporary duplicates as the manager of the queue is a loop
362# that
363#
364#  (1) looks at the first item in the queue without shifting it off
365#
366#  (2) cares for the item
367#
368#  (3) removes the item from the queue, *even if its agenda failed and
369#      even if the item isn't the first in the queue anymore* (that way
370#      protecting against never ending queues)
371#
372# So if an item has prerequisites, the installation fails now, but we
373# want to retry later. That's easy if we have it twice in the queue.
374#
375# I also expect insane dependency situations where an item gets more
376# than two lives in the queue. Simplest example is triggered by 'install
377# Foo Foo Foo'. People make this kind of mistakes and I don't want to
378# get in the way. I wanted the queue manager to be a dumb servant, not
379# one that knows everything.
380#
381# Who would I tell in this model that the user wants to be asked before
382# processing? I can't attach that information to the module object,
383# because not modules are installed but distributions. So I'd have to
384# tell the distribution object that it should ask the user before
385# processing. Where would the question be triggered then? Most probably
386# in CPAN::Distribution::rematein.
387# Hope that makes sense, my head is a bit off:-) -- AK
388
389use vars qw{ @All };
390
391# CPAN::Queue::new ;
392sub new {
393  my($class,$s) = @_;
394  my $self = bless { qmod => $s }, $class;
395  push @All, $self;
396  return $self;
397}
398
399# CPAN::Queue::first ;
400sub first {
401  my $obj = $All[0];
402  $obj->{qmod};
403}
404
405# CPAN::Queue::delete_first ;
406sub delete_first {
407  my($class,$what) = @_;
408  my $i;
409  for my $i (0..$#All) {
410    if (  $All[$i]->{qmod} eq $what ) {
411      splice @All, $i, 1;
412      return;
413    }
414  }
415}
416
417# CPAN::Queue::jumpqueue ;
418sub jumpqueue {
419    my $class = shift;
420    my @what = @_;
421    CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
422                        join(",",map {$_->{qmod}} @All),
423                        join(",",@what)
424                       )) if $CPAN::DEBUG;
425  WHAT: for my $what (reverse @what) {
426        my $jumped = 0;
427        for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
428            CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
429            if ($All[$i]->{qmod} eq $what){
430                $jumped++;
431                if ($jumped > 100) { # one's OK if e.g. just
432                                     # processing now; more are OK if
433                                     # user typed it several times
434                    $CPAN::Frontend->mywarn(
435qq{Object [$what] queued more than 100 times, ignoring}
436				 );
437                    next WHAT;
438                }
439            }
440        }
441        my $obj = bless { qmod => $what }, $class;
442        unshift @All, $obj;
443    }
444    CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
445                        join(",",map {$_->{qmod}} @All),
446                        join(",",@what)
447                       )) if $CPAN::DEBUG;
448}
449
450# CPAN::Queue::exists ;
451sub exists {
452  my($self,$what) = @_;
453  my @all = map { $_->{qmod} } @All;
454  my $exists = grep { $_->{qmod} eq $what } @All;
455  # warn "in exists what[$what] all[@all] exists[$exists]";
456  $exists;
457}
458
459# CPAN::Queue::delete ;
460sub delete {
461  my($self,$mod) = @_;
462  @All = grep { $_->{qmod} ne $mod } @All;
463}
464
465# CPAN::Queue::nullify_queue ;
466sub nullify_queue {
467  @All = ();
468}
469
470
471
472package CPAN;
473
474$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
475
476# from here on only subs.
477################################################################################
478
479#-> sub CPAN::all_objects ;
480sub all_objects {
481    my($mgr,$class) = @_;
482    CPAN::Config->load unless $CPAN::Config_loaded++;
483    CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
484    CPAN::Index->reload;
485    values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
486}
487*all = \&all_objects;
488
489# Called by shell, not in batch mode. In batch mode I see no risk in
490# having many processes updating something as installations are
491# continually checked at runtime. In shell mode I suspect it is
492# unintentional to open more than one shell at a time
493
494#-> sub CPAN::checklock ;
495sub checklock {
496    my($self) = @_;
497    my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
498    if (-f $lockfile && -M _ > 0) {
499	my $fh = FileHandle->new($lockfile) or
500            $CPAN::Frontend->mydie("Could not open $lockfile: $!");
501	my $otherpid  = <$fh>;
502	my $otherhost = <$fh>;
503	$fh->close;
504	if (defined $otherpid && $otherpid) {
505	    chomp $otherpid;
506        }
507	if (defined $otherhost && $otherhost) {
508	    chomp $otherhost;
509	}
510	my $thishost  = hostname();
511	if (defined $otherhost && defined $thishost &&
512	    $otherhost ne '' && $thishost ne '' &&
513	    $otherhost ne $thishost) {
514            $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
515                                           "reports other host $otherhost and other process $otherpid.\n".
516                                           "Cannot proceed.\n"));
517	}
518	elsif (defined $otherpid && $otherpid) {
519	    return if $$ == $otherpid; # should never happen
520	    $CPAN::Frontend->mywarn(
521				    qq{
522There seems to be running another CPAN process (pid $otherpid).  Contacting...
523});
524	    if (kill 0, $otherpid) {
525		$CPAN::Frontend->mydie(qq{Other job is running.
526You may want to kill it and delete the lockfile, maybe. On UNIX try:
527    kill $otherpid
528    rm $lockfile
529});
530	    } elsif (-w $lockfile) {
531		my($ans) =
532		    ExtUtils::MakeMaker::prompt
533			(qq{Other job not responding. Shall I overwrite }.
534			 qq{the lockfile? (Y/N)},"y");
535		$CPAN::Frontend->myexit("Ok, bye\n")
536		    unless $ans =~ /^y/i;
537	    } else {
538		Carp::croak(
539			    qq{Lockfile $lockfile not writeable by you. }.
540			    qq{Cannot proceed.\n}.
541			    qq{    On UNIX try:\n}.
542			    qq{    rm $lockfile\n}.
543			    qq{  and then rerun us.\n}
544			   );
545	    }
546	} else {
547            $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
548                                           "reports other process with ID ".
549                                           "$otherpid. Cannot proceed.\n"));
550        }
551    }
552    my $dotcpan = $CPAN::Config->{cpan_home};
553    eval { File::Path::mkpath($dotcpan);};
554    if ($@) {
555      # A special case at least for Jarkko.
556      my $firsterror = $@;
557      my $seconderror;
558      my $symlinkcpan;
559      if (-l $dotcpan) {
560	$symlinkcpan = readlink $dotcpan;
561	die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
562	eval { File::Path::mkpath($symlinkcpan); };
563	if ($@) {
564	  $seconderror = $@;
565	} else {
566	  $CPAN::Frontend->mywarn(qq{
567Working directory $symlinkcpan created.
568});
569	}
570      }
571      unless (-d $dotcpan) {
572	my $diemess = qq{
573Your configuration suggests "$dotcpan" as your
574CPAN.pm working directory. I could not create this directory due
575to this error: $firsterror\n};
576	$diemess .= qq{
577As "$dotcpan" is a symlink to "$symlinkcpan",
578I tried to create that, but I failed with this error: $seconderror
579} if $seconderror;
580	$diemess .= qq{
581Please make sure the directory exists and is writable.
582};
583	$CPAN::Frontend->mydie($diemess);
584      }
585    }
586    my $fh;
587    unless ($fh = FileHandle->new(">$lockfile")) {
588	if ($! =~ /Permission/) {
589	    my $incc = $INC{'CPAN/Config.pm'};
590	    my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
591	    $CPAN::Frontend->myprint(qq{
592
593Your configuration suggests that CPAN.pm should use a working
594directory of
595    $CPAN::Config->{cpan_home}
596Unfortunately we could not create the lock file
597    $lockfile
598due to permission problems.
599
600Please make sure that the configuration variable
601    \$CPAN::Config->{cpan_home}
602points to a directory where you can write a .lock file. You can set
603this variable in either
604    $incc
605or
606    $myincc
607
608});
609	}
610	$CPAN::Frontend->mydie("Could not open >$lockfile: $!");
611    }
612    $fh->print($$, "\n");
613    $fh->print(hostname(), "\n");
614    $self->{LOCK} = $lockfile;
615    $fh->close;
616    $SIG{TERM} = sub {
617      &cleanup;
618      $CPAN::Frontend->mydie("Got SIGTERM, leaving");
619    };
620    $SIG{INT} = sub {
621      # no blocks!!!
622      &cleanup if $Signal;
623      $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
624      print "Caught SIGINT\n";
625      $Signal++;
626    };
627
628#       From: Larry Wall <larry@wall.org>
629#       Subject: Re: deprecating SIGDIE
630#       To: perl5-porters@perl.org
631#       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
632#
633#       The original intent of __DIE__ was only to allow you to substitute one
634#       kind of death for another on an application-wide basis without respect
635#       to whether you were in an eval or not.  As a global backstop, it should
636#       not be used any more lightly (or any more heavily :-) than class
637#       UNIVERSAL.  Any attempt to build a general exception model on it should
638#       be politely squashed.  Any bug that causes every eval {} to have to be
639#       modified should be not so politely squashed.
640#
641#       Those are my current opinions.  It is also my optinion that polite
642#       arguments degenerate to personal arguments far too frequently, and that
643#       when they do, it's because both people wanted it to, or at least didn't
644#       sufficiently want it not to.
645#
646#       Larry
647
648    # global backstop to cleanup if we should really die
649    $SIG{__DIE__} = \&cleanup;
650    $self->debug("Signal handler set.") if $CPAN::DEBUG;
651}
652
653#-> sub CPAN::DESTROY ;
654sub DESTROY {
655    &cleanup; # need an eval?
656}
657
658#-> sub CPAN::anycwd ;
659sub anycwd () {
660    my $getcwd;
661    $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
662    CPAN->$getcwd();
663}
664
665#-> sub CPAN::cwd ;
666sub cwd {Cwd::cwd();}
667
668#-> sub CPAN::getcwd ;
669sub getcwd {Cwd::getcwd();}
670
671#-> sub CPAN::exists ;
672sub exists {
673    my($mgr,$class,$id) = @_;
674    CPAN::Config->load unless $CPAN::Config_loaded++;
675    CPAN::Index->reload;
676    ### Carp::croak "exists called without class argument" unless $class;
677    $id ||= "";
678    exists $META->{readonly}{$class}{$id} or
679        exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
680}
681
682#-> sub CPAN::delete ;
683sub delete {
684  my($mgr,$class,$id) = @_;
685  delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
686  delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
687}
688
689#-> sub CPAN::has_usable
690# has_inst is sometimes too optimistic, we should replace it with this
691# has_usable whenever a case is given
692sub has_usable {
693    my($self,$mod,$message) = @_;
694    return 1 if $HAS_USABLE->{$mod};
695    my $has_inst = $self->has_inst($mod,$message);
696    return unless $has_inst;
697    my $usable;
698    $usable = {
699               LWP => [ # we frequently had "Can't locate object
700                        # method "new" via package "LWP::UserAgent" at
701                        # (eval 69) line 2006
702                       sub {require LWP},
703                       sub {require LWP::UserAgent},
704                       sub {require HTTP::Request},
705                       sub {require URI::URL},
706                      ],
707               Net::FTP => [
708                            sub {require Net::FTP},
709                            sub {require Net::Config},
710                           ]
711              };
712    if ($usable->{$mod}) {
713      for my $c (0..$#{$usable->{$mod}}) {
714        my $code = $usable->{$mod}[$c];
715        my $ret = eval { &$code() };
716        if ($@) {
717          warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
718          return;
719        }
720      }
721    }
722    return $HAS_USABLE->{$mod} = 1;
723}
724
725#-> sub CPAN::has_inst
726sub has_inst {
727    my($self,$mod,$message) = @_;
728    Carp::croak("CPAN->has_inst() called without an argument")
729	unless defined $mod;
730    if (defined $message && $message eq "no"
731        ||
732        exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
733        ||
734        exists $CPAN::Config->{dontload_hash}{$mod}
735       ) {
736      $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
737      return 0;
738    }
739    my $file = $mod;
740    my $obj;
741    $file =~ s|::|/|g;
742    $file .= ".pm";
743    if ($INC{$file}) {
744	# checking %INC is wrong, because $INC{LWP} may be true
745	# although $INC{"URI/URL.pm"} may have failed. But as
746	# I really want to say "bla loaded OK", I have to somehow
747	# cache results.
748	### warn "$file in %INC"; #debug
749	return 1;
750    } elsif (eval { require $file }) {
751	# eval is good: if we haven't yet read the database it's
752	# perfect and if we have installed the module in the meantime,
753	# it tries again. The second require is only a NOOP returning
754	# 1 if we had success, otherwise it's retrying
755
756	$CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
757	if ($mod eq "CPAN::WAIT") {
758	    push @CPAN::Shell::ISA, CPAN::WAIT;
759	}
760	return 1;
761    } elsif ($mod eq "Net::FTP") {
762	$CPAN::Frontend->mywarn(qq{
763  Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
764  if you just type
765      install Bundle::libnet
766
767}) unless $Have_warned->{"Net::FTP"}++;
768	sleep 3;
769    } elsif ($mod eq "Digest::MD5"){
770	$CPAN::Frontend->myprint(qq{
771  CPAN: MD5 security checks disabled because Digest::MD5 not installed.
772  Please consider installing the Digest::MD5 module.
773
774});
775	sleep 2;
776    } else {
777	delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
778    }
779    return 0;
780}
781
782#-> sub CPAN::instance ;
783sub instance {
784    my($mgr,$class,$id) = @_;
785    CPAN::Index->reload;
786    $id ||= "";
787    # unsafe meta access, ok?
788    return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
789    $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
790}
791
792#-> sub CPAN::new ;
793sub new {
794    bless {}, shift;
795}
796
797#-> sub CPAN::cleanup ;
798sub cleanup {
799  # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
800  local $SIG{__DIE__} = '';
801  my($message) = @_;
802  my $i = 0;
803  my $ineval = 0;
804  my($subroutine);
805  while ((undef,undef,undef,$subroutine) = caller(++$i)) {
806      $ineval = 1, last if
807	  $subroutine eq '(eval)';
808  }
809  return if $ineval && !$End;
810  return unless defined $META->{LOCK};
811  return unless -f $META->{LOCK};
812  $META->savehist;
813  unlink $META->{LOCK};
814  # require Carp;
815  # Carp::cluck("DEBUGGING");
816  $CPAN::Frontend->mywarn("Lockfile removed.\n");
817}
818
819#-> sub CPAN::savehist
820sub savehist {
821    my($self) = @_;
822    my($histfile,$histsize);
823    unless ($histfile = $CPAN::Config->{'histfile'}){
824        $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
825        return;
826    }
827    $histsize = $CPAN::Config->{'histsize'} || 100;
828    if ($CPAN::term){
829        unless ($CPAN::term->can("GetHistory")) {
830            $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
831            return;
832        }
833    } else {
834        return;
835    }
836    my @h = $CPAN::term->GetHistory;
837    splice @h, 0, @h-$histsize if @h>$histsize;
838    my($fh) = FileHandle->new;
839    open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
840    local $\ = local $, = "\n";
841    print $fh @h;
842    close $fh;
843}
844
845sub is_tested {
846    my($self,$what) = @_;
847    $self->{is_tested}{$what} = 1;
848}
849
850sub is_installed {
851    my($self,$what) = @_;
852    delete $self->{is_tested}{$what};
853}
854
855sub set_perl5lib {
856    my($self) = @_;
857    $self->{is_tested} ||= {};
858    return unless %{$self->{is_tested}};
859    my $env = $ENV{PERL5LIB};
860    $env = $ENV{PERLLIB} unless defined $env;
861    my @env;
862    push @env, $env if defined $env and length $env;
863    my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
864    $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
865    $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
866}
867
868package CPAN::CacheMgr;
869
870#-> sub CPAN::CacheMgr::as_string ;
871sub as_string {
872    eval { require Data::Dumper };
873    if ($@) {
874	return shift->SUPER::as_string;
875    } else {
876	return Data::Dumper::Dumper(shift);
877    }
878}
879
880#-> sub CPAN::CacheMgr::cachesize ;
881sub cachesize {
882    shift->{DU};
883}
884
885#-> sub CPAN::CacheMgr::tidyup ;
886sub tidyup {
887  my($self) = @_;
888  return unless -d $self->{ID};
889  while ($self->{DU} > $self->{'MAX'} ) {
890    my($toremove) = shift @{$self->{FIFO}};
891    $CPAN::Frontend->myprint(sprintf(
892				     "Deleting from cache".
893				     ": $toremove (%.1f>%.1f MB)\n",
894				     $self->{DU}, $self->{'MAX'})
895			    );
896    return if $CPAN::Signal;
897    $self->force_clean_cache($toremove);
898    return if $CPAN::Signal;
899  }
900}
901
902#-> sub CPAN::CacheMgr::dir ;
903sub dir {
904    shift->{ID};
905}
906
907#-> sub CPAN::CacheMgr::entries ;
908sub entries {
909    my($self,$dir) = @_;
910    return unless defined $dir;
911    $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
912    $dir ||= $self->{ID};
913    my($cwd) = CPAN::anycwd();
914    chdir $dir or Carp::croak("Can't chdir to $dir: $!");
915    my $dh = DirHandle->new(File::Spec->curdir)
916        or Carp::croak("Couldn't opendir $dir: $!");
917    my(@entries);
918    for ($dh->read) {
919	next if $_ eq "." || $_ eq "..";
920	if (-f $_) {
921	    push @entries, File::Spec->catfile($dir,$_);
922	} elsif (-d _) {
923	    push @entries, File::Spec->catdir($dir,$_);
924	} else {
925	    $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
926	}
927    }
928    chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
929    sort { -M $b <=> -M $a} @entries;
930}
931
932#-> sub CPAN::CacheMgr::disk_usage ;
933sub disk_usage {
934    my($self,$dir) = @_;
935    return if exists $self->{SIZE}{$dir};
936    return if $CPAN::Signal;
937    my($Du) = 0;
938    find(
939	 sub {
940	   $File::Find::prune++ if $CPAN::Signal;
941	   return if -l $_;
942	   if ($^O eq 'MacOS') {
943	     require Mac::Files;
944	     my $cat  = Mac::Files::FSpGetCatInfo($_);
945	     $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
946	   } else {
947	     $Du += (-s _);
948	   }
949	 },
950	 $dir
951	);
952    return if $CPAN::Signal;
953    $self->{SIZE}{$dir} = $Du/1024/1024;
954    push @{$self->{FIFO}}, $dir;
955    $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
956    $self->{DU} += $Du/1024/1024;
957    $self->{DU};
958}
959
960#-> sub CPAN::CacheMgr::force_clean_cache ;
961sub force_clean_cache {
962    my($self,$dir) = @_;
963    return unless -e $dir;
964    $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
965	if $CPAN::DEBUG;
966    File::Path::rmtree($dir);
967    $self->{DU} -= $self->{SIZE}{$dir};
968    delete $self->{SIZE}{$dir};
969}
970
971#-> sub CPAN::CacheMgr::new ;
972sub new {
973    my $class = shift;
974    my $time = time;
975    my($debug,$t2);
976    $debug = "";
977    my $self = {
978		ID => $CPAN::Config->{'build_dir'},
979		MAX => $CPAN::Config->{'build_cache'},
980		SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
981		DU => 0
982	       };
983    File::Path::mkpath($self->{ID});
984    my $dh = DirHandle->new($self->{ID});
985    bless $self, $class;
986    $self->scan_cache;
987    $t2 = time;
988    $debug .= "timing of CacheMgr->new: ".($t2 - $time);
989    $time = $t2;
990    CPAN->debug($debug) if $CPAN::DEBUG;
991    $self;
992}
993
994#-> sub CPAN::CacheMgr::scan_cache ;
995sub scan_cache {
996    my $self = shift;
997    return if $self->{SCAN} eq 'never';
998    $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
999	unless $self->{SCAN} eq 'atstart';
1000    $CPAN::Frontend->myprint(
1001			     sprintf("Scanning cache %s for sizes\n",
1002				     $self->{ID}));
1003    my $e;
1004    for $e ($self->entries($self->{ID})) {
1005	next if $e eq ".." || $e eq ".";
1006	$self->disk_usage($e);
1007	return if $CPAN::Signal;
1008    }
1009    $self->tidyup;
1010}
1011
1012package CPAN::Debug;
1013
1014#-> sub CPAN::Debug::debug ;
1015sub debug {
1016    my($self,$arg) = @_;
1017    my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
1018                                               # Complete, caller(1)
1019                                               # eg readline
1020    ($caller) = caller(0);
1021    $caller =~ s/.*:://;
1022    $arg = "" unless defined $arg;
1023    my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
1024    if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
1025	if ($arg and ref $arg) {
1026	    eval { require Data::Dumper };
1027	    if ($@) {
1028		$CPAN::Frontend->myprint($arg->as_string);
1029	    } else {
1030		$CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
1031	    }
1032	} else {
1033	    $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
1034	}
1035    }
1036}
1037
1038package CPAN::Config;
1039
1040#-> sub CPAN::Config::edit ;
1041# returns true on successful action
1042sub edit {
1043    my($self,@args) = @_;
1044    return unless @args;
1045    CPAN->debug("self[$self]args[".join(" | ",@args)."]");
1046    my($o,$str,$func,$args,$key_exists);
1047    $o = shift @args;
1048    if($can{$o}) {
1049	$self->$o(@args);
1050	return 1;
1051    } else {
1052        CPAN->debug("o[$o]") if $CPAN::DEBUG;
1053	if ($o =~ /list$/) {
1054	    $func = shift @args;
1055	    $func ||= "";
1056            CPAN->debug("func[$func]") if $CPAN::DEBUG;
1057            my $changed;
1058	    # Let's avoid eval, it's easier to comprehend without.
1059	    if ($func eq "push") {
1060		push @{$CPAN::Config->{$o}}, @args;
1061                $changed = 1;
1062	    } elsif ($func eq "pop") {
1063		pop @{$CPAN::Config->{$o}};
1064                $changed = 1;
1065	    } elsif ($func eq "shift") {
1066		shift @{$CPAN::Config->{$o}};
1067                $changed = 1;
1068	    } elsif ($func eq "unshift") {
1069		unshift @{$CPAN::Config->{$o}}, @args;
1070                $changed = 1;
1071	    } elsif ($func eq "splice") {
1072		splice @{$CPAN::Config->{$o}}, @args;
1073                $changed = 1;
1074	    } elsif (@args) {
1075		$CPAN::Config->{$o} = [@args];
1076                $changed = 1;
1077	    } else {
1078                $self->prettyprint($o);
1079	    }
1080            if ($o eq "urllist" && $changed) {
1081                # reset the cached values
1082                undef $CPAN::FTP::Thesite;
1083                undef $CPAN::FTP::Themethod;
1084            }
1085            return $changed;
1086	} else {
1087	    $CPAN::Config->{$o} = $args[0] if defined $args[0];
1088	    $self->prettyprint($o);
1089	}
1090    }
1091}
1092
1093sub prettyprint {
1094  my($self,$k) = @_;
1095  my $v = $CPAN::Config->{$k};
1096  if (ref $v) {
1097    my(@report) = ref $v eq "ARRAY" ?
1098        @$v :
1099            map { sprintf("   %-18s => %s\n",
1100                          $_,
1101                          defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1102                         )} keys %$v;
1103    $CPAN::Frontend->myprint(
1104                             join(
1105                                  "",
1106                                  sprintf(
1107                                          "    %-18s\n",
1108                                          $k
1109                                         ),
1110                                  map {"\t$_\n"} @report
1111                                 )
1112                            );
1113  } elsif (defined $v) {
1114    $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1115  } else {
1116    $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, "UNDEFINED");
1117  }
1118}
1119
1120#-> sub CPAN::Config::commit ;
1121sub commit {
1122    my($self,$configpm) = @_;
1123    unless (defined $configpm){
1124	$configpm ||= $INC{"CPAN/MyConfig.pm"};
1125	$configpm ||= $INC{"CPAN/Config.pm"};
1126	$configpm || Carp::confess(q{
1127CPAN::Config::commit called without an argument.
1128Please specify a filename where to save the configuration or try
1129"o conf init" to have an interactive course through configing.
1130});
1131    }
1132    my($mode);
1133    if (-f $configpm) {
1134	$mode = (stat $configpm)[2];
1135	if ($mode && ! -w _) {
1136	    Carp::confess("$configpm is not writable");
1137	}
1138    }
1139
1140    my $msg;
1141    $msg = <<EOF unless $configpm =~ /MyConfig/;
1142
1143# This is CPAN.pm's systemwide configuration file. This file provides
1144# defaults for users, and the values can be changed in a per-user
1145# configuration file. The user-config file is being looked for as
1146# ~/.cpan/CPAN/MyConfig.pm.
1147
1148EOF
1149    $msg ||= "\n";
1150    my($fh) = FileHandle->new;
1151    rename $configpm, "$configpm~" if -f $configpm;
1152    open $fh, ">$configpm" or
1153        $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
1154    $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1155    foreach (sort keys %$CPAN::Config) {
1156	$fh->print(
1157		   "  '$_' => ",
1158		   ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1159		   ",\n"
1160		  );
1161    }
1162
1163    $fh->print("};\n1;\n__END__\n");
1164    close $fh;
1165
1166    #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1167    #chmod $mode, $configpm;
1168###why was that so?    $self->defaults;
1169    $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1170    1;
1171}
1172
1173*default = \&defaults;
1174#-> sub CPAN::Config::defaults ;
1175sub defaults {
1176    my($self) = @_;
1177    $self->unload;
1178    $self->load;
1179    1;
1180}
1181
1182sub init {
1183    my($self) = @_;
1184    undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1185                                                      # have the least
1186                                                      # important
1187                                                      # variable
1188                                                      # undefined
1189    $self->load;
1190    1;
1191}
1192
1193# This is a piece of repeated code that is abstracted here for
1194# maintainability.  RMB
1195#
1196sub _configpmtest {
1197    my($configpmdir, $configpmtest) = @_;
1198    if (-w $configpmtest) {
1199        return $configpmtest;
1200    } elsif (-w $configpmdir) {
1201        #_#_# following code dumped core on me with 5.003_11, a.k.
1202        my $configpm_bak = "$configpmtest.bak";
1203        unlink $configpm_bak if -f $configpm_bak;
1204        if( -f $configpmtest ) {
1205            if( rename $configpmtest, $configpm_bak ) {
1206                $CPAN::Frontend->mywarn(<<END)
1207Old configuration file $configpmtest
1208    moved to $configpm_bak
1209END
1210	    }
1211	}
1212	my $fh = FileHandle->new;
1213	if ($fh->open(">$configpmtest")) {
1214	    $fh->print("1;\n");
1215	    return $configpmtest;
1216	} else {
1217	    # Should never happen
1218	    Carp::confess("Cannot open >$configpmtest");
1219	}
1220    } else { return }
1221}
1222
1223#-> sub CPAN::Config::load ;
1224sub load {
1225    my($self) = shift;
1226    my(@miss);
1227    use Carp;
1228    eval {require CPAN::Config;};       # We eval because of some
1229                                        # MakeMaker problems
1230    unless ($dot_cpan++){
1231      unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
1232      eval {require CPAN::MyConfig;};   # where you can override
1233                                        # system wide settings
1234      shift @INC;
1235    }
1236    return unless @miss = $self->missing_config_data;
1237
1238    require CPAN::FirstTime;
1239    my($configpm,$fh,$redo,$theycalled);
1240    $redo ||= "";
1241    $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1242    if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1243	$configpm = $INC{"CPAN/Config.pm"};
1244	$redo++;
1245    } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1246	$configpm = $INC{"CPAN/MyConfig.pm"};
1247	$redo++;
1248    } else {
1249	my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1250	my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1251	my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
1252	if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1253	    $configpm = _configpmtest($configpmdir,$configpmtest);
1254	}
1255	unless ($configpm) {
1256	    $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
1257	    File::Path::mkpath($configpmdir);
1258	    $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
1259	    $configpm = _configpmtest($configpmdir,$configpmtest);
1260	    unless ($configpm) {
1261		Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1262			      qq{create a configuration file.});
1263	    }
1264	}
1265    }
1266    local($") = ", ";
1267    $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1268We have to reconfigure CPAN.pm due to following uninitialized parameters:
1269
1270@miss
1271END
1272    $CPAN::Frontend->myprint(qq{
1273$configpm initialized.
1274});
1275    sleep 2;
1276    CPAN::FirstTime::init($configpm);
1277}
1278
1279#-> sub CPAN::Config::missing_config_data ;
1280sub missing_config_data {
1281    my(@miss);
1282    for (
1283         "cpan_home", "keep_source_where", "build_dir", "build_cache",
1284         "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1285         "pager",
1286         "makepl_arg", "make_arg", "make_install_arg", "urllist",
1287         "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1288         "prerequisites_policy",
1289         "cache_metadata",
1290        ) {
1291	push @miss, $_ unless defined $CPAN::Config->{$_};
1292    }
1293    return @miss;
1294}
1295
1296#-> sub CPAN::Config::unload ;
1297sub unload {
1298    delete $INC{'CPAN/MyConfig.pm'};
1299    delete $INC{'CPAN/Config.pm'};
1300}
1301
1302#-> sub CPAN::Config::help ;
1303sub help {
1304    $CPAN::Frontend->myprint(q[
1305Known options:
1306  defaults  reload default config values from disk
1307  commit    commit session changes to disk
1308  init      go through a dialog to set all parameters
1309
1310You may edit key values in the follow fashion (the "o" is a literal
1311letter o):
1312
1313  o conf build_cache 15
1314
1315  o conf build_dir "/foo/bar"
1316
1317  o conf urllist shift
1318
1319  o conf urllist unshift ftp://ftp.foo.bar/
1320
1321]);
1322    undef; #don't reprint CPAN::Config
1323}
1324
1325#-> sub CPAN::Config::cpl ;
1326sub cpl {
1327    my($word,$line,$pos) = @_;
1328    $word ||= "";
1329    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1330    my(@words) = split " ", substr($line,0,$pos+1);
1331    if (
1332	defined($words[2])
1333	and
1334	(
1335	 $words[2] =~ /list$/ && @words == 3
1336	 ||
1337	 $words[2] =~ /list$/ && @words == 4 && length($word)
1338	)
1339       ) {
1340	return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1341    } elsif (@words >= 4) {
1342	return ();
1343    }
1344    my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1345    return grep /^\Q$word\E/, @o_conf;
1346}
1347
1348package CPAN::Shell;
1349
1350#-> sub CPAN::Shell::h ;
1351sub h {
1352    my($class,$about) = @_;
1353    if (defined $about) {
1354	$CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1355    } else {
1356	$CPAN::Frontend->myprint(q{
1357Display Information
1358 command  argument          description
1359 a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1360 i        WORD or /REGEXP/  about anything of above
1361 r        NONE              reinstall recommendations
1362 ls       AUTHOR            about files in the author's directory
1363
1364Download, Test, Make, Install...
1365 get                        download
1366 make                       make (implies get)
1367 test      MODULES,         make test (implies make)
1368 install   DISTS, BUNDLES   make install (implies test)
1369 clean                      make clean
1370 look                       open subshell in these dists' directories
1371 readme                     display these dists' README files
1372
1373Other
1374 h,?           display this menu       ! perl-code   eval a perl command
1375 o conf [opt]  set and query options   q             quit the cpan shell
1376 reload cpan   load CPAN.pm again      reload index  load newer indices
1377 autobundle    Snapshot                force cmd     unconditionally do cmd});
1378    }
1379}
1380
1381*help = \&h;
1382
1383#-> sub CPAN::Shell::a ;
1384sub a {
1385  my($self,@arg) = @_;
1386  # authors are always UPPERCASE
1387  for (@arg) {
1388    $_ = uc $_ unless /=/;
1389  }
1390  $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1391}
1392
1393#-> sub CPAN::Shell::ls ;
1394sub ls      {
1395    my($self,@arg) = @_;
1396    my @accept;
1397    for (@arg) {
1398        unless (/^[A-Z\-]+$/i) {
1399            $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1400            next;
1401        }
1402        push @accept, uc $_;
1403    }
1404    for my $a (@accept){
1405        my $author = $self->expand('Author',$a) or die "No author found for $a";
1406        $author->ls;
1407    }
1408}
1409
1410#-> sub CPAN::Shell::local_bundles ;
1411sub local_bundles {
1412    my($self,@which) = @_;
1413    my($incdir,$bdir,$dh);
1414    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1415        my @bbase = "Bundle";
1416        while (my $bbase = shift @bbase) {
1417            $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1418            CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1419            if ($dh = DirHandle->new($bdir)) { # may fail
1420                my($entry);
1421                for $entry ($dh->read) {
1422                    next if $entry =~ /^\./;
1423                    if (-d File::Spec->catdir($bdir,$entry)){
1424                        push @bbase, "$bbase\::$entry";
1425                    } else {
1426                        next unless $entry =~ s/\.pm(?!\n)\Z//;
1427                        $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1428                    }
1429                }
1430            }
1431        }
1432    }
1433}
1434
1435#-> sub CPAN::Shell::b ;
1436sub b {
1437    my($self,@which) = @_;
1438    CPAN->debug("which[@which]") if $CPAN::DEBUG;
1439    $self->local_bundles;
1440    $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1441}
1442
1443#-> sub CPAN::Shell::d ;
1444sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1445
1446#-> sub CPAN::Shell::m ;
1447sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1448    my $self = shift;
1449    $CPAN::Frontend->myprint($self->format_result('Module',@_));
1450}
1451
1452#-> sub CPAN::Shell::i ;
1453sub i {
1454    my($self) = shift;
1455    my(@args) = @_;
1456    my(@type,$type,@m);
1457    @type = qw/Author Bundle Distribution Module/;
1458    @args = '/./' unless @args;
1459    my(@result);
1460    for $type (@type) {
1461	push @result, $self->expand($type,@args);
1462    }
1463    my $result = @result == 1 ?
1464	$result[0]->as_string :
1465            @result == 0 ?
1466                "No objects found of any type for argument @args\n" :
1467                    join("",
1468                         (map {$_->as_glimpse} @result),
1469                         scalar @result, " items found\n",
1470                        );
1471    $CPAN::Frontend->myprint($result);
1472}
1473
1474#-> sub CPAN::Shell::o ;
1475
1476# CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1477# should have been called set and 'o debug' maybe 'set debug'
1478sub o {
1479    my($self,$o_type,@o_what) = @_;
1480    $o_type ||= "";
1481    CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1482    if ($o_type eq 'conf') {
1483	shift @o_what if @o_what && $o_what[0] eq 'help';
1484	if (!@o_what) { # print all things, "o conf"
1485	    my($k,$v);
1486	    $CPAN::Frontend->myprint("CPAN::Config options");
1487	    if (exists $INC{'CPAN/Config.pm'}) {
1488	      $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1489	    }
1490	    if (exists $INC{'CPAN/MyConfig.pm'}) {
1491	      $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1492	    }
1493	    $CPAN::Frontend->myprint(":\n");
1494	    for $k (sort keys %CPAN::Config::can) {
1495		$v = $CPAN::Config::can{$k};
1496		$CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1497	    }
1498	    $CPAN::Frontend->myprint("\n");
1499	    for $k (sort keys %$CPAN::Config) {
1500                CPAN::Config->prettyprint($k);
1501	    }
1502	    $CPAN::Frontend->myprint("\n");
1503	} elsif (!CPAN::Config->edit(@o_what)) {
1504	    $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1505                                     qq{edit options\n\n});
1506	}
1507    } elsif ($o_type eq 'debug') {
1508	my(%valid);
1509	@o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1510	if (@o_what) {
1511	    while (@o_what) {
1512		my($what) = shift @o_what;
1513                if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1514                    $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1515                    next;
1516                }
1517		if ( exists $CPAN::DEBUG{$what} ) {
1518		    $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1519		} elsif ($what =~ /^\d/) {
1520		    $CPAN::DEBUG = $what;
1521		} elsif (lc $what eq 'all') {
1522		    my($max) = 0;
1523		    for (values %CPAN::DEBUG) {
1524			$max += $_;
1525		    }
1526		    $CPAN::DEBUG = $max;
1527		} else {
1528		    my($known) = 0;
1529		    for (keys %CPAN::DEBUG) {
1530			next unless lc($_) eq lc($what);
1531			$CPAN::DEBUG |= $CPAN::DEBUG{$_};
1532			$known = 1;
1533		    }
1534		    $CPAN::Frontend->myprint("unknown argument [$what]\n")
1535			unless $known;
1536		}
1537	    }
1538	} else {
1539	  my $raw = "Valid options for debug are ".
1540	      join(", ",sort(keys %CPAN::DEBUG), 'all').
1541		  qq{ or a number. Completion works on the options. }.
1542		      qq{Case is ignored.};
1543	  require Text::Wrap;
1544	  $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1545	  $CPAN::Frontend->myprint("\n\n");
1546	}
1547	if ($CPAN::DEBUG) {
1548	    $CPAN::Frontend->myprint("Options set for debugging:\n");
1549	    my($k,$v);
1550	    for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1551		$v = $CPAN::DEBUG{$k};
1552		$CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1553                    if $v & $CPAN::DEBUG;
1554	    }
1555	} else {
1556	    $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1557	}
1558    } else {
1559	$CPAN::Frontend->myprint(qq{
1560Known options:
1561  conf    set or get configuration variables
1562  debug   set or get debugging options
1563});
1564    }
1565}
1566
1567sub paintdots_onreload {
1568    my($ref) = shift;
1569    sub {
1570	if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1571	    my($subr) = $1;
1572	    ++$$ref;
1573	    local($|) = 1;
1574	    # $CPAN::Frontend->myprint(".($subr)");
1575	    $CPAN::Frontend->myprint(".");
1576	    return;
1577	}
1578	warn @_;
1579    };
1580}
1581
1582#-> sub CPAN::Shell::reload ;
1583sub reload {
1584    my($self,$command,@arg) = @_;
1585    $command ||= "";
1586    $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1587    if ($command =~ /cpan/i) {
1588        for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
1589            next unless $INC{$f};
1590            CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
1591            my $fh = FileHandle->new($INC{$f});
1592            local($/);
1593            my $redef = 0;
1594            local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1595            eval <$fh>;
1596            warn $@ if $@;
1597            $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1598        }
1599    } elsif ($command =~ /index/) {
1600      CPAN::Index->force_reload;
1601    } else {
1602      $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
1603index    re-reads the index files\n});
1604    }
1605}
1606
1607#-> sub CPAN::Shell::_binary_extensions ;
1608sub _binary_extensions {
1609    my($self) = shift @_;
1610    my(@result,$module,%seen,%need,$headerdone);
1611    for $module ($self->expand('Module','/./')) {
1612	my $file  = $module->cpan_file;
1613	next if $file eq "N/A";
1614	next if $file =~ /^Contact Author/;
1615        my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1616	next if $dist->isa_perl;
1617	next unless $module->xs_file;
1618	local($|) = 1;
1619	$CPAN::Frontend->myprint(".");
1620	push @result, $module;
1621    }
1622#    print join " | ", @result;
1623    $CPAN::Frontend->myprint("\n");
1624    return @result;
1625}
1626
1627#-> sub CPAN::Shell::recompile ;
1628sub recompile {
1629    my($self) = shift @_;
1630    my($module,@module,$cpan_file,%dist);
1631    @module = $self->_binary_extensions();
1632    for $module (@module){  # we force now and compile later, so we
1633                            # don't do it twice
1634	$cpan_file = $module->cpan_file;
1635	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1636	$pack->force;
1637	$dist{$cpan_file}++;
1638    }
1639    for $cpan_file (sort keys %dist) {
1640	$CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1641	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1642	$pack->install;
1643	$CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1644                           # stop a package from recompiling,
1645                           # e.g. IO-1.12 when we have perl5.003_10
1646    }
1647}
1648
1649#-> sub CPAN::Shell::_u_r_common ;
1650sub _u_r_common {
1651    my($self) = shift @_;
1652    my($what) = shift @_;
1653    CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1654    Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1655          $what && $what =~ /^[aru]$/;
1656    my(@args) = @_;
1657    @args = '/./' unless @args;
1658    my(@result,$module,%seen,%need,$headerdone,
1659       $version_undefs,$version_zeroes);
1660    $version_undefs = $version_zeroes = 0;
1661    my $sprintf = "%s%-25s%s %9s %9s  %s\n";
1662    my @expand = $self->expand('Module',@args);
1663    my $expand = scalar @expand;
1664    if (0) { # Looks like noise to me, was very useful for debugging
1665             # for metadata cache
1666        $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1667    }
1668    for $module (@expand) {
1669	my $file  = $module->cpan_file;
1670	next unless defined $file; # ??
1671	my($latest) = $module->cpan_version;
1672	my($inst_file) = $module->inst_file;
1673	my($have);
1674	return if $CPAN::Signal;
1675	if ($inst_file){
1676	    if ($what eq "a") {
1677		$have = $module->inst_version;
1678	    } elsif ($what eq "r") {
1679		$have = $module->inst_version;
1680		local($^W) = 0;
1681		if ($have eq "undef"){
1682		    $version_undefs++;
1683		} elsif ($have == 0){
1684		    $version_zeroes++;
1685		}
1686		next unless CPAN::Version->vgt($latest, $have);
1687# to be pedantic we should probably say:
1688#    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1689# to catch the case where CPAN has a version 0 and we have a version undef
1690	    } elsif ($what eq "u") {
1691		next;
1692	    }
1693	} else {
1694	    if ($what eq "a") {
1695		next;
1696	    } elsif ($what eq "r") {
1697		next;
1698	    } elsif ($what eq "u") {
1699		$have = "-";
1700	    }
1701	}
1702	return if $CPAN::Signal; # this is sometimes lengthy
1703	$seen{$file} ||= 0;
1704	if ($what eq "a") {
1705	    push @result, sprintf "%s %s\n", $module->id, $have;
1706	} elsif ($what eq "r") {
1707	    push @result, $module->id;
1708	    next if $seen{$file}++;
1709	} elsif ($what eq "u") {
1710	    push @result, $module->id;
1711	    next if $seen{$file}++;
1712	    next if $file =~ /^Contact/;
1713	}
1714	unless ($headerdone++){
1715	    $CPAN::Frontend->myprint("\n");
1716	    $CPAN::Frontend->myprint(sprintf(
1717                                             $sprintf,
1718                                             "",
1719                                             "Package namespace",
1720                                             "",
1721                                             "installed",
1722                                             "latest",
1723                                             "in CPAN file"
1724                                            ));
1725	}
1726        my $color_on = "";
1727        my $color_off = "";
1728        if (
1729            $COLOR_REGISTERED
1730            &&
1731            $CPAN::META->has_inst("Term::ANSIColor")
1732            &&
1733            $module->{RO}{description}
1734           ) {
1735            $color_on = Term::ANSIColor::color("green");
1736            $color_off = Term::ANSIColor::color("reset");
1737        }
1738	$CPAN::Frontend->myprint(sprintf $sprintf,
1739                                 $color_on,
1740                                 $module->id,
1741                                 $color_off,
1742                                 $have,
1743                                 $latest,
1744                                 $file);
1745	$need{$module->id}++;
1746    }
1747    unless (%need) {
1748	if ($what eq "u") {
1749	    $CPAN::Frontend->myprint("No modules found for @args\n");
1750	} elsif ($what eq "r") {
1751	    $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1752	}
1753    }
1754    if ($what eq "r") {
1755	if ($version_zeroes) {
1756	    my $s_has = $version_zeroes > 1 ? "s have" : " has";
1757	    $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1758		qq{a version number of 0\n});
1759	}
1760	if ($version_undefs) {
1761	    my $s_has = $version_undefs > 1 ? "s have" : " has";
1762	    $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1763		qq{parseable version number\n});
1764	}
1765    }
1766    @result;
1767}
1768
1769#-> sub CPAN::Shell::r ;
1770sub r {
1771    shift->_u_r_common("r",@_);
1772}
1773
1774#-> sub CPAN::Shell::u ;
1775sub u {
1776    shift->_u_r_common("u",@_);
1777}
1778
1779#-> sub CPAN::Shell::autobundle ;
1780sub autobundle {
1781    my($self) = shift;
1782    CPAN::Config->load unless $CPAN::Config_loaded++;
1783    my(@bundle) = $self->_u_r_common("a",@_);
1784    my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1785    File::Path::mkpath($todir);
1786    unless (-d $todir) {
1787	$CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1788	return;
1789    }
1790    my($y,$m,$d) =  (localtime)[5,4,3];
1791    $y+=1900;
1792    $m++;
1793    my($c) = 0;
1794    my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1795    my($to) = File::Spec->catfile($todir,"$me.pm");
1796    while (-f $to) {
1797	$me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1798	$to = File::Spec->catfile($todir,"$me.pm");
1799    }
1800    my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1801    $fh->print(
1802	       "package Bundle::$me;\n\n",
1803	       "\$VERSION = '0.01';\n\n",
1804	       "1;\n\n",
1805	       "__END__\n\n",
1806	       "=head1 NAME\n\n",
1807	       "Bundle::$me - Snapshot of installation on ",
1808	       $Config::Config{'myhostname'},
1809	       " on ",
1810	       scalar(localtime),
1811	       "\n\n=head1 SYNOPSIS\n\n",
1812	       "perl -MCPAN -e 'install Bundle::$me'\n\n",
1813	       "=head1 CONTENTS\n\n",
1814	       join("\n", @bundle),
1815	       "\n\n=head1 CONFIGURATION\n\n",
1816	       Config->myconfig,
1817	       "\n\n=head1 AUTHOR\n\n",
1818	       "This Bundle has been generated automatically ",
1819	       "by the autobundle routine in CPAN.pm.\n",
1820	      );
1821    $fh->close;
1822    $CPAN::Frontend->myprint("\nWrote bundle file
1823    $to\n\n");
1824}
1825
1826#-> sub CPAN::Shell::expandany ;
1827sub expandany {
1828    my($self,$s) = @_;
1829    CPAN->debug("s[$s]") if $CPAN::DEBUG;
1830    if ($s =~ m|/|) { # looks like a file
1831        $s = CPAN::Distribution->normalize($s);
1832        return $CPAN::META->instance('CPAN::Distribution',$s);
1833        # Distributions spring into existence, not expand
1834    } elsif ($s =~ m|^Bundle::|) {
1835        $self->local_bundles; # scanning so late for bundles seems
1836                              # both attractive and crumpy: always
1837                              # current state but easy to forget
1838                              # somewhere
1839        return $self->expand('Bundle',$s);
1840    } else {
1841        return $self->expand('Module',$s)
1842            if $CPAN::META->exists('CPAN::Module',$s);
1843    }
1844    return;
1845}
1846
1847#-> sub CPAN::Shell::expand ;
1848sub expand {
1849    shift;
1850    my($type,@args) = @_;
1851    my($arg,@m);
1852    CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
1853    for $arg (@args) {
1854	my($regex,$command);
1855	if ($arg =~ m|^/(.*)/$|) {
1856	    $regex = $1;
1857	} elsif ($arg =~ m/=/) {
1858            $command = 1;
1859        }
1860	my $class = "CPAN::$type";
1861	my $obj;
1862        CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1863                    $class,
1864                    defined $regex ? $regex : "UNDEFINED",
1865                    $command || "UNDEFINED",
1866                   ) if $CPAN::DEBUG;
1867	if (defined $regex) {
1868            for $obj (
1869                      sort
1870                      {$a->id cmp $b->id}
1871                      $CPAN::META->all_objects($class)
1872                     ) {
1873                unless ($obj->id){
1874                    # BUG, we got an empty object somewhere
1875                    require Data::Dumper;
1876                    CPAN->debug(sprintf(
1877                                        "Bug in CPAN: Empty id on obj[%s][%s]",
1878                                        $obj,
1879                                        Data::Dumper::Dumper($obj)
1880                                       )) if $CPAN::DEBUG;
1881                    next;
1882                }
1883                push @m, $obj
1884                    if $obj->id =~ /$regex/i
1885                        or
1886                            (
1887                             (
1888                              $] < 5.00303 ### provide sort of
1889                              ### compatibility with 5.003
1890                              ||
1891                              $obj->can('name')
1892                             )
1893                             &&
1894                             $obj->name  =~ /$regex/i
1895                            );
1896            }
1897        } elsif ($command) {
1898            die "equal sign in command disabled (immature interface), ".
1899                "you can set
1900 ! \$CPAN::Shell::ADVANCED_QUERY=1
1901to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1902that may go away anytime.\n"
1903                    unless $ADVANCED_QUERY;
1904            my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1905            my($matchcrit) = $criterion =~ m/^~(.+)/;
1906            for my $self (
1907                          sort
1908                          {$a->id cmp $b->id}
1909                          $CPAN::META->all_objects($class)
1910                         ) {
1911                my $lhs = $self->$method() or next; # () for 5.00503
1912                if ($matchcrit) {
1913                    push @m, $self if $lhs =~ m/$matchcrit/;
1914                } else {
1915                    push @m, $self if $lhs eq $criterion;
1916                }
1917            }
1918	} else {
1919	    my($xarg) = $arg;
1920	    if ( $type eq 'Bundle' ) {
1921		$xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1922	    } elsif ($type eq "Distribution") {
1923                $xarg = CPAN::Distribution->normalize($arg);
1924            }
1925	    if ($CPAN::META->exists($class,$xarg)) {
1926		$obj = $CPAN::META->instance($class,$xarg);
1927	    } elsif ($CPAN::META->exists($class,$arg)) {
1928		$obj = $CPAN::META->instance($class,$arg);
1929	    } else {
1930		next;
1931	    }
1932	    push @m, $obj;
1933	}
1934    }
1935    return wantarray ? @m : $m[0];
1936}
1937
1938#-> sub CPAN::Shell::format_result ;
1939sub format_result {
1940    my($self) = shift;
1941    my($type,@args) = @_;
1942    @args = '/./' unless @args;
1943    my(@result) = $self->expand($type,@args);
1944    my $result = @result == 1 ?
1945	$result[0]->as_string :
1946            @result == 0 ?
1947                "No objects of type $type found for argument @args\n" :
1948                    join("",
1949                         (map {$_->as_glimpse} @result),
1950                         scalar @result, " items found\n",
1951                        );
1952    $result;
1953}
1954
1955# The only reason for this method is currently to have a reliable
1956# debugging utility that reveals which output is going through which
1957# channel. No, I don't like the colors ;-)
1958
1959#-> sub CPAN::Shell::print_ornameted ;
1960sub print_ornamented {
1961    my($self,$what,$ornament) = @_;
1962    my $longest = 0;
1963    return unless defined $what;
1964
1965    if ($CPAN::Config->{term_is_latin}){
1966        # courtesy jhi:
1967        $what
1968            =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1969    }
1970    if ($PRINT_ORNAMENTING) {
1971	unless (defined &color) {
1972	    if ($CPAN::META->has_inst("Term::ANSIColor")) {
1973		import Term::ANSIColor "color";
1974	    } else {
1975		*color = sub { return "" };
1976	    }
1977	}
1978	my $line;
1979	for $line (split /\n/, $what) {
1980	    $longest = length($line) if length($line) > $longest;
1981	}
1982	my $sprintf = "%-" . $longest . "s";
1983	while ($what){
1984	    $what =~ s/(.*\n?)//m;
1985	    my $line = $1;
1986	    last unless $line;
1987	    my($nl) = chomp $line ? "\n" : "";
1988	    #	print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1989	    print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1990	}
1991    } else {
1992        # chomp $what;
1993        # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
1994	print $what;
1995    }
1996}
1997
1998sub myprint {
1999    my($self,$what) = @_;
2000
2001    $self->print_ornamented($what, 'bold blue on_yellow');
2002}
2003
2004sub myexit {
2005    my($self,$what) = @_;
2006    $self->myprint($what);
2007    exit;
2008}
2009
2010sub mywarn {
2011    my($self,$what) = @_;
2012    $self->print_ornamented($what, 'bold red on_yellow');
2013}
2014
2015sub myconfess {
2016    my($self,$what) = @_;
2017    $self->print_ornamented($what, 'bold red on_white');
2018    Carp::confess "died";
2019}
2020
2021sub mydie {
2022    my($self,$what) = @_;
2023    $self->print_ornamented($what, 'bold red on_white');
2024    die "\n";
2025}
2026
2027sub setup_output {
2028    return if -t STDOUT;
2029    my $odef = select STDERR;
2030    $| = 1;
2031    select STDOUT;
2032    $| = 1;
2033    select $odef;
2034}
2035
2036#-> sub CPAN::Shell::rematein ;
2037# RE-adme||MA-ke||TE-st||IN-stall
2038sub rematein {
2039    shift;
2040    my($meth,@some) = @_;
2041    my $pragma = "";
2042    if ($meth eq 'force') {
2043	$pragma = $meth;
2044	$meth = shift @some;
2045    }
2046    setup_output();
2047    CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
2048
2049    # Here is the place to set "test_count" on all involved parties to
2050    # 0. We then can pass this counter on to the involved
2051    # distributions and those can refuse to test if test_count > X. In
2052    # the first stab at it we could use a 1 for "X".
2053
2054    # But when do I reset the distributions to start with 0 again?
2055    # Jost suggested to have a random or cycling interaction ID that
2056    # we pass through. But the ID is something that is just left lying
2057    # around in addition to the counter, so I'd prefer to set the
2058    # counter to 0 now, and repeat at the end of the loop. But what
2059    # about dependencies? They appear later and are not reset, they
2060    # enter the queue but not its copy. How do they get a sensible
2061    # test_count?
2062
2063    # construct the queue
2064    my($s,@s,@qcopy);
2065    foreach $s (@some) {
2066	my $obj;
2067	if (ref $s) {
2068            CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2069	    $obj = $s;
2070	} elsif ($s =~ m|^/|) { # looks like a regexp
2071            $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2072                                    "not supported\n");
2073            sleep 2;
2074            next;
2075	} else {
2076            CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2077	    $obj = CPAN::Shell->expandany($s);
2078	}
2079	if (ref $obj) {
2080            $obj->color_cmd_tmps(0,1);
2081            CPAN::Queue->new($obj->id);
2082            push @qcopy, $obj;
2083	} elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2084	    $obj = $CPAN::META->instance('CPAN::Author',$s);
2085            if ($meth =~ /^(dump|ls)$/) {
2086                $obj->$meth();
2087            } else {
2088                $CPAN::Frontend->myprint(
2089                                         join "",
2090                                         "Don't be silly, you can't $meth ",
2091                                         $obj->fullname,
2092                                         " ;-)\n"
2093                                        );
2094                sleep 2;
2095            }
2096	} else {
2097	    $CPAN::Frontend
2098		->myprint(qq{Warning: Cannot $meth $s, }.
2099			  qq{don\'t know what it is.
2100Try the command
2101
2102    i /$s/
2103
2104to find objects with matching identifiers.
2105});
2106            sleep 2;
2107	}
2108    }
2109
2110    # queuerunner (please be warned: when I started to change the
2111    # queue to hold objects instead of names, I made one or two
2112    # mistakes and never found which. I reverted back instead)
2113    while ($s = CPAN::Queue->first) {
2114        my $obj;
2115	if (ref $s) {
2116	    $obj = $s; # I do not believe, we would survive if this happened
2117	} else {
2118	    $obj = CPAN::Shell->expandany($s);
2119	}
2120        if ($pragma
2121            &&
2122            ($] < 5.00303 || $obj->can($pragma))){
2123            ### compatibility with 5.003
2124            $obj->$pragma($meth); # the pragma "force" in
2125                                  # "CPAN::Distribution" must know
2126                                  # what we are intending
2127        }
2128        if ($]>=5.00303 && $obj->can('called_for')) {
2129            $obj->called_for($s);
2130        }
2131        CPAN->debug(
2132                    qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2133                    $obj->as_string.
2134                    qq{\]}
2135                   ) if $CPAN::DEBUG;
2136
2137        if ($obj->$meth()){
2138            CPAN::Queue->delete($s);
2139        } else {
2140            CPAN->debug("failed");
2141        }
2142
2143        $obj->undelay;
2144	CPAN::Queue->delete_first($s);
2145    }
2146    for my $obj (@qcopy) {
2147        $obj->color_cmd_tmps(0,0);
2148    }
2149}
2150
2151#-> sub CPAN::Shell::dump ;
2152sub dump    { shift->rematein('dump',@_); }
2153#-> sub CPAN::Shell::force ;
2154sub force   { shift->rematein('force',@_); }
2155#-> sub CPAN::Shell::get ;
2156sub get     { shift->rematein('get',@_); }
2157#-> sub CPAN::Shell::readme ;
2158sub readme  { shift->rematein('readme',@_); }
2159#-> sub CPAN::Shell::make ;
2160sub make    { shift->rematein('make',@_); }
2161#-> sub CPAN::Shell::test ;
2162sub test    { shift->rematein('test',@_); }
2163#-> sub CPAN::Shell::install ;
2164sub install { shift->rematein('install',@_); }
2165#-> sub CPAN::Shell::clean ;
2166sub clean   { shift->rematein('clean',@_); }
2167#-> sub CPAN::Shell::look ;
2168sub look   { shift->rematein('look',@_); }
2169#-> sub CPAN::Shell::cvs_import ;
2170sub cvs_import   { shift->rematein('cvs_import',@_); }
2171
2172package CPAN::LWP::UserAgent;
2173
2174sub config {
2175    return if $SETUPDONE;
2176    if ($CPAN::META->has_usable('LWP::UserAgent')) {
2177        require LWP::UserAgent;
2178        @ISA = qw(Exporter LWP::UserAgent);
2179        $SETUPDONE++;
2180    } else {
2181        $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
2182    }
2183}
2184
2185sub get_basic_credentials {
2186    my($self, $realm, $uri, $proxy) = @_;
2187    return unless $proxy;
2188    if ($USER && $PASSWD) {
2189    } elsif (defined $CPAN::Config->{proxy_user} &&
2190             defined $CPAN::Config->{proxy_pass}) {
2191        $USER = $CPAN::Config->{proxy_user};
2192        $PASSWD = $CPAN::Config->{proxy_pass};
2193    } else {
2194        require ExtUtils::MakeMaker;
2195        ExtUtils::MakeMaker->import(qw(prompt));
2196        $USER = prompt("Proxy authentication needed!
2197 (Note: to permanently configure username and password run
2198   o conf proxy_user your_username
2199   o conf proxy_pass your_password
2200 )\nUsername:");
2201        if ($CPAN::META->has_inst("Term::ReadKey")) {
2202            Term::ReadKey::ReadMode("noecho");
2203        } else {
2204            $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2205        }
2206        $PASSWD = prompt("Password:");
2207        if ($CPAN::META->has_inst("Term::ReadKey")) {
2208            Term::ReadKey::ReadMode("restore");
2209        }
2210        $CPAN::Frontend->myprint("\n\n");
2211    }
2212    return($USER,$PASSWD);
2213}
2214
2215# mirror(): Its purpose is to deal with proxy authentication. When we
2216# call SUPER::mirror, we relly call the mirror method in
2217# LWP::UserAgent. LWP::UserAgent will then call
2218# $self->get_basic_credentials or some equivalent and this will be
2219# $self->dispatched to our own get_basic_credentials method.
2220
2221# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2222
2223# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2224# although we have gone through our get_basic_credentials, the proxy
2225# server refuses to connect. This could be a case where the username or
2226# password has changed in the meantime, so I'm trying once again without
2227# $USER and $PASSWD to give the get_basic_credentials routine another
2228# chance to set $USER and $PASSWD.
2229
2230sub mirror {
2231    my($self,$url,$aslocal) = @_;
2232    my $result = $self->SUPER::mirror($url,$aslocal);
2233    if ($result->code == 407) {
2234        undef $USER;
2235        undef $PASSWD;
2236        $result = $self->SUPER::mirror($url,$aslocal);
2237    }
2238    $result;
2239}
2240
2241package CPAN::FTP;
2242
2243#-> sub CPAN::FTP::ftp_get ;
2244sub ftp_get {
2245  my($class,$host,$dir,$file,$target) = @_;
2246  $class->debug(
2247		qq[Going to fetch file [$file] from dir [$dir]
2248	on host [$host] as local [$target]\n]
2249		      ) if $CPAN::DEBUG;
2250  my $ftp = Net::FTP->new($host);
2251  return 0 unless defined $ftp;
2252  $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2253  $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2254  unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2255    warn "Couldn't login on $host";
2256    return;
2257  }
2258  unless ( $ftp->cwd($dir) ){
2259    warn "Couldn't cwd $dir";
2260    return;
2261  }
2262  $ftp->binary;
2263  $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2264  unless ( $ftp->get($file,$target) ){
2265    warn "Couldn't fetch $file from $host\n";
2266    return;
2267  }
2268  $ftp->quit; # it's ok if this fails
2269  return 1;
2270}
2271
2272# If more accuracy is wanted/needed, Chris Leach sent me this patch...
2273
2274 # > *** /install/perl/live/lib/CPAN.pm-	Wed Sep 24 13:08:48 1997
2275 # > --- /tmp/cp	Wed Sep 24 13:26:40 1997
2276 # > ***************
2277 # > *** 1562,1567 ****
2278 # > --- 1562,1580 ----
2279 # >       return 1 if substr($url,0,4) eq "file";
2280 # >       return 1 unless $url =~ m|://([^/]+)|;
2281 # >       my $host = $1;
2282 # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2283 # > +     if ($proxy) {
2284 # > +         $proxy =~ m|://([^/:]+)|;
2285 # > +         $proxy = $1;
2286 # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2287 # > +         if ($noproxy) {
2288 # > +             if ($host !~ /$noproxy$/) {
2289 # > +                 $host = $proxy;
2290 # > +             }
2291 # > +         } else {
2292 # > +             $host = $proxy;
2293 # > +         }
2294 # > +     }
2295 # >       require Net::Ping;
2296 # >       return 1 unless $Net::Ping::VERSION >= 2;
2297 # >       my $p;
2298
2299
2300#-> sub CPAN::FTP::localize ;
2301sub localize {
2302    my($self,$file,$aslocal,$force) = @_;
2303    $force ||= 0;
2304    Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2305	unless defined $aslocal;
2306    $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2307	if $CPAN::DEBUG;
2308
2309    if ($^O eq 'MacOS') {
2310        # Comment by AK on 2000-09-03: Uniq short filenames would be
2311        # available in CHECKSUMS file
2312        my($name, $path) = File::Basename::fileparse($aslocal, '');
2313        if (length($name) > 31) {
2314            $name =~ s/(
2315                        \.(
2316                           readme(\.(gz|Z))? |
2317                           (tar\.)?(gz|Z) |
2318                           tgz |
2319                           zip |
2320                           pm\.(gz|Z)
2321                          )
2322                       )$//x;
2323            my $suf = $1;
2324            my $size = 31 - length($suf);
2325            while (length($name) > $size) {
2326                chop $name;
2327            }
2328            $name .= $suf;
2329            $aslocal = File::Spec->catfile($path, $name);
2330        }
2331    }
2332
2333    return $aslocal if -f $aslocal && -r _ && !($force & 1);
2334    my($restore) = 0;
2335    if (-f $aslocal){
2336	rename $aslocal, "$aslocal.bak";
2337	$restore++;
2338    }
2339
2340    my($aslocal_dir) = File::Basename::dirname($aslocal);
2341    File::Path::mkpath($aslocal_dir);
2342    $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2343	qq{directory "$aslocal_dir".
2344    I\'ll continue, but if you encounter problems, they may be due
2345    to insufficient permissions.\n}) unless -w $aslocal_dir;
2346
2347    # Inheritance is not easier to manage than a few if/else branches
2348    if ($CPAN::META->has_usable('LWP::UserAgent')) {
2349 	unless ($Ua) {
2350            CPAN::LWP::UserAgent->config;
2351	    eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2352            if ($@) {
2353                $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2354                    if $CPAN::DEBUG;
2355            } else {
2356                my($var);
2357                $Ua->proxy('ftp',  $var)
2358                    if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2359                $Ua->proxy('http', $var)
2360                    if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2361
2362
2363# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2364#
2365#  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2366#  > use ones that require basic autorization.
2367#
2368#  > Example of when I use it manually in my own stuff:
2369#
2370#  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2371#  > $req->proxy_authorization_basic("username","password");
2372#  > $res = $ua->request($req);
2373#
2374
2375                $Ua->no_proxy($var)
2376                    if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2377            }
2378	}
2379    }
2380    for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2381        $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2382    }
2383
2384    # Try the list of urls for each single object. We keep a record
2385    # where we did get a file from
2386    my(@reordered,$last);
2387    $CPAN::Config->{urllist} ||= [];
2388    unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2389        warn "Malformed urllist; ignoring.  Configuration file corrupt?\n";
2390    }
2391    $last = $#{$CPAN::Config->{urllist}};
2392    if ($force & 2) { # local cpans probably out of date, don't reorder
2393	@reordered = (0..$last);
2394    } else {
2395	@reordered =
2396	    sort {
2397		(substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2398		    <=>
2399		(substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2400		    or
2401		defined($Thesite)
2402		    and
2403		($b == $Thesite)
2404		    <=>
2405		($a == $Thesite)
2406	    } 0..$last;
2407    }
2408    my(@levels);
2409    if ($Themethod) {
2410	@levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2411    } else {
2412	@levels = qw/easy hard hardest/;
2413    }
2414    @levels = qw/easy/ if $^O eq 'MacOS';
2415    my($levelno);
2416    for $levelno (0..$#levels) {
2417        my $level = $levels[$levelno];
2418	my $method = "host$level";
2419	my @host_seq = $level eq "easy" ?
2420	    @reordered : 0..$last;  # reordered has CDROM up front
2421	@host_seq = (0) unless @host_seq;
2422	my $ret = $self->$method(\@host_seq,$file,$aslocal);
2423	if ($ret) {
2424	  $Themethod = $level;
2425	  my $now = time;
2426	  # utime $now, $now, $aslocal; # too bad, if we do that, we
2427                                      # might alter a local mirror
2428	  $self->debug("level[$level]") if $CPAN::DEBUG;
2429	  return $ret;
2430	} else {
2431	  unlink $aslocal;
2432          last if $CPAN::Signal; # need to cleanup
2433	}
2434    }
2435    unless ($CPAN::Signal) {
2436        my(@mess);
2437        push @mess,
2438            qq{Please check, if the URLs I found in your configuration file \(}.
2439                join(", ", @{$CPAN::Config->{urllist}}).
2440                    qq{\) are valid. The urllist can be edited.},
2441                        qq{E.g. with 'o conf urllist push ftp://myurl/'};
2442        $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2443        sleep 2;
2444        $CPAN::Frontend->myprint("Could not fetch $file\n");
2445    }
2446    if ($restore) {
2447	rename "$aslocal.bak", $aslocal;
2448	$CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2449				 $self->ls($aslocal));
2450	return $aslocal;
2451    }
2452    return;
2453}
2454
2455sub hosteasy {
2456    my($self,$host_seq,$file,$aslocal) = @_;
2457    my($i);
2458  HOSTEASY: for $i (@$host_seq) {
2459        my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2460	$url .= "/" unless substr($url,-1) eq "/";
2461	$url .= $file;
2462	$self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2463	if ($url =~ /^file:/) {
2464	    my $l;
2465	    if ($CPAN::META->has_inst('URI::URL')) {
2466		my $u =  URI::URL->new($url);
2467		$l = $u->path;
2468	    } else { # works only on Unix, is poorly constructed, but
2469		# hopefully better than nothing.
2470		# RFC 1738 says fileurl BNF is
2471		# fileurl = "file://" [ host | "localhost" ] "/" fpath
2472		# Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2473		# the code
2474		($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2475		$l =~ s|^file:||;                   # assume they
2476                                                    # meant
2477                                                    # file://localhost
2478		$l =~ s|^/||s unless -f $l;         # e.g. /P:
2479		$self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
2480	    }
2481	    if ( -f $l && -r _) {
2482		$Thesite = $i;
2483		return $l;
2484	    }
2485	    # Maybe mirror has compressed it?
2486	    if (-f "$l.gz") {
2487		$self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2488		CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2489		if ( -f $aslocal) {
2490		    $Thesite = $i;
2491		    return $aslocal;
2492		}
2493	    }
2494	}
2495        if ($CPAN::META->has_usable('LWP')) {
2496	  $CPAN::Frontend->myprint("Fetching with LWP:
2497  $url
2498");
2499	  unless ($Ua) {
2500              CPAN::LWP::UserAgent->config;
2501              eval { $Ua = CPAN::LWP::UserAgent->new; };
2502              if ($@) {
2503                  $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2504              }
2505	  }
2506	  my $res = $Ua->mirror($url, $aslocal);
2507	  if ($res->is_success) {
2508	    $Thesite = $i;
2509	    my $now = time;
2510	    utime $now, $now, $aslocal; # download time is more
2511                                        # important than upload time
2512	    return $aslocal;
2513	  } elsif ($url !~ /\.gz(?!\n)\Z/) {
2514	    my $gzurl = "$url.gz";
2515	    $CPAN::Frontend->myprint("Fetching with LWP:
2516  $gzurl
2517");
2518	    $res = $Ua->mirror($gzurl, "$aslocal.gz");
2519	    if ($res->is_success &&
2520		CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2521	       ) {
2522	      $Thesite = $i;
2523	      return $aslocal;
2524	    }
2525	  } else {
2526              $CPAN::Frontend->myprint(sprintf(
2527                                               "LWP failed with code[%s] message[%s]\n",
2528                                               $res->code,
2529                                               $res->message,
2530                                              ));
2531	    # Alan Burlison informed me that in firewall environments
2532	    # Net::FTP can still succeed where LWP fails. So we do not
2533	    # skip Net::FTP anymore when LWP is available.
2534	  }
2535	} else {
2536            $CPAN::Frontend->myprint("LWP not available\n");
2537	}
2538        return if $CPAN::Signal;
2539	if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2540	    # that's the nice and easy way thanks to Graham
2541	    my($host,$dir,$getfile) = ($1,$2,$3);
2542	    if ($CPAN::META->has_usable('Net::FTP')) {
2543		$dir =~ s|/+|/|g;
2544		$CPAN::Frontend->myprint("Fetching with Net::FTP:
2545  $url
2546");
2547		$self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2548			     "aslocal[$aslocal]") if $CPAN::DEBUG;
2549		if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2550		    $Thesite = $i;
2551		    return $aslocal;
2552		}
2553		if ($aslocal !~ /\.gz(?!\n)\Z/) {
2554		    my $gz = "$aslocal.gz";
2555		    $CPAN::Frontend->myprint("Fetching with Net::FTP
2556  $url.gz
2557");
2558		   if (CPAN::FTP->ftp_get($host,
2559					   $dir,
2560					   "$getfile.gz",
2561					   $gz) &&
2562			CPAN::Tarzip->gunzip($gz,$aslocal)
2563		       ){
2564			$Thesite = $i;
2565			return $aslocal;
2566		    }
2567		}
2568		# next HOSTEASY;
2569	    }
2570	}
2571        return if $CPAN::Signal;
2572    }
2573}
2574
2575sub hosthard {
2576  my($self,$host_seq,$file,$aslocal) = @_;
2577
2578  # Came back if Net::FTP couldn't establish connection (or
2579  # failed otherwise) Maybe they are behind a firewall, but they
2580  # gave us a socksified (or other) ftp program...
2581
2582  my($i);
2583  my($devnull) = $CPAN::Config->{devnull} || "";
2584  # < /dev/null ";
2585  my($aslocal_dir) = File::Basename::dirname($aslocal);
2586  File::Path::mkpath($aslocal_dir);
2587  HOSTHARD: for $i (@$host_seq) {
2588	my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2589	$url .= "/" unless substr($url,-1) eq "/";
2590	$url .= $file;
2591	my($proto,$host,$dir,$getfile);
2592
2593	# Courtesy Mark Conty mark_conty@cargill.com change from
2594	# if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2595	# to
2596	if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2597	  # proto not yet used
2598	  ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2599	} else {
2600	  next HOSTHARD; # who said, we could ftp anything except ftp?
2601	}
2602        next HOSTHARD if $proto eq "file"; # file URLs would have had
2603                                           # success above. Likely a bogus URL
2604
2605	$self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2606	my($f,$funkyftp);
2607	for $f ('lynx','ncftpget','ncftp','wget') {
2608	  next unless exists $CPAN::Config->{$f};
2609	  $funkyftp = $CPAN::Config->{$f};
2610	  next unless defined $funkyftp;
2611	  next if $funkyftp =~ /^\s*$/;
2612	  my($asl_ungz, $asl_gz);
2613	  ($asl_ungz = $aslocal) =~ s/\.gz//;
2614          $asl_gz = "$asl_ungz.gz";
2615	  my($src_switch) = "";
2616	  if ($f eq "lynx"){
2617	    $src_switch = " -source";
2618	  } elsif ($f eq "ncftp"){
2619	    $src_switch = " -c";
2620          } elsif ($f eq "wget"){
2621              $src_switch = " -O -";
2622	  }
2623	  my($chdir) = "";
2624	  my($stdout_redir) = " > $asl_ungz";
2625	  if ($f eq "ncftpget"){
2626	    $chdir = "cd $aslocal_dir && ";
2627	    $stdout_redir = "";
2628	  }
2629	  $CPAN::Frontend->myprint(
2630				   qq[
2631Trying with "$funkyftp$src_switch" to get
2632    $url
2633]);
2634	  my($system) =
2635	      "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
2636	  $self->debug("system[$system]") if $CPAN::DEBUG;
2637	  my($wstatus);
2638	  if (($wstatus = system($system)) == 0
2639	      &&
2640	      ($f eq "lynx" ?
2641	       -s $asl_ungz # lynx returns 0 when it fails somewhere
2642	       : 1
2643	      )
2644	     ) {
2645	    if (-s $aslocal) {
2646	      # Looks good
2647	    } elsif ($asl_ungz ne $aslocal) {
2648	      # test gzip integrity
2649	      if (CPAN::Tarzip->gtest($asl_ungz)) {
2650                  # e.g. foo.tar is gzipped --> foo.tar.gz
2651                  rename $asl_ungz, $aslocal;
2652	      } else {
2653                  CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2654	      }
2655	    }
2656	    $Thesite = $i;
2657	    return $aslocal;
2658	  } elsif ($url !~ /\.gz(?!\n)\Z/) {
2659	    unlink $asl_ungz if
2660		-f $asl_ungz && -s _ == 0;
2661	    my $gz = "$aslocal.gz";
2662	    my $gzurl = "$url.gz";
2663	    $CPAN::Frontend->myprint(
2664				     qq[
2665Trying with "$funkyftp$src_switch" to get
2666  $url.gz
2667]);
2668	    my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
2669	    $self->debug("system[$system]") if $CPAN::DEBUG;
2670	    my($wstatus);
2671	    if (($wstatus = system($system)) == 0
2672		&&
2673		-s $asl_gz
2674	       ) {
2675	      # test gzip integrity
2676	      if (CPAN::Tarzip->gtest($asl_gz)) {
2677                  CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2678	      } else {
2679                  # somebody uncompressed file for us?
2680                  rename $asl_ungz, $aslocal;
2681	      }
2682	      $Thesite = $i;
2683	      return $aslocal;
2684	    } else {
2685	      unlink $asl_gz if -f $asl_gz;
2686	    }
2687	  } else {
2688	    my $estatus = $wstatus >> 8;
2689	    my $size = -f $aslocal ?
2690		", left\n$aslocal with size ".-s _ :
2691		    "\nWarning: expected file [$aslocal] doesn't exist";
2692	    $CPAN::Frontend->myprint(qq{
2693System call "$system"
2694returned status $estatus (wstat $wstatus)$size
2695});
2696	  }
2697          return if $CPAN::Signal;
2698	} # lynx,ncftpget,ncftp
2699    } # host
2700}
2701
2702sub hosthardest {
2703    my($self,$host_seq,$file,$aslocal) = @_;
2704
2705    my($i);
2706    my($aslocal_dir) = File::Basename::dirname($aslocal);
2707    File::Path::mkpath($aslocal_dir);
2708    my $ftpbin = $CPAN::Config->{ftp};
2709  HOSTHARDEST: for $i (@$host_seq) {
2710	unless (length $ftpbin && MM->maybe_command($ftpbin)) {
2711	    $CPAN::Frontend->myprint("No external ftp command available\n\n");
2712	    last HOSTHARDEST;
2713	}
2714	my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2715	$url .= "/" unless substr($url,-1) eq "/";
2716	$url .= $file;
2717	$self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2718	unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2719	    next;
2720	}
2721	my($host,$dir,$getfile) = ($1,$2,$3);
2722	my $timestamp = 0;
2723	my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2724	   $ctime,$blksize,$blocks) = stat($aslocal);
2725	$timestamp = $mtime ||= 0;
2726	my($netrc) = CPAN::FTP::netrc->new;
2727	my($netrcfile) = $netrc->netrc;
2728	my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2729	my $targetfile = File::Basename::basename($aslocal);
2730	my(@dialog);
2731	push(
2732	     @dialog,
2733	     "lcd $aslocal_dir",
2734	     "cd /",
2735	     map("cd $_", split /\//, $dir), # RFC 1738
2736	     "bin",
2737	     "get $getfile $targetfile",
2738	     "quit"
2739	    );
2740	if (! $netrcfile) {
2741	    CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2742	} elsif ($netrc->hasdefault || $netrc->contains($host)) {
2743	    CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2744				$netrc->hasdefault,
2745				$netrc->contains($host))) if $CPAN::DEBUG;
2746	    if ($netrc->protected) {
2747		$CPAN::Frontend->myprint(qq{
2748  Trying with external ftp to get
2749    $url
2750  As this requires some features that are not thoroughly tested, we\'re
2751  not sure, that we get it right....
2752
2753}
2754		     );
2755		$self->talk_ftp("$ftpbin$verbose $host",
2756				@dialog);
2757		($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2758		 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2759		$mtime ||= 0;
2760		if ($mtime > $timestamp) {
2761		    $CPAN::Frontend->myprint("GOT $aslocal\n");
2762		    $Thesite = $i;
2763		    return $aslocal;
2764		} else {
2765		    $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2766		}
2767                return if $CPAN::Signal;
2768	    } else {
2769		$CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2770					qq{correctly protected.\n});
2771	    }
2772	} else {
2773	    $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2774  nor does it have a default entry\n");
2775	}
2776
2777	# OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2778	# then and login manually to host, using e-mail as
2779	# password.
2780	$CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
2781	unshift(
2782		@dialog,
2783		"open $host",
2784		"user anonymous $Config::Config{'cf_email'}"
2785	       );
2786	$self->talk_ftp("$ftpbin$verbose -n", @dialog);
2787	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2788	 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2789	$mtime ||= 0;
2790	if ($mtime > $timestamp) {
2791	    $CPAN::Frontend->myprint("GOT $aslocal\n");
2792	    $Thesite = $i;
2793	    return $aslocal;
2794	} else {
2795	    $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2796	}
2797        return if $CPAN::Signal;
2798	$CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2799	sleep 2;
2800    } # host
2801}
2802
2803sub talk_ftp {
2804    my($self,$command,@dialog) = @_;
2805    my $fh = FileHandle->new;
2806    $fh->open("|$command") or die "Couldn't open ftp: $!";
2807    foreach (@dialog) { $fh->print("$_\n") }
2808    $fh->close;		# Wait for process to complete
2809    my $wstatus = $?;
2810    my $estatus = $wstatus >> 8;
2811    $CPAN::Frontend->myprint(qq{
2812Subprocess "|$command"
2813  returned status $estatus (wstat $wstatus)
2814}) if $wstatus;
2815}
2816
2817# find2perl needs modularization, too, all the following is stolen
2818# from there
2819# CPAN::FTP::ls
2820sub ls {
2821    my($self,$name) = @_;
2822    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2823     $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2824
2825    my($perms,%user,%group);
2826    my $pname = $name;
2827
2828    if ($blocks) {
2829	$blocks = int(($blocks + 1) / 2);
2830    }
2831    else {
2832	$blocks = int(($sizemm + 1023) / 1024);
2833    }
2834
2835    if    (-f _) { $perms = '-'; }
2836    elsif (-d _) { $perms = 'd'; }
2837    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2838    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2839    elsif (-p _) { $perms = 'p'; }
2840    elsif (-S _) { $perms = 's'; }
2841    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2842
2843    my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2844    my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2845    my $tmpmode = $mode;
2846    my $tmp = $rwx[$tmpmode & 7];
2847    $tmpmode >>= 3;
2848    $tmp = $rwx[$tmpmode & 7] . $tmp;
2849    $tmpmode >>= 3;
2850    $tmp = $rwx[$tmpmode & 7] . $tmp;
2851    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2852    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2853    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2854    $perms .= $tmp;
2855
2856    my $user = $user{$uid} || $uid;   # too lazy to implement lookup
2857    my $group = $group{$gid} || $gid;
2858
2859    my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2860    my($timeyear);
2861    my($moname) = $moname[$mon];
2862    if (-M _ > 365.25 / 2) {
2863	$timeyear = $year + 1900;
2864    }
2865    else {
2866	$timeyear = sprintf("%02d:%02d", $hour, $min);
2867    }
2868
2869    sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2870	    $ino,
2871		 $blocks,
2872		      $perms,
2873			    $nlink,
2874				$user,
2875				     $group,
2876					  $sizemm,
2877					      $moname,
2878						 $mday,
2879						     $timeyear,
2880							 $pname;
2881}
2882
2883package CPAN::FTP::netrc;
2884
2885sub new {
2886    my($class) = @_;
2887    my $file = File::Spec->catfile($ENV{HOME},".netrc");
2888
2889    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2890       $atime,$mtime,$ctime,$blksize,$blocks)
2891	= stat($file);
2892    $mode ||= 0;
2893    my $protected = 0;
2894
2895    my($fh,@machines,$hasdefault);
2896    $hasdefault = 0;
2897    $fh = FileHandle->new or die "Could not create a filehandle";
2898
2899    if($fh->open($file)){
2900	$protected = ($mode & 077) == 0;
2901	local($/) = "";
2902      NETRC: while (<$fh>) {
2903	    my(@tokens) = split " ", $_;
2904	  TOKEN: while (@tokens) {
2905		my($t) = shift @tokens;
2906		if ($t eq "default"){
2907		    $hasdefault++;
2908		    last NETRC;
2909		}
2910		last TOKEN if $t eq "macdef";
2911		if ($t eq "machine") {
2912		    push @machines, shift @tokens;
2913		}
2914	    }
2915	}
2916    } else {
2917	$file = $hasdefault = $protected = "";
2918    }
2919
2920    bless {
2921	   'mach' => [@machines],
2922	   'netrc' => $file,
2923	   'hasdefault' => $hasdefault,
2924	   'protected' => $protected,
2925	  }, $class;
2926}
2927
2928# CPAN::FTP::hasdefault;
2929sub hasdefault { shift->{'hasdefault'} }
2930sub netrc      { shift->{'netrc'}      }
2931sub protected  { shift->{'protected'}  }
2932sub contains {
2933    my($self,$mach) = @_;
2934    for ( @{$self->{'mach'}} ) {
2935	return 1 if $_ eq $mach;
2936    }
2937    return 0;
2938}
2939
2940package CPAN::Complete;
2941
2942sub gnu_cpl {
2943    my($text, $line, $start, $end) = @_;
2944    my(@perlret) = cpl($text, $line, $start);
2945    # find longest common match. Can anybody show me how to peruse
2946    # T::R::Gnu to have this done automatically? Seems expensive.
2947    return () unless @perlret;
2948    my($newtext) = $text;
2949    for (my $i = length($text)+1;;$i++) {
2950	last unless length($perlret[0]) && length($perlret[0]) >= $i;
2951	my $try = substr($perlret[0],0,$i);
2952	my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2953	# warn "try[$try]tries[@tries]";
2954	if (@tries == @perlret) {
2955	    $newtext = $try;
2956	} else {
2957	    last;
2958	}
2959    }
2960    ($newtext,@perlret);
2961}
2962
2963#-> sub CPAN::Complete::cpl ;
2964sub cpl {
2965    my($word,$line,$pos) = @_;
2966    $word ||= "";
2967    $line ||= "";
2968    $pos ||= 0;
2969    CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2970    $line =~ s/^\s*//;
2971    if ($line =~ s/^(force\s*)//) {
2972	$pos -= length($1);
2973    }
2974    my @return;
2975    if ($pos == 0) {
2976	@return = grep /^$word/, @CPAN::Complete::COMMANDS;
2977    } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
2978	@return = ();
2979    } elsif ($line =~ /^(a|ls)\s/) {
2980	@return = cplx('CPAN::Author',uc($word));
2981    } elsif ($line =~ /^b\s/) {
2982        CPAN::Shell->local_bundles;
2983	@return = cplx('CPAN::Bundle',$word);
2984    } elsif ($line =~ /^d\s/) {
2985	@return = cplx('CPAN::Distribution',$word);
2986    } elsif ($line =~ m/^(
2987                          [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
2988                         )\s/x ) {
2989        if ($word =~ /^Bundle::/) {
2990            CPAN::Shell->local_bundles;
2991        }
2992	@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2993    } elsif ($line =~ /^i\s/) {
2994	@return = cpl_any($word);
2995    } elsif ($line =~ /^reload\s/) {
2996	@return = cpl_reload($word,$line,$pos);
2997    } elsif ($line =~ /^o\s/) {
2998	@return = cpl_option($word,$line,$pos);
2999    } elsif ($line =~ m/^\S+\s/ ) {
3000        # fallback for future commands and what we have forgotten above
3001	@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3002    } else {
3003	@return = ();
3004    }
3005    return @return;
3006}
3007
3008#-> sub CPAN::Complete::cplx ;
3009sub cplx {
3010    my($class, $word) = @_;
3011    # I believed for many years that this was sorted, today I
3012    # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3013    # make it sorted again. Maybe sort was dropped when GNU-readline
3014    # support came in? The RCS file is difficult to read on that:-(
3015    sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3016}
3017
3018#-> sub CPAN::Complete::cpl_any ;
3019sub cpl_any {
3020    my($word) = shift;
3021    return (
3022	    cplx('CPAN::Author',$word),
3023	    cplx('CPAN::Bundle',$word),
3024	    cplx('CPAN::Distribution',$word),
3025	    cplx('CPAN::Module',$word),
3026	   );
3027}
3028
3029#-> sub CPAN::Complete::cpl_reload ;
3030sub cpl_reload {
3031    my($word,$line,$pos) = @_;
3032    $word ||= "";
3033    my(@words) = split " ", $line;
3034    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3035    my(@ok) = qw(cpan index);
3036    return @ok if @words == 1;
3037    return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3038}
3039
3040#-> sub CPAN::Complete::cpl_option ;
3041sub cpl_option {
3042    my($word,$line,$pos) = @_;
3043    $word ||= "";
3044    my(@words) = split " ", $line;
3045    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3046    my(@ok) = qw(conf debug);
3047    return @ok if @words == 1;
3048    return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3049    if (0) {
3050    } elsif ($words[1] eq 'index') {
3051	return ();
3052    } elsif ($words[1] eq 'conf') {
3053	return CPAN::Config::cpl(@_);
3054    } elsif ($words[1] eq 'debug') {
3055	return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
3056    }
3057}
3058
3059package CPAN::Index;
3060
3061#-> sub CPAN::Index::force_reload ;
3062sub force_reload {
3063    my($class) = @_;
3064    $CPAN::Index::LAST_TIME = 0;
3065    $class->reload(1);
3066}
3067
3068#-> sub CPAN::Index::reload ;
3069sub reload {
3070    my($cl,$force) = @_;
3071    my $time = time;
3072
3073    # XXX check if a newer one is available. (We currently read it
3074    # from time to time)
3075    for ($CPAN::Config->{index_expire}) {
3076	$_ = 0.001 unless $_ && $_ > 0.001;
3077    }
3078    unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3079        # debug here when CPAN doesn't seem to read the Metadata
3080        require Carp;
3081        Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3082    }
3083    unless ($CPAN::META->{PROTOCOL}) {
3084        $cl->read_metadata_cache;
3085        $CPAN::META->{PROTOCOL} ||= "1.0";
3086    }
3087    if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
3088        # warn "Setting last_time to 0";
3089        $LAST_TIME = 0; # No warning necessary
3090    }
3091    return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3092	and ! $force;
3093    if (0) {
3094        # IFF we are developing, it helps to wipe out the memory
3095        # between reloads, otherwise it is not what a user expects.
3096        undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3097        $CPAN::META = CPAN->new;
3098    }
3099    {
3100        my($debug,$t2);
3101        local $LAST_TIME = $time;
3102        local $CPAN::META->{PROTOCOL} = PROTOCOL;
3103
3104        my $needshort = $^O eq "dos";
3105
3106        $cl->rd_authindex($cl
3107                          ->reload_x(
3108                                     "authors/01mailrc.txt.gz",
3109                                     $needshort ?
3110                                     File::Spec->catfile('authors', '01mailrc.gz') :
3111                                     File::Spec->catfile('authors', '01mailrc.txt.gz'),
3112                                     $force));
3113        $t2 = time;
3114        $debug = "timing reading 01[".($t2 - $time)."]";
3115        $time = $t2;
3116        return if $CPAN::Signal; # this is sometimes lengthy
3117        $cl->rd_modpacks($cl
3118                         ->reload_x(
3119                                    "modules/02packages.details.txt.gz",
3120                                    $needshort ?
3121                                    File::Spec->catfile('modules', '02packag.gz') :
3122                                    File::Spec->catfile('modules', '02packages.details.txt.gz'),
3123                                    $force));
3124        $t2 = time;
3125        $debug .= "02[".($t2 - $time)."]";
3126        $time = $t2;
3127        return if $CPAN::Signal; # this is sometimes lengthy
3128        $cl->rd_modlist($cl
3129                        ->reload_x(
3130                                   "modules/03modlist.data.gz",
3131                                   $needshort ?
3132                                   File::Spec->catfile('modules', '03mlist.gz') :
3133                                   File::Spec->catfile('modules', '03modlist.data.gz'),
3134                                   $force));
3135        $cl->write_metadata_cache;
3136        $t2 = time;
3137        $debug .= "03[".($t2 - $time)."]";
3138        $time = $t2;
3139        CPAN->debug($debug) if $CPAN::DEBUG;
3140    }
3141    $LAST_TIME = $time;
3142    $CPAN::META->{PROTOCOL} = PROTOCOL;
3143}
3144
3145#-> sub CPAN::Index::reload_x ;
3146sub reload_x {
3147    my($cl,$wanted,$localname,$force) = @_;
3148    $force |= 2; # means we're dealing with an index here
3149    CPAN::Config->load; # we should guarantee loading wherever we rely
3150                        # on Config XXX
3151    $localname ||= $wanted;
3152    my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3153					 $localname);
3154    if (
3155	-f $abs_wanted &&
3156	-M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3157	!($force & 1)
3158       ) {
3159	my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3160	$cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3161		   qq{day$s. I\'ll use that.});
3162	return $abs_wanted;
3163    } else {
3164	$force |= 1; # means we're quite serious about it.
3165    }
3166    return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3167}
3168
3169#-> sub CPAN::Index::rd_authindex ;
3170sub rd_authindex {
3171    my($cl, $index_target) = @_;
3172    my @lines;
3173    return unless defined $index_target;
3174    $CPAN::Frontend->myprint("Going to read $index_target\n");
3175    local(*FH);
3176    tie *FH, CPAN::Tarzip, $index_target;
3177    local($/) = "\n";
3178    push @lines, split /\012/ while <FH>;
3179    foreach (@lines) {
3180	my($userid,$fullname,$email) =
3181	    m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3182	next unless $userid && $fullname && $email;
3183
3184	# instantiate an author object
3185 	my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3186	$userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3187	return if $CPAN::Signal;
3188    }
3189}
3190
3191sub userid {
3192  my($self,$dist) = @_;
3193  $dist = $self->{'id'} unless defined $dist;
3194  my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3195  $ret;
3196}
3197
3198#-> sub CPAN::Index::rd_modpacks ;
3199sub rd_modpacks {
3200    my($self, $index_target) = @_;
3201    my @lines;
3202    return unless defined $index_target;
3203    $CPAN::Frontend->myprint("Going to read $index_target\n");
3204    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3205    local($/) = "\n";
3206    while ($_ = $fh->READLINE) {
3207	s/\012/\n/g;
3208	my @ls = map {"$_\n"} split /\n/, $_;
3209	unshift @ls, "\n" x length($1) if /^(\n+)/;
3210	push @lines, @ls;
3211    }
3212    # read header
3213    my($line_count,$last_updated);
3214    while (@lines) {
3215	my $shift = shift(@lines);
3216	last if $shift =~ /^\s*$/;
3217	$shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3218        $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3219    }
3220    if (not defined $line_count) {
3221
3222	warn qq{Warning: Your $index_target does not contain a Line-Count header.
3223Please check the validity of the index file by comparing it to more
3224than one CPAN mirror. I'll continue but problems seem likely to
3225happen.\a
3226};
3227
3228	sleep 5;
3229    } elsif ($line_count != scalar @lines) {
3230
3231	warn sprintf qq{Warning: Your %s
3232contains a Line-Count header of %d but I see %d lines there. Please
3233check the validity of the index file by comparing it to more than one
3234CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3235$index_target, $line_count, scalar(@lines);
3236
3237    }
3238    if (not defined $last_updated) {
3239
3240	warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3241Please check the validity of the index file by comparing it to more
3242than one CPAN mirror. I'll continue but problems seem likely to
3243happen.\a
3244};
3245
3246	sleep 5;
3247    } else {
3248
3249	$CPAN::Frontend
3250            ->myprint(sprintf qq{  Database was generated on %s\n},
3251                      $last_updated);
3252        $DATE_OF_02 = $last_updated;
3253
3254        if ($CPAN::META->has_inst(HTTP::Date)) {
3255            require HTTP::Date;
3256            my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3257            if ($age > 30) {
3258
3259                $CPAN::Frontend
3260                    ->mywarn(sprintf
3261                             qq{Warning: This index file is %d days old.
3262  Please check the host you chose as your CPAN mirror for staleness.
3263  I'll continue but problems seem likely to happen.\a\n},
3264                             $age);
3265
3266            }
3267        } else {
3268            $CPAN::Frontend->myprint("  HTTP::Date not available\n");
3269        }
3270    }
3271
3272
3273    # A necessity since we have metadata_cache: delete what isn't
3274    # there anymore
3275    my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3276    CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3277    my(%exists);
3278    foreach (@lines) {
3279	chomp;
3280        # before 1.56 we split into 3 and discarded the rest. From
3281        # 1.57 we assign remaining text to $comment thus allowing to
3282        # influence isa_perl
3283	my($mod,$version,$dist,$comment) = split " ", $_, 4;
3284	my($bundle,$id,$userid);
3285
3286	if ($mod eq 'CPAN' &&
3287	    ! (
3288	       CPAN::Queue->exists('Bundle::CPAN') ||
3289	       CPAN::Queue->exists('CPAN')
3290	      )
3291	   ) {
3292            local($^W)= 0;
3293            if ($version > $CPAN::VERSION){
3294                $CPAN::Frontend->myprint(qq{
3295  There's a new CPAN.pm version (v$version) available!
3296  [Current version is v$CPAN::VERSION]
3297  You might want to try
3298    install Bundle::CPAN
3299    reload cpan
3300  without quitting the current session. It should be a seamless upgrade
3301  while we are running...
3302}); #});
3303                sleep 2;
3304		$CPAN::Frontend->myprint(qq{\n});
3305	    }
3306	    last if $CPAN::Signal;
3307	} elsif ($mod =~ /^Bundle::(.*)/) {
3308	    $bundle = $1;
3309	}
3310
3311	if ($bundle){
3312	    $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
3313	    # Let's make it a module too, because bundles have so much
3314	    # in common with modules.
3315
3316            # Changed in 1.57_63: seems like memory bloat now without
3317            # any value, so commented out
3318
3319	    # $CPAN::META->instance('CPAN::Module',$mod);
3320
3321	} else {
3322
3323	    # instantiate a module object
3324	    $id = $CPAN::META->instance('CPAN::Module',$mod);
3325
3326	}
3327
3328	if ($id->cpan_file ne $dist){ # update only if file is
3329                                      # different. CPAN prohibits same
3330                                      # name with different version
3331	    $userid = $id->userid || $self->userid($dist);
3332	    $id->set(
3333		     'CPAN_USERID' => $userid,
3334		     'CPAN_VERSION' => $version,
3335		     'CPAN_FILE' => $dist,
3336		    );
3337	}
3338
3339	# instantiate a distribution object
3340	if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3341	  # we do not need CONTAINSMODS unless we do something with
3342	  # this dist, so we better produce it on demand.
3343
3344	  ## my $obj = $CPAN::META->instance(
3345	  ## 				  'CPAN::Distribution' => $dist
3346	  ## 				 );
3347	  ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3348	} else {
3349	  $CPAN::META->instance(
3350				'CPAN::Distribution' => $dist
3351			       )->set(
3352				      'CPAN_USERID' => $userid,
3353                                      'CPAN_COMMENT' => $comment,
3354				     );
3355	}
3356        if ($secondtime) {
3357            for my $name ($mod,$dist) {
3358                CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
3359                $exists{$name} = undef;
3360            }
3361        }
3362	return if $CPAN::Signal;
3363    }
3364    undef $fh;
3365    if ($secondtime) {
3366        for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3367            for my $o ($CPAN::META->all_objects($class)) {
3368                next if exists $exists{$o->{ID}};
3369                $CPAN::META->delete($class,$o->{ID});
3370                CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3371                    if $CPAN::DEBUG;
3372            }
3373        }
3374    }
3375}
3376
3377#-> sub CPAN::Index::rd_modlist ;
3378sub rd_modlist {
3379    my($cl,$index_target) = @_;
3380    return unless defined $index_target;
3381    $CPAN::Frontend->myprint("Going to read $index_target\n");
3382    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3383    my @eval;
3384    local($/) = "\n";
3385    while ($_ = $fh->READLINE) {
3386	s/\012/\n/g;
3387	my @ls = map {"$_\n"} split /\n/, $_;
3388	unshift @ls, "\n" x length($1) if /^(\n+)/;
3389	push @eval, @ls;
3390    }
3391    while (@eval) {
3392	my $shift = shift(@eval);
3393	if ($shift =~ /^Date:\s+(.*)/){
3394	    return if $DATE_OF_03 eq $1;
3395	    ($DATE_OF_03) = $1;
3396	}
3397	last if $shift =~ /^\s*$/;
3398    }
3399    undef $fh;
3400    push @eval, q{CPAN::Modulelist->data;};
3401    local($^W) = 0;
3402    my($comp) = Safe->new("CPAN::Safe1");
3403    my($eval) = join("", @eval);
3404    my $ret = $comp->reval($eval);
3405    Carp::confess($@) if $@;
3406    return if $CPAN::Signal;
3407    for (keys %$ret) {
3408	my $obj = $CPAN::META->instance("CPAN::Module",$_);
3409        delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
3410	$obj->set(%{$ret->{$_}});
3411	return if $CPAN::Signal;
3412    }
3413}
3414
3415#-> sub CPAN::Index::write_metadata_cache ;
3416sub write_metadata_cache {
3417    my($self) = @_;
3418    return unless $CPAN::Config->{'cache_metadata'};
3419    return unless $CPAN::META->has_usable("Storable");
3420    my $cache;
3421    foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3422		      CPAN::Distribution)) {
3423	$cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
3424    }
3425    my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3426    $cache->{last_time} = $LAST_TIME;
3427    $cache->{DATE_OF_02} = $DATE_OF_02;
3428    $cache->{PROTOCOL} = PROTOCOL;
3429    $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3430    eval { Storable::nstore($cache, $metadata_file) };
3431    $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3432}
3433
3434#-> sub CPAN::Index::read_metadata_cache ;
3435sub read_metadata_cache {
3436    my($self) = @_;
3437    return unless $CPAN::Config->{'cache_metadata'};
3438    return unless $CPAN::META->has_usable("Storable");
3439    my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
3440    return unless -r $metadata_file and -f $metadata_file;
3441    $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3442    my $cache;
3443    eval { $cache = Storable::retrieve($metadata_file) };
3444    $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
3445    if (!$cache || ref $cache ne 'HASH'){
3446        $LAST_TIME = 0;
3447        return;
3448    }
3449    if (exists $cache->{PROTOCOL}) {
3450        if (PROTOCOL > $cache->{PROTOCOL}) {
3451            $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3452                                            "with protocol v%s, requiring v%s\n",
3453                                            $cache->{PROTOCOL},
3454                                            PROTOCOL)
3455                                   );
3456            return;
3457        }
3458    } else {
3459        $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3460                                "with protocol v1.0\n");
3461        return;
3462    }
3463    my $clcnt = 0;
3464    my $idcnt = 0;
3465    while(my($class,$v) = each %$cache) {
3466	next unless $class =~ /^CPAN::/;
3467	$CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3468        while (my($id,$ro) = each %$v) {
3469            $CPAN::META->{readwrite}{$class}{$id} ||=
3470                $class->new(ID=>$id, RO=>$ro);
3471            $idcnt++;
3472        }
3473        $clcnt++;
3474    }
3475    unless ($clcnt) { # sanity check
3476        $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3477        return;
3478    }
3479    if ($idcnt < 1000) {
3480        $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3481                                 "in $metadata_file\n");
3482        return;
3483    }
3484    $CPAN::META->{PROTOCOL} ||=
3485        $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3486                            # does initialize to some protocol
3487    $LAST_TIME = $cache->{last_time};
3488    $DATE_OF_02 = $cache->{DATE_OF_02};
3489    $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
3490	if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
3491    return;
3492}
3493
3494package CPAN::InfoObj;
3495
3496# Accessors
3497sub cpan_userid {
3498    my $self = shift;
3499    $self->{RO}{CPAN_USERID}
3500}
3501
3502sub id { shift->{ID}; }
3503
3504#-> sub CPAN::InfoObj::new ;
3505sub new {
3506    my $this = bless {}, shift;
3507    %$this = @_;
3508    $this
3509}
3510
3511# The set method may only be used by code that reads index data or
3512# otherwise "objective" data from the outside world. All session
3513# related material may do anything else with instance variables but
3514# must not touch the hash under the RO attribute. The reason is that
3515# the RO hash gets written to Metadata file and is thus persistent.
3516
3517#-> sub CPAN::InfoObj::set ;
3518sub set {
3519    my($self,%att) = @_;
3520    my $class = ref $self;
3521
3522    # This must be ||=, not ||, because only if we write an empty
3523    # reference, only then the set method will write into the readonly
3524    # area. But for Distributions that spring into existence, maybe
3525    # because of a typo, we do not like it that they are written into
3526    # the readonly area and made permanent (at least for a while) and
3527    # that is why we do not "allow" other places to call ->set.
3528    unless ($self->id) {
3529        CPAN->debug("Bug? Empty ID, rejecting");
3530        return;
3531    }
3532    my $ro = $self->{RO} =
3533        $CPAN::META->{readonly}{$class}{$self->id} ||= {};
3534
3535    while (my($k,$v) = each %att) {
3536        $ro->{$k} = $v;
3537    }
3538}
3539
3540#-> sub CPAN::InfoObj::as_glimpse ;
3541sub as_glimpse {
3542    my($self) = @_;
3543    my(@m);
3544    my $class = ref($self);
3545    $class =~ s/^CPAN:://;
3546    push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3547    join "", @m;
3548}
3549
3550#-> sub CPAN::InfoObj::as_string ;
3551sub as_string {
3552    my($self) = @_;
3553    my(@m);
3554    my $class = ref($self);
3555    $class =~ s/^CPAN:://;
3556    push @m, $class, " id = $self->{ID}\n";
3557    for (sort keys %{$self->{RO}}) {
3558	# next if m/^(ID|RO)$/;
3559	my $extra = "";
3560	if ($_ eq "CPAN_USERID") {
3561            $extra .= " (".$self->author;
3562            my $email; # old perls!
3563            if ($email = $CPAN::META->instance("CPAN::Author",
3564                                               $self->cpan_userid
3565                                              )->email) {
3566                $extra .= " <$email>";
3567            } else {
3568                $extra .= " <no email>";
3569            }
3570            $extra .= ")";
3571        } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3572            push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
3573            next;
3574        }
3575        next unless defined $self->{RO}{$_};
3576        push @m, sprintf "    %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3577    }
3578    for (sort keys %$self) {
3579	next if m/^(ID|RO)$/;
3580	if (ref($self->{$_}) eq "ARRAY") {
3581	  push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
3582	} elsif (ref($self->{$_}) eq "HASH") {
3583	  push @m, sprintf(
3584			   "    %-12s %s\n",
3585			   $_,
3586			   join(" ",keys %{$self->{$_}}),
3587                          );
3588	} else {
3589	  push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
3590	}
3591    }
3592    join "", @m, "\n";
3593}
3594
3595#-> sub CPAN::InfoObj::author ;
3596sub author {
3597    my($self) = @_;
3598    $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
3599}
3600
3601#-> sub CPAN::InfoObj::dump ;
3602sub dump {
3603  my($self) = @_;
3604  require Data::Dumper;
3605  print Data::Dumper::Dumper($self);
3606}
3607
3608package CPAN::Author;
3609
3610#-> sub CPAN::Author::id
3611sub id {
3612    my $self = shift;
3613    my $id = $self->{ID};
3614    $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3615    $id;
3616}
3617
3618#-> sub CPAN::Author::as_glimpse ;
3619sub as_glimpse {
3620    my($self) = @_;
3621    my(@m);
3622    my $class = ref($self);
3623    $class =~ s/^CPAN:://;
3624    push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3625                     $class,
3626                     $self->{ID},
3627                     $self->fullname,
3628                     $self->email);
3629    join "", @m;
3630}
3631
3632#-> sub CPAN::Author::fullname ;
3633sub fullname {
3634    shift->{RO}{FULLNAME};
3635}
3636*name = \&fullname;
3637
3638#-> sub CPAN::Author::email ;
3639sub email    { shift->{RO}{EMAIL}; }
3640
3641#-> sub CPAN::Author::ls ;
3642sub ls {
3643    my $self = shift;
3644    my $id = $self->id;
3645
3646    # adapted from CPAN::Distribution::verifyMD5 ;
3647    my(@csf); # chksumfile
3648    @csf = $self->id =~ /(.)(.)(.*)/;
3649    $csf[1] = join "", @csf[0,1];
3650    $csf[2] = join "", @csf[1,2];
3651    my(@dl);
3652    @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3653    unless (grep {$_->[2] eq $csf[1]} @dl) {
3654        $CPAN::Frontend->myprint("No files in the directory of $id\n");
3655        return;
3656    }
3657    @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3658    unless (grep {$_->[2] eq $csf[2]} @dl) {
3659        $CPAN::Frontend->myprint("No files in the directory of $id\n");
3660        return;
3661    }
3662    @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3663    $CPAN::Frontend->myprint(join "", map {
3664        sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
3665    } sort { $a->[2] cmp $b->[2] } @dl);
3666}
3667
3668# returns an array of arrays, the latter contain (size,mtime,filename)
3669#-> sub CPAN::Author::dir_listing ;
3670sub dir_listing {
3671    my $self = shift;
3672    my $chksumfile = shift;
3673    my $recursive = shift;
3674    my $lc_want =
3675	File::Spec->catfile($CPAN::Config->{keep_source_where},
3676			    "authors", "id", @$chksumfile);
3677    local($") = "/";
3678    # connect "force" argument with "index_expire".
3679    my $force = 0;
3680    if (my @stat = stat $lc_want) {
3681        $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3682    }
3683    my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3684                                      $lc_want,$force);
3685    unless ($lc_file) {
3686        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3687	$chksumfile->[-1] .= ".gz";
3688	$lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
3689                                       "$lc_want.gz",1);
3690	if ($lc_file) {
3691	    $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3692	    CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3693	} else {
3694	    return;
3695	}
3696    }
3697
3698    # adapted from CPAN::Distribution::MD5_check_file ;
3699    my $fh = FileHandle->new;
3700    my($cksum);
3701    if (open $fh, $lc_file){
3702	local($/);
3703	my $eval = <$fh>;
3704	$eval =~ s/\015?\012/\n/g;
3705	close $fh;
3706	my($comp) = Safe->new();
3707	$cksum = $comp->reval($eval);
3708	if ($@) {
3709	    rename $lc_file, "$lc_file.bad";
3710	    Carp::confess($@) if $@;
3711	}
3712    } else {
3713	Carp::carp "Could not open $lc_file for reading";
3714    }
3715    my(@result,$f);
3716    for $f (sort keys %$cksum) {
3717        if (exists $cksum->{$f}{isdir}) {
3718            if ($recursive) {
3719                my(@dir) = @$chksumfile;
3720                pop @dir;
3721                push @dir, $f, "CHECKSUMS";
3722                push @result, map {
3723                    [$_->[0], $_->[1], "$f/$_->[2]"]
3724                } $self->dir_listing(\@dir,1);
3725            } else {
3726                push @result, [ 0, "-", $f ];
3727            }
3728        } else {
3729            push @result, [
3730                           ($cksum->{$f}{"size"}||0),
3731                           $cksum->{$f}{"mtime"}||"---",
3732                           $f
3733                          ];
3734        }
3735    }
3736    @result;
3737}
3738
3739package CPAN::Distribution;
3740
3741# Accessors
3742sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3743
3744sub undelay {
3745    my $self = shift;
3746    delete $self->{later};
3747}
3748
3749# CPAN::Distribution::normalize
3750sub normalize {
3751    my($self,$s) = @_;
3752    $s = $self->id unless defined $s;
3753    if (
3754        $s =~ tr|/|| == 1
3755        or
3756        $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3757       ) {
3758        return $s if $s =~ m:^N/A|^Contact Author: ;
3759        $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3760            $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
3761        CPAN->debug("s[$s]") if $CPAN::DEBUG;
3762    }
3763    $s;
3764}
3765
3766#-> sub CPAN::Distribution::color_cmd_tmps ;
3767sub color_cmd_tmps {
3768    my($self) = shift;
3769    my($depth) = shift || 0;
3770    my($color) = shift || 0;
3771    my($ancestors) = shift || [];
3772    # a distribution needs to recurse into its prereq_pms
3773
3774    return if exists $self->{incommandcolor}
3775        && $self->{incommandcolor}==$color;
3776    if ($depth>=100){
3777        $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
3778    }
3779    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3780    my $prereq_pm = $self->prereq_pm;
3781    if (defined $prereq_pm) {
3782        for my $pre (keys %$prereq_pm) {
3783            my $premo = CPAN::Shell->expand("Module",$pre);
3784            $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
3785        }
3786    }
3787    if ($color==0) {
3788        delete $self->{sponsored_mods};
3789        delete $self->{badtestcnt};
3790    }
3791    $self->{incommandcolor} = $color;
3792}
3793
3794#-> sub CPAN::Distribution::as_string ;
3795sub as_string {
3796  my $self = shift;
3797  $self->containsmods;
3798  $self->SUPER::as_string(@_);
3799}
3800
3801#-> sub CPAN::Distribution::containsmods ;
3802sub containsmods {
3803  my $self = shift;
3804  return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3805  my $dist_id = $self->{ID};
3806  for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3807    my $mod_file = $mod->cpan_file or next;
3808    my $mod_id = $mod->{ID} or next;
3809    # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3810    # sleep 1;
3811    $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3812  }
3813  keys %{$self->{CONTAINSMODS}};
3814}
3815
3816#-> sub CPAN::Distribution::uptodate ;
3817sub uptodate {
3818    my($self) = @_;
3819    my $c;
3820    foreach $c ($self->containsmods) {
3821        my $obj = CPAN::Shell->expandany($c);
3822        return 0 unless $obj->uptodate;
3823    }
3824    return 1;
3825}
3826
3827#-> sub CPAN::Distribution::called_for ;
3828sub called_for {
3829    my($self,$id) = @_;
3830    $self->{CALLED_FOR} = $id if defined $id;
3831    return $self->{CALLED_FOR};
3832}
3833
3834#-> sub CPAN::Distribution::safe_chdir ;
3835sub safe_chdir {
3836    my($self,$todir) = @_;
3837    # we die if we cannot chdir and we are debuggable
3838    Carp::confess("safe_chdir called without todir argument")
3839          unless defined $todir and length $todir;
3840    if (chdir $todir) {
3841        $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3842            if $CPAN::DEBUG;
3843    } else {
3844        my $cwd = CPAN::anycwd();
3845        $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3846                               qq{to todir[$todir]: $!});
3847    }
3848}
3849
3850#-> sub CPAN::Distribution::get ;
3851sub get {
3852    my($self) = @_;
3853  EXCUSE: {
3854	my @e;
3855	exists $self->{'build_dir'} and push @e,
3856	    "Is already unwrapped into directory $self->{'build_dir'}";
3857	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3858    }
3859    my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3860
3861    #
3862    # Get the file on local disk
3863    #
3864
3865    my($local_file);
3866    my($local_wanted) =
3867        File::Spec->catfile(
3868			    $CPAN::Config->{keep_source_where},
3869			    "authors",
3870			    "id",
3871			    split(/\//,$self->id)
3872			   );
3873
3874    $self->debug("Doing localize") if $CPAN::DEBUG;
3875    unless ($local_file =
3876            CPAN::FTP->localize("authors/id/$self->{ID}",
3877                                $local_wanted)) {
3878        my $note = "";
3879        if ($CPAN::Index::DATE_OF_02) {
3880            $note = "Note: Current database in memory was generated ".
3881                "on $CPAN::Index::DATE_OF_02\n";
3882        }
3883        $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3884    }
3885    $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3886    $self->{localfile} = $local_file;
3887    return if $CPAN::Signal;
3888
3889    #
3890    # Check integrity
3891    #
3892    if ($CPAN::META->has_inst("Digest::MD5")) {
3893	$self->debug("Digest::MD5 is installed, verifying");
3894	$self->verifyMD5;
3895    } else {
3896	$self->debug("Digest::MD5 is NOT installed");
3897    }
3898    return if $CPAN::Signal;
3899
3900    #
3901    # Create a clean room and go there
3902    #
3903    $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3904    my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3905    $self->safe_chdir($builddir);
3906    $self->debug("Removing tmp") if $CPAN::DEBUG;
3907    File::Path::rmtree("tmp");
3908    mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3909    if ($CPAN::Signal){
3910        $self->safe_chdir($sub_wd);
3911        return;
3912    }
3913    $self->safe_chdir("tmp");
3914
3915    #
3916    # Unpack the goods
3917    #
3918    if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3919        $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3920	$self->untar_me($local_file);
3921    } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3922	$self->unzip_me($local_file);
3923    } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3924        $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
3925	$self->pm2dir_me($local_file);
3926    } else {
3927	$self->{archived} = "NO";
3928        $self->safe_chdir($sub_wd);
3929        return;
3930    }
3931
3932    # we are still in the tmp directory!
3933    # Let's check if the package has its own directory.
3934    my $dh = DirHandle->new(File::Spec->curdir)
3935        or Carp::croak("Couldn't opendir .: $!");
3936    my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3937    $dh->close;
3938    my ($distdir,$packagedir);
3939    if (@readdir == 1 && -d $readdir[0]) {
3940        $distdir = $readdir[0];
3941        $packagedir = File::Spec->catdir($builddir,$distdir);
3942        $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3943            if $CPAN::DEBUG;
3944        -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3945                                                    "$packagedir\n");
3946        File::Path::rmtree($packagedir);
3947        rename($distdir,$packagedir) or
3948            Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3949        $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3950                             $distdir,
3951                             $packagedir,
3952                             -e $packagedir,
3953                             -d $packagedir,
3954                            )) if $CPAN::DEBUG;
3955    } else {
3956        my $userid = $self->cpan_userid;
3957        unless ($userid) {
3958            CPAN->debug("no userid? self[$self]");
3959            $userid = "anon";
3960        }
3961        my $pragmatic_dir = $userid . '000';
3962        $pragmatic_dir =~ s/\W_//g;
3963        $pragmatic_dir++ while -d "../$pragmatic_dir";
3964        $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
3965        $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3966        File::Path::mkpath($packagedir);
3967        my($f);
3968        for $f (@readdir) { # is already without "." and ".."
3969            my $to = File::Spec->catdir($packagedir,$f);
3970            rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3971        }
3972    }
3973    if ($CPAN::Signal){
3974        $self->safe_chdir($sub_wd);
3975        return;
3976    }
3977
3978    $self->{'build_dir'} = $packagedir;
3979    $self->safe_chdir($builddir);
3980    File::Path::rmtree("tmp");
3981
3982    my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
3983    my($mpl_exists) = -f $mpl;
3984    unless ($mpl_exists) {
3985        # NFS has been reported to have racing problems after the
3986        # renaming of a directory in some environments.
3987        # This trick helps.
3988        sleep 1;
3989        my $mpldh = DirHandle->new($packagedir)
3990            or Carp::croak("Couldn't opendir $packagedir: $!");
3991        $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3992        $mpldh->close;
3993    }
3994    unless ($mpl_exists) {
3995        $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3996                             $mpl,
3997                             CPAN::anycwd(),
3998                            )) if $CPAN::DEBUG;
3999        my($configure) = File::Spec->catfile($packagedir,"Configure");
4000        if (-f $configure) {
4001            # do we have anything to do?
4002            $self->{'configure'} = $configure;
4003        } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
4004            $CPAN::Frontend->myprint(qq{
4005Package comes with a Makefile and without a Makefile.PL.
4006We\'ll try to build it with that Makefile then.
4007});
4008            $self->{writemakefile} = "YES";
4009            sleep 2;
4010        } else {
4011            my $cf = $self->called_for || "unknown";
4012            if ($cf =~ m|/|) {
4013                $cf =~ s|.*/||;
4014                $cf =~ s|\W.*||;
4015            }
4016            $cf =~ s|[/\\:]||g; # risk of filesystem damage
4017            $cf = "unknown" unless length($cf);
4018            $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
4019  (The test -f "$mpl" returned false.)
4020  Writing one on our own (setting NAME to $cf)\a\n});
4021            $self->{had_no_makefile_pl}++;
4022            sleep 3;
4023
4024            # Writing our own Makefile.PL
4025
4026            my $fh = FileHandle->new;
4027            $fh->open(">$mpl")
4028                or Carp::croak("Could not open >$mpl: $!");
4029            $fh->print(
4030qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
4031# because there was no Makefile.PL supplied.
4032# Autogenerated on: }.scalar localtime().qq{
4033
4034use ExtUtils::MakeMaker;
4035WriteMakefile(NAME => q[$cf]);
4036
4037});
4038            $fh->close;
4039        }
4040    }
4041
4042    return $self;
4043}
4044
4045# CPAN::Distribution::untar_me ;
4046sub untar_me {
4047    my($self,$local_file) = @_;
4048    $self->{archived} = "tar";
4049    if (CPAN::Tarzip->untar($local_file)) {
4050	$self->{unwrapped} = "YES";
4051    } else {
4052	$self->{unwrapped} = "NO";
4053    }
4054}
4055
4056# CPAN::Distribution::unzip_me ;
4057sub unzip_me {
4058    my($self,$local_file) = @_;
4059    $self->{archived} = "zip";
4060    if (CPAN::Tarzip->unzip($local_file)) {
4061	$self->{unwrapped} = "YES";
4062    } else {
4063	$self->{unwrapped} = "NO";
4064    }
4065    return;
4066}
4067
4068sub pm2dir_me {
4069    my($self,$local_file) = @_;
4070    $self->{archived} = "pm";
4071    my $to = File::Basename::basename($local_file);
4072    $to =~ s/\.(gz|Z)(?!\n)\Z//;
4073    if (CPAN::Tarzip->gunzip($local_file,$to)) {
4074	$self->{unwrapped} = "YES";
4075    } else {
4076	$self->{unwrapped} = "NO";
4077    }
4078}
4079
4080#-> sub CPAN::Distribution::new ;
4081sub new {
4082    my($class,%att) = @_;
4083
4084    # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
4085
4086    my $this = { %att };
4087    return bless $this, $class;
4088}
4089
4090#-> sub CPAN::Distribution::look ;
4091sub look {
4092    my($self) = @_;
4093
4094    if ($^O eq 'MacOS') {
4095      $self->Mac::BuildTools::look;
4096      return;
4097    }
4098
4099    if (  $CPAN::Config->{'shell'} ) {
4100	$CPAN::Frontend->myprint(qq{
4101Trying to open a subshell in the build directory...
4102});
4103    } else {
4104	$CPAN::Frontend->myprint(qq{
4105Your configuration does not define a value for subshells.
4106Please define it with "o conf shell <your shell>"
4107});
4108	return;
4109    }
4110    my $dist = $self->id;
4111    my $dir;
4112    unless ($dir = $self->dir) {
4113        $self->get;
4114    }
4115    unless ($dir ||= $self->dir) {
4116	$CPAN::Frontend->mywarn(qq{
4117Could not determine which directory to use for looking at $dist.
4118});
4119	return;
4120    }
4121    my $pwd  = CPAN::anycwd();
4122    $self->safe_chdir($dir);
4123    $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4124    unless (system($CPAN::Config->{'shell'}) == 0) {
4125        my $code = $? >> 8;
4126        $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
4127    }
4128    $self->safe_chdir($pwd);
4129}
4130
4131# CPAN::Distribution::cvs_import ;
4132sub cvs_import {
4133    my($self) = @_;
4134    $self->get;
4135    my $dir = $self->dir;
4136
4137    my $package = $self->called_for;
4138    my $module = $CPAN::META->instance('CPAN::Module', $package);
4139    my $version = $module->cpan_version;
4140
4141    my $userid = $self->cpan_userid;
4142
4143    my $cvs_dir = (split /\//, $dir)[-1];
4144    $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
4145    my $cvs_root =
4146      $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4147    my $cvs_site_perl =
4148      $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4149    if ($cvs_site_perl) {
4150	$cvs_dir = "$cvs_site_perl/$cvs_dir";
4151    }
4152    my $cvs_log = qq{"imported $package $version sources"};
4153    $version =~ s/\./_/g;
4154    my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4155	       "$cvs_dir", $userid, "v$version");
4156
4157    my $pwd  = CPAN::anycwd();
4158    chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
4159
4160    $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4161
4162    $CPAN::Frontend->myprint(qq{@cmd\n});
4163    system(@cmd) == 0 or
4164	$CPAN::Frontend->mydie("cvs import failed");
4165    chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
4166}
4167
4168#-> sub CPAN::Distribution::readme ;
4169sub readme {
4170    my($self) = @_;
4171    my($dist) = $self->id;
4172    my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4173    $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4174    my($local_file);
4175    my($local_wanted) =
4176	 File::Spec->catfile(
4177			     $CPAN::Config->{keep_source_where},
4178			     "authors",
4179			     "id",
4180			     split(/\//,"$sans.readme"),
4181			    );
4182    $self->debug("Doing localize") if $CPAN::DEBUG;
4183    $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4184				      $local_wanted)
4185	or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
4186
4187    if ($^O eq 'MacOS') {
4188        Mac::BuildTools::launch_file($local_file);
4189        return;
4190    }
4191
4192    my $fh_pager = FileHandle->new;
4193    local($SIG{PIPE}) = "IGNORE";
4194    $fh_pager->open("|$CPAN::Config->{'pager'}")
4195	or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4196    my $fh_readme = FileHandle->new;
4197    $fh_readme->open($local_file)
4198	or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4199    $CPAN::Frontend->myprint(qq{
4200Displaying file
4201  $local_file
4202with pager "$CPAN::Config->{'pager'}"
4203});
4204    sleep 2;
4205    $fh_pager->print(<$fh_readme>);
4206}
4207
4208#-> sub CPAN::Distribution::verifyMD5 ;
4209sub verifyMD5 {
4210    my($self) = @_;
4211  EXCUSE: {
4212	my @e;
4213	$self->{MD5_STATUS} ||= "";
4214	$self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
4215	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4216    }
4217    my($lc_want,$lc_file,@local,$basename);
4218    @local = split(/\//,$self->id);
4219    pop @local;
4220    push @local, "CHECKSUMS";
4221    $lc_want =
4222	File::Spec->catfile($CPAN::Config->{keep_source_where},
4223			    "authors", "id", @local);
4224    local($") = "/";
4225    if (
4226	-s $lc_want
4227	&&
4228	$self->MD5_check_file($lc_want)
4229       ) {
4230	return $self->{MD5_STATUS} = "OK";
4231    }
4232    $lc_file = CPAN::FTP->localize("authors/id/@local",
4233				   $lc_want,1);
4234    unless ($lc_file) {
4235        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4236	$local[-1] .= ".gz";
4237	$lc_file = CPAN::FTP->localize("authors/id/@local",
4238				       "$lc_want.gz",1);
4239	if ($lc_file) {
4240	    $lc_file =~ s/\.gz(?!\n)\Z//;
4241	    CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
4242	} else {
4243	    return;
4244	}
4245    }
4246    $self->MD5_check_file($lc_file);
4247}
4248
4249#-> sub CPAN::Distribution::MD5_check_file ;
4250sub MD5_check_file {
4251    my($self,$chk_file) = @_;
4252    my($cksum,$file,$basename);
4253    $file = $self->{localfile};
4254    $basename = File::Basename::basename($file);
4255    my $fh = FileHandle->new;
4256    if (open $fh, $chk_file){
4257	local($/);
4258	my $eval = <$fh>;
4259	$eval =~ s/\015?\012/\n/g;
4260	close $fh;
4261	my($comp) = Safe->new();
4262	$cksum = $comp->reval($eval);
4263	if ($@) {
4264	    rename $chk_file, "$chk_file.bad";
4265	    Carp::confess($@) if $@;
4266	}
4267    } else {
4268	Carp::carp "Could not open $chk_file for reading";
4269    }
4270
4271    if (exists $cksum->{$basename}{md5}) {
4272	$self->debug("Found checksum for $basename:" .
4273		     "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4274
4275	open($fh, $file);
4276	binmode $fh;
4277	my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4278	$fh->close;
4279	$fh = CPAN::Tarzip->TIEHANDLE($file);
4280
4281	unless ($eq) {
4282	  # had to inline it, when I tied it, the tiedness got lost on
4283	  # the call to eq_MD5. (Jan 1998)
4284	  my $md5 = Digest::MD5->new;
4285	  my($data,$ref);
4286	  $ref = \$data;
4287	  while ($fh->READ($ref, 4096) > 0){
4288	    $md5->add($data);
4289	  }
4290	  my $hexdigest = $md5->hexdigest;
4291	  $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4292	}
4293
4294	if ($eq) {
4295	  $CPAN::Frontend->myprint("Checksum for $file ok\n");
4296	  return $self->{MD5_STATUS} = "OK";
4297	} else {
4298	    $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
4299				     qq{distribution file. }.
4300				     qq{Please investigate.\n\n}.
4301				     $self->as_string,
4302				     $CPAN::META->instance(
4303							   'CPAN::Author',
4304							   $self->cpan_userid
4305							  )->as_string);
4306
4307	    my $wrap = qq{I\'d recommend removing $file. Its MD5
4308checksum is incorrect. Maybe you have configured your 'urllist' with
4309a bad URL. Please check this array with 'o conf urllist', and
4310retry.};
4311
4312            $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4313
4314            # former versions just returned here but this seems a
4315            # serious threat that deserves a die
4316
4317	    # $CPAN::Frontend->myprint("\n\n");
4318	    # sleep 3;
4319	    # return;
4320	}
4321	# close $fh if fileno($fh);
4322    } else {
4323	$self->{MD5_STATUS} ||= "";
4324	if ($self->{MD5_STATUS} eq "NIL") {
4325	    $CPAN::Frontend->mywarn(qq{
4326Warning: No md5 checksum for $basename in $chk_file.
4327
4328The cause for this may be that the file is very new and the checksum
4329has not yet been calculated, but it may also be that something is
4330going awry right now.
4331});
4332            my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4333            $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
4334	}
4335	$self->{MD5_STATUS} = "NIL";
4336	return;
4337    }
4338}
4339
4340#-> sub CPAN::Distribution::eq_MD5 ;
4341sub eq_MD5 {
4342    my($self,$fh,$expectMD5) = @_;
4343    my $md5 = Digest::MD5->new;
4344    my($data);
4345    while (read($fh, $data, 4096)){
4346      $md5->add($data);
4347    }
4348    # $md5->addfile($fh);
4349    my $hexdigest = $md5->hexdigest;
4350    # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
4351    $hexdigest eq $expectMD5;
4352}
4353
4354#-> sub CPAN::Distribution::force ;
4355
4356# Both modules and distributions know if "force" is in effect by
4357# autoinspection, not by inspecting a global variable. One of the
4358# reason why this was chosen to work that way was the treatment of
4359# dependencies. They should not autpomatically inherit the force
4360# status. But this has the downside that ^C and die() will return to
4361# the prompt but will not be able to reset the force_update
4362# attributes. We try to correct for it currently in the read_metadata
4363# routine, and immediately before we check for a Signal. I hope this
4364# works out in one of v1.57_53ff
4365
4366sub force {
4367  my($self, $method) = @_;
4368  for my $att (qw(
4369  MD5_STATUS archived build_dir localfile make install unwrapped
4370  writemakefile
4371 )) {
4372    delete $self->{$att};
4373  }
4374  if ($method && $method eq "install") {
4375    $self->{"force_update"}++; # name should probably have been force_install
4376  }
4377}
4378
4379#-> sub CPAN::Distribution::unforce ;
4380sub unforce {
4381  my($self) = @_;
4382  delete $self->{'force_update'};
4383}
4384
4385#-> sub CPAN::Distribution::isa_perl ;
4386sub isa_perl {
4387  my($self) = @_;
4388  my $file = File::Basename::basename($self->id);
4389  if ($file =~ m{ ^ perl
4390                  -?
4391		  (5)
4392		  ([._-])
4393		  (
4394                   \d{3}(_[0-4][0-9])?
4395                   |
4396                   \d*[24680]\.\d+
4397                  )
4398		  \.tar[._-]gz
4399		  (?!\n)\Z
4400		}xs){
4401    return "$1.$3";
4402  } elsif ($self->cpan_comment
4403           &&
4404           $self->cpan_comment =~ /isa_perl\(.+?\)/){
4405    return $1;
4406  }
4407}
4408
4409#-> sub CPAN::Distribution::perl ;
4410sub perl {
4411    my($self) = @_;
4412    my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
4413    my $pwd  = CPAN::anycwd();
4414    my $candidate = File::Spec->catfile($pwd,$^X);
4415    $perl ||= $candidate if MM->maybe_command($candidate);
4416    unless ($perl) {
4417	my ($component,$perl_name);
4418      DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
4419	    PATH_COMPONENT: foreach $component (File::Spec->path(),
4420						$Config::Config{'binexp'}) {
4421		  next unless defined($component) && $component;
4422		  my($abs) = File::Spec->catfile($component,$perl_name);
4423		  if (MM->maybe_command($abs)) {
4424		      $perl = $abs;
4425		      last DIST_PERLNAME;
4426		  }
4427	      }
4428	  }
4429    }
4430    $perl;
4431}
4432
4433#-> sub CPAN::Distribution::make ;
4434sub make {
4435    my($self) = @_;
4436    $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
4437    # Emergency brake if they said install Pippi and get newest perl
4438    if ($self->isa_perl) {
4439      if (
4440	  $self->called_for ne $self->id &&
4441          ! $self->{force_update}
4442	 ) {
4443        # if we die here, we break bundles
4444	$CPAN::Frontend->mywarn(sprintf qq{
4445The most recent version "%s" of the module "%s"
4446comes with the current version of perl (%s).
4447I\'ll build that only if you ask for something like
4448    force install %s
4449or
4450    install %s
4451},
4452			       $CPAN::META->instance(
4453						     'CPAN::Module',
4454						     $self->called_for
4455						    )->cpan_version,
4456			       $self->called_for,
4457			       $self->isa_perl,
4458			       $self->called_for,
4459			       $self->id);
4460        sleep 5; return;
4461      }
4462    }
4463    $self->get;
4464  EXCUSE: {
4465	my @e;
4466	$self->{archived} eq "NO" and push @e,
4467	"Is neither a tar nor a zip archive.";
4468
4469	$self->{unwrapped} eq "NO" and push @e,
4470	"had problems unarchiving. Please build manually";
4471
4472	exists $self->{writemakefile} &&
4473	    $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4474		$1 || "Had some problem writing Makefile";
4475
4476	defined $self->{'make'} and push @e,
4477            "Has already been processed within this session";
4478
4479        exists $self->{later} and length($self->{later}) and
4480            push @e, $self->{later};
4481
4482	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4483    }
4484    $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
4485    my $builddir = $self->dir;
4486    chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4487    $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4488
4489    if ($^O eq 'MacOS') {
4490        Mac::BuildTools::make($self);
4491        return;
4492    }
4493
4494    my $system;
4495    if ($self->{'configure'}) {
4496      $system = $self->{'configure'};
4497    } else {
4498	my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4499	my $switch = "";
4500# This needs a handler that can be turned on or off:
4501#	$switch = "-MExtUtils::MakeMaker ".
4502#	    "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4503#	    if $] > 5.00310;
4504	$system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4505    }
4506    unless (exists $self->{writemakefile}) {
4507	local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4508	my($ret,$pid);
4509	$@ = "";
4510	if ($CPAN::Config->{inactivity_timeout}) {
4511	    eval {
4512		alarm $CPAN::Config->{inactivity_timeout};
4513		local $SIG{CHLD}; # = sub { wait };
4514		if (defined($pid = fork)) {
4515		    if ($pid) { #parent
4516			# wait;
4517			waitpid $pid, 0;
4518		    } else {    #child
4519		      # note, this exec isn't necessary if
4520		      # inactivity_timeout is 0. On the Mac I'd
4521		      # suggest, we set it always to 0.
4522		      exec $system;
4523		    }
4524		} else {
4525		    $CPAN::Frontend->myprint("Cannot fork: $!");
4526		    return;
4527		}
4528	    };
4529	    alarm 0;
4530	    if ($@){
4531		kill 9, $pid;
4532		waitpid $pid, 0;
4533		$CPAN::Frontend->myprint($@);
4534		$self->{writemakefile} = "NO $@";
4535		$@ = "";
4536		return;
4537	    }
4538	} else {
4539	  $ret = system($system);
4540	  if ($ret != 0) {
4541	    $self->{writemakefile} = "NO Makefile.PL returned status $ret";
4542	    return;
4543	  }
4544	}
4545	if (-f "Makefile") {
4546	  $self->{writemakefile} = "YES";
4547          delete $self->{make_clean}; # if cleaned before, enable next
4548	} else {
4549	  $self->{writemakefile} =
4550	      qq{NO Makefile.PL refused to write a Makefile.};
4551	  # It's probably worth it to record the reason, so let's retry
4552	  # local $/;
4553	  # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4554	  # $self->{writemakefile} .= <$fh>;
4555	}
4556    }
4557    if ($CPAN::Signal){
4558      delete $self->{force_update};
4559      return;
4560    }
4561    if (my @prereq = $self->unsat_prereq){
4562      return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4563    }
4564    $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4565    if (system($system) == 0) {
4566	 $CPAN::Frontend->myprint("  $system -- OK\n");
4567	 $self->{'make'} = "YES";
4568    } else {
4569	 $self->{writemakefile} ||= "YES";
4570	 $self->{'make'} = "NO";
4571	 $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4572    }
4573}
4574
4575sub follow_prereqs {
4576    my($self) = shift;
4577    my(@prereq) = @_;
4578    my $id = $self->id;
4579    $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4580                             "during [$id] -----\n");
4581
4582    for my $p (@prereq) {
4583	$CPAN::Frontend->myprint("    $p\n");
4584    }
4585    my $follow = 0;
4586    if ($CPAN::Config->{prerequisites_policy} eq "follow") {
4587	$follow = 1;
4588    } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
4589	require ExtUtils::MakeMaker;
4590	my $answer = ExtUtils::MakeMaker::prompt(
4591"Shall I follow them and prepend them to the queue
4592of modules we are processing right now?", "yes");
4593	$follow = $answer =~ /^\s*y/i;
4594    } else {
4595	local($") = ", ";
4596	$CPAN::Frontend->
4597            myprint("  Ignoring dependencies on modules @prereq\n");
4598    }
4599    if ($follow) {
4600        # color them as dirty
4601        for my $p (@prereq) {
4602            # warn "calling color_cmd_tmps(0,1)";
4603            CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4604        }
4605        CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4606        $self->{later} = "Delayed until after prerequisites";
4607        return 1; # signal success to the queuerunner
4608    }
4609}
4610
4611#-> sub CPAN::Distribution::unsat_prereq ;
4612sub unsat_prereq {
4613    my($self) = @_;
4614    my $prereq_pm = $self->prereq_pm or return;
4615    my(@need);
4616  NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4617        my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4618        # we were too demanding:
4619        next if $nmo->uptodate;
4620
4621        # if they have not specified a version, we accept any installed one
4622        if (not defined $need_version or
4623           $need_version == 0 or
4624           $need_version eq "undef") {
4625            next if defined $nmo->inst_file;
4626        }
4627
4628        # We only want to install prereqs if either they're not installed
4629        # or if the installed version is too old. We cannot omit this
4630        # check, because if 'force' is in effect, nobody else will check.
4631        {
4632            local($^W) = 0;
4633            if (
4634                defined $nmo->inst_file &&
4635                ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4636               ){
4637                CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4638                            $nmo->id,
4639                            $nmo->inst_file,
4640                            $nmo->inst_version,
4641                            CPAN::Version->readable($need_version)
4642                           );
4643                next NEED;
4644            }
4645        }
4646
4647        if ($self->{sponsored_mods}{$need_module}++){
4648            # We have already sponsored it and for some reason it's still
4649            # not available. So we do nothing. Or what should we do?
4650            # if we push it again, we have a potential infinite loop
4651            next;
4652        }
4653        push @need, $need_module;
4654    }
4655    @need;
4656}
4657
4658#-> sub CPAN::Distribution::prereq_pm ;
4659sub prereq_pm {
4660  my($self) = @_;
4661  return $self->{prereq_pm} if
4662      exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4663  return unless $self->{writemakefile}; # no need to have succeeded
4664                                        # but we must have run it
4665  my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4666  my $makefile = File::Spec->catfile($build_dir,"Makefile");
4667  my(%p) = ();
4668  my $fh;
4669  if (-f $makefile
4670      and
4671      $fh = FileHandle->new("<$makefile\0")) {
4672
4673      local($/) = "\n";
4674
4675      #  A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4676      while (<$fh>) {
4677          last if /MakeMaker post_initialize section/;
4678          my($p) = m{^[\#]
4679		 \s+PREREQ_PM\s+=>\s+(.+)
4680		 }x;
4681          next unless $p;
4682          # warn "Found prereq expr[$p]";
4683
4684          #  Regexp modified by A.Speer to remember actual version of file
4685          #  PREREQ_PM hash key wants, then add to
4686          while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4687              # In case a prereq is mentioned twice, complain.
4688              if ( defined $p{$1} ) {
4689                  warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4690              }
4691              $p{$1} = $2;
4692          }
4693          last;
4694      }
4695  }
4696  $self->{prereq_pm_detected}++;
4697  return $self->{prereq_pm} = \%p;
4698}
4699
4700#-> sub CPAN::Distribution::test ;
4701sub test {
4702    my($self) = @_;
4703    $self->make;
4704    if ($CPAN::Signal){
4705      delete $self->{force_update};
4706      return;
4707    }
4708    $CPAN::Frontend->myprint("Running make test\n");
4709    if (my @prereq = $self->unsat_prereq){
4710      return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4711    }
4712  EXCUSE: {
4713	my @e;
4714	exists $self->{make} or exists $self->{later} or push @e,
4715	"Make had some problems, maybe interrupted? Won't test";
4716
4717	exists $self->{'make'} and
4718	    $self->{'make'} eq 'NO' and
4719		push @e, "Can't test without successful make";
4720
4721	exists $self->{build_dir} or push @e, "Has no own directory";
4722        $self->{badtestcnt} ||= 0;
4723        $self->{badtestcnt} > 0 and
4724            push @e, "Won't repeat unsuccessful test during this command";
4725
4726        exists $self->{later} and length($self->{later}) and
4727            push @e, $self->{later};
4728
4729	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4730    }
4731    chdir $self->{'build_dir'} or
4732	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4733    $self->debug("Changed directory to $self->{'build_dir'}")
4734	if $CPAN::DEBUG;
4735
4736    if ($^O eq 'MacOS') {
4737        Mac::BuildTools::make_test($self);
4738        return;
4739    }
4740
4741    local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4742    $CPAN::META->set_perl5lib;
4743    my $system = join " ", $CPAN::Config->{'make'}, "test";
4744    if (system($system) == 0) {
4745	 $CPAN::Frontend->myprint("  $system -- OK\n");
4746	 $CPAN::META->is_tested($self->{'build_dir'});
4747	 $self->{make_test} = "YES";
4748    } else {
4749	 $self->{make_test} = "NO";
4750         $self->{badtestcnt}++;
4751	 $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4752    }
4753}
4754
4755#-> sub CPAN::Distribution::clean ;
4756sub clean {
4757    my($self) = @_;
4758    $CPAN::Frontend->myprint("Running make clean\n");
4759  EXCUSE: {
4760	my @e;
4761        exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4762            push @e, "make clean already called once";
4763	exists $self->{build_dir} or push @e, "Has no own directory";
4764	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4765    }
4766    chdir $self->{'build_dir'} or
4767	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4768    $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
4769
4770    if ($^O eq 'MacOS') {
4771        Mac::BuildTools::make_clean($self);
4772        return;
4773    }
4774
4775    my $system = join " ", $CPAN::Config->{'make'}, "clean";
4776    if (system($system) == 0) {
4777      $CPAN::Frontend->myprint("  $system -- OK\n");
4778
4779      # $self->force;
4780
4781      # Jost Krieger pointed out that this "force" was wrong because
4782      # it has the effect that the next "install" on this distribution
4783      # will untar everything again. Instead we should bring the
4784      # object's state back to where it is after untarring.
4785
4786      delete $self->{force_update};
4787      delete $self->{install};
4788      delete $self->{writemakefile};
4789      delete $self->{make};
4790      delete $self->{make_test}; # no matter if yes or no, tests must be redone
4791      $self->{make_clean} = "YES";
4792
4793    } else {
4794      # Hmmm, what to do if make clean failed?
4795
4796      $CPAN::Frontend->myprint(qq{  $system -- NOT OK
4797
4798make clean did not succeed, marking directory as unusable for further work.
4799});
4800      $self->force("make"); # so that this directory won't be used again
4801
4802    }
4803}
4804
4805#-> sub CPAN::Distribution::install ;
4806sub install {
4807    my($self) = @_;
4808    $self->test;
4809    if ($CPAN::Signal){
4810      delete $self->{force_update};
4811      return;
4812    }
4813    $CPAN::Frontend->myprint("Running make install\n");
4814  EXCUSE: {
4815	my @e;
4816	exists $self->{build_dir} or push @e, "Has no own directory";
4817
4818	exists $self->{make} or exists $self->{later} or push @e,
4819	"Make had some problems, maybe interrupted? Won't install";
4820
4821	exists $self->{'make'} and
4822	    $self->{'make'} eq 'NO' and
4823		push @e, "make had returned bad status, install seems impossible";
4824
4825	push @e, "make test had returned bad status, ".
4826	    "won't install without force"
4827	    if exists $self->{'make_test'} and
4828	    $self->{'make_test'} eq 'NO' and
4829	    ! $self->{'force_update'};
4830
4831	exists $self->{'install'} and push @e,
4832	$self->{'install'} eq "YES" ?
4833	    "Already done" : "Already tried without success";
4834
4835        exists $self->{later} and length($self->{later}) and
4836            push @e, $self->{later};
4837
4838	$CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
4839    }
4840    chdir $self->{'build_dir'} or
4841	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4842    $self->debug("Changed directory to $self->{'build_dir'}")
4843	if $CPAN::DEBUG;
4844
4845    if ($^O eq 'MacOS') {
4846        Mac::BuildTools::make_install($self);
4847        return;
4848    }
4849
4850    my $system = join(" ", $CPAN::Config->{'make'},
4851		      "install", $CPAN::Config->{make_install_arg});
4852    my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4853    my($pipe) = FileHandle->new("$system $stderr |");
4854    my($makeout) = "";
4855    while (<$pipe>){
4856	$CPAN::Frontend->myprint($_);
4857	$makeout .= $_;
4858    }
4859    $pipe->close;
4860    if ($?==0) {
4861	 $CPAN::Frontend->myprint("  $system -- OK\n");
4862	 $CPAN::META->is_installed($self->{'build_dir'});
4863	 return $self->{'install'} = "YES";
4864    } else {
4865	 $self->{'install'} = "NO";
4866	 $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4867	 if ($makeout =~ /permission/s && $> > 0) {
4868	     $CPAN::Frontend->myprint(qq{    You may have to su }.
4869				      qq{to root to install the package\n});
4870	 }
4871    }
4872    delete $self->{force_update};
4873}
4874
4875#-> sub CPAN::Distribution::dir ;
4876sub dir {
4877    shift->{'build_dir'};
4878}
4879
4880package CPAN::Bundle;
4881
4882sub look {
4883    my $self = shift;
4884    $CPAN::Frontend->myprint($self->as_string);
4885}
4886
4887sub undelay {
4888    my $self = shift;
4889    delete $self->{later};
4890    for my $c ( $self->contains ) {
4891        my $obj = CPAN::Shell->expandany($c) or next;
4892        $obj->undelay;
4893    }
4894}
4895
4896#-> sub CPAN::Bundle::color_cmd_tmps ;
4897sub color_cmd_tmps {
4898    my($self) = shift;
4899    my($depth) = shift || 0;
4900    my($color) = shift || 0;
4901    my($ancestors) = shift || [];
4902    # a module needs to recurse to its cpan_file, a distribution needs
4903    # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4904
4905    return if exists $self->{incommandcolor}
4906        && $self->{incommandcolor}==$color;
4907    if ($depth>=100){
4908        $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
4909    }
4910    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4911
4912    for my $c ( $self->contains ) {
4913        my $obj = CPAN::Shell->expandany($c) or next;
4914        CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4915        $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
4916    }
4917    if ($color==0) {
4918        delete $self->{badtestcnt};
4919    }
4920    $self->{incommandcolor} = $color;
4921}
4922
4923#-> sub CPAN::Bundle::as_string ;
4924sub as_string {
4925    my($self) = @_;
4926    $self->contains;
4927    # following line must be "=", not "||=" because we have a moving target
4928    $self->{INST_VERSION} = $self->inst_version;
4929    return $self->SUPER::as_string;
4930}
4931
4932#-> sub CPAN::Bundle::contains ;
4933sub contains {
4934    my($self) = @_;
4935    my($inst_file) = $self->inst_file || "";
4936    my($id) = $self->id;
4937    $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4938    unless ($inst_file) {
4939        # Try to get at it in the cpan directory
4940        $self->debug("no inst_file") if $CPAN::DEBUG;
4941        my $cpan_file;
4942        $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4943              $cpan_file = $self->cpan_file;
4944        if ($cpan_file eq "N/A") {
4945            $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4946  Maybe stale symlink? Maybe removed during session? Giving up.\n");
4947        }
4948        my $dist = $CPAN::META->instance('CPAN::Distribution',
4949                                         $self->cpan_file);
4950        $dist->get;
4951        $self->debug($dist->as_string) if $CPAN::DEBUG;
4952        my($todir) = $CPAN::Config->{'cpan_home'};
4953        my(@me,$from,$to,$me);
4954        @me = split /::/, $self->id;
4955        $me[-1] .= ".pm";
4956        $me = File::Spec->catfile(@me);
4957        $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4958        $to = File::Spec->catfile($todir,$me);
4959        File::Path::mkpath(File::Basename::dirname($to));
4960        File::Copy::copy($from, $to)
4961              or Carp::confess("Couldn't copy $from to $to: $!");
4962        $inst_file = $to;
4963    }
4964    my @result;
4965    my $fh = FileHandle->new;
4966    local $/ = "\n";
4967    open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4968    my $in_cont = 0;
4969    $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4970    while (<$fh>) {
4971        $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4972            m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4973        next unless $in_cont;
4974        next if /^=/;
4975        s/\#.*//;
4976        next if /^\s+$/;
4977        chomp;
4978        push @result, (split " ", $_, 2)[0];
4979    }
4980    close $fh;
4981    delete $self->{STATUS};
4982    $self->{CONTAINS} = \@result;
4983    $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4984    unless (@result) {
4985        $CPAN::Frontend->mywarn(qq{
4986The bundle file "$inst_file" may be a broken
4987bundlefile. It seems not to contain any bundle definition.
4988Please check the file and if it is bogus, please delete it.
4989Sorry for the inconvenience.
4990});
4991    }
4992    @result;
4993}
4994
4995#-> sub CPAN::Bundle::find_bundle_file
4996sub find_bundle_file {
4997    my($self,$where,$what) = @_;
4998    $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4999### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5000###    my $bu = File::Spec->catfile($where,$what);
5001###    return $bu if -f $bu;
5002    my $manifest = File::Spec->catfile($where,"MANIFEST");
5003    unless (-f $manifest) {
5004	require ExtUtils::Manifest;
5005	my $cwd = CPAN::anycwd();
5006	chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
5007	ExtUtils::Manifest::mkmanifest();
5008	chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
5009    }
5010    my $fh = FileHandle->new($manifest)
5011	or Carp::croak("Couldn't open $manifest: $!");
5012    local($/) = "\n";
5013    my $what2 = $what;
5014    if ($^O eq 'MacOS') {
5015      $what =~ s/^://;
5016      $what =~ tr|:|/|;
5017      $what2 =~ s/:Bundle://;
5018      $what2 =~ tr|:|/|;
5019    } else {
5020	$what2 =~ s|Bundle[/\\]||;
5021    }
5022    my $bu;
5023    while (<$fh>) {
5024	next if /^\s*\#/;
5025	my($file) = /(\S+)/;
5026	if ($file =~ m|\Q$what\E$|) {
5027	    $bu = $file;
5028	    # return File::Spec->catfile($where,$bu); # bad
5029	    last;
5030	}
5031	# retry if she managed to
5032	# have no Bundle directory
5033	$bu = $file if $file =~ m|\Q$what2\E$|;
5034    }
5035    $bu =~ tr|/|:| if $^O eq 'MacOS';
5036    return File::Spec->catfile($where, $bu) if $bu;
5037    Carp::croak("Couldn't find a Bundle file in $where");
5038}
5039
5040# needs to work quite differently from Module::inst_file because of
5041# cpan_home/Bundle/ directory and the possibility that we have
5042# shadowing effect. As it makes no sense to take the first in @INC for
5043# Bundles, we parse them all for $VERSION and take the newest.
5044
5045#-> sub CPAN::Bundle::inst_file ;
5046sub inst_file {
5047    my($self) = @_;
5048    my($inst_file);
5049    my(@me);
5050    @me = split /::/, $self->id;
5051    $me[-1] .= ".pm";
5052    my($incdir,$bestv);
5053    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5054        my $bfile = File::Spec->catfile($incdir, @me);
5055        CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
5056        next unless -f $bfile;
5057        my $foundv = MM->parse_version($bfile);
5058        if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
5059            $self->{INST_FILE} = $bfile;
5060            $self->{INST_VERSION} = $bestv = $foundv;
5061        }
5062    }
5063    $self->{INST_FILE};
5064}
5065
5066#-> sub CPAN::Bundle::inst_version ;
5067sub inst_version {
5068    my($self) = @_;
5069    $self->inst_file; # finds INST_VERSION as side effect
5070    $self->{INST_VERSION};
5071}
5072
5073#-> sub CPAN::Bundle::rematein ;
5074sub rematein {
5075    my($self,$meth) = @_;
5076    $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
5077    my($id) = $self->id;
5078    Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
5079	unless $self->inst_file || $self->cpan_file;
5080    my($s,%fail);
5081    for $s ($self->contains) {
5082	my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5083	    $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5084	if ($type eq 'CPAN::Distribution') {
5085	    $CPAN::Frontend->mywarn(qq{
5086The Bundle }.$self->id.qq{ contains
5087explicitly a file $s.
5088});
5089	    sleep 3;
5090	}
5091	# possibly noisy action:
5092        $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
5093	my $obj = $CPAN::META->instance($type,$s);
5094	$obj->$meth();
5095        if ($obj->isa(CPAN::Bundle)
5096            &&
5097            exists $obj->{install_failed}
5098            &&
5099            ref($obj->{install_failed}) eq "HASH"
5100           ) {
5101          for (keys %{$obj->{install_failed}}) {
5102            $self->{install_failed}{$_} = undef; # propagate faiure up
5103                                                 # to me in a
5104                                                 # recursive call
5105            $fail{$s} = 1; # the bundle itself may have succeeded but
5106                           # not all children
5107          }
5108        } else {
5109          my $success;
5110          $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5111          $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5112          if ($success) {
5113            delete $self->{install_failed}{$s};
5114          } else {
5115            $fail{$s} = 1;
5116          }
5117        }
5118    }
5119
5120    # recap with less noise
5121    if ( $meth eq "install" ) {
5122	if (%fail) {
5123	    require Text::Wrap;
5124	    my $raw = sprintf(qq{Bundle summary:
5125The following items in bundle %s had installation problems:},
5126			      $self->id
5127			     );
5128	    $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5129	    $CPAN::Frontend->myprint("\n");
5130	    my $paragraph = "";
5131            my %reported;
5132	    for $s ($self->contains) {
5133              if ($fail{$s}){
5134		$paragraph .= "$s ";
5135                $self->{install_failed}{$s} = undef;
5136                $reported{$s} = undef;
5137              }
5138	    }
5139            my $report_propagated;
5140            for $s (sort keys %{$self->{install_failed}}) {
5141              next if exists $reported{$s};
5142              $paragraph .= "and the following items had problems
5143during recursive bundle calls: " unless $report_propagated++;
5144              $paragraph .= "$s ";
5145            }
5146	    $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
5147	    $CPAN::Frontend->myprint("\n");
5148	} else {
5149	    $self->{'install'} = 'YES';
5150	}
5151    }
5152}
5153
5154#sub CPAN::Bundle::xs_file
5155sub xs_file {
5156    # If a bundle contains another that contains an xs_file we have
5157    # here, we just don't bother I suppose
5158    return 0;
5159}
5160
5161#-> sub CPAN::Bundle::force ;
5162sub force   { shift->rematein('force',@_); }
5163#-> sub CPAN::Bundle::get ;
5164sub get     { shift->rematein('get',@_); }
5165#-> sub CPAN::Bundle::make ;
5166sub make    { shift->rematein('make',@_); }
5167#-> sub CPAN::Bundle::test ;
5168sub test    {
5169    my $self = shift;
5170    $self->{badtestcnt} ||= 0;
5171    $self->rematein('test',@_);
5172}
5173#-> sub CPAN::Bundle::install ;
5174sub install {
5175  my $self = shift;
5176  $self->rematein('install',@_);
5177}
5178#-> sub CPAN::Bundle::clean ;
5179sub clean   { shift->rematein('clean',@_); }
5180
5181#-> sub CPAN::Bundle::uptodate ;
5182sub uptodate {
5183    my($self) = @_;
5184    return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5185    my $c;
5186    foreach $c ($self->contains) {
5187        my $obj = CPAN::Shell->expandany($c);
5188        return 0 unless $obj->uptodate;
5189    }
5190    return 1;
5191}
5192
5193#-> sub CPAN::Bundle::readme ;
5194sub readme  {
5195    my($self) = @_;
5196    my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5197No File found for bundle } . $self->id . qq{\n}), return;
5198    $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5199    $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5200}
5201
5202package CPAN::Module;
5203
5204# Accessors
5205# sub CPAN::Module::userid
5206sub userid {
5207    my $self = shift;
5208    return unless exists $self->{RO}; # should never happen
5209    return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
5210}
5211# sub CPAN::Module::description
5212sub description { shift->{RO}{description} }
5213
5214sub undelay {
5215    my $self = shift;
5216    delete $self->{later};
5217    if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5218        $dist->undelay;
5219    }
5220}
5221
5222#-> sub CPAN::Module::color_cmd_tmps ;
5223sub color_cmd_tmps {
5224    my($self) = shift;
5225    my($depth) = shift || 0;
5226    my($color) = shift || 0;
5227    my($ancestors) = shift || [];
5228    # a module needs to recurse to its cpan_file
5229
5230    return if exists $self->{incommandcolor}
5231        && $self->{incommandcolor}==$color;
5232    if ($depth>=100){
5233        $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5234    }
5235    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5236
5237    if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5238        $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5239    }
5240    if ($color==0) {
5241        delete $self->{badtestcnt};
5242    }
5243    $self->{incommandcolor} = $color;
5244}
5245
5246#-> sub CPAN::Module::as_glimpse ;
5247sub as_glimpse {
5248    my($self) = @_;
5249    my(@m);
5250    my $class = ref($self);
5251    $class =~ s/^CPAN:://;
5252    my $color_on = "";
5253    my $color_off = "";
5254    if (
5255        $CPAN::Shell::COLOR_REGISTERED
5256        &&
5257        $CPAN::META->has_inst("Term::ANSIColor")
5258        &&
5259        $self->{RO}{description}
5260       ) {
5261        $color_on = Term::ANSIColor::color("green");
5262        $color_off = Term::ANSIColor::color("reset");
5263    }
5264    push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5265                     $class,
5266                     $color_on,
5267                     $self->id,
5268                     $color_off,
5269		     $self->cpan_file);
5270    join "", @m;
5271}
5272
5273#-> sub CPAN::Module::as_string ;
5274sub as_string {
5275    my($self) = @_;
5276    my(@m);
5277    CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
5278    my $class = ref($self);
5279    $class =~ s/^CPAN:://;
5280    local($^W) = 0;
5281    push @m, $class, " id = $self->{ID}\n";
5282    my $sprintf = "    %-12s %s\n";
5283    push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5284	if $self->description;
5285    my $sprintf2 = "    %-12s %s (%s)\n";
5286    my($userid);
5287    $userid = $self->userid;
5288    if ( $userid ){
5289	my $author;
5290	if ($author = CPAN::Shell->expand('Author',$userid)) {
5291	  my $email = "";
5292	  my $m; # old perls
5293	  if ($m = $author->email) {
5294            $email = " <$m>";
5295          }
5296	  push @m, sprintf(
5297			   $sprintf2,
5298			   'CPAN_USERID',
5299			   $userid,
5300			   $author->fullname . $email
5301			  );
5302	}
5303    }
5304    push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5305	if $self->cpan_version;
5306    push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5307	if $self->cpan_file;
5308    my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5309    my(%statd,%stats,%statl,%stati);
5310    @statd{qw,? i c a b R M S,} = qw,unknown idea
5311	pre-alpha alpha beta released mature standard,;
5312    @stats{qw,? m d u n a,}       = qw,unknown mailing-list
5313	developer comp.lang.perl.* none abandoned,;
5314    @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
5315    @stati{qw,? f r O h,}         = qw,unknown functions
5316	references+ties object-oriented hybrid,;
5317    $statd{' '} = 'unknown';
5318    $stats{' '} = 'unknown';
5319    $statl{' '} = 'unknown';
5320    $stati{' '} = 'unknown';
5321    push @m, sprintf(
5322		     $sprintf3,
5323		     'DSLI_STATUS',
5324		     $self->{RO}{statd},
5325		     $self->{RO}{stats},
5326		     $self->{RO}{statl},
5327		     $self->{RO}{stati},
5328		     $statd{$self->{RO}{statd}},
5329		     $stats{$self->{RO}{stats}},
5330		     $statl{$self->{RO}{statl}},
5331		     $stati{$self->{RO}{stati}}
5332		    ) if $self->{RO}{statd};
5333    my $local_file = $self->inst_file;
5334    unless ($self->{MANPAGE}) {
5335        if ($local_file) {
5336            $self->{MANPAGE} = $self->manpage_headline($local_file);
5337        } else {
5338            # If we have already untarred it, we should look there
5339            my $dist = $CPAN::META->instance('CPAN::Distribution',
5340                                             $self->cpan_file);
5341            # warn "dist[$dist]";
5342            # mff=manifest file; mfh=manifest handle
5343            my($mff,$mfh);
5344            if (
5345                $dist->{build_dir}
5346                and
5347                (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
5348                and
5349                $mfh = FileHandle->new($mff)
5350               ) {
5351                CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
5352                my $lfre = $self->id; # local file RE
5353                $lfre =~ s/::/./g;
5354                $lfre .= "\\.pm\$";
5355                my($lfl); # local file file
5356                local $/ = "\n";
5357                my(@mflines) = <$mfh>;
5358                for (@mflines) {
5359                    s/^\s+//;
5360                    s/\s.*//s;
5361                }
5362                while (length($lfre)>5 and !$lfl) {
5363                    ($lfl) = grep /$lfre/, @mflines;
5364                    CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
5365                    $lfre =~ s/.+?\.//;
5366                }
5367                $lfl =~ s/\s.*//; # remove comments
5368                $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5369                my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
5370                # warn "lfl_abs[$lfl_abs]";
5371                if (-f $lfl_abs) {
5372                    $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5373                }
5374            }
5375        }
5376    }
5377    my($item);
5378    for $item (qw/MANPAGE/) {
5379	push @m, sprintf($sprintf, $item, $self->{$item})
5380	    if exists $self->{$item};
5381    }
5382    for $item (qw/CONTAINS/) {
5383	push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5384	    if exists $self->{$item} && @{$self->{$item}};
5385    }
5386    push @m, sprintf($sprintf, 'INST_FILE',
5387		     $local_file || "(not installed)");
5388    push @m, sprintf($sprintf, 'INST_VERSION',
5389		     $self->inst_version) if $local_file;
5390    join "", @m, "\n";
5391}
5392
5393sub manpage_headline {
5394  my($self,$local_file) = @_;
5395  my(@local_file) = $local_file;
5396  $local_file =~ s/\.pm(?!\n)\Z/.pod/;
5397  push @local_file, $local_file;
5398  my(@result,$locf);
5399  for $locf (@local_file) {
5400    next unless -f $locf;
5401    my $fh = FileHandle->new($locf)
5402	or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5403    my $inpod = 0;
5404    local $/ = "\n";
5405    while (<$fh>) {
5406      $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5407	  m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
5408      next unless $inpod;
5409      next if /^=/;
5410      next if /^\s+$/;
5411      chomp;
5412      push @result, $_;
5413    }
5414    close $fh;
5415    last if @result;
5416  }
5417  join " ", @result;
5418}
5419
5420#-> sub CPAN::Module::cpan_file ;
5421# Note: also inherited by CPAN::Bundle
5422sub cpan_file {
5423    my $self = shift;
5424    CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5425    unless (defined $self->{RO}{CPAN_FILE}) {
5426	CPAN::Index->reload;
5427    }
5428    if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5429	return $self->{RO}{CPAN_FILE};
5430    } else {
5431        my $userid = $self->userid;
5432        if ( $userid ) {
5433            if ($CPAN::META->exists("CPAN::Author",$userid)) {
5434                my $author = $CPAN::META->instance("CPAN::Author",
5435                                                   $userid);
5436                my $fullname = $author->fullname;
5437                my $email = $author->email;
5438                unless (defined $fullname && defined $email) {
5439                    return sprintf("Contact Author %s",
5440                                   $userid,
5441                                  );
5442                }
5443                return "Contact Author $fullname <$email>";
5444            } else {
5445                return "Contact Author $userid (Email address not available)";
5446            }
5447        } else {
5448            return "N/A";
5449        }
5450    }
5451}
5452
5453#-> sub CPAN::Module::cpan_version ;
5454sub cpan_version {
5455    my $self = shift;
5456
5457    $self->{RO}{CPAN_VERSION} = 'undef'
5458	unless defined $self->{RO}{CPAN_VERSION};
5459    # I believe this is always a bug in the index and should be reported
5460    # as such, but usually I find out such an error and do not want to
5461    # provoke too many bugreports
5462
5463    $self->{RO}{CPAN_VERSION};
5464}
5465
5466#-> sub CPAN::Module::force ;
5467sub force {
5468    my($self) = @_;
5469    $self->{'force_update'}++;
5470}
5471
5472#-> sub CPAN::Module::rematein ;
5473sub rematein {
5474    my($self,$meth) = @_;
5475    $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5476                                     $meth,
5477                                     $self->id));
5478    my $cpan_file = $self->cpan_file;
5479    if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5480      $CPAN::Frontend->mywarn(sprintf qq{
5481  The module %s isn\'t available on CPAN.
5482
5483  Either the module has not yet been uploaded to CPAN, or it is
5484  temporary unavailable. Please contact the author to find out
5485  more about the status. Try 'i %s'.
5486},
5487			      $self->id,
5488			      $self->id,
5489			     );
5490      return;
5491    }
5492    my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5493    $pack->called_for($self->id);
5494    $pack->force($meth) if exists $self->{'force_update'};
5495    $pack->$meth();
5496    $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
5497    delete $self->{'force_update'};
5498}
5499
5500#-> sub CPAN::Module::readme ;
5501sub readme { shift->rematein('readme') }
5502#-> sub CPAN::Module::look ;
5503sub look { shift->rematein('look') }
5504#-> sub CPAN::Module::cvs_import ;
5505sub cvs_import { shift->rematein('cvs_import') }
5506#-> sub CPAN::Module::get ;
5507sub get    { shift->rematein('get',@_); }
5508#-> sub CPAN::Module::make ;
5509sub make   {
5510    my $self = shift;
5511    $self->rematein('make');
5512}
5513#-> sub CPAN::Module::test ;
5514sub test   {
5515    my $self = shift;
5516    $self->{badtestcnt} ||= 0;
5517    $self->rematein('test',@_);
5518}
5519#-> sub CPAN::Module::uptodate ;
5520sub uptodate {
5521    my($self) = @_;
5522    my($latest) = $self->cpan_version;
5523    $latest ||= 0;
5524    my($inst_file) = $self->inst_file;
5525    my($have) = 0;
5526    if (defined $inst_file) {
5527	$have = $self->inst_version;
5528    }
5529    local($^W)=0;
5530    if ($inst_file
5531	&&
5532	! CPAN::Version->vgt($latest, $have)
5533       ) {
5534        CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5535                    "latest[$latest] have[$have]") if $CPAN::DEBUG;
5536        return 1;
5537    }
5538    return;
5539}
5540#-> sub CPAN::Module::install ;
5541sub install {
5542    my($self) = @_;
5543    my($doit) = 0;
5544    if ($self->uptodate
5545	&&
5546	not exists $self->{'force_update'}
5547       ) {
5548	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5549    } else {
5550	$doit = 1;
5551    }
5552    if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
5553        $CPAN::Frontend->mywarn(qq{
5554\n\n\n     ***WARNING***
5555     The module $self->{ID} has no active maintainer.\n\n\n
5556});
5557        sleep 5;
5558    }
5559    $self->rematein('install') if $doit;
5560}
5561#-> sub CPAN::Module::clean ;
5562sub clean  { shift->rematein('clean') }
5563
5564#-> sub CPAN::Module::inst_file ;
5565sub inst_file {
5566    my($self) = @_;
5567    my($dir,@packpath);
5568    @packpath = split /::/, $self->{ID};
5569    $packpath[-1] .= ".pm";
5570    foreach $dir (@INC) {
5571	my $pmfile = File::Spec->catfile($dir,@packpath);
5572	if (-f $pmfile){
5573	    return $pmfile;
5574	}
5575    }
5576    return;
5577}
5578
5579#-> sub CPAN::Module::xs_file ;
5580sub xs_file {
5581    my($self) = @_;
5582    my($dir,@packpath);
5583    @packpath = split /::/, $self->{ID};
5584    push @packpath, $packpath[-1];
5585    $packpath[-1] .= "." . $Config::Config{'dlext'};
5586    foreach $dir (@INC) {
5587	my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
5588	if (-f $xsfile){
5589	    return $xsfile;
5590	}
5591    }
5592    return;
5593}
5594
5595#-> sub CPAN::Module::inst_version ;
5596sub inst_version {
5597    my($self) = @_;
5598    my $parsefile = $self->inst_file or return;
5599    local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
5600    my $have;
5601
5602    # there was a bug in 5.6.0 that let lots of unini warnings out of
5603    # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
5604    # the following workaround after 5.6.1 is out.
5605    local($SIG{__WARN__}) =  sub { my $w = shift;
5606                                   return if $w =~ /uninitialized/i;
5607                                   warn $w;
5608                                 };
5609
5610    $have = MM->parse_version($parsefile) || "undef";
5611    $have =~ s/^ //; # since the %vd hack these two lines here are needed
5612    $have =~ s/ $//; # trailing whitespace happens all the time
5613
5614    # My thoughts about why %vd processing should happen here
5615
5616    # Alt1 maintain it as string with leading v:
5617    # read index files     do nothing
5618    # compare it           use utility for compare
5619    # print it             do nothing
5620
5621    # Alt2 maintain it as what it is
5622    # read index files     convert
5623    # compare it           use utility because there's still a ">" vs "gt" issue
5624    # print it             use CPAN::Version for print
5625
5626    # Seems cleaner to hold it in memory as a string starting with a "v"
5627
5628    # If the author of this module made a mistake and wrote a quoted
5629    # "v1.13" instead of v1.13, we simply leave it at that with the
5630    # effect that *we* will treat it like a v-tring while the rest of
5631    # perl won't. Seems sensible when we consider that any action we
5632    # could take now would just add complexity.
5633
5634    $have = CPAN::Version->readable($have);
5635
5636    $have =~ s/\s*//g; # stringify to float around floating point issues
5637    $have; # no stringify needed, \s* above matches always
5638}
5639
5640package CPAN::Tarzip;
5641
5642# CPAN::Tarzip::gzip
5643sub gzip {
5644  my($class,$read,$write) = @_;
5645  if ($CPAN::META->has_inst("Compress::Zlib")) {
5646    my($buffer,$fhw);
5647    $fhw = FileHandle->new($read)
5648	or $CPAN::Frontend->mydie("Could not open $read: $!");
5649    my $gz = Compress::Zlib::gzopen($write, "wb")
5650	or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5651    $gz->gzwrite($buffer)
5652	while read($fhw,$buffer,4096) > 0 ;
5653    $gz->gzclose() ;
5654    $fhw->close;
5655    return 1;
5656  } else {
5657    system("$CPAN::Config->{gzip} -c $read > $write")==0;
5658  }
5659}
5660
5661
5662# CPAN::Tarzip::gunzip
5663sub gunzip {
5664  my($class,$read,$write) = @_;
5665  if ($CPAN::META->has_inst("Compress::Zlib")) {
5666    my($buffer,$fhw);
5667    $fhw = FileHandle->new(">$write")
5668	or $CPAN::Frontend->mydie("Could not open >$write: $!");
5669    my $gz = Compress::Zlib::gzopen($read, "rb")
5670	or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5671    $fhw->print($buffer)
5672	while $gz->gzread($buffer) > 0 ;
5673    $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5674	if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5675    $gz->gzclose() ;
5676    $fhw->close;
5677    return 1;
5678  } else {
5679    system("$CPAN::Config->{gzip} -dc $read > $write")==0;
5680  }
5681}
5682
5683
5684# CPAN::Tarzip::gtest
5685sub gtest {
5686  my($class,$read) = @_;
5687  # After I had reread the documentation in zlib.h, I discovered that
5688  # uncompressed files do not lead to an gzerror (anymore?).
5689  if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5690    my($buffer,$len);
5691    $len = 0;
5692    my $gz = Compress::Zlib::gzopen($read, "rb")
5693	or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5694                                          $read,
5695                                          $Compress::Zlib::gzerrno));
5696    while ($gz->gzread($buffer) > 0 ){
5697        $len += length($buffer);
5698        $buffer = "";
5699    }
5700    my $err = $gz->gzerror;
5701    my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5702    if ($len == -s $read){
5703        $success = 0;
5704        CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5705    }
5706    $gz->gzclose();
5707    CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
5708    return $success;
5709  } else {
5710      return system("$CPAN::Config->{gzip} -dt $read")==0;
5711  }
5712}
5713
5714
5715# CPAN::Tarzip::TIEHANDLE
5716sub TIEHANDLE {
5717  my($class,$file) = @_;
5718  my $ret;
5719  $class->debug("file[$file]");
5720  if ($CPAN::META->has_inst("Compress::Zlib")) {
5721    my $gz = Compress::Zlib::gzopen($file,"rb") or
5722	die "Could not gzopen $file";
5723    $ret = bless {GZ => $gz}, $class;
5724  } else {
5725    my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
5726    my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
5727    binmode $fh;
5728    $ret = bless {FH => $fh}, $class;
5729  }
5730  $ret;
5731}
5732
5733
5734# CPAN::Tarzip::READLINE
5735sub READLINE {
5736  my($self) = @_;
5737  if (exists $self->{GZ}) {
5738    my $gz = $self->{GZ};
5739    my($line,$bytesread);
5740    $bytesread = $gz->gzreadline($line);
5741    return undef if $bytesread <= 0;
5742    return $line;
5743  } else {
5744    my $fh = $self->{FH};
5745    return scalar <$fh>;
5746  }
5747}
5748
5749
5750# CPAN::Tarzip::READ
5751sub READ {
5752  my($self,$ref,$length,$offset) = @_;
5753  die "read with offset not implemented" if defined $offset;
5754  if (exists $self->{GZ}) {
5755    my $gz = $self->{GZ};
5756    my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5757    return $byteread;
5758  } else {
5759    my $fh = $self->{FH};
5760    return read($fh,$$ref,$length);
5761  }
5762}
5763
5764
5765# CPAN::Tarzip::DESTROY
5766sub DESTROY {
5767    my($self) = @_;
5768    if (exists $self->{GZ}) {
5769        my $gz = $self->{GZ};
5770        $gz->gzclose() if defined $gz; # hard to say if it is allowed
5771                                       # to be undef ever. AK, 2000-09
5772    } else {
5773        my $fh = $self->{FH};
5774        $fh->close if defined $fh;
5775    }
5776    undef $self;
5777}
5778
5779
5780# CPAN::Tarzip::untar
5781sub untar {
5782  my($class,$file) = @_;
5783  my($prefer) = 0;
5784
5785  if (0) { # makes changing order easier
5786  } elsif ($BUGHUNTING){
5787      $prefer=2;
5788  } elsif (MM->maybe_command($CPAN::Config->{gzip})
5789           &&
5790           MM->maybe_command($CPAN::Config->{'tar'})) {
5791      # should be default until Archive::Tar is fixed
5792      $prefer = 1;
5793  } elsif (
5794           $CPAN::META->has_inst("Archive::Tar")
5795           &&
5796           $CPAN::META->has_inst("Compress::Zlib") ) {
5797      $prefer = 2;
5798  } else {
5799    $CPAN::Frontend->mydie(qq{
5800CPAN.pm needs either both external programs tar and gzip installed or
5801both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5802is available. Can\'t continue.
5803});
5804  }
5805  if ($prefer==1) { # 1 => external gzip+tar
5806    my($system);
5807    my $is_compressed = $class->gtest($file);
5808    if ($is_compressed) {
5809        $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5810            "< $file | $CPAN::Config->{tar} xvf -";
5811    } else {
5812        $system = "$CPAN::Config->{tar} xvf $file";
5813    }
5814    if (system($system) != 0) {
5815        # people find the most curious tar binaries that cannot handle
5816        # pipes
5817        if ($is_compressed) {
5818            (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5819            if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5820                $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5821            } else {
5822                $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5823            }
5824            $file = $ungzf;
5825        }
5826        $system = "$CPAN::Config->{tar} xvf $file";
5827        $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5828        if (system($system)==0) {
5829            $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5830        } else {
5831            $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5832        }
5833        return 1;
5834    } else {
5835        return 1;
5836    }
5837  } elsif ($prefer==2) { # 2 => modules
5838    my $tar = Archive::Tar->new($file,1);
5839    my $af; # archive file
5840    my @af;
5841    if ($BUGHUNTING) {
5842        # RCS 1.337 had this code, it turned out unacceptable slow but
5843        # it revealed a bug in Archive::Tar. Code is only here to hunt
5844        # the bug again. It should never be enabled in published code.
5845        # GDGraph3d-0.53 was an interesting case according to Larry
5846        # Virden.
5847        warn(">>>Bughunting code enabled<<< " x 20);
5848        for $af ($tar->list_files) {
5849            if ($af =~ m!^(/|\.\./)!) {
5850                $CPAN::Frontend->mydie("ALERT: Archive contains ".
5851                                       "illegal member [$af]");
5852            }
5853            $CPAN::Frontend->myprint("$af\n");
5854            $tar->extract($af); # slow but effective for finding the bug
5855            return if $CPAN::Signal;
5856        }
5857    } else {
5858        for $af ($tar->list_files) {
5859            if ($af =~ m!^(/|\.\./)!) {
5860                $CPAN::Frontend->mydie("ALERT: Archive contains ".
5861                                       "illegal member [$af]");
5862            }
5863            $CPAN::Frontend->myprint("$af\n");
5864            push @af, $af;
5865            return if $CPAN::Signal;
5866        }
5867        $tar->extract(@af);
5868    }
5869
5870    Mac::BuildTools::convert_files([$tar->list_files], 1)
5871        if ($^O eq 'MacOS');
5872
5873    return 1;
5874  }
5875}
5876
5877sub unzip {
5878    my($class,$file) = @_;
5879    if ($CPAN::META->has_inst("Archive::Zip")) {
5880        # blueprint of the code from Archive::Zip::Tree::extractTree();
5881        my $zip = Archive::Zip->new();
5882        my $status;
5883        $status = $zip->read($file);
5884        die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5885        $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5886        my @members = $zip->members();
5887        for my $member ( @members ) {
5888            my $af = $member->fileName();
5889            if ($af =~ m!^(/|\.\./)!) {
5890                $CPAN::Frontend->mydie("ALERT: Archive contains ".
5891                                       "illegal member [$af]");
5892            }
5893            my $status = $member->extractToFileNamed( $af );
5894            $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5895            die "Extracting of file[$af] from zipfile[$file] failed\n" if
5896                $status != Archive::Zip::AZ_OK();
5897            return if $CPAN::Signal;
5898        }
5899        return 1;
5900    } else {
5901        my $unzip = $CPAN::Config->{unzip} or
5902            $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5903        my @system = ($unzip, $file);
5904        return system(@system) == 0;
5905    }
5906}
5907
5908
5909package CPAN::Version;
5910# CPAN::Version::vcmp courtesy Jost Krieger
5911sub vcmp {
5912  my($self,$l,$r) = @_;
5913  local($^W) = 0;
5914  CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
5915
5916  return 0 if $l eq $r; # short circuit for quicker success
5917
5918  if ($l=~/^v/ <=> $r=~/^v/) {
5919      for ($l,$r) {
5920          next if /^v/;
5921          $_ = $self->float2vv($_);
5922      }
5923  }
5924
5925  return
5926      ($l ne "undef") <=> ($r ne "undef") ||
5927          ($] >= 5.006 &&
5928           $l =~ /^v/ &&
5929           $r =~ /^v/ &&
5930           $self->vstring($l) cmp $self->vstring($r)) ||
5931               $l <=> $r ||
5932                   $l cmp $r;
5933}
5934
5935sub vgt {
5936  my($self,$l,$r) = @_;
5937  $self->vcmp($l,$r) > 0;
5938}
5939
5940sub vstring {
5941  my($self,$n) = @_;
5942  $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5943  pack "U*", split /\./, $n;
5944}
5945
5946# vv => visible vstring
5947sub float2vv {
5948    my($self,$n) = @_;
5949    my($rev) = int($n);
5950    $rev ||= 0;
5951    my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5952                                          # architecture influence
5953    $mantissa ||= 0;
5954    $mantissa .= "0" while length($mantissa)%3;
5955    my $ret = "v" . $rev;
5956    while ($mantissa) {
5957        $mantissa =~ s/(\d{1,3})// or
5958            die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5959        $ret .= ".".int($1);
5960    }
5961    # warn "n[$n]ret[$ret]";
5962    $ret;
5963}
5964
5965sub readable {
5966  my($self,$n) = @_;
5967  $n =~ /^([\w\-\+\.]+)/;
5968
5969  return $1 if defined $1 && length($1)>0;
5970  # if the first user reaches version v43, he will be treated as "+".
5971  # We'll have to decide about a new rule here then, depending on what
5972  # will be the prevailing versioning behavior then.
5973
5974  if ($] < 5.006) { # or whenever v-strings were introduced
5975    # we get them wrong anyway, whatever we do, because 5.005 will
5976    # have already interpreted 0.2.4 to be "0.24". So even if he
5977    # indexer sends us something like "v0.2.4" we compare wrongly.
5978
5979    # And if they say v1.2, then the old perl takes it as "v12"
5980
5981    $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
5982    return $n;
5983  }
5984  my $better = sprintf "v%vd", $n;
5985  CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5986  return $better;
5987}
5988
5989package CPAN;
5990
59911;
5992
5993__END__
5994
5995=head1 NAME
5996
5997CPAN - query, download and build perl modules from CPAN sites
5998
5999=head1 SYNOPSIS
6000
6001Interactive mode:
6002
6003  perl -MCPAN -e shell;
6004
6005Batch mode:
6006
6007  use CPAN;
6008
6009  autobundle, clean, install, make, recompile, test
6010
6011=head1 STATUS
6012
6013This module will eventually be replaced by CPANPLUS. CPANPLUS is kind
6014of a modern rewrite from ground up with greater extensibility and more
6015features but no full compatibility. If you're new to CPAN.pm, you
6016probably should investigate if CPANPLUS is the better choice for you.
6017If you're already used to CPAN.pm you're welcome to continue using it,
6018if you accept that its development is mostly (though not completely)
6019stalled.
6020
6021=head1 DESCRIPTION
6022
6023The CPAN module is designed to automate the make and install of perl
6024modules and extensions. It includes some primitive searching capabilities and
6025knows how to use Net::FTP or LWP (or lynx or an external ftp client)
6026to fetch the raw data from the net.
6027
6028Modules are fetched from one or more of the mirrored CPAN
6029(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
6030directory.
6031
6032The CPAN module also supports the concept of named and versioned
6033I<bundles> of modules. Bundles simplify the handling of sets of
6034related modules. See Bundles below.
6035
6036The package contains a session manager and a cache manager. There is
6037no status retained between sessions. The session manager keeps track
6038of what has been fetched, built and installed in the current
6039session. The cache manager keeps track of the disk space occupied by
6040the make processes and deletes excess space according to a simple FIFO
6041mechanism.
6042
6043For extended searching capabilities there's a plugin for CPAN available,
6044L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
6045that indexes all documents available in CPAN authors directories. If
6046C<CPAN::WAIT> is installed on your system, the interactive shell of
6047CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
6048which send queries to the WAIT server that has been configured for your
6049installation.
6050
6051All other methods provided are accessible in a programmer style and in an
6052interactive shell style.
6053
6054=head2 Interactive Mode
6055
6056The interactive mode is entered by running
6057
6058    perl -MCPAN -e shell
6059
6060which puts you into a readline interface. You will have the most fun if
6061you install Term::ReadKey and Term::ReadLine to enjoy both history and
6062command completion.
6063
6064Once you are on the command line, type 'h' and the rest should be
6065self-explanatory.
6066
6067The function call C<shell> takes two optional arguments, one is the
6068prompt, the second is the default initial command line (the latter
6069only works if a real ReadLine interface module is installed).
6070
6071The most common uses of the interactive modes are
6072
6073=over 2
6074
6075=item Searching for authors, bundles, distribution files and modules
6076
6077There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
6078for each of the four categories and another, C<i> for any of the
6079mentioned four. Each of the four entities is implemented as a class
6080with slightly differing methods for displaying an object.
6081
6082Arguments you pass to these commands are either strings exactly matching
6083the identification string of an object or regular expressions that are
6084then matched case-insensitively against various attributes of the
6085objects. The parser recognizes a regular expression only if you
6086enclose it between two slashes.
6087
6088The principle is that the number of found objects influences how an
6089item is displayed. If the search finds one item, the result is
6090displayed with the rather verbose method C<as_string>, but if we find
6091more than one, we display each object with the terse method
6092<as_glimpse>.
6093
6094=item make, test, install, clean  modules or distributions
6095
6096These commands take any number of arguments and investigate what is
6097necessary to perform the action. If the argument is a distribution
6098file name (recognized by embedded slashes), it is processed. If it is
6099a module, CPAN determines the distribution file in which this module
6100is included and processes that, following any dependencies named in
6101the module's Makefile.PL (this behavior is controlled by
6102I<prerequisites_policy>.)
6103
6104Any C<make> or C<test> are run unconditionally. An
6105
6106  install <distribution_file>
6107
6108also is run unconditionally. But for
6109
6110  install <module>
6111
6112CPAN checks if an install is actually needed for it and prints
6113I<module up to date> in the case that the distribution file containing
6114the module doesn't need to be updated.
6115
6116CPAN also keeps track of what it has done within the current session
6117and doesn't try to build a package a second time regardless if it
6118succeeded or not. The C<force> command takes as a first argument the
6119method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
6120command from scratch.
6121
6122Example:
6123
6124    cpan> install OpenGL
6125    OpenGL is up to date.
6126    cpan> force install OpenGL
6127    Running make
6128    OpenGL-0.4/
6129    OpenGL-0.4/COPYRIGHT
6130    [...]
6131
6132A C<clean> command results in a
6133
6134  make clean
6135
6136being executed within the distribution file's working directory.
6137
6138=item get, readme, look module or distribution
6139
6140C<get> downloads a distribution file without further action. C<readme>
6141displays the README file of the associated distribution. C<Look> gets
6142and untars (if not yet done) the distribution file, changes to the
6143appropriate directory and opens a subshell process in that directory.
6144
6145=item ls author
6146
6147C<ls> lists all distribution files in and below an author's CPAN
6148directory. Only those files that contain modules are listed and if
6149there is more than one for any given module, only the most recent one
6150is listed.
6151
6152=item Signals
6153
6154CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6155in the cpan-shell it is intended that you can press C<^C> anytime and
6156return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6157to clean up and leave the shell loop. You can emulate the effect of a
6158SIGTERM by sending two consecutive SIGINTs, which usually means by
6159pressing C<^C> twice.
6160
6161CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6162SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
6163
6164=back
6165
6166=head2 CPAN::Shell
6167
6168The commands that are available in the shell interface are methods in
6169the package CPAN::Shell. If you enter the shell command, all your
6170input is split by the Text::ParseWords::shellwords() routine which
6171acts like most shells do. The first word is being interpreted as the
6172method to be called and the rest of the words are treated as arguments
6173to this method. Continuation lines are supported if a line ends with a
6174literal backslash.
6175
6176=head2 autobundle
6177
6178C<autobundle> writes a bundle file into the
6179C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6180a list of all modules that are both available from CPAN and currently
6181installed within @INC. The name of the bundle file is based on the
6182current date and a counter.
6183
6184=head2 recompile
6185
6186recompile() is a very special command in that it takes no argument and
6187runs the make/test/install cycle with brute force over all installed
6188dynamically loadable extensions (aka XS modules) with 'force' in
6189effect. The primary purpose of this command is to finish a network
6190installation. Imagine, you have a common source tree for two different
6191architectures. You decide to do a completely independent fresh
6192installation. You start on one architecture with the help of a Bundle
6193file produced earlier. CPAN installs the whole Bundle for you, but
6194when you try to repeat the job on the second architecture, CPAN
6195responds with a C<"Foo up to date"> message for all modules. So you
6196invoke CPAN's recompile on the second architecture and you're done.
6197
6198Another popular use for C<recompile> is to act as a rescue in case your
6199perl breaks binary compatibility. If one of the modules that CPAN uses
6200is in turn depending on binary compatibility (so you cannot run CPAN
6201commands), then you should try the CPAN::Nox module for recovery.
6202
6203=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
6204
6205Although it may be considered internal, the class hierarchy does matter
6206for both users and programmer. CPAN.pm deals with above mentioned four
6207classes, and all those classes share a set of methods. A classical
6208single polymorphism is in effect. A metaclass object registers all
6209objects of all kinds and indexes them with a string. The strings
6210referencing objects have a separated namespace (well, not completely
6211separated):
6212
6213         Namespace                         Class
6214
6215   words containing a "/" (slash)      Distribution
6216    words starting with Bundle::          Bundle
6217          everything else            Module or Author
6218
6219Modules know their associated Distribution objects. They always refer
6220to the most recent official release. Developers may mark their releases
6221as unstable development versions (by inserting an underbar into the
6222module version number which will also be reflected in the distribution
6223name when you run 'make dist'), so the really hottest and newest
6224distribution is not always the default.  If a module Foo circulates
6225on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6226way to install version 1.23 by saying
6227
6228    install Foo
6229
6230This would install the complete distribution file (say
6231BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6232like to install version 1.23_90, you need to know where the
6233distribution file resides on CPAN relative to the authors/id/
6234directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
6235so you would have to say
6236
6237    install BAR/Foo-1.23_90.tar.gz
6238
6239The first example will be driven by an object of the class
6240CPAN::Module, the second by an object of class CPAN::Distribution.
6241
6242=head2 Programmer's interface
6243
6244If you do not enter the shell, the available shell commands are both
6245available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
6246functions in the calling package (C<install(...)>).
6247
6248There's currently only one class that has a stable interface -
6249CPAN::Shell. All commands that are available in the CPAN shell are
6250methods of the class CPAN::Shell. Each of the commands that produce
6251listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6252the IDs of all modules within the list.
6253
6254=over 2
6255
6256=item expand($type,@things)
6257
6258The IDs of all objects available within a program are strings that can
6259be expanded to the corresponding real objects with the
6260C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6261list of CPAN::Module objects according to the C<@things> arguments
6262given. In scalar context it only returns the first element of the
6263list.
6264
6265=item expandany(@things)
6266
6267Like expand, but returns objects of the appropriate type, i.e.
6268CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6269CPAN::Distribution objects fro distributions.
6270
6271=item Programming Examples
6272
6273This enables the programmer to do operations that combine
6274functionalities that are available in the shell.
6275
6276    # install everything that is outdated on my disk:
6277    perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6278
6279    # install my favorite programs if necessary:
6280    for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
6281        my $obj = CPAN::Shell->expand('Module',$mod);
6282        $obj->install;
6283    }
6284
6285    # list all modules on my disk that have no VERSION number
6286    for $mod (CPAN::Shell->expand("Module","/./")){
6287	next unless $mod->inst_file;
6288        # MakeMaker convention for undefined $VERSION:
6289	next unless $mod->inst_version eq "undef";
6290	print "No VERSION in ", $mod->id, "\n";
6291    }
6292
6293    # find out which distribution on CPAN contains a module:
6294    print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6295
6296Or if you want to write a cronjob to watch The CPAN, you could list
6297all modules that need updating. First a quick and dirty way:
6298
6299    perl -e 'use CPAN; CPAN::Shell->r;'
6300
6301If you don't want to get any output in the case that all modules are
6302up to date, you can parse the output of above command for the regular
6303expression //modules are up to date// and decide to mail the output
6304only if it doesn't match. Ick?
6305
6306If you prefer to do it more in a programmer style in one single
6307process, maybe something like this suits you better:
6308
6309  # list all modules on my disk that have newer versions on CPAN
6310  for $mod (CPAN::Shell->expand("Module","/./")){
6311    next unless $mod->inst_file;
6312    next if $mod->uptodate;
6313    printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6314        $mod->id, $mod->inst_version, $mod->cpan_version;
6315  }
6316
6317If that gives you too much output every day, you maybe only want to
6318watch for three modules. You can write
6319
6320  for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6321
6322as the first line instead. Or you can combine some of the above
6323tricks:
6324
6325  # watch only for a new mod_perl module
6326  $mod = CPAN::Shell->expand("Module","mod_perl");
6327  exit if $mod->uptodate;
6328  # new mod_perl arrived, let me know all update recommendations
6329  CPAN::Shell->r;
6330
6331=back
6332
6333=head2 Methods in the other Classes
6334
6335The programming interface for the classes CPAN::Module,
6336CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6337beta and partially even alpha. In the following paragraphs only those
6338methods are documented that have proven useful over a longer time and
6339thus are unlikely to change.
6340
6341=over 4
6342
6343=item CPAN::Author::as_glimpse()
6344
6345Returns a one-line description of the author
6346
6347=item CPAN::Author::as_string()
6348
6349Returns a multi-line description of the author
6350
6351=item CPAN::Author::email()
6352
6353Returns the author's email address
6354
6355=item CPAN::Author::fullname()
6356
6357Returns the author's name
6358
6359=item CPAN::Author::name()
6360
6361An alias for fullname
6362
6363=item CPAN::Bundle::as_glimpse()
6364
6365Returns a one-line description of the bundle
6366
6367=item CPAN::Bundle::as_string()
6368
6369Returns a multi-line description of the bundle
6370
6371=item CPAN::Bundle::clean()
6372
6373Recursively runs the C<clean> method on all items contained in the bundle.
6374
6375=item CPAN::Bundle::contains()
6376
6377Returns a list of objects' IDs contained in a bundle. The associated
6378objects may be bundles, modules or distributions.
6379
6380=item CPAN::Bundle::force($method,@args)
6381
6382Forces CPAN to perform a task that normally would have failed. Force
6383takes as arguments a method name to be called and any number of
6384additional arguments that should be passed to the called method. The
6385internals of the object get the needed changes so that CPAN.pm does
6386not refuse to take the action. The C<force> is passed recursively to
6387all contained objects.
6388
6389=item CPAN::Bundle::get()
6390
6391Recursively runs the C<get> method on all items contained in the bundle
6392
6393=item CPAN::Bundle::inst_file()
6394
6395Returns the highest installed version of the bundle in either @INC or
6396C<$CPAN::Config->{cpan_home}>. Note that this is different from
6397CPAN::Module::inst_file.
6398
6399=item CPAN::Bundle::inst_version()
6400
6401Like CPAN::Bundle::inst_file, but returns the $VERSION
6402
6403=item CPAN::Bundle::uptodate()
6404
6405Returns 1 if the bundle itself and all its members are uptodate.
6406
6407=item CPAN::Bundle::install()
6408
6409Recursively runs the C<install> method on all items contained in the bundle
6410
6411=item CPAN::Bundle::make()
6412
6413Recursively runs the C<make> method on all items contained in the bundle
6414
6415=item CPAN::Bundle::readme()
6416
6417Recursively runs the C<readme> method on all items contained in the bundle
6418
6419=item CPAN::Bundle::test()
6420
6421Recursively runs the C<test> method on all items contained in the bundle
6422
6423=item CPAN::Distribution::as_glimpse()
6424
6425Returns a one-line description of the distribution
6426
6427=item CPAN::Distribution::as_string()
6428
6429Returns a multi-line description of the distribution
6430
6431=item CPAN::Distribution::clean()
6432
6433Changes to the directory where the distribution has been unpacked and
6434runs C<make clean> there.
6435
6436=item CPAN::Distribution::containsmods()
6437
6438Returns a list of IDs of modules contained in a distribution file.
6439Only works for distributions listed in the 02packages.details.txt.gz
6440file. This typically means that only the most recent version of a
6441distribution is covered.
6442
6443=item CPAN::Distribution::cvs_import()
6444
6445Changes to the directory where the distribution has been unpacked and
6446runs something like
6447
6448    cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6449
6450there.
6451
6452=item CPAN::Distribution::dir()
6453
6454Returns the directory into which this distribution has been unpacked.
6455
6456=item CPAN::Distribution::force($method,@args)
6457
6458Forces CPAN to perform a task that normally would have failed. Force
6459takes as arguments a method name to be called and any number of
6460additional arguments that should be passed to the called method. The
6461internals of the object get the needed changes so that CPAN.pm does
6462not refuse to take the action.
6463
6464=item CPAN::Distribution::get()
6465
6466Downloads the distribution from CPAN and unpacks it. Does nothing if
6467the distribution has already been downloaded and unpacked within the
6468current session.
6469
6470=item CPAN::Distribution::install()
6471
6472Changes to the directory where the distribution has been unpacked and
6473runs the external command C<make install> there. If C<make> has not
6474yet been run, it will be run first. A C<make test> will be issued in
6475any case and if this fails, the install will be canceled. The
6476cancellation can be avoided by letting C<force> run the C<install> for
6477you.
6478
6479=item CPAN::Distribution::isa_perl()
6480
6481Returns 1 if this distribution file seems to be a perl distribution.
6482Normally this is derived from the file name only, but the index from
6483CPAN can contain a hint to achieve a return value of true for other
6484filenames too.
6485
6486=item CPAN::Distribution::look()
6487
6488Changes to the directory where the distribution has been unpacked and
6489opens a subshell there. Exiting the subshell returns.
6490
6491=item CPAN::Distribution::make()
6492
6493First runs the C<get> method to make sure the distribution is
6494downloaded and unpacked. Changes to the directory where the
6495distribution has been unpacked and runs the external commands C<perl
6496Makefile.PL> and C<make> there.
6497
6498=item CPAN::Distribution::prereq_pm()
6499
6500Returns the hash reference that has been announced by a distribution
6501as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6502attempt has been made to C<make> the distribution. Returns undef
6503otherwise.
6504
6505=item CPAN::Distribution::readme()
6506
6507Downloads the README file associated with a distribution and runs it
6508through the pager specified in C<$CPAN::Config->{pager}>.
6509
6510=item CPAN::Distribution::test()
6511
6512Changes to the directory where the distribution has been unpacked and
6513runs C<make test> there.
6514
6515=item CPAN::Distribution::uptodate()
6516
6517Returns 1 if all the modules contained in the distribution are
6518uptodate. Relies on containsmods.
6519
6520=item CPAN::Index::force_reload()
6521
6522Forces a reload of all indices.
6523
6524=item CPAN::Index::reload()
6525
6526Reloads all indices if they have been read more than
6527C<$CPAN::Config->{index_expire}> days.
6528
6529=item CPAN::InfoObj::dump()
6530
6531CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6532inherit this method. It prints the data structure associated with an
6533object. Useful for debugging. Note: the data structure is considered
6534internal and thus subject to change without notice.
6535
6536=item CPAN::Module::as_glimpse()
6537
6538Returns a one-line description of the module
6539
6540=item CPAN::Module::as_string()
6541
6542Returns a multi-line description of the module
6543
6544=item CPAN::Module::clean()
6545
6546Runs a clean on the distribution associated with this module.
6547
6548=item CPAN::Module::cpan_file()
6549
6550Returns the filename on CPAN that is associated with the module.
6551
6552=item CPAN::Module::cpan_version()
6553
6554Returns the latest version of this module available on CPAN.
6555
6556=item CPAN::Module::cvs_import()
6557
6558Runs a cvs_import on the distribution associated with this module.
6559
6560=item CPAN::Module::description()
6561
6562Returns a 44 character description of this module. Only available for
6563modules listed in The Module List (CPAN/modules/00modlist.long.html
6564or 00modlist.long.txt.gz)
6565
6566=item CPAN::Module::force($method,@args)
6567
6568Forces CPAN to perform a task that normally would have failed. Force
6569takes as arguments a method name to be called and any number of
6570additional arguments that should be passed to the called method. The
6571internals of the object get the needed changes so that CPAN.pm does
6572not refuse to take the action.
6573
6574=item CPAN::Module::get()
6575
6576Runs a get on the distribution associated with this module.
6577
6578=item CPAN::Module::inst_file()
6579
6580Returns the filename of the module found in @INC. The first file found
6581is reported just like perl itself stops searching @INC when it finds a
6582module.
6583
6584=item CPAN::Module::inst_version()
6585
6586Returns the version number of the module in readable format.
6587
6588=item CPAN::Module::install()
6589
6590Runs an C<install> on the distribution associated with this module.
6591
6592=item CPAN::Module::look()
6593
6594Changes to the directory where the distribution associated with this
6595module has been unpacked and opens a subshell there. Exiting the
6596subshell returns.
6597
6598=item CPAN::Module::make()
6599
6600Runs a C<make> on the distribution associated with this module.
6601
6602=item CPAN::Module::manpage_headline()
6603
6604If module is installed, peeks into the module's manpage, reads the
6605headline and returns it. Moreover, if the module has been downloaded
6606within this session, does the equivalent on the downloaded module even
6607if it is not installed.
6608
6609=item CPAN::Module::readme()
6610
6611Runs a C<readme> on the distribution associated with this module.
6612
6613=item CPAN::Module::test()
6614
6615Runs a C<test> on the distribution associated with this module.
6616
6617=item CPAN::Module::uptodate()
6618
6619Returns 1 if the module is installed and up-to-date.
6620
6621=item CPAN::Module::userid()
6622
6623Returns the author's ID of the module.
6624
6625=back
6626
6627=head2 Cache Manager
6628
6629Currently the cache manager only keeps track of the build directory
6630($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
6631deletes complete directories below C<build_dir> as soon as the size of
6632all directories there gets bigger than $CPAN::Config->{build_cache}
6633(in MB). The contents of this cache may be used for later
6634re-installations that you intend to do manually, but will never be
6635trusted by CPAN itself. This is due to the fact that the user might
6636use these directories for building modules on different architectures.
6637
6638There is another directory ($CPAN::Config->{keep_source_where}) where
6639the original distribution files are kept. This directory is not
6640covered by the cache manager and must be controlled by the user. If
6641you choose to have the same directory as build_dir and as
6642keep_source_where directory, then your sources will be deleted with
6643the same fifo mechanism.
6644
6645=head2 Bundles
6646
6647A bundle is just a perl module in the namespace Bundle:: that does not
6648define any functions or methods. It usually only contains documentation.
6649
6650It starts like a perl module with a package declaration and a $VERSION
6651variable. After that the pod section looks like any other pod with the
6652only difference being that I<one special pod section> exists starting with
6653(verbatim):
6654
6655	=head1 CONTENTS
6656
6657In this pod section each line obeys the format
6658
6659        Module_Name [Version_String] [- optional text]
6660
6661The only required part is the first field, the name of a module
6662(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
6663of the line is optional. The comment part is delimited by a dash just
6664as in the man page header.
6665
6666The distribution of a bundle should follow the same convention as
6667other distributions.
6668
6669Bundles are treated specially in the CPAN package. If you say 'install
6670Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
6671the modules in the CONTENTS section of the pod. You can install your
6672own Bundles locally by placing a conformant Bundle file somewhere into
6673your @INC path. The autobundle() command which is available in the
6674shell interface does that for you by including all currently installed
6675modules in a snapshot bundle file.
6676
6677=head2 Prerequisites
6678
6679If you have a local mirror of CPAN and can access all files with
6680"file:" URLs, then you only need a perl better than perl5.003 to run
6681this module. Otherwise Net::FTP is strongly recommended. LWP may be
6682required for non-UNIX systems or if your nearest CPAN site is
6683associated with a URL that is not C<ftp:>.
6684
6685If you have neither Net::FTP nor LWP, there is a fallback mechanism
6686implemented for an external ftp command or for an external lynx
6687command.
6688
6689=head2 Finding packages and VERSION
6690
6691This module presumes that all packages on CPAN
6692
6693=over 2
6694
6695=item *
6696
6697declare their $VERSION variable in an easy to parse manner. This
6698prerequisite can hardly be relaxed because it consumes far too much
6699memory to load all packages into the running program just to determine
6700the $VERSION variable. Currently all programs that are dealing with
6701version use something like this
6702
6703    perl -MExtUtils::MakeMaker -le \
6704        'print MM->parse_version(shift)' filename
6705
6706If you are author of a package and wonder if your $VERSION can be
6707parsed, please try the above method.
6708
6709=item *
6710
6711come as compressed or gzipped tarfiles or as zip files and contain a
6712Makefile.PL (well, we try to handle a bit more, but without much
6713enthusiasm).
6714
6715=back
6716
6717=head2 Debugging
6718
6719The debugging of this module is a bit complex, because we have
6720interferences of the software producing the indices on CPAN, of the
6721mirroring process on CPAN, of packaging, of configuration, of
6722synchronicity, and of bugs within CPAN.pm.
6723
6724For code debugging in interactive mode you can try "o debug" which
6725will list options for debugging the various parts of the code. You
6726should know that "o debug" has built-in completion support.
6727
6728For data debugging there is the C<dump> command which takes the same
6729arguments as make/test/install and outputs the object's Data::Dumper
6730dump.
6731
6732=head2 Floppy, Zip, Offline Mode
6733
6734CPAN.pm works nicely without network too. If you maintain machines
6735that are not networked at all, you should consider working with file:
6736URLs. Of course, you have to collect your modules somewhere first. So
6737you might use CPAN.pm to put together all you need on a networked
6738machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6739$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6740of a personal CPAN. CPAN.pm on the non-networked machines works nicely
6741with this floppy. See also below the paragraph about CD-ROM support.
6742
6743=head1 CONFIGURATION
6744
6745When the CPAN module is used for the first time, a configuration
6746dialog tries to determine a couple of site specific options. The
6747result of the dialog is stored in a hash reference C< $CPAN::Config >
6748in a file CPAN/Config.pm.
6749
6750The default values defined in the CPAN/Config.pm file can be
6751overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
6752best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
6753added to the search path of the CPAN module before the use() or
6754require() statements.
6755
6756The configuration dialog can be started any time later again by
6757issueing the command C< o conf init > in the CPAN shell.
6758
6759Currently the following keys in the hash reference $CPAN::Config are
6760defined:
6761
6762  build_cache        size of cache for directories to build modules
6763  build_dir          locally accessible directory to build modules
6764  index_expire       after this many days refetch index files
6765  cache_metadata     use serializer to cache metadata
6766  cpan_home          local directory reserved for this package
6767  dontload_hash      anonymous hash: modules in the keys will not be
6768                     loaded by the CPAN::has_inst() routine
6769  gzip		     location of external program gzip
6770  histfile           file to maintain history between sessions
6771  histsize           maximum number of lines to keep in histfile
6772  inactivity_timeout breaks interactive Makefile.PLs after this
6773                     many seconds inactivity. Set to 0 to never break.
6774  inhibit_startup_message
6775                     if true, does not print the startup message
6776  keep_source_where  directory in which to keep the source (if we do)
6777  make               location of external make program
6778  make_arg	     arguments that should always be passed to 'make'
6779  make_install_arg   same as make_arg for 'make install'
6780  makepl_arg	     arguments passed to 'perl Makefile.PL'
6781  pager              location of external program more (or any pager)
6782  prerequisites_policy
6783                     what to do if you are missing module prerequisites
6784                     ('follow' automatically, 'ask' me, or 'ignore')
6785  proxy_user         username for accessing an authenticating proxy
6786  proxy_pass         password for accessing an authenticating proxy
6787  scan_cache	     controls scanning of cache ('atstart' or 'never')
6788  tar                location of external program tar
6789  term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
6790                     (and nonsense for characters outside latin range)
6791  unzip              location of external program unzip
6792  urllist	     arrayref to nearby CPAN sites (or equivalent locations)
6793  wait_list          arrayref to a wait server to try (See CPAN::WAIT)
6794  ftp_proxy,      }  the three usual variables for configuring
6795    http_proxy,   }  proxy requests. Both as CPAN::Config variables
6796    no_proxy      }  and as environment variables configurable.
6797
6798You can set and query each of these options interactively in the cpan
6799shell with the command set defined within the C<o conf> command:
6800
6801=over 2
6802
6803=item C<o conf E<lt>scalar optionE<gt>>
6804
6805prints the current value of the I<scalar option>
6806
6807=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
6808
6809Sets the value of the I<scalar option> to I<value>
6810
6811=item C<o conf E<lt>list optionE<gt>>
6812
6813prints the current value of the I<list option> in MakeMaker's
6814neatvalue format.
6815
6816=item C<o conf E<lt>list optionE<gt> [shift|pop]>
6817
6818shifts or pops the array in the I<list option> variable
6819
6820=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
6821
6822works like the corresponding perl commands.
6823
6824=back
6825
6826=head2 Note on urllist parameter's format
6827
6828urllist parameters are URLs according to RFC 1738. We do a little
6829guessing if your URL is not compliant, but if you have problems with
6830file URLs, please try the correct format. Either:
6831
6832    file://localhost/whatever/ftp/pub/CPAN/
6833
6834or
6835
6836    file:///home/ftp/pub/CPAN/
6837
6838=head2 urllist parameter has CD-ROM support
6839
6840The C<urllist> parameter of the configuration table contains a list of
6841URLs that are to be used for downloading. If the list contains any
6842C<file> URLs, CPAN always tries to get files from there first. This
6843feature is disabled for index files. So the recommendation for the
6844owner of a CD-ROM with CPAN contents is: include your local, possibly
6845outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6846
6847  o conf urllist push file://localhost/CDROM/CPAN
6848
6849CPAN.pm will then fetch the index files from one of the CPAN sites
6850that come at the beginning of urllist. It will later check for each
6851module if there is a local copy of the most recent version.
6852
6853Another peculiarity of urllist is that the site that we could
6854successfully fetch the last file from automatically gets a preference
6855token and is tried as the first site for the next request. So if you
6856add a new site at runtime it may happen that the previously preferred
6857site will be tried another time. This means that if you want to disallow
6858a site for the next transfer, it must be explicitly removed from
6859urllist.
6860
6861=head1 SECURITY
6862
6863There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6864install foreign, unmasked, unsigned code on your machine. We compare
6865to a checksum that comes from the net just as the distribution file
6866itself. If somebody has managed to tamper with the distribution file,
6867they may have as well tampered with the CHECKSUMS file. Future
6868development will go towards strong authentication.
6869
6870=head1 EXPORT
6871
6872Most functions in package CPAN are exported per default. The reason
6873for this is that the primary use is intended for the cpan shell or for
6874one-liners.
6875
6876=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6877
6878Populating a freshly installed perl with my favorite modules is pretty
6879easy if you maintain a private bundle definition file. To get a useful
6880blueprint of a bundle definition file, the command autobundle can be used
6881on the CPAN shell command line. This command writes a bundle definition
6882file for all modules that are installed for the currently running perl
6883interpreter. It's recommended to run this command only once and from then
6884on maintain the file manually under a private name, say
6885Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6886
6887    cpan> install Bundle::my_bundle
6888
6889then answer a few questions and then go out for a coffee.
6890
6891Maintaining a bundle definition file means keeping track of two
6892things: dependencies and interactivity. CPAN.pm sometimes fails on
6893calculating dependencies because not all modules define all MakeMaker
6894attributes correctly, so a bundle definition file should specify
6895prerequisites as early as possible. On the other hand, it's a bit
6896annoying that many distributions need some interactive configuring. So
6897what I try to accomplish in my private bundle file is to have the
6898packages that need to be configured early in the file and the gentle
6899ones later, so I can go out after a few minutes and leave CPAN.pm
6900untended.
6901
6902=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6903
6904Thanks to Graham Barr for contributing the following paragraphs about
6905the interaction between perl, and various firewall configurations. For
6906further informations on firewalls, it is recommended to consult the
6907documentation that comes with the ncftp program. If you are unable to
6908go through the firewall with a simple Perl setup, it is very likely
6909that you can configure ncftp so that it works for your firewall.
6910
6911=head2 Three basic types of firewalls
6912
6913Firewalls can be categorized into three basic types.
6914
6915=over 4
6916
6917=item http firewall
6918
6919This is where the firewall machine runs a web server and to access the
6920outside world you must do it via the web server. If you set environment
6921variables like http_proxy or ftp_proxy to a values beginning with http://
6922or in your web browser you have to set proxy information then you know
6923you are running an http firewall.
6924
6925To access servers outside these types of firewalls with perl (even for
6926ftp) you will need to use LWP.
6927
6928=item ftp firewall
6929
6930This where the firewall machine runs an ftp server. This kind of
6931firewall will only let you access ftp servers outside the firewall.
6932This is usually done by connecting to the firewall with ftp, then
6933entering a username like "user@outside.host.com"
6934
6935To access servers outside these type of firewalls with perl you
6936will need to use Net::FTP.
6937
6938=item One way visibility
6939
6940I say one way visibility as these firewalls try to make themselves look
6941invisible to the users inside the firewall. An FTP data connection is
6942normally created by sending the remote server your IP address and then
6943listening for the connection. But the remote server will not be able to
6944connect to you because of the firewall. So for these types of firewall
6945FTP connections need to be done in a passive mode.
6946
6947There are two that I can think off.
6948
6949=over 4
6950
6951=item SOCKS
6952
6953If you are using a SOCKS firewall you will need to compile perl and link
6954it with the SOCKS library, this is what is normally called a 'socksified'
6955perl. With this executable you will be able to connect to servers outside
6956the firewall as if it is not there.
6957
6958=item IP Masquerade
6959
6960This is the firewall implemented in the Linux kernel, it allows you to
6961hide a complete network behind one IP address. With this firewall no
6962special compiling is needed as you can access hosts directly.
6963
6964For accessing ftp servers behind such firewalls you may need to set
6965the environment variable C<FTP_PASSIVE> to a true value, e.g.
6966
6967    env FTP_PASSIVE=1 perl -MCPAN -eshell
6968
6969or
6970
6971    perl -MCPAN -e '$ENV{FTP_PASSIVE} = 1; shell'
6972
6973
6974=back
6975
6976=back
6977
6978=head2 Configuring lynx or ncftp for going through a firewall
6979
6980If you can go through your firewall with e.g. lynx, presumably with a
6981command such as
6982
6983    /usr/local/bin/lynx -pscott:tiger
6984
6985then you would configure CPAN.pm with the command
6986
6987    o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6988
6989That's all. Similarly for ncftp or ftp, you would configure something
6990like
6991
6992    o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6993
6994Your mileage may vary...
6995
6996=head1 FAQ
6997
6998=over 4
6999
7000=item 1)
7001
7002I installed a new version of module X but CPAN keeps saying,
7003I have the old version installed
7004
7005Most probably you B<do> have the old version installed. This can
7006happen if a module installs itself into a different directory in the
7007@INC path than it was previously installed. This is not really a
7008CPAN.pm problem, you would have the same problem when installing the
7009module manually. The easiest way to prevent this behaviour is to add
7010the argument C<UNINST=1> to the C<make install> call, and that is why
7011many people add this argument permanently by configuring
7012
7013  o conf make_install_arg UNINST=1
7014
7015=item 2)
7016
7017So why is UNINST=1 not the default?
7018
7019Because there are people who have their precise expectations about who
7020may install where in the @INC path and who uses which @INC array. In
7021fine tuned environments C<UNINST=1> can cause damage.
7022
7023=item 3)
7024
7025I want to clean up my mess, and install a new perl along with
7026all modules I have. How do I go about it?
7027
7028Run the autobundle command for your old perl and optionally rename the
7029resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
7030with the Configure option prefix, e.g.
7031
7032    ./Configure -Dprefix=/usr/local/perl-5.6.78.9
7033
7034Install the bundle file you produced in the first step with something like
7035
7036    cpan> install Bundle::mybundle
7037
7038and you're done.
7039
7040=item 4)
7041
7042When I install bundles or multiple modules with one command
7043there is too much output to keep track of.
7044
7045You may want to configure something like
7046
7047  o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
7048  o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
7049
7050so that STDOUT is captured in a file for later inspection.
7051
7052
7053=item 5)
7054
7055I am not root, how can I install a module in a personal directory?
7056
7057You will most probably like something like this:
7058
7059  o conf makepl_arg "LIB=~/myperl/lib \
7060                    INSTALLMAN1DIR=~/myperl/man/man1 \
7061                    INSTALLMAN3DIR=~/myperl/man/man3"
7062  install Sybase::Sybperl
7063
7064You can make this setting permanent like all C<o conf> settings with
7065C<o conf commit>.
7066
7067You will have to add ~/myperl/man to the MANPATH environment variable
7068and also tell your perl programs to look into ~/myperl/lib, e.g. by
7069including
7070
7071  use lib "$ENV{HOME}/myperl/lib";
7072
7073or setting the PERL5LIB environment variable.
7074
7075Another thing you should bear in mind is that the UNINST parameter
7076should never be set if you are not root.
7077
7078=item 6)
7079
7080How to get a package, unwrap it, and make a change before building it?
7081
7082  look Sybase::Sybperl
7083
7084=item 7)
7085
7086I installed a Bundle and had a couple of fails. When I
7087retried, everything resolved nicely. Can this be fixed to work
7088on first try?
7089
7090The reason for this is that CPAN does not know the dependencies of all
7091modules when it starts out. To decide about the additional items to
7092install, it just uses data found in the generated Makefile. An
7093undetected missing piece breaks the process. But it may well be that
7094your Bundle installs some prerequisite later than some depending item
7095and thus your second try is able to resolve everything. Please note,
7096CPAN.pm does not know the dependency tree in advance and cannot sort
7097the queue of things to install in a topologically correct order. It
7098resolves perfectly well IFF all modules declare the prerequisites
7099correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
7100fail and you need to install often, it is recommended sort the Bundle
7101definition file manually. It is planned to improve the metadata
7102situation for dependencies on CPAN in general, but this will still
7103take some time.
7104
7105=item 8)
7106
7107In our intranet we have many modules for internal use. How
7108can I integrate these modules with CPAN.pm but without uploading
7109the modules to CPAN?
7110
7111Have a look at the CPAN::Site module.
7112
7113=item 9)
7114
7115When I run CPAN's shell, I get error msg about line 1 to 4,
7116setting meta input/output via the /etc/inputrc file.
7117
7118Some versions of readline are picky about capitalization in the
7119/etc/inputrc file and specifically RedHat 6.2 comes with a
7120/etc/inputrc that contains the word C<on> in lowercase. Change the
7121occurrences of C<on> to C<On> and the bug should disappear.
7122
7123=item 10)
7124
7125Some authors have strange characters in their names.
7126
7127Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7128expecting ISO-8859-1 charset, a converter can be activated by setting
7129term_is_latin to a true value in your config file. One way of doing so
7130would be
7131
7132    cpan> ! $CPAN::Config->{term_is_latin}=1
7133
7134Extended support for converters will be made available as soon as perl
7135becomes stable with regard to charset issues.
7136
7137=back
7138
7139=head1 BUGS
7140
7141We should give coverage for B<all> of the CPAN and not just the PAUSE
7142part, right? In this discussion CPAN and PAUSE have become equal --
7143but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
7144PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
7145
7146Future development should be directed towards a better integration of
7147the other parts.
7148
7149If a Makefile.PL requires special customization of libraries, prompts
7150the user for special input, etc. then you may find CPAN is not able to
7151build the distribution. In that case, you should attempt the
7152traditional method of building a Perl module package from a shell.
7153
7154=head1 AUTHOR
7155
7156Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
7157
7158=head1 TRANSLATIONS
7159
7160Kawai,Takanori provides a Japanese translation of this manpage at
7161http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7162
7163=head1 SEE ALSO
7164
7165perl(1), CPAN::Nox(3)
7166
7167=cut
7168
7169