20b67be8078fd9a0fc2f39a368f1f74b44bf8ef7
[perl.git] / lib / CPAN.pm
1 package CPAN;
2 use vars qw{$Try_autoload
3             $Revision
4             $META $Signal $Cwd $End
5             $Suppress_readline
6             $Frontend  $Defaultsite
7            }; #};
8
9 $VERSION = '1.57_51';
10
11 # $Id: CPAN.pm,v 1.314 2000/08/21 12:37:43 k Exp $
12
13 # only used during development:
14 $Revision = "";
15 # $Revision = "[".substr(q$Revision: 1.314 $, 10)."]";
16
17 use Carp ();
18 use Config ();
19 use Cwd ();
20 use DirHandle;
21 use Exporter ();
22 use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
23 use File::Basename ();
24 use File::Copy ();
25 use File::Find;
26 use File::Path ();
27 use FileHandle ();
28 use Safe ();
29 use Text::ParseWords ();
30 use Text::Wrap;
31 use File::Spec;
32 no lib "."; # we need to run chdir all over and we would get at wrong
33             # libraries there
34
35 END { $End++; &cleanup; }
36
37 %CPAN::DEBUG = qw[
38                   CPAN              1
39                   Index             2
40                   InfoObj           4
41                   Author            8
42                   Distribution     16
43                   Bundle           32
44                   Module           64
45                   CacheMgr        128
46                   Complete        256
47                   FTP             512
48                   Shell          1024
49                   Eval           2048
50                   Config         4096
51                   Tarzip         8192
52                   Version       16384
53 ];
54
55 $CPAN::DEBUG ||= 0;
56 $CPAN::Signal ||= 0;
57 $CPAN::Frontend ||= "CPAN::Shell";
58 $CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
59
60 package CPAN;
61 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term);
62 use strict qw(vars);
63
64 @CPAN::ISA = qw(CPAN::Debug Exporter);
65
66 @EXPORT = qw(
67              autobundle bundle expand force get cvs_import
68              install make readme recompile shell test clean
69             );
70
71 #-> sub CPAN::AUTOLOAD ;
72 sub AUTOLOAD {
73     my($l) = $AUTOLOAD;
74     $l =~ s/.*:://;
75     my(%EXPORT);
76     @EXPORT{@EXPORT} = '';
77     CPAN::Config->load unless $CPAN::Config_loaded++;
78     if (exists $EXPORT{$l}){
79         CPAN::Shell->$l(@_);
80     } else {
81         my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
82         if ($ok) {
83             goto &$AUTOLOAD;
84 #       } else {
85 #           $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
86         }
87         $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
88                                 qq{Type ? for help.
89 });
90     }
91 }
92
93 #-> sub CPAN::shell ;
94 sub shell {
95     my($self) = @_;
96     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
97     CPAN::Config->load unless $CPAN::Config_loaded++;
98
99     CPAN::Index->read_metadata_cache;
100
101     my $prompt = "cpan> ";
102     local($^W) = 1;
103     unless ($Suppress_readline) {
104         require Term::ReadLine;
105 #       import Term::ReadLine;
106         $term = Term::ReadLine->new('CPAN Monitor');
107         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
108             my $attribs = $term->Attribs;
109 #            $attribs->{completion_entry_function} =
110 #                $attribs->{'list_completion_function'};
111              $attribs->{attempted_completion_function} = sub {
112                  &CPAN::Complete::gnu_cpl;
113              }
114 #           $attribs->{completion_word} =
115 #               [qw(help me somebody to find out how
116 #                    to use completion with GNU)];
117         } else {
118             $readline::rl_completion_function =
119                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
120         }
121         # $term->OUT is autoflushed anyway
122         my $odef = select STDERR;
123         $| = 1;
124         select STDOUT;
125         $| = 1;
126         select $odef;
127     }
128
129     no strict;
130     $META->checklock();
131     my $getcwd;
132     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
133     my $cwd = CPAN->$getcwd();
134     my $try_detect_readline;
135     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
136     my $rl_avail = $Suppress_readline ? "suppressed" :
137         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
138             "available (try ``install Bundle::CPAN'')";
139
140     $CPAN::Frontend->myprint(
141                              qq{
142 cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
143 ReadLine support $rl_avail
144
145 }) unless $CPAN::Config->{'inhibit_startup_message'} ;
146     my($continuation) = "";
147     while () {
148         if ($Suppress_readline) {
149             print $prompt;
150             last unless defined ($_ = <> );
151             chomp;
152         } else {
153             last unless defined ($_ = $term->readline($prompt));
154         }
155         $_ = "$continuation$_" if $continuation;
156         s/^\s+//;
157         next if /^$/;
158         $_ = 'h' if /^\s*\?/;
159         if (/^(?:q(?:uit)?|bye|exit)$/i) {
160             last;
161         } elsif (s/\\$//s) {
162             chomp;
163             $continuation = $_;
164             $prompt = "    > ";
165         } elsif (/^\!/) {
166             s/^\!//;
167             my($eval) = $_;
168             package CPAN::Eval;
169             use vars qw($import_done);
170             CPAN->import(':DEFAULT') unless $import_done++;
171             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
172             eval($eval);
173             warn $@ if $@;
174             $continuation = "";
175             $prompt = "cpan> ";
176         } elsif (/./) {
177             my(@line);
178             if ($] < 5.00322) { # parsewords had a bug until recently
179                 @line = split;
180             } else {
181                 eval { @line = Text::ParseWords::shellwords($_) };
182                 warn($@), next if $@;
183             }
184             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
185             my $command = shift @line;
186             eval { CPAN::Shell->$command(@line) };
187             warn $@ if $@;
188             chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
189             $CPAN::Frontend->myprint("\n");
190             $continuation = "";
191             $prompt = "cpan> ";
192         }
193     } continue {
194       $Signal=0;
195       CPAN::Queue->nullify_queue;
196       if ($try_detect_readline) {
197         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
198             ||
199             $CPAN::META->has_inst("Term::ReadLine::Perl")
200            ) {
201             delete $INC{"Term/ReadLine.pm"};
202             my $redef;
203             local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef);
204             require Term::ReadLine;
205             $CPAN::Frontend->myprint("\n$redef subroutines in ".
206                                      "Term::ReadLine redefined\n");
207             goto &shell;
208         }
209       }
210     }
211 }
212
213 package CPAN::CacheMgr;
214 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
215 use File::Find;
216
217 package CPAN::Config;
218 use vars qw(%can $dot_cpan);
219
220 %can = (
221   'commit' => "Commit changes to disk",
222   'defaults' => "Reload defaults from disk",
223   'init'   => "Interactive setting of all options",
224 );
225
226 package CPAN::FTP;
227 use vars qw($Ua $Thesite $Themethod);
228 @CPAN::FTP::ISA = qw(CPAN::Debug);
229
230 package CPAN::Complete;
231 @CPAN::Complete::ISA = qw(CPAN::Debug);
232
233 package CPAN::Index;
234 use vars qw($last_time $date_of_03);
235 @CPAN::Index::ISA = qw(CPAN::Debug);
236 $last_time ||= 0;
237 $date_of_03 ||= 0;
238
239 package CPAN::InfoObj;
240 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
241
242 package CPAN::Author;
243 @CPAN::Author::ISA = qw(CPAN::InfoObj);
244
245 package CPAN::Distribution;
246 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
247
248 package CPAN::Bundle;
249 @CPAN::Bundle::ISA = qw(CPAN::Module);
250
251 package CPAN::Module;
252 @CPAN::Module::ISA = qw(CPAN::InfoObj);
253
254 package CPAN::Shell;
255 use vars qw($AUTOLOAD $redef @ISA);
256 @CPAN::Shell::ISA = qw(CPAN::Debug);
257
258 #-> sub CPAN::Shell::AUTOLOAD ;
259 sub AUTOLOAD {
260     my($autoload) = $AUTOLOAD;
261     my $class = shift(@_);
262     # warn "autoload[$autoload] class[$class]";
263     $autoload =~ s/.*:://;
264     if ($autoload =~ /^w/) {
265         if ($CPAN::META->has_inst('CPAN::WAIT')) {
266             CPAN::WAIT->$autoload(@_);
267         } else {
268             $CPAN::Frontend->mywarn(qq{
269 Commands starting with "w" require CPAN::WAIT to be installed.
270 Please consider installing CPAN::WAIT to use the fulltext index.
271 For this you just need to type
272     install CPAN::WAIT
273 });
274         }
275     } else {
276         my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
277         if ($ok) {
278             goto &$AUTOLOAD;
279 #       } else {
280 #           $CPAN::Frontend->mywarn("Could not autoload $autoload");
281         }
282         $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
283                                 qq{Type ? for help.
284 });
285     }
286 }
287
288 #-> CPAN::Shell::try_dot_al
289 sub try_dot_al {
290     my($class,$autoload) = @_;
291     return unless $CPAN::Try_autoload;
292     # I don't see how to re-use that from the AutoLoader...
293     my($name,$ok);
294     # Braces used to preserve $1 et al.
295     {
296         my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
297         $pkg =~ s|::|/|g;
298         if (defined($name=$INC{"$pkg.pm"}))
299             {
300                 $name =~ s|^(.*)$pkg\.pm(?!\n)\Z|$1auto/$pkg/$func.al|s;
301                 $name = undef unless (-r $name);
302             }
303         unless (defined $name)
304             {
305                 $name = "auto/$autoload.al";
306                 $name =~ s|::|/|g;
307             }
308     }
309     my $save = $@;
310     eval {local $SIG{__DIE__};require $name};
311     if ($@) {
312         if (substr($autoload,-9) eq '::DESTROY') {
313             *$autoload = sub {};
314             $ok = 1;
315         } else {
316             if ($name =~ s{(\w{12,})\.al(?!\n)\Z}{substr($1,0,11).".al"}e){
317                 eval {local $SIG{__DIE__};require $name};
318             }
319             if ($@){
320                 $@ =~ s/ at .*\n//;
321                 Carp::croak $@;
322             } else {
323                 $ok = 1;
324             }
325         }
326     } else {
327
328       $ok = 1;
329
330     }
331     $@ = $save;
332 #    my $lm = Carp::longmess();
333 #    warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
334     return $ok;
335 }
336
337 #### autoloader is experimental
338 #### to try it we have to set $Try_autoload and uncomment
339 #### the use statement and uncomment the __END__ below
340 #### You also need AutoSplit 1.01 available. MakeMaker will
341 #### then build CPAN with all the AutoLoad stuff.
342 # use AutoLoader;
343 # $Try_autoload = 1;
344
345 if ($CPAN::Try_autoload) {
346   my $p;
347     for $p (qw(
348                CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
349                CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
350                CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
351                  )) {
352         *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
353     }
354 }
355
356 package CPAN::Tarzip;
357 use vars qw($AUTOLOAD @ISA);
358 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
359
360 package CPAN::Queue;
361
362 # One use of the queue is to determine if we should or shouldn't
363 # announce the availability of a new CPAN module
364
365 # Now we try to use it for dependency tracking. For that to happen
366 # we need to draw a dependency tree and do the leaves first. This can
367 # easily be reached by running CPAN.pm recursively, but we don't want
368 # to waste memory and run into deep recursion. So what we can do is
369 # this:
370
371 # CPAN::Queue is the package where the queue is maintained. Dependencies
372 # often have high priority and must be brought to the head of the queue,
373 # possibly by jumping the queue if they are already there. My first code
374 # attempt tried to be extremely correct. Whenever a module needed
375 # immediate treatment, I either unshifted it to the front of the queue,
376 # or, if it was already in the queue, I spliced and let it bypass the
377 # others. This became a too correct model that made it impossible to put
378 # an item more than once into the queue. Why would you need that? Well,
379 # you need temporary duplicates as the manager of the queue is a loop
380 # that
381 #
382 #  (1) looks at the first item in the queue without shifting it off
383 #
384 #  (2) cares for the item
385 #
386 #  (3) removes the item from the queue, *even if its agenda failed and
387 #      even if the item isn't the first in the queue anymore* (that way
388 #      protecting against never ending queues)
389 #
390 # So if an item has prerequisites, the installation fails now, but we
391 # want to retry later. That's easy if we have it twice in the queue.
392 #
393 # I also expect insane dependency situations where an item gets more
394 # than two lives in the queue. Simplest example is triggered by 'install
395 # Foo Foo Foo'. People make this kind of mistakes and I don't want to
396 # get in the way. I wanted the queue manager to be a dumb servant, not
397 # one that knows everything.
398 #
399 # Who would I tell in this model that the user wants to be asked before
400 # processing? I can't attach that information to the module object,
401 # because not modules are installed but distributions. So I'd have to
402 # tell the distribution object that it should ask the user before
403 # processing. Where would the question be triggered then? Most probably
404 # in CPAN::Distribution::rematein.
405 # Hope that makes sense, my head is a bit off:-) -- AK
406
407 use vars qw{ @All };
408
409 sub new {
410   my($class,$mod) = @_;
411   my $self = bless {mod => $mod}, $class;
412   push @All, $self;
413   # my @all = map { $_->{mod} } @All;
414   # warn "Adding Queue object for mod[$mod] all[@all]";
415   return $self;
416 }
417
418 sub first {
419   my $obj = $All[0];
420   $obj->{mod};
421 }
422
423 sub delete_first {
424   my($class,$what) = @_;
425   my $i;
426   for my $i (0..$#All) {
427     if (  $All[$i]->{mod} eq $what ) {
428       splice @All, $i, 1;
429       return;
430     }
431   }
432 }
433
434 sub jumpqueue {
435   my $class = shift;
436   my @what = @_;
437   my $obj;
438   WHAT: for my $what (reverse @what) {
439     my $jumped = 0;
440     for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
441       if ($All[$i]->{mod} eq $what){
442         $jumped++;
443         if ($jumped > 100) { # one's OK if e.g. just processing now;
444                              # more are OK if user typed it several
445                              # times
446           $CPAN::Frontend->mywarn(
447 qq{Object [$what] queued more than 100 times, ignoring}
448                                  );
449           next WHAT;
450         }
451       }
452     }
453     my $obj = bless { mod => $what }, $class;
454     unshift @All, $obj;
455   }
456 }
457
458 sub exists {
459   my($self,$what) = @_;
460   my @all = map { $_->{mod} } @All;
461   my $exists = grep { $_->{mod} eq $what } @All;
462   # warn "Checking exists in Queue object for mod[$what] all[@all] exists[$exists]";
463   $exists;
464 }
465
466 sub delete {
467   my($self,$mod) = @_;
468   @All = grep { $_->{mod} ne $mod } @All;
469   # my @all = map { $_->{mod} } @All;
470   # warn "Deleting Queue object for mod[$mod] all[@all]";
471 }
472
473 sub nullify_queue {
474   @All = ();
475 }
476
477
478
479 package CPAN;
480
481 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
482
483 1;
484
485 # __END__ # uncomment this and AutoSplit version 1.01 will split it
486
487 #-> sub CPAN::autobundle ;
488 sub autobundle;
489 #-> sub CPAN::bundle ;
490 sub bundle;
491 #-> sub CPAN::expand ;
492 sub expand;
493 #-> sub CPAN::force ;
494 sub force;
495 #-> sub CPAN::install ;
496 sub install;
497 #-> sub CPAN::make ;
498 sub make;
499 #-> sub CPAN::clean ;
500 sub clean;
501 #-> sub CPAN::test ;
502 sub test;
503
504 #-> sub CPAN::all ;
505 sub all_objects {
506     my($mgr,$class) = @_;
507     CPAN::Config->load unless $CPAN::Config_loaded++;
508     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
509     CPAN::Index->reload;
510     values %{ $META->{$class} };
511 }
512 *all = \&all_objects;
513
514 # Called by shell, not in batch mode. Not clean XXX
515 #-> sub CPAN::checklock ;
516 sub checklock {
517     my($self) = @_;
518     my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
519     if (-f $lockfile && -M _ > 0) {
520         my $fh = FileHandle->new($lockfile);
521         my $other = <$fh>;
522         $fh->close;
523         if (defined $other && $other) {
524             chomp $other;
525             return if $$==$other; # should never happen
526             $CPAN::Frontend->mywarn(
527                                     qq{
528 There seems to be running another CPAN process ($other). Contacting...
529 });
530             if (kill 0, $other) {
531                 $CPAN::Frontend->mydie(qq{Other job is running.
532 You may want to kill it and delete the lockfile, maybe. On UNIX try:
533     kill $other
534     rm $lockfile
535 });
536             } elsif (-w $lockfile) {
537                 my($ans) =
538                     ExtUtils::MakeMaker::prompt
539                         (qq{Other job not responding. Shall I overwrite }.
540                          qq{the lockfile? (Y/N)},"y");
541                 $CPAN::Frontend->myexit("Ok, bye\n")
542                     unless $ans =~ /^y/i;
543             } else {
544                 Carp::croak(
545                             qq{Lockfile $lockfile not writeable by you. }.
546                             qq{Cannot proceed.\n}.
547                             qq{    On UNIX try:\n}.
548                             qq{    rm $lockfile\n}.
549                             qq{  and then rerun us.\n}
550                            );
551             }
552         }
553     }
554     my $dotcpan = $CPAN::Config->{cpan_home};
555     eval { File::Path::mkpath($dotcpan);};
556     if ($@) {
557       # A special case at least for Jarkko.
558       my $firsterror = $@;
559       my $seconderror;
560       my $symlinkcpan;
561       if (-l $dotcpan) {
562         $symlinkcpan = readlink $dotcpan;
563         die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
564         eval { File::Path::mkpath($symlinkcpan); };
565         if ($@) {
566           $seconderror = $@;
567         } else {
568           $CPAN::Frontend->mywarn(qq{
569 Working directory $symlinkcpan created.
570 });
571         }
572       }
573       unless (-d $dotcpan) {
574         my $diemess = qq{
575 Your configuration suggests "$dotcpan" as your
576 CPAN.pm working directory. I could not create this directory due
577 to this error: $firsterror\n};
578         $diemess .= qq{
579 As "$dotcpan" is a symlink to "$symlinkcpan",
580 I tried to create that, but I failed with this error: $seconderror
581 } if $seconderror;
582         $diemess .= qq{
583 Please make sure the directory exists and is writable.
584 };
585         $CPAN::Frontend->mydie($diemess);
586       }
587     }
588     my $fh;
589     unless ($fh = FileHandle->new(">$lockfile")) {
590         if ($! =~ /Permission/) {
591             my $incc = $INC{'CPAN/Config.pm'};
592             my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
593             $CPAN::Frontend->myprint(qq{
594
595 Your configuration suggests that CPAN.pm should use a working
596 directory of
597     $CPAN::Config->{cpan_home}
598 Unfortunately we could not create the lock file
599     $lockfile
600 due to permission problems.
601
602 Please make sure that the configuration variable
603     \$CPAN::Config->{cpan_home}
604 points to a directory where you can write a .lock file. You can set
605 this variable in either
606     $incc
607 or
608     $myincc
609
610 });
611         }
612         $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
613     }
614     $fh->print($$, "\n");
615     $self->{LOCK} = $lockfile;
616     $fh->close;
617     $SIG{'TERM'} = sub {
618       &cleanup;
619       $CPAN::Frontend->mydie("Got SIGTERM, leaving");
620     };
621     $SIG{'INT'} = sub {
622       # no blocks!!!
623       &cleanup if $Signal;
624       $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
625       print "Caught SIGINT\n";
626       $Signal++;
627     };
628
629 #       From: Larry Wall <larry@wall.org>
630 #       Subject: Re: deprecating SIGDIE
631 #       To: perl5-porters@perl.org
632 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
633 #
634 #       The original intent of __DIE__ was only to allow you to substitute one
635 #       kind of death for another on an application-wide basis without respect
636 #       to whether you were in an eval or not.  As a global backstop, it should
637 #       not be used any more lightly (or any more heavily :-) than class
638 #       UNIVERSAL.  Any attempt to build a general exception model on it should
639 #       be politely squashed.  Any bug that causes every eval {} to have to be
640 #       modified should be not so politely squashed.
641 #
642 #       Those are my current opinions.  It is also my optinion that polite
643 #       arguments degenerate to personal arguments far too frequently, and that
644 #       when they do, it's because both people wanted it to, or at least didn't
645 #       sufficiently want it not to.
646 #
647 #       Larry
648
649     $SIG{'__DIE__'} = \&cleanup;
650     $self->debug("Signal handler set.") if $CPAN::DEBUG;
651 }
652
653 #-> sub CPAN::DESTROY ;
654 sub DESTROY {
655     &cleanup; # need an eval?
656 }
657
658 #-> sub CPAN::cwd ;
659 sub cwd {Cwd::cwd();}
660
661 #-> sub CPAN::getcwd ;
662 sub getcwd {Cwd::getcwd();}
663
664 #-> sub CPAN::exists ;
665 sub exists {
666     my($mgr,$class,$id) = @_;
667     CPAN::Index->reload;
668     ### Carp::croak "exists called without class argument" unless $class;
669     $id ||= "";
670     exists $META->{$class}{$id};
671 }
672
673 #-> sub CPAN::delete ;
674 sub delete {
675   my($mgr,$class,$id) = @_;
676   delete $META->{$class}{$id};
677 }
678
679 #-> sub CPAN::has_usable
680 # has_inst is sometimes too optimistic, we should replace it with this
681 # has_usable whenever a case is given
682 sub has_usable {
683     my($self,$mod,$message) = @_;
684     return 1 if $HAS_USABLE->{$mod};
685     my $has_inst = $self->has_inst($mod,$message);
686     return unless $has_inst;
687     my $capabilities;
688     $capabilities = {
689                      LWP => [ # we frequently had "Can't locate object
690                               # method "new" via package
691                               # "LWP::UserAgent" at (eval 69) line
692                               # 2006
693                              sub {require LWP},
694                              sub {require LWP::UserAgent},
695                              sub {require HTTP::Request},
696                              sub {require URI::URL},
697                             ],
698                      Net::FTP => [
699                                   sub {require Net::FTP},
700                                   sub {require Net::Config},
701                                  ]
702                     };
703     if ($capabilities->{$mod}) {
704       for my $c (0..$#{$capabilities->{$mod}}) {
705         my $code = $capabilities->{$mod}[$c];
706         my $ret = eval { &$code() };
707         if ($@) {
708           warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
709           return;
710         }
711       }
712     }
713     return $HAS_USABLE->{$mod} = 1;
714 }
715
716 #-> sub CPAN::has_inst
717 sub has_inst {
718     my($self,$mod,$message) = @_;
719     Carp::croak("CPAN->has_inst() called without an argument")
720         unless defined $mod;
721     if (defined $message && $message eq "no"
722         ||
723         exists $CPAN::META->{dontload_hash}{$mod}
724         ||
725         exists $CPAN::Config->{dontload_hash}{$mod}
726        ) {
727       $CPAN::META->{dontload_hash}{$mod}||=1;
728       return 0;
729     }
730     my $file = $mod;
731     my $obj;
732     $file =~ s|::|/|g;
733     $file =~ s|/|\\|g if $^O eq 'MSWin32';
734     $file .= ".pm";
735     if ($INC{$file}) {
736         # checking %INC is wrong, because $INC{LWP} may be true
737         # although $INC{"URI/URL.pm"} may have failed. But as
738         # I really want to say "bla loaded OK", I have to somehow
739         # cache results.
740         ### warn "$file in %INC"; #debug
741         return 1;
742     } elsif (eval { require $file }) {
743         # eval is good: if we haven't yet read the database it's
744         # perfect and if we have installed the module in the meantime,
745         # it tries again. The second require is only a NOOP returning
746         # 1 if we had success, otherwise it's retrying
747
748         $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
749         if ($mod eq "CPAN::WAIT") {
750             push @CPAN::Shell::ISA, CPAN::WAIT;
751         }
752         return 1;
753     } elsif ($mod eq "Net::FTP") {
754         warn qq{
755   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
756   if you just type
757       install Bundle::libnet
758
759 };
760         sleep 2;
761     } elsif ($mod eq "MD5"){
762         $CPAN::Frontend->myprint(qq{
763   CPAN: MD5 security checks disabled because MD5 not installed.
764   Please consider installing the MD5 module.
765
766 });
767         sleep 2;
768     } else {
769         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
770     }
771     return 0;
772 }
773
774 #-> sub CPAN::instance ;
775 sub instance {
776     my($mgr,$class,$id) = @_;
777     CPAN::Index->reload;
778     $id ||= "";
779     $META->{$class}{$id} ||= $class->new(ID => $id );
780 }
781
782 #-> sub CPAN::new ;
783 sub new {
784     bless {}, shift;
785 }
786
787 #-> sub CPAN::cleanup ;
788 sub cleanup {
789   # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
790   local $SIG{__DIE__} = '';
791   my($message) = @_;
792   my $i = 0;
793   my $ineval = 0;
794   if (
795       0 &&           # disabled, try reload cpan with it
796       $] > 5.004_60  # thereabouts
797      ) {
798     $ineval = $^S;
799   } else {
800     my($subroutine);
801     while ((undef,undef,undef,$subroutine) = caller(++$i)) {
802       $ineval = 1, last if
803           $subroutine eq '(eval)';
804     }
805   }
806   return if $ineval && !$End;
807   return unless defined $META->{'LOCK'};
808   return unless -f $META->{'LOCK'};
809   unlink $META->{'LOCK'};
810   # require Carp;
811   # Carp::cluck("DEBUGGING");
812   $CPAN::Frontend->mywarn("Lockfile removed.\n");
813 }
814
815 package CPAN::CacheMgr;
816
817 #-> sub CPAN::CacheMgr::as_string ;
818 sub as_string {
819     eval { require Data::Dumper };
820     if ($@) {
821         return shift->SUPER::as_string;
822     } else {
823         return Data::Dumper::Dumper(shift);
824     }
825 }
826
827 #-> sub CPAN::CacheMgr::cachesize ;
828 sub cachesize {
829     shift->{DU};
830 }
831
832 sub tidyup {
833   my($self) = @_;
834   return unless -d $self->{ID};
835   while ($self->{DU} > $self->{'MAX'} ) {
836     my($toremove) = shift @{$self->{FIFO}};
837     $CPAN::Frontend->myprint(sprintf(
838                                      "Deleting from cache".
839                                      ": $toremove (%.1f>%.1f MB)\n",
840                                      $self->{DU}, $self->{'MAX'})
841                             );
842     return if $CPAN::Signal;
843     $self->force_clean_cache($toremove);
844     return if $CPAN::Signal;
845   }
846 }
847
848 #-> sub CPAN::CacheMgr::dir ;
849 sub dir {
850     shift->{ID};
851 }
852
853 #-> sub CPAN::CacheMgr::entries ;
854 sub entries {
855     my($self,$dir) = @_;
856     return unless defined $dir;
857     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
858     $dir ||= $self->{ID};
859     my $getcwd;
860     $getcwd  = $CPAN::Config->{'getcwd'} || 'cwd';
861     my($cwd) = CPAN->$getcwd();
862     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
863     my $dh = DirHandle->new(File::Spec->curdir)
864         or Carp::croak("Couldn't opendir $dir: $!");
865     my(@entries);
866     for ($dh->read) {
867         next if $_ eq "." || $_ eq "..";
868         if (-f $_) {
869             push @entries, MM->catfile($dir,$_);
870         } elsif (-d _) {
871             push @entries, MM->catdir($dir,$_);
872         } else {
873             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
874         }
875     }
876     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
877     sort { -M $b <=> -M $a} @entries;
878 }
879
880 #-> sub CPAN::CacheMgr::disk_usage ;
881 sub disk_usage {
882     my($self,$dir) = @_;
883     return if exists $self->{SIZE}{$dir};
884     return if $CPAN::Signal;
885     my($Du) = 0;
886     find(
887          sub {
888            $File::Find::prune++ if $CPAN::Signal;
889            return if -l $_;
890            if ($^O eq 'MacOS') {
891              require Mac::Files;
892              my $cat  = Mac::Files::FSpGetCatInfo($_);
893              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
894            } else {
895              $Du += (-s _);
896            }
897          },
898          $dir
899         );
900     return if $CPAN::Signal;
901     $self->{SIZE}{$dir} = $Du/1024/1024;
902     push @{$self->{FIFO}}, $dir;
903     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
904     $self->{DU} += $Du/1024/1024;
905     $self->{DU};
906 }
907
908 #-> sub CPAN::CacheMgr::force_clean_cache ;
909 sub force_clean_cache {
910     my($self,$dir) = @_;
911     return unless -e $dir;
912     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
913         if $CPAN::DEBUG;
914     File::Path::rmtree($dir);
915     $self->{DU} -= $self->{SIZE}{$dir};
916     delete $self->{SIZE}{$dir};
917 }
918
919 #-> sub CPAN::CacheMgr::new ;
920 sub new {
921     my $class = shift;
922     my $time = time;
923     my($debug,$t2);
924     $debug = "";
925     my $self = {
926                 ID => $CPAN::Config->{'build_dir'},
927                 MAX => $CPAN::Config->{'build_cache'},
928                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
929                 DU => 0
930                };
931     File::Path::mkpath($self->{ID});
932     my $dh = DirHandle->new($self->{ID});
933     bless $self, $class;
934     $self->scan_cache;
935     $t2 = time;
936     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
937     $time = $t2;
938     CPAN->debug($debug) if $CPAN::DEBUG;
939     $self;
940 }
941
942 #-> sub CPAN::CacheMgr::scan_cache ;
943 sub scan_cache {
944     my $self = shift;
945     return if $self->{SCAN} eq 'never';
946     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
947         unless $self->{SCAN} eq 'atstart';
948     $CPAN::Frontend->myprint(
949                              sprintf("Scanning cache %s for sizes\n",
950                                      $self->{ID}));
951     my $e;
952     for $e ($self->entries($self->{ID})) {
953         next if $e eq ".." || $e eq ".";
954         $self->disk_usage($e);
955         return if $CPAN::Signal;
956     }
957     $self->tidyup;
958 }
959
960 package CPAN::Debug;
961
962 #-> sub CPAN::Debug::debug ;
963 sub debug {
964     my($self,$arg) = @_;
965     my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
966                                                # Complete, caller(1)
967                                                # eg readline
968     ($caller) = caller(0);
969     $caller =~ s/.*:://;
970     $arg = "" unless defined $arg;
971     my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
972     if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
973         if ($arg and ref $arg) {
974             eval { require Data::Dumper };
975             if ($@) {
976                 $CPAN::Frontend->myprint($arg->as_string);
977             } else {
978                 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
979             }
980         } else {
981             $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
982         }
983     }
984 }
985
986 package CPAN::Config;
987
988 #-> sub CPAN::Config::edit ;
989 # returns true on successful action
990 sub edit {
991     my($self,@args) = @_;
992     return unless @args;
993     CPAN->debug("self[$self]args[".join(" | ",@args)."]");
994     my($o,$str,$func,$args,$key_exists);
995     $o = shift @args;
996     if($can{$o}) {
997         $self->$o(@args);
998         return 1;
999     } else {
1000         CPAN->debug("o[$o]") if $CPAN::DEBUG;
1001         if ($o =~ /list$/) {
1002             $func = shift @args;
1003             $func ||= "";
1004             CPAN->debug("func[$func]") if $CPAN::DEBUG;
1005             my $changed;
1006             # Let's avoid eval, it's easier to comprehend without.
1007             if ($func eq "push") {
1008                 push @{$CPAN::Config->{$o}}, @args;
1009                 $changed = 1;
1010             } elsif ($func eq "pop") {
1011                 pop @{$CPAN::Config->{$o}};
1012                 $changed = 1;
1013             } elsif ($func eq "shift") {
1014                 shift @{$CPAN::Config->{$o}};
1015                 $changed = 1;
1016             } elsif ($func eq "unshift") {
1017                 unshift @{$CPAN::Config->{$o}}, @args;
1018                 $changed = 1;
1019             } elsif ($func eq "splice") {
1020                 splice @{$CPAN::Config->{$o}}, @args;
1021                 $changed = 1;
1022             } elsif (@args) {
1023                 $CPAN::Config->{$o} = [@args];
1024                 $changed = 1;
1025             } else {
1026                 $self->prettyprint($o);
1027             }
1028             if ($o eq "urllist" && $changed) {
1029                 # reset the cached values
1030                 undef $CPAN::FTP::Thesite;
1031                 undef $CPAN::FTP::Themethod;
1032             }
1033             return $changed;
1034         } else {
1035             $CPAN::Config->{$o} = $args[0] if defined $args[0];
1036             $self->prettyprint($o);
1037         }
1038     }
1039 }
1040
1041 sub prettyprint {
1042   my($self,$k) = @_;
1043   my $v = $CPAN::Config->{$k};
1044   if (ref $v) {
1045     my(@report) = ref $v eq "ARRAY" ?
1046         @$v :
1047             map { sprintf("   %-18s => %s\n",
1048                           $_,
1049                           defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1050                          )} keys %$v;
1051     $CPAN::Frontend->myprint(
1052                              join(
1053                                   "",
1054                                   sprintf(
1055                                           "    %-18s\n",
1056                                           $k
1057                                          ),
1058                                   map {"\t$_\n"} @report
1059                                  )
1060                             );
1061   } elsif (defined $v) {
1062     $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1063   } else {
1064     $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, "UNDEFINED");
1065   }
1066 }
1067
1068 #-> sub CPAN::Config::commit ;
1069 sub commit {
1070     my($self,$configpm) = @_;
1071     unless (defined $configpm){
1072         $configpm ||= $INC{"CPAN/MyConfig.pm"};
1073         $configpm ||= $INC{"CPAN/Config.pm"};
1074         $configpm || Carp::confess(q{
1075 CPAN::Config::commit called without an argument.
1076 Please specify a filename where to save the configuration or try
1077 "o conf init" to have an interactive course through configing.
1078 });
1079     }
1080     my($mode);
1081     if (-f $configpm) {
1082         $mode = (stat $configpm)[2];
1083         if ($mode && ! -w _) {
1084             Carp::confess("$configpm is not writable");
1085         }
1086     }
1087
1088     my $msg;
1089     $msg = <<EOF unless $configpm =~ /MyConfig/;
1090
1091 # This is CPAN.pm's systemwide configuration file. This file provides
1092 # defaults for users, and the values can be changed in a per-user
1093 # configuration file. The user-config file is being looked for as
1094 # ~/.cpan/CPAN/MyConfig.pm.
1095
1096 EOF
1097     $msg ||= "\n";
1098     my($fh) = FileHandle->new;
1099     rename $configpm, "$configpm~" if -f $configpm;
1100     open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
1101     $fh->print(qq[$msg\$CPAN::Config = \{\n]);
1102     foreach (sort keys %$CPAN::Config) {
1103         $fh->print(
1104                    "  '$_' => ",
1105                    ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1106                    ",\n"
1107                   );
1108     }
1109
1110     $fh->print("};\n1;\n__END__\n");
1111     close $fh;
1112
1113     #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1114     #chmod $mode, $configpm;
1115 ###why was that so?    $self->defaults;
1116     $CPAN::Frontend->myprint("commit: wrote $configpm\n");
1117     1;
1118 }
1119
1120 *default = \&defaults;
1121 #-> sub CPAN::Config::defaults ;
1122 sub defaults {
1123     my($self) = @_;
1124     $self->unload;
1125     $self->load;
1126     1;
1127 }
1128
1129 sub init {
1130     my($self) = @_;
1131     undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1132                                                       # have the least
1133                                                       # important
1134                                                       # variable
1135                                                       # undefined
1136     $self->load;
1137     1;
1138 }
1139
1140 #-> sub CPAN::Config::load ;
1141 sub load {
1142     my($self) = shift;
1143     my(@miss);
1144     use Carp;
1145     eval {require CPAN::Config;};       # We eval because of some
1146                                         # MakeMaker problems
1147     unless ($dot_cpan++){
1148       unshift @INC, MM->catdir($ENV{HOME},".cpan");
1149       eval {require CPAN::MyConfig;};   # where you can override
1150                                         # system wide settings
1151       shift @INC;
1152     }
1153     return unless @miss = $self->not_loaded;
1154     # XXX better check for arrayrefs too
1155     require CPAN::FirstTime;
1156     my($configpm,$fh,$redo,$theycalled);
1157     $redo ||= "";
1158     $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
1159     if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1160         $configpm = $INC{"CPAN/Config.pm"};
1161         $redo++;
1162     } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1163         $configpm = $INC{"CPAN/MyConfig.pm"};
1164         $redo++;
1165     } else {
1166         my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
1167         my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
1168         my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
1169         if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
1170             if (-w $configpmtest) {
1171                 $configpm = $configpmtest;
1172             } elsif (-w $configpmdir) {
1173                 #_#_# following code dumped core on me with 5.003_11, a.k.
1174                 unlink "$configpmtest.bak" if -f "$configpmtest.bak";
1175                 rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
1176                 my $fh = FileHandle->new;
1177                 if ($fh->open(">$configpmtest")) {
1178                     $fh->print("1;\n");
1179                     $configpm = $configpmtest;
1180                 } else {
1181                     # Should never happen
1182                     Carp::confess("Cannot open >$configpmtest");
1183                 }
1184             }
1185         }
1186         unless ($configpm) {
1187             $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
1188             File::Path::mkpath($configpmdir);
1189             $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
1190             if (-w $configpmtest) {
1191                 $configpm = $configpmtest;
1192             } elsif (-w $configpmdir) {
1193                 #_#_# following code dumped core on me with 5.003_11, a.k.
1194                 my $fh = FileHandle->new;
1195                 if ($fh->open(">$configpmtest")) {
1196                     $fh->print("1;\n");
1197                     $configpm = $configpmtest;
1198                 } else {
1199                     # Should never happen
1200                     Carp::confess("Cannot open >$configpmtest");
1201                 }
1202             } else {
1203                 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1204                               qq{create a configuration file.});
1205             }
1206         }
1207     }
1208     local($") = ", ";
1209     $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
1210 We have to reconfigure CPAN.pm due to following uninitialized parameters:
1211
1212 @miss
1213 END
1214     $CPAN::Frontend->myprint(qq{
1215 $configpm initialized.
1216 });
1217     sleep 2;
1218     CPAN::FirstTime::init($configpm);
1219 }
1220
1221 #-> sub CPAN::Config::not_loaded ;
1222 sub not_loaded {
1223     my(@miss);
1224     for (qw(
1225             cpan_home keep_source_where build_dir build_cache scan_cache
1226             index_expire gzip tar unzip make pager makepl_arg make_arg
1227             make_install_arg urllist inhibit_startup_message
1228             ftp_proxy http_proxy no_proxy prerequisites_policy
1229             cache_metadata
1230            )) {
1231         push @miss, $_ unless defined $CPAN::Config->{$_};
1232     }
1233     return @miss;
1234 }
1235
1236 #-> sub CPAN::Config::unload ;
1237 sub unload {
1238     delete $INC{'CPAN/MyConfig.pm'};
1239     delete $INC{'CPAN/Config.pm'};
1240 }
1241
1242 #-> sub CPAN::Config::help ;
1243 sub help {
1244     $CPAN::Frontend->myprint(q[
1245 Known options:
1246   defaults  reload default config values from disk
1247   commit    commit session changes to disk
1248   init      go through a dialog to set all parameters
1249
1250 You may edit key values in the follow fashion (the "o" is a literal
1251 letter o):
1252
1253   o conf build_cache 15
1254
1255   o conf build_dir "/foo/bar"
1256
1257   o conf urllist shift
1258
1259   o conf urllist unshift ftp://ftp.foo.bar/
1260
1261 ]);
1262     undef; #don't reprint CPAN::Config
1263 }
1264
1265 #-> sub CPAN::Config::cpl ;
1266 sub cpl {
1267     my($word,$line,$pos) = @_;
1268     $word ||= "";
1269     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1270     my(@words) = split " ", substr($line,0,$pos+1);
1271     if (
1272         defined($words[2])
1273         and
1274         (
1275          $words[2] =~ /list$/ && @words == 3
1276          ||
1277          $words[2] =~ /list$/ && @words == 4 && length($word)
1278         )
1279        ) {
1280         return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1281     } elsif (@words >= 4) {
1282         return ();
1283     }
1284     my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1285     return grep /^\Q$word\E/, @o_conf;
1286 }
1287
1288 package CPAN::Shell;
1289
1290 #-> sub CPAN::Shell::h ;
1291 sub h {
1292     my($class,$about) = @_;
1293     if (defined $about) {
1294         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1295     } else {
1296         $CPAN::Frontend->myprint(q{
1297 Display Information
1298  a                                    authors
1299  b         string           display   bundles
1300  d         or               info      distributions
1301  m         /regex/          about     modules
1302  i         or                         anything of above
1303  r         none             reinstall recommendations
1304  u                          uninstalled distributions
1305
1306 Download, Test, Make, Install...
1307  get                        download
1308  make                       make (implies get)
1309  test      modules,         make test (implies make)
1310  install   dists, bundles   make install (implies test)
1311  clean                      make clean
1312  look                       open subshell in these dists' directories
1313  readme                     display these dists' README files
1314
1315 Other
1316  h,?           display this menu       ! perl-code   eval a perl command
1317  o conf [opt]  set and query options   q             quit the cpan shell
1318  reload cpan   load CPAN.pm again      reload index  load newer indices
1319  autobundle    Snapshot                force cmd     unconditionally do cmd});
1320     }
1321 }
1322
1323 *help = \&h;
1324
1325 #-> sub CPAN::Shell::a ;
1326 sub a {
1327   my($self,@arg) = @_;
1328   # authors are always UPPERCASE
1329   for (@arg) {
1330     $_ = uc $_;
1331   }
1332   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1333 }
1334 #-> sub CPAN::Shell::b ;
1335 sub b {
1336     my($self,@which) = @_;
1337     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1338     my($incdir,$bdir,$dh);
1339     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1340         $bdir = MM->catdir($incdir,"Bundle");
1341         if ($dh = DirHandle->new($bdir)) { # may fail
1342             my($entry);
1343             for $entry ($dh->read) {
1344                 next if -d MM->catdir($bdir,$entry);
1345                 next unless $entry =~ s/\.pm(?!\n)\Z//;
1346                 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1347             }
1348         }
1349     }
1350     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1351 }
1352 #-> sub CPAN::Shell::d ;
1353 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1354 #-> sub CPAN::Shell::m ;
1355 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1356     $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1357 }
1358
1359 #-> sub CPAN::Shell::i ;
1360 sub i {
1361     my($self) = shift;
1362     my(@args) = @_;
1363     my(@type,$type,@m);
1364     @type = qw/Author Bundle Distribution Module/;
1365     @args = '/./' unless @args;
1366     my(@result);
1367     for $type (@type) {
1368         push @result, $self->expand($type,@args);
1369     }
1370     my $result =  @result == 1 ?
1371         $result[0]->as_string :
1372             join "", map {$_->as_glimpse} @result;
1373     $result ||= "No objects found of any type for argument @args\n";
1374     $CPAN::Frontend->myprint($result);
1375 }
1376
1377 #-> sub CPAN::Shell::o ;
1378
1379 # CPAN::Shell::o and CPAN::Config::edit are closely related. I suspect
1380 # some code duplication
1381 sub o {
1382     my($self,$o_type,@o_what) = @_;
1383     $o_type ||= "";
1384     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1385     if ($o_type eq 'conf') {
1386         shift @o_what if @o_what && $o_what[0] eq 'help';
1387         if (!@o_what) { # print all things, "o conf"
1388             my($k,$v);
1389             $CPAN::Frontend->myprint("CPAN::Config options");
1390             if (exists $INC{'CPAN/Config.pm'}) {
1391               $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1392             }
1393             if (exists $INC{'CPAN/MyConfig.pm'}) {
1394               $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1395             }
1396             $CPAN::Frontend->myprint(":\n");
1397             for $k (sort keys %CPAN::Config::can) {
1398                 $v = $CPAN::Config::can{$k};
1399                 $CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
1400             }
1401             $CPAN::Frontend->myprint("\n");
1402             for $k (sort keys %$CPAN::Config) {
1403                 CPAN::Config->prettyprint($k);
1404             }
1405             $CPAN::Frontend->myprint("\n");
1406         } elsif (!CPAN::Config->edit(@o_what)) {
1407             $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
1408         }
1409     } elsif ($o_type eq 'debug') {
1410         my(%valid);
1411         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1412         if (@o_what) {
1413             while (@o_what) {
1414                 my($what) = shift @o_what;
1415                 if ( exists $CPAN::DEBUG{$what} ) {
1416                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1417                 } elsif ($what =~ /^\d/) {
1418                     $CPAN::DEBUG = $what;
1419                 } elsif (lc $what eq 'all') {
1420                     my($max) = 0;
1421                     for (values %CPAN::DEBUG) {
1422                         $max += $_;
1423                     }
1424                     $CPAN::DEBUG = $max;
1425                 } else {
1426                     my($known) = 0;
1427                     for (keys %CPAN::DEBUG) {
1428                         next unless lc($_) eq lc($what);
1429                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1430                         $known = 1;
1431                     }
1432                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1433                         unless $known;
1434                 }
1435             }
1436         } else {
1437           my $raw = "Valid options for debug are ".
1438               join(", ",sort(keys %CPAN::DEBUG), 'all').
1439                   qq{ or a number. Completion works on the options. }.
1440                       qq{Case is ignored.};
1441           require Text::Wrap;
1442           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1443           $CPAN::Frontend->myprint("\n\n");
1444         }
1445         if ($CPAN::DEBUG) {
1446             $CPAN::Frontend->myprint("Options set for debugging:\n");
1447             my($k,$v);
1448             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1449                 $v = $CPAN::DEBUG{$k};
1450                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1451                     if $v & $CPAN::DEBUG;
1452             }
1453         } else {
1454             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1455         }
1456     } else {
1457         $CPAN::Frontend->myprint(qq{
1458 Known options:
1459   conf    set or get configuration variables
1460   debug   set or get debugging options
1461 });
1462     }
1463 }
1464
1465 sub dotdot_onreload {
1466     my($ref) = shift;
1467     sub {
1468         if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1469             my($subr) = $1;
1470             ++$$ref;
1471             local($|) = 1;
1472             # $CPAN::Frontend->myprint(".($subr)");
1473             $CPAN::Frontend->myprint(".");
1474             return;
1475         }
1476         warn @_;
1477     };
1478 }
1479
1480 #-> sub CPAN::Shell::reload ;
1481 sub reload {
1482     my($self,$command,@arg) = @_;
1483     $command ||= "";
1484     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1485     if ($command =~ /cpan/i) {
1486         CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1487         my $fh = FileHandle->new($INC{'CPAN.pm'});
1488         local($/);
1489         $redef = 0;
1490         local($SIG{__WARN__}) = dotdot_onreload(\$redef);
1491         eval <$fh>;
1492         warn $@ if $@;
1493         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1494     } elsif ($command =~ /index/) {
1495       CPAN::Index->force_reload;
1496     } else {
1497       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN.pm file
1498 index    re-reads the index files\n});
1499     }
1500 }
1501
1502 #-> sub CPAN::Shell::_binary_extensions ;
1503 sub _binary_extensions {
1504     my($self) = shift @_;
1505     my(@result,$module,%seen,%need,$headerdone);
1506     for $module ($self->expand('Module','/./')) {
1507         my $file  = $module->cpan_file;
1508         next if $file eq "N/A";
1509         next if $file =~ /^Contact Author/;
1510         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1511         next if $dist->isa_perl;
1512         next unless $module->xs_file;
1513         local($|) = 1;
1514         $CPAN::Frontend->myprint(".");
1515         push @result, $module;
1516     }
1517 #    print join " | ", @result;
1518     $CPAN::Frontend->myprint("\n");
1519     return @result;
1520 }
1521
1522 #-> sub CPAN::Shell::recompile ;
1523 sub recompile {
1524     my($self) = shift @_;
1525     my($module,@module,$cpan_file,%dist);
1526     @module = $self->_binary_extensions();
1527     for $module (@module){  # we force now and compile later, so we
1528                             # don't do it twice
1529         $cpan_file = $module->cpan_file;
1530         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1531         $pack->force;
1532         $dist{$cpan_file}++;
1533     }
1534     for $cpan_file (sort keys %dist) {
1535         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1536         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1537         $pack->install;
1538         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1539                            # stop a package from recompiling,
1540                            # e.g. IO-1.12 when we have perl5.003_10
1541     }
1542 }
1543
1544 #-> sub CPAN::Shell::_u_r_common ;
1545 sub _u_r_common {
1546     my($self) = shift @_;
1547     my($what) = shift @_;
1548     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1549     Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1550     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1551     my(@args) = @_;
1552     @args = '/./' unless @args;
1553     my(@result,$module,%seen,%need,$headerdone,
1554        $version_undefs,$version_zeroes);
1555     $version_undefs = $version_zeroes = 0;
1556     my $sprintf = "%-25s %9s %9s  %s\n";
1557     for $module ($self->expand('Module',@args)) {
1558         my $file  = $module->cpan_file;
1559         next unless defined $file; # ??
1560         my($latest) = $module->cpan_version; # %vd not needed
1561         my($inst_file) = $module->inst_file;
1562         my($have);
1563         return if $CPAN::Signal;
1564         if ($inst_file){
1565             if ($what eq "a") {
1566                 $have = $module->inst_version; # %vd already applied
1567             } elsif ($what eq "r") {
1568                 $have = $module->inst_version; # %vd already applied
1569                 local($^W) = 0;
1570                 if ($have eq "undef"){
1571                     $version_undefs++;
1572                 } elsif ($have == 0){
1573                     $version_zeroes++;
1574                 }
1575                 next unless CPAN::Version->vgt($latest, $have);
1576 # to be pedantic we should probably say:
1577 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1578 # to catch the case where CPAN has a version 0 and we have a version undef
1579             } elsif ($what eq "u") {
1580                 next;
1581             }
1582         } else {
1583             if ($what eq "a") {
1584                 next;
1585             } elsif ($what eq "r") {
1586                 next;
1587             } elsif ($what eq "u") {
1588                 $have = "-";
1589             }
1590         }
1591         return if $CPAN::Signal; # this is sometimes lengthy
1592         $seen{$file} ||= 0;
1593         if ($what eq "a") {
1594             push @result, sprintf "%s %s\n", $module->id, $have;
1595         } elsif ($what eq "r") {
1596             push @result, $module->id;
1597             next if $seen{$file}++;
1598         } elsif ($what eq "u") {
1599             push @result, $module->id;
1600             next if $seen{$file}++;
1601             next if $file =~ /^Contact/;
1602         }
1603         unless ($headerdone++){
1604             $CPAN::Frontend->myprint("\n");
1605             $CPAN::Frontend->myprint(sprintf(
1606                    $sprintf,
1607                    "Package namespace",
1608                    "installed",
1609                    "latest",
1610                    "in CPAN file"
1611                    ));
1612         }
1613 ####        for ($have,$latest) {
1614 ####          # $_ = CPAN::Version->readable($_); # %vd already applied
1615 ####          if (length($_) > 8){
1616 ####            my $trunc = substr($_,0,8);
1617 ####            $CPAN::Frontend->mywarn("Truncating VERSION from [$_] to [$trunc]\n");
1618 ####            $_ = $trunc;
1619 ####          }
1620 ####        }
1621         $CPAN::Frontend->myprint(sprintf $sprintf,
1622                                  $module->id,
1623                                  $have,
1624                                  $latest,
1625                                  $file);
1626         $need{$module->id}++;
1627     }
1628     unless (%need) {
1629         if ($what eq "u") {
1630             $CPAN::Frontend->myprint("No modules found for @args\n");
1631         } elsif ($what eq "r") {
1632             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1633         }
1634     }
1635     if ($what eq "r") {
1636         if ($version_zeroes) {
1637             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1638             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1639                 qq{a version number of 0\n});
1640         }
1641         if ($version_undefs) {
1642             my $s_has = $version_undefs > 1 ? "s have" : " has";
1643             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1644                 qq{parseable version number\n});
1645         }
1646     }
1647     @result;
1648 }
1649
1650 #-> sub CPAN::Shell::r ;
1651 sub r {
1652     shift->_u_r_common("r",@_);
1653 }
1654
1655 #-> sub CPAN::Shell::u ;
1656 sub u {
1657     shift->_u_r_common("u",@_);
1658 }
1659
1660 #-> sub CPAN::Shell::autobundle ;
1661 sub autobundle {
1662     my($self) = shift;
1663     CPAN::Config->load unless $CPAN::Config_loaded++;
1664     my(@bundle) = $self->_u_r_common("a",@_);
1665     my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
1666     File::Path::mkpath($todir);
1667     unless (-d $todir) {
1668         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
1669         return;
1670     }
1671     my($y,$m,$d) =  (localtime)[5,4,3];
1672     $y+=1900;
1673     $m++;
1674     my($c) = 0;
1675     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
1676     my($to) = MM->catfile($todir,"$me.pm");
1677     while (-f $to) {
1678         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
1679         $to = MM->catfile($todir,"$me.pm");
1680     }
1681     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1682     $fh->print(
1683                "package Bundle::$me;\n\n",
1684                "\$VERSION = '0.01';\n\n",
1685                "1;\n\n",
1686                "__END__\n\n",
1687                "=head1 NAME\n\n",
1688                "Bundle::$me - Snapshot of installation on ",
1689                $Config::Config{'myhostname'},
1690                " on ",
1691                scalar(localtime),
1692                "\n\n=head1 SYNOPSIS\n\n",
1693                "perl -MCPAN -e 'install Bundle::$me'\n\n",
1694                "=head1 CONTENTS\n\n",
1695                join("\n", @bundle),
1696                "\n\n=head1 CONFIGURATION\n\n",
1697                Config->myconfig,
1698                "\n\n=head1 AUTHOR\n\n",
1699                "This Bundle has been generated automatically ",
1700                "by the autobundle routine in CPAN.pm.\n",
1701               );
1702     $fh->close;
1703     $CPAN::Frontend->myprint("\nWrote bundle file
1704     $to\n\n");
1705 }
1706
1707 #-> sub CPAN::Shell::expand ;
1708 sub expand {
1709     shift;
1710     my($type,@args) = @_;
1711     my($arg,@m);
1712     for $arg (@args) {
1713         my $regex;
1714         if ($arg =~ m|^/(.*)/$|) {
1715             $regex = $1;
1716         }
1717         my $class = "CPAN::$type";
1718         my $obj;
1719         if (defined $regex) {
1720           for $obj (
1721                     sort
1722                     {$a->id cmp $b->id}
1723                     $CPAN::META->all_objects($class)
1724                    ) {
1725             unless ($obj->id){
1726               # BUG, we got an empty object somewhere
1727               CPAN->debug(sprintf(
1728                                   "Empty id on obj[%s]%%[%s]",
1729                                   $obj,
1730                                   join(":", %$obj)
1731                                  )) if $CPAN::DEBUG;
1732               next;
1733             }
1734             push @m, $obj
1735                 if $obj->id =~ /$regex/i
1736                     or
1737                         (
1738                          (
1739                           $] < 5.00303 ### provide sort of
1740                                        ### compatibility with 5.003
1741                           ||
1742                           $obj->can('name')
1743                          )
1744                          &&
1745                          $obj->name  =~ /$regex/i
1746                         );
1747           }
1748         } else {
1749             my($xarg) = $arg;
1750             if ( $type eq 'Bundle' ) {
1751                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1752             }
1753             if ($CPAN::META->exists($class,$xarg)) {
1754                 $obj = $CPAN::META->instance($class,$xarg);
1755             } elsif ($CPAN::META->exists($class,$arg)) {
1756                 $obj = $CPAN::META->instance($class,$arg);
1757             } else {
1758                 next;
1759             }
1760             push @m, $obj;
1761         }
1762     }
1763     return wantarray ? @m : $m[0];
1764 }
1765
1766 #-> sub CPAN::Shell::format_result ;
1767 sub format_result {
1768     my($self) = shift;
1769     my($type,@args) = @_;
1770     @args = '/./' unless @args;
1771     my(@result) = $self->expand($type,@args);
1772     my $result =  @result == 1 ?
1773         $result[0]->as_string :
1774             join "", map {$_->as_glimpse} @result;
1775     $result ||= "No objects of type $type found for argument @args\n";
1776     $result;
1777 }
1778
1779 # The only reason for this method is currently to have a reliable
1780 # debugging utility that reveals which output is going through which
1781 # channel. No, I don't like the colors ;-)
1782 sub print_ornamented {
1783     my($self,$what,$ornament) = @_;
1784     my $longest = 0;
1785     my $ornamenting = 0; # turn the colors on
1786
1787     if ($ornamenting) {
1788         unless (defined &color) {
1789             if ($CPAN::META->has_inst("Term::ANSIColor")) {
1790                 import Term::ANSIColor "color";
1791             } else {
1792                 *color = sub { return "" };
1793             }
1794         }
1795         my $line;
1796         for $line (split /\n/, $what) {
1797             $longest = length($line) if length($line) > $longest;
1798         }
1799         my $sprintf = "%-" . $longest . "s";
1800         while ($what){
1801             $what =~ s/(.*\n?)//m;
1802             my $line = $1;
1803             last unless $line;
1804             my($nl) = chomp $line ? "\n" : "";
1805             #   print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1806             print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1807         }
1808     } else {
1809         print $what;
1810     }
1811 }
1812
1813 sub myprint {
1814     my($self,$what) = @_;
1815     $self->print_ornamented($what, 'bold blue on_yellow');
1816 }
1817
1818 sub myexit {
1819     my($self,$what) = @_;
1820     $self->myprint($what);
1821     exit;
1822 }
1823
1824 sub mywarn {
1825     my($self,$what) = @_;
1826     $self->print_ornamented($what, 'bold red on_yellow');
1827 }
1828
1829 sub myconfess {
1830     my($self,$what) = @_;
1831     $self->print_ornamented($what, 'bold red on_white');
1832     Carp::confess "died";
1833 }
1834
1835 sub mydie {
1836     my($self,$what) = @_;
1837     $self->print_ornamented($what, 'bold red on_white');
1838     die "\n";
1839 }
1840
1841 sub setup_output {
1842     return if -t STDOUT;
1843     my $odef = select STDERR;
1844     $| = 1;
1845     select STDOUT;
1846     $| = 1;
1847     select $odef;
1848 }
1849
1850 #-> sub CPAN::Shell::rematein ;
1851 # RE-adme||MA-ke||TE-st||IN-stall
1852 sub rematein {
1853     shift;
1854     my($meth,@some) = @_;
1855     my $pragma = "";
1856     if ($meth eq 'force') {
1857         $pragma = $meth;
1858         $meth = shift @some;
1859     }
1860     setup_output();
1861     CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1862     my($s,@s);
1863     foreach $s (@some) {
1864       CPAN::Queue->new($s);
1865     }
1866     while ($s = CPAN::Queue->first) {
1867         my $obj;
1868         if (ref $s) {
1869             $obj = $s;
1870         } elsif ($s =~ m|/|) { # looks like a file
1871             $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1872         } elsif ($s =~ m|^Bundle::|) {
1873             $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1874         } else {
1875             $obj = $CPAN::META->instance('CPAN::Module',$s)
1876                 if $CPAN::META->exists('CPAN::Module',$s);
1877         }
1878         if (ref $obj) {
1879             CPAN->debug(
1880                         qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
1881                         $obj->as_string.
1882                         qq{\]}
1883                        ) if $CPAN::DEBUG;
1884             $obj->$pragma()
1885                 if
1886                     $pragma
1887                         &&
1888                     ($] < 5.00303 || $obj->can($pragma)); ###
1889                                                           ### compatibility
1890                                                           ### with
1891                                                           ### 5.003
1892             if ($]>=5.00303 && $obj->can('called_for')) {
1893               $obj->called_for($s);
1894             }
1895             CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1896                                                       # than once in
1897                                                       # the queue
1898         } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1899             $obj = $CPAN::META->instance('CPAN::Author',$s);
1900             $CPAN::Frontend->myprint(
1901                                      join "",
1902                                      "Don't be silly, you can't $meth ",
1903                                      $obj->fullname,
1904                                      " ;-)\n"
1905                                     );
1906         } else {
1907             $CPAN::Frontend
1908                 ->myprint(qq{Warning: Cannot $meth $s, }.
1909                           qq{don\'t know what it is.
1910 Try the command
1911
1912     i /$s/
1913
1914 to find objects with similar identifiers.
1915 });
1916         }
1917         CPAN::Queue->delete_first($s);
1918     }
1919 }
1920
1921 #-> sub CPAN::Shell::force ;
1922 sub force   { shift->rematein('force',@_); }
1923 #-> sub CPAN::Shell::get ;
1924 sub get     { shift->rematein('get',@_); }
1925 #-> sub CPAN::Shell::readme ;
1926 sub readme  { shift->rematein('readme',@_); }
1927 #-> sub CPAN::Shell::make ;
1928 sub make    { shift->rematein('make',@_); }
1929 #-> sub CPAN::Shell::test ;
1930 sub test    { shift->rematein('test',@_); }
1931 #-> sub CPAN::Shell::install ;
1932 sub install { shift->rematein('install',@_); }
1933 #-> sub CPAN::Shell::clean ;
1934 sub clean   { shift->rematein('clean',@_); }
1935 #-> sub CPAN::Shell::look ;
1936 sub look   { shift->rematein('look',@_); }
1937 #-> sub CPAN::Shell::cvs_import ;
1938 sub cvs_import   { shift->rematein('cvs_import',@_); }
1939
1940 package CPAN::FTP;
1941
1942 #-> sub CPAN::FTP::ftp_get ;
1943 sub ftp_get {
1944   my($class,$host,$dir,$file,$target) = @_;
1945   $class->debug(
1946                 qq[Going to fetch file [$file] from dir [$dir]
1947         on host [$host] as local [$target]\n]
1948                       ) if $CPAN::DEBUG;
1949   my $ftp = Net::FTP->new($host);
1950   return 0 unless defined $ftp;
1951   $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1952   $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1953   unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1954     warn "Couldn't login on $host";
1955     return;
1956   }
1957   unless ( $ftp->cwd($dir) ){
1958     warn "Couldn't cwd $dir";
1959     return;
1960   }
1961   $ftp->binary;
1962   $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1963   unless ( $ftp->get($file,$target) ){
1964     warn "Couldn't fetch $file from $host\n";
1965     return;
1966   }
1967   $ftp->quit; # it's ok if this fails
1968   return 1;
1969 }
1970
1971 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
1972
1973  # leach,> *** /install/perl/live/lib/CPAN.pm-  Wed Sep 24 13:08:48 1997
1974  # leach,> --- /tmp/cp  Wed Sep 24 13:26:40 1997
1975  # leach,> ***************
1976  # leach,> *** 1562,1567 ****
1977  # leach,> --- 1562,1580 ----
1978  # leach,>       return 1 if substr($url,0,4) eq "file";
1979  # leach,>       return 1 unless $url =~ m|://([^/]+)|;
1980  # leach,>       my $host = $1;
1981  # leach,> +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1982  # leach,> +     if ($proxy) {
1983  # leach,> +         $proxy =~ m|://([^/:]+)|;
1984  # leach,> +         $proxy = $1;
1985  # leach,> +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1986  # leach,> +         if ($noproxy) {
1987  # leach,> +             if ($host !~ /$noproxy$/) {
1988  # leach,> +                 $host = $proxy;
1989  # leach,> +             }
1990  # leach,> +         } else {
1991  # leach,> +             $host = $proxy;
1992  # leach,> +         }
1993  # leach,> +     }
1994  # leach,>       require Net::Ping;
1995  # leach,>       return 1 unless $Net::Ping::VERSION >= 2;
1996  # leach,>       my $p;
1997
1998
1999 # this is quite optimistic and returns one on several occasions where
2000 # inappropriate. But this does no harm. It would do harm if we were
2001 # too pessimistic (as I was before the http_proxy
2002 sub is_reachable {
2003     my($self,$url) = @_;
2004     return 1; # we can't simply roll our own, firewalls may break ping
2005     return 0 unless $url;
2006     return 1 if substr($url,0,4) eq "file";
2007     return 1 unless $url =~ m|^(\w+)://([^/]+)|;
2008     my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
2009     my $host = $2;
2010     return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
2011     require Net::Ping;
2012     return 1 unless $Net::Ping::VERSION >= 2;
2013     my $p;
2014     # 1.3101 had it different: only if the first eval raised an
2015     # exception we tried it with TCP. Now we are happy if icmp wins
2016     # the order and return, we don't even check for $@. Thanks to
2017     # thayer@uis.edu for the suggestion.
2018     eval {$p = Net::Ping->new("icmp");};
2019     return 1 if $p && ref($p) && $p->ping($host, 10);
2020     eval {$p = Net::Ping->new("tcp");};
2021     $CPAN::Frontend->mydie($@) if $@;
2022     return $p->ping($host, 10);
2023 }
2024
2025 #-> sub CPAN::FTP::localize ;
2026 # sorry for the ugly code here, I'll clean it up as soon as Net::FTP
2027 # is in the core
2028 sub localize {
2029     my($self,$file,$aslocal,$force) = @_;
2030     $force ||= 0;
2031     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2032         unless defined $aslocal;
2033     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2034         if $CPAN::DEBUG;
2035
2036     if ($^O eq 'MacOS') {
2037         my($name, $path) = File::Basename::fileparse($aslocal, '');
2038         if (length($name) > 31) {
2039             $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
2040             my $suf = $1;
2041             my $size = 31 - length($suf);
2042             while (length($name) > $size) {
2043                 chop $name;
2044             }
2045             $name .= $suf;
2046             $aslocal = File::Spec->catfile($path, $name);
2047         }
2048     }
2049
2050     return $aslocal if -f $aslocal && -r _ && !($force & 1);
2051     my($restore) = 0;
2052     if (-f $aslocal){
2053         rename $aslocal, "$aslocal.bak";
2054         $restore++;
2055     }
2056
2057     my($aslocal_dir) = File::Basename::dirname($aslocal);
2058     File::Path::mkpath($aslocal_dir);
2059     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2060         qq{directory "$aslocal_dir".
2061     I\'ll continue, but if you encounter problems, they may be due
2062     to insufficient permissions.\n}) unless -w $aslocal_dir;
2063
2064     # Inheritance is not easier to manage than a few if/else branches
2065     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2066         unless ($Ua) {
2067             $Ua = LWP::UserAgent->new;
2068             my($var);
2069             $Ua->proxy('ftp',  $var)
2070                 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
2071             $Ua->proxy('http', $var)
2072                 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2073             $Ua->no_proxy($var)
2074                 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2075         }
2076     }
2077
2078     # Try the list of urls for each single object. We keep a record
2079     # where we did get a file from
2080     my(@reordered,$last);
2081     $CPAN::Config->{urllist} ||= [];
2082     $last = $#{$CPAN::Config->{urllist}};
2083     if ($force & 2) { # local cpans probably out of date, don't reorder
2084         @reordered = (0..$last);
2085     } else {
2086         @reordered =
2087             sort {
2088                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2089                     <=>
2090                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2091                     or
2092                 defined($Thesite)
2093                     and
2094                 ($b == $Thesite)
2095                     <=>
2096                 ($a == $Thesite)
2097             } 0..$last;
2098     }
2099     my($level,@levels);
2100     if ($Themethod) {
2101         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2102     } else {
2103         @levels = qw/easy hard hardest/;
2104     }
2105     @levels = qw/easy/ if $^O eq 'MacOS';
2106     for $level (@levels) {
2107         my $method = "host$level";
2108         my @host_seq = $level eq "easy" ?
2109             @reordered : 0..$last;  # reordered has CDROM up front
2110         @host_seq = (0) unless @host_seq;
2111         my $ret = $self->$method(\@host_seq,$file,$aslocal);
2112         if ($ret) {
2113           $Themethod = $level;
2114           my $now = time;
2115           # utime $now, $now, $aslocal; # too bad, if we do that, we
2116                                       # might alter a local mirror
2117           $self->debug("level[$level]") if $CPAN::DEBUG;
2118           return $ret;
2119         } else {
2120           unlink $aslocal;
2121         }
2122     }
2123     my(@mess);
2124     push @mess,
2125     qq{Please check, if the URLs I found in your configuration file \(}.
2126         join(", ", @{$CPAN::Config->{urllist}}).
2127             qq{\) are valid. The urllist can be edited.},
2128             qq{E.g. with ``o conf urllist push ftp://myurl/''};
2129     $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2130     sleep 2;
2131     $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
2132     if ($restore) {
2133         rename "$aslocal.bak", $aslocal;
2134         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2135                                  $self->ls($aslocal));
2136         return $aslocal;
2137     }
2138     return;
2139 }
2140
2141 sub hosteasy {
2142     my($self,$host_seq,$file,$aslocal) = @_;
2143     my($i);
2144   HOSTEASY: for $i (@$host_seq) {
2145       my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2146         unless ($self->is_reachable($url)) {
2147             $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
2148             sleep 2;
2149             next;
2150         }
2151         $url .= "/" unless substr($url,-1) eq "/";
2152         $url .= $file;
2153         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2154         if ($url =~ /^file:/) {
2155             my $l;
2156             if ($CPAN::META->has_inst('URI::URL')) {
2157                 my $u =  URI::URL->new($url);
2158                 $l = $u->path;
2159             } else { # works only on Unix, is poorly constructed, but
2160                 # hopefully better than nothing.
2161                 # RFC 1738 says fileurl BNF is
2162                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2163                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2164                 # the code
2165                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2166                 $l =~ s|^file:||;                   # assume they
2167                                                     # meant
2168                                                     # file://localhost
2169                 $l =~ s|^/||s unless -f $l;         # e.g. /P:
2170             }
2171             if ( -f $l && -r _) {
2172                 $Thesite = $i;
2173                 return $l;
2174             }
2175             # Maybe mirror has compressed it?
2176             if (-f "$l.gz") {
2177                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2178                 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
2179                 if ( -f $aslocal) {
2180                     $Thesite = $i;
2181                     return $aslocal;
2182                 }
2183             }
2184         }
2185       if ($CPAN::META->has_usable('LWP')) {
2186           $CPAN::Frontend->myprint("Fetching with LWP:
2187   $url
2188 ");
2189           unless ($Ua) {
2190             require LWP::UserAgent;
2191             $Ua = LWP::UserAgent->new;
2192           }
2193           my $res = $Ua->mirror($url, $aslocal);
2194           if ($res->is_success) {
2195             $Thesite = $i;
2196             my $now = time;
2197             utime $now, $now, $aslocal; # download time is more
2198                                         # important than upload time
2199             return $aslocal;
2200           } elsif ($url !~ /\.gz(?!\n)\Z/) {
2201             my $gzurl = "$url.gz";
2202             $CPAN::Frontend->myprint("Fetching with LWP:
2203   $gzurl
2204 ");
2205             $res = $Ua->mirror($gzurl, "$aslocal.gz");
2206             if ($res->is_success &&
2207                 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2208                ) {
2209               $Thesite = $i;
2210               return $aslocal;
2211             } else {
2212               # next HOSTEASY ;
2213             }
2214           } else {
2215             # Alan Burlison informed me that in firewall envs Net::FTP
2216             # can still succeed where LWP fails. So we do not skip
2217             # Net::FTP anymore when LWP is available.
2218             # next HOSTEASY ;
2219           }
2220         } else {
2221           $self->debug("LWP not installed") if $CPAN::DEBUG;
2222         }
2223         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2224             # that's the nice and easy way thanks to Graham
2225             my($host,$dir,$getfile) = ($1,$2,$3);
2226             if ($CPAN::META->has_usable('Net::FTP')) {
2227                 $dir =~ s|/+|/|g;
2228                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
2229   $url
2230 ");
2231                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2232                              "aslocal[$aslocal]") if $CPAN::DEBUG;
2233                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2234                     $Thesite = $i;
2235                     return $aslocal;
2236                 }
2237                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
2238                     my $gz = "$aslocal.gz";
2239                     $CPAN::Frontend->myprint("Fetching with Net::FTP
2240   $url.gz
2241 ");
2242                    if (CPAN::FTP->ftp_get($host,
2243                                            $dir,
2244                                            "$getfile.gz",
2245                                            $gz) &&
2246                         CPAN::Tarzip->gunzip($gz,$aslocal)
2247                        ){
2248                         $Thesite = $i;
2249                         return $aslocal;
2250                     }
2251                 }
2252                 # next HOSTEASY;
2253             }
2254         }
2255     }
2256 }
2257
2258 sub hosthard {
2259   my($self,$host_seq,$file,$aslocal) = @_;
2260
2261   # Came back if Net::FTP couldn't establish connection (or
2262   # failed otherwise) Maybe they are behind a firewall, but they
2263   # gave us a socksified (or other) ftp program...
2264
2265   my($i);
2266   my($devnull) = $CPAN::Config->{devnull} || "";
2267   # < /dev/null ";
2268   my($aslocal_dir) = File::Basename::dirname($aslocal);
2269   File::Path::mkpath($aslocal_dir);
2270   HOSTHARD: for $i (@$host_seq) {
2271         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2272         unless ($self->is_reachable($url)) {
2273           $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2274           next;
2275         }
2276         $url .= "/" unless substr($url,-1) eq "/";
2277         $url .= $file;
2278         my($proto,$host,$dir,$getfile);
2279
2280         # Courtesy Mark Conty mark_conty@cargill.com change from
2281         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2282         # to
2283         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
2284           # proto not yet used
2285           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
2286         } else {
2287           next HOSTHARD; # who said, we could ftp anything except ftp?
2288         }
2289
2290         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2291         my($f,$funkyftp);
2292         for $f ('lynx','ncftpget','ncftp') {
2293           next unless exists $CPAN::Config->{$f};
2294           $funkyftp = $CPAN::Config->{$f};
2295           next unless defined $funkyftp;
2296           next if $funkyftp =~ /^\s*$/;
2297           my($asl_ungz, $asl_gz);
2298           ($asl_ungz = $aslocal) =~ s/\.gz//;
2299           $asl_gz = "$asl_ungz.gz";
2300           my($src_switch) = "";
2301           if ($f eq "lynx"){
2302             $src_switch = " -source";
2303           } elsif ($f eq "ncftp"){
2304             $src_switch = " -c";
2305           }
2306           my($chdir) = "";
2307           my($stdout_redir) = " > $asl_ungz";
2308           if ($f eq "ncftpget"){
2309             $chdir = "cd $aslocal_dir && ";
2310             $stdout_redir = "";
2311           }
2312           $CPAN::Frontend->myprint(
2313                                    qq[
2314 Trying with "$funkyftp$src_switch" to get
2315     $url
2316 ]);
2317           my($system) =
2318               "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
2319           $self->debug("system[$system]") if $CPAN::DEBUG;
2320           my($wstatus);
2321           if (($wstatus = system($system)) == 0
2322               &&
2323               ($f eq "lynx" ?
2324                -s $asl_ungz   # lynx returns 0 on my
2325                                           # system even if it fails
2326                : 1
2327               )
2328              ) {
2329             if (-s $aslocal) {
2330               # Looks good
2331             } elsif ($asl_ungz ne $aslocal) {
2332               # test gzip integrity
2333               if (
2334                   CPAN::Tarzip->gtest($asl_ungz)
2335                  ) {
2336                 rename $asl_ungz, $aslocal;
2337               } else {
2338                 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
2339               }
2340             }
2341             $Thesite = $i;
2342             return $aslocal;
2343           } elsif ($url !~ /\.gz(?!\n)\Z/) {
2344             unlink $asl_ungz if
2345                 -f $asl_ungz && -s _ == 0;
2346             my $gz = "$aslocal.gz";
2347             my $gzurl = "$url.gz";
2348             $CPAN::Frontend->myprint(
2349                                      qq[
2350 Trying with "$funkyftp$src_switch" to get
2351   $url.gz
2352 ]);
2353             my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
2354             $self->debug("system[$system]") if $CPAN::DEBUG;
2355             my($wstatus);
2356             if (($wstatus = system($system)) == 0
2357                 &&
2358                 -s $asl_gz
2359                ) {
2360               # test gzip integrity
2361               if (CPAN::Tarzip->gtest($asl_gz)) {
2362                 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2363               } else {
2364                 rename $asl_ungz, $aslocal;
2365               }
2366               $Thesite = $i;
2367               return $aslocal;
2368             } else {
2369               unlink $asl_gz if -f $asl_gz;
2370             }
2371           } else {
2372             my $estatus = $wstatus >> 8;
2373             my $size = -f $aslocal ?
2374                 ", left\n$aslocal with size ".-s _ :
2375                     "\nWarning: expected file [$aslocal] doesn't exist";
2376             $CPAN::Frontend->myprint(qq{
2377 System call "$system"
2378 returned status $estatus (wstat $wstatus)$size
2379 });
2380           }
2381         }
2382     }
2383 }
2384
2385 sub hosthardest {
2386     my($self,$host_seq,$file,$aslocal) = @_;
2387
2388     my($i);
2389     my($aslocal_dir) = File::Basename::dirname($aslocal);
2390     File::Path::mkpath($aslocal_dir);
2391   HOSTHARDEST: for $i (@$host_seq) {
2392         unless (length $CPAN::Config->{'ftp'}) {
2393             $CPAN::Frontend->myprint("No external ftp command available\n\n");
2394             last HOSTHARDEST;
2395         }
2396         my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
2397         unless ($self->is_reachable($url)) {
2398             $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2399             next;
2400         }
2401         $url .= "/" unless substr($url,-1) eq "/";
2402         $url .= $file;
2403         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2404         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2405             next;
2406         }
2407         my($host,$dir,$getfile) = ($1,$2,$3);
2408         my $timestamp = 0;
2409         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2410            $ctime,$blksize,$blocks) = stat($aslocal);
2411         $timestamp = $mtime ||= 0;
2412         my($netrc) = CPAN::FTP::netrc->new;
2413         my($netrcfile) = $netrc->netrc;
2414         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2415         my $targetfile = File::Basename::basename($aslocal);
2416         my(@dialog);
2417         push(
2418              @dialog,
2419              "lcd $aslocal_dir",
2420              "cd /",
2421              map("cd $_", split "/", $dir), # RFC 1738
2422              "bin",
2423              "get $getfile $targetfile",
2424              "quit"
2425             );
2426         if (! $netrcfile) {
2427             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2428         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2429             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2430                                 $netrc->hasdefault,
2431                                 $netrc->contains($host))) if $CPAN::DEBUG;
2432             if ($netrc->protected) {
2433                 $CPAN::Frontend->myprint(qq{
2434   Trying with external ftp to get
2435     $url
2436   As this requires some features that are not thoroughly tested, we\'re
2437   not sure, that we get it right....
2438
2439 }
2440                      );
2441                 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2442                                 @dialog);
2443                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2444                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2445                 $mtime ||= 0;
2446                 if ($mtime > $timestamp) {
2447                     $CPAN::Frontend->myprint("GOT $aslocal\n");
2448                     $Thesite = $i;
2449                     return $aslocal;
2450                 } else {
2451                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
2452                 }
2453             } else {
2454                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2455                                         qq{correctly protected.\n});
2456             }
2457         } else {
2458             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2459   nor does it have a default entry\n");
2460         }
2461
2462         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2463         # then and login manually to host, using e-mail as
2464         # password.
2465         $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2466         unshift(
2467                 @dialog,
2468                 "open $host",
2469                 "user anonymous $Config::Config{'cf_email'}"
2470                );
2471         $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2472         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2473          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2474         $mtime ||= 0;
2475         if ($mtime > $timestamp) {
2476             $CPAN::Frontend->myprint("GOT $aslocal\n");
2477             $Thesite = $i;
2478             return $aslocal;
2479         } else {
2480             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
2481         }
2482         $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2483         sleep 2;
2484     }
2485 }
2486
2487 sub talk_ftp {
2488     my($self,$command,@dialog) = @_;
2489     my $fh = FileHandle->new;
2490     $fh->open("|$command") or die "Couldn't open ftp: $!";
2491     foreach (@dialog) { $fh->print("$_\n") }
2492     $fh->close;         # Wait for process to complete
2493     my $wstatus = $?;
2494     my $estatus = $wstatus >> 8;
2495     $CPAN::Frontend->myprint(qq{
2496 Subprocess "|$command"
2497   returned status $estatus (wstat $wstatus)
2498 }) if $wstatus;
2499 }
2500
2501 # find2perl needs modularization, too, all the following is stolen
2502 # from there
2503 # CPAN::FTP::ls
2504 sub ls {
2505     my($self,$name) = @_;
2506     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2507      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2508
2509     my($perms,%user,%group);
2510     my $pname = $name;
2511
2512     if ($blocks) {
2513         $blocks = int(($blocks + 1) / 2);
2514     }
2515     else {
2516         $blocks = int(($sizemm + 1023) / 1024);
2517     }
2518
2519     if    (-f _) { $perms = '-'; }
2520     elsif (-d _) { $perms = 'd'; }
2521     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2522     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2523     elsif (-p _) { $perms = 'p'; }
2524     elsif (-S _) { $perms = 's'; }
2525     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2526
2527     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2528     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2529     my $tmpmode = $mode;
2530     my $tmp = $rwx[$tmpmode & 7];
2531     $tmpmode >>= 3;
2532     $tmp = $rwx[$tmpmode & 7] . $tmp;
2533     $tmpmode >>= 3;
2534     $tmp = $rwx[$tmpmode & 7] . $tmp;
2535     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2536     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2537     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2538     $perms .= $tmp;
2539
2540     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
2541     my $group = $group{$gid} || $gid;
2542
2543     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2544     my($timeyear);
2545     my($moname) = $moname[$mon];
2546     if (-M _ > 365.25 / 2) {
2547         $timeyear = $year + 1900;
2548     }
2549     else {
2550         $timeyear = sprintf("%02d:%02d", $hour, $min);
2551     }
2552
2553     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2554             $ino,
2555                  $blocks,
2556                       $perms,
2557                             $nlink,
2558                                 $user,
2559                                      $group,
2560                                           $sizemm,
2561                                               $moname,
2562                                                  $mday,
2563                                                      $timeyear,
2564                                                          $pname;
2565 }
2566
2567 package CPAN::FTP::netrc;
2568
2569 sub new {
2570     my($class) = @_;
2571     my $file = MM->catfile($ENV{HOME},".netrc");
2572
2573     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2574        $atime,$mtime,$ctime,$blksize,$blocks)
2575         = stat($file);
2576     $mode ||= 0;
2577     my $protected = 0;
2578
2579     my($fh,@machines,$hasdefault);
2580     $hasdefault = 0;
2581     $fh = FileHandle->new or die "Could not create a filehandle";
2582
2583     if($fh->open($file)){
2584         $protected = ($mode & 077) == 0;
2585         local($/) = "";
2586       NETRC: while (<$fh>) {
2587             my(@tokens) = split " ", $_;
2588           TOKEN: while (@tokens) {
2589                 my($t) = shift @tokens;
2590                 if ($t eq "default"){
2591                     $hasdefault++;
2592                     last NETRC;
2593                 }
2594                 last TOKEN if $t eq "macdef";
2595                 if ($t eq "machine") {
2596                     push @machines, shift @tokens;
2597                 }
2598             }
2599         }
2600     } else {
2601         $file = $hasdefault = $protected = "";
2602     }
2603
2604     bless {
2605            'mach' => [@machines],
2606            'netrc' => $file,
2607            'hasdefault' => $hasdefault,
2608            'protected' => $protected,
2609           }, $class;
2610 }
2611
2612 sub hasdefault { shift->{'hasdefault'} }
2613 sub netrc      { shift->{'netrc'}      }
2614 sub protected  { shift->{'protected'}  }
2615 sub contains {
2616     my($self,$mach) = @_;
2617     for ( @{$self->{'mach'}} ) {
2618         return 1 if $_ eq $mach;
2619     }
2620     return 0;
2621 }
2622
2623 package CPAN::Complete;
2624
2625 sub gnu_cpl {
2626     my($text, $line, $start, $end) = @_;
2627     my(@perlret) = cpl($text, $line, $start);
2628     # find longest common match. Can anybody show me how to peruse
2629     # T::R::Gnu to have this done automatically? Seems expensive.
2630     return () unless @perlret;
2631     my($newtext) = $text;
2632     for (my $i = length($text)+1;;$i++) {
2633         last unless length($perlret[0]) && length($perlret[0]) >= $i;
2634         my $try = substr($perlret[0],0,$i);
2635         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2636         # warn "try[$try]tries[@tries]";
2637         if (@tries == @perlret) {
2638             $newtext = $try;
2639         } else {
2640             last;
2641         }
2642     }
2643     ($newtext,@perlret);
2644 }
2645
2646 #-> sub CPAN::Complete::cpl ;
2647 sub cpl {
2648     my($word,$line,$pos) = @_;
2649     $word ||= "";
2650     $line ||= "";
2651     $pos ||= 0;
2652     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2653     $line =~ s/^\s*//;
2654     if ($line =~ s/^(force\s*)//) {
2655         $pos -= length($1);
2656     }
2657     my @return;
2658     if ($pos == 0) {
2659         @return = grep(
2660                        /^$word/,
2661                        sort qw(
2662                                ! a b d h i m o q r u autobundle clean
2663                                make test install force reload look cvs_import
2664                               )
2665                       );
2666     } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
2667         @return = ();
2668     } elsif ($line =~ /^a\s/) {
2669         @return = cplx('CPAN::Author',$word);
2670     } elsif ($line =~ /^b\s/) {
2671         @return = cplx('CPAN::Bundle',$word);
2672     } elsif ($line =~ /^d\s/) {
2673         @return = cplx('CPAN::Distribution',$word);
2674     } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) {
2675         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
2676     } elsif ($line =~ /^i\s/) {
2677         @return = cpl_any($word);
2678     } elsif ($line =~ /^reload\s/) {
2679         @return = cpl_reload($word,$line,$pos);
2680     } elsif ($line =~ /^o\s/) {
2681         @return = cpl_option($word,$line,$pos);
2682     } else {
2683         @return = ();
2684     }
2685     return @return;
2686 }
2687
2688 #-> sub CPAN::Complete::cplx ;
2689 sub cplx {
2690     my($class, $word) = @_;
2691     # I believed for many years that this was sorted, today I
2692     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2693     # make it sorted again. Maybe sort was dropped when GNU-readline
2694     # support came in? The RCS file is difficult to read on that:-(
2695     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
2696 }
2697
2698 #-> sub CPAN::Complete::cpl_any ;
2699 sub cpl_any {
2700     my($word) = shift;
2701     return (
2702             cplx('CPAN::Author',$word),
2703             cplx('CPAN::Bundle',$word),
2704             cplx('CPAN::Distribution',$word),
2705             cplx('CPAN::Module',$word),
2706            );
2707 }
2708
2709 #-> sub CPAN::Complete::cpl_reload ;
2710 sub cpl_reload {
2711     my($word,$line,$pos) = @_;
2712     $word ||= "";
2713     my(@words) = split " ", $line;
2714     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2715     my(@ok) = qw(cpan index);
2716     return @ok if @words == 1;
2717     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
2718 }
2719
2720 #-> sub CPAN::Complete::cpl_option ;
2721 sub cpl_option {
2722     my($word,$line,$pos) = @_;
2723     $word ||= "";
2724     my(@words) = split " ", $line;
2725     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2726     my(@ok) = qw(conf debug);
2727     return @ok if @words == 1;
2728     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
2729     if (0) {
2730     } elsif ($words[1] eq 'index') {
2731         return ();
2732     } elsif ($words[1] eq 'conf') {
2733         return CPAN::Config::cpl(@_);
2734     } elsif ($words[1] eq 'debug') {
2735         return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2736     }
2737 }
2738
2739 package CPAN::Index;
2740
2741 #-> sub CPAN::Index::force_reload ;
2742 sub force_reload {
2743     my($class) = @_;
2744     $CPAN::Index::last_time = 0;
2745     $class->reload(1);
2746 }
2747
2748 #-> sub CPAN::Index::reload ;
2749 sub reload {
2750     my($cl,$force) = @_;
2751     my $time = time;
2752
2753     # XXX check if a newer one is available. (We currently read it
2754     # from time to time)
2755     for ($CPAN::Config->{index_expire}) {
2756         $_ = 0.001 unless $_ && $_ > 0.001;
2757     }
2758     return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2759         and ! $force;
2760     ## IFF we are developing, it helps to wipe out the memory between
2761     ## reloads, otherwise it is not what a user expects.
2762
2763     ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2764     ## $CPAN::META = CPAN->new;
2765     my($debug,$t2);
2766     $last_time = $time;
2767
2768     my $needshort = $^O eq "dos";
2769
2770     $cl->rd_authindex($cl
2771                       ->reload_x(
2772                                  "authors/01mailrc.txt.gz",
2773                                  $needshort ?
2774                                  File::Spec->catfile('authors', '01mailrc.gz') :
2775                                  File::Spec->catfile('authors', '01mailrc.txt.gz'),
2776                                  $force));
2777     $t2 = time;
2778     $debug = "timing reading 01[".($t2 - $time)."]";
2779     $time = $t2;
2780     return if $CPAN::Signal; # this is sometimes lengthy
2781     $cl->rd_modpacks($cl
2782                      ->reload_x(
2783                                 "modules/02packages.details.txt.gz",
2784                                 $needshort ?
2785                                 File::Spec->catfile('modules', '02packag.gz') :
2786                                 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2787                                 $force));
2788     $t2 = time;
2789     $debug .= "02[".($t2 - $time)."]";
2790     $time = $t2;
2791     return if $CPAN::Signal; # this is sometimes lengthy
2792     $cl->rd_modlist($cl
2793                     ->reload_x(
2794                                "modules/03modlist.data.gz",
2795                                $needshort ?
2796                                File::Spec->catfile('modules', '03mlist.gz') :
2797                                File::Spec->catfile('modules', '03modlist.data.gz'),
2798                                $force));
2799     $cl->write_metadata_cache;
2800     $t2 = time;
2801     $debug .= "03[".($t2 - $time)."]";
2802     $time = $t2;
2803     CPAN->debug($debug) if $CPAN::DEBUG;
2804 }
2805
2806 #-> sub CPAN::Index::reload_x ;
2807 sub reload_x {
2808     my($cl,$wanted,$localname,$force) = @_;
2809     $force |= 2; # means we're dealing with an index here
2810     CPAN::Config->load; # we should guarantee loading wherever we rely
2811                         # on Config XXX
2812     $localname ||= $wanted;
2813     my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
2814                                    $localname);
2815     if (
2816         -f $abs_wanted &&
2817         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
2818         !($force & 1)
2819        ) {
2820         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
2821         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
2822                    qq{day$s. I\'ll use that.});
2823         return $abs_wanted;
2824     } else {
2825         $force |= 1; # means we're quite serious about it.
2826     }
2827     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2828 }
2829
2830 #-> sub CPAN::Index::rd_authindex ;
2831 sub rd_authindex {
2832     my($cl, $index_target) = @_;
2833     my @lines;
2834     return unless defined $index_target;
2835     $CPAN::Frontend->myprint("Going to read $index_target\n");
2836 #    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2837 #    while ($_ = $fh->READLINE) {
2838     # no strict 'refs';
2839     local(*FH);
2840     tie *FH, CPAN::Tarzip, $index_target;
2841     local($/) = "\n";
2842     push @lines, split /\012/ while <FH>;
2843     foreach (@lines) {
2844         my($userid,$fullname,$email) =
2845             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
2846         next unless $userid && $fullname && $email;
2847
2848         # instantiate an author object
2849         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2850         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2851         return if $CPAN::Signal;
2852     }
2853 }
2854
2855 sub userid {
2856   my($self,$dist) = @_;
2857   $dist = $self->{'id'} unless defined $dist;
2858   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2859   $ret;
2860 }
2861
2862 #-> sub CPAN::Index::rd_modpacks ;
2863 sub rd_modpacks {
2864     my($self, $index_target) = @_;
2865     my @lines;
2866     return unless defined $index_target;
2867     $CPAN::Frontend->myprint("Going to read $index_target\n");
2868     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2869     local($/) = "\n";
2870     while ($_ = $fh->READLINE) {
2871         s/\012/\n/g;
2872         my @ls = map {"$_\n"} split /\n/, $_;
2873         unshift @ls, "\n" x length($1) if /^(\n+)/;
2874         push @lines, @ls;
2875     }
2876     # read header
2877     my $line_count;
2878     while (@lines) {
2879         my $shift = shift(@lines);
2880         $shift =~ /^Line-Count:\s+(\d+)/;
2881         $line_count = $1 if $1;
2882         last if $shift =~ /^\s*$/;
2883     }
2884     if (not defined $line_count) {
2885
2886         warn qq{Warning: Your $index_target does not contain a Line-Count header.
2887 Please check the validity of the index file by comparing it to more
2888 than one CPAN mirror. I'll continue but problems seem likely to
2889 happen.\a
2890 };
2891
2892         sleep 5;
2893     } elsif ($line_count != scalar @lines) {
2894
2895         warn sprintf qq{Warning: Your %s
2896 contains a Line-Count header of %d but I see %d lines there. Please
2897 check the validity of the index file by comparing it to more than one
2898 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
2899 $index_target, $line_count, scalar(@lines);
2900
2901     }
2902     foreach (@lines) {
2903         chomp;
2904         # before 1.56 we split into 3 and discarded the rest. From
2905         # 1.57 we assign remaining text to $comment thus allowing to
2906         # influence isa_perl
2907         my($mod,$version,$dist,$comment) = split " ", $_, 4;
2908 ###     $version =~ s/^\+//;
2909
2910         # if it is a bundle, instantiate a bundle object
2911         my($bundle,$id,$userid);
2912
2913         if ($mod eq 'CPAN' &&
2914             ! (
2915                CPAN::Queue->exists('Bundle::CPAN') ||
2916                CPAN::Queue->exists('CPAN')
2917               )
2918            ) {
2919             local($^W)= 0;
2920             if ($version > $CPAN::VERSION){
2921                 $CPAN::Frontend->myprint(qq{
2922   There\'s a new CPAN.pm version (v$version) available!
2923   [Current version is v$CPAN::VERSION]
2924   You might want to try
2925     install Bundle::CPAN
2926     reload cpan
2927   without quitting the current session. It should be a seamless upgrade
2928   while we are running...
2929 });
2930                 sleep 2;
2931                 $CPAN::Frontend->myprint(qq{\n});
2932             }
2933             last if $CPAN::Signal;
2934         } elsif ($mod =~ /^Bundle::(.*)/) {
2935             $bundle = $1;
2936         }
2937
2938         if ($bundle){
2939             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
2940             # warn "made mod[$mod]a bundle";
2941             # Let's make it a module too, because bundles have so much
2942             # in common with modules
2943             $CPAN::META->instance('CPAN::Module',$mod);
2944             # warn "made mod[$mod]a module";
2945
2946 # This "next" makes us faster but if the job is running long, we ignore
2947 # rereads which is bad. So we have to be a bit slower again.
2948 #       } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2949 #           next;
2950
2951         }
2952         else {
2953             # instantiate a module object
2954             $id = $CPAN::META->instance('CPAN::Module',$mod);
2955         }
2956
2957         if ($id->cpan_file ne $dist){ # update only if file is
2958                                       # different. CPAN prohibits same
2959                                       # name with different version
2960             $userid = $self->userid($dist);
2961             $id->set(
2962                      'CPAN_USERID' => $userid,
2963                      'CPAN_VERSION' => $version, # %vd not needed
2964                      'CPAN_FILE' => $dist,
2965                      'CPAN_COMMENT' => $comment,
2966                     );
2967         }
2968
2969         # instantiate a distribution object
2970         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2971           # we do not need CONTAINSMODS unless we do something with
2972           # this dist, so we better produce it on demand.
2973
2974           ## my $obj = $CPAN::META->instance(
2975           ##                              'CPAN::Distribution' => $dist
2976           ##                             );
2977           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
2978         } else {
2979           $CPAN::META->instance(
2980                                 'CPAN::Distribution' => $dist
2981                                )->set(
2982                                       'CPAN_USERID' => $userid
2983                                      );
2984         }
2985
2986         return if $CPAN::Signal;
2987     }
2988     undef $fh;
2989 }
2990
2991 #-> sub CPAN::Index::rd_modlist ;
2992 sub rd_modlist {
2993     my($cl,$index_target) = @_;
2994     return unless defined $index_target;
2995     $CPAN::Frontend->myprint("Going to read $index_target\n");
2996     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2997     my @eval;
2998     local($/) = "\n";
2999     while ($_ = $fh->READLINE) {
3000         s/\012/\n/g;
3001         my @ls = map {"$_\n"} split /\n/, $_;
3002         unshift @ls, "\n" x length($1) if /^(\n+)/;
3003         push @eval, @ls;
3004     }
3005     while (@eval) {
3006         my $shift = shift(@eval);
3007         if ($shift =~ /^Date:\s+(.*)/){
3008             return if $date_of_03 eq $1;
3009             ($date_of_03) = $1;
3010         }
3011         last if $shift =~ /^\s*$/;
3012     }
3013     undef $fh;
3014     push @eval, q{CPAN::Modulelist->data;};
3015     local($^W) = 0;
3016     my($comp) = Safe->new("CPAN::Safe1");
3017     my($eval) = join("", @eval);
3018     my $ret = $comp->reval($eval);
3019     Carp::confess($@) if $@;
3020     return if $CPAN::Signal;
3021     for (keys %$ret) {
3022         my $obj = $CPAN::META->instance(CPAN::Module,$_);
3023         $obj->set(%{$ret->{$_}});
3024         return if $CPAN::Signal;
3025     }
3026 }
3027
3028 #-> sub CPAN::Index::write_metadata_cache ;
3029 sub write_metadata_cache {
3030     my($self) = @_;
3031     return unless $CPAN::Config->{'cache_metadata'};
3032     return unless $CPAN::META->has_usable("Storable");
3033     my $cache;
3034     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3035                       CPAN::Distribution)) {
3036         $cache->{$k} = $CPAN::META->{$k};
3037     }
3038     my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3039     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
3040     $cache->{last_time} = $last_time;
3041     eval { Storable::store($cache, $metadata_file) };
3042     $CPAN::Frontent->mywarn($@) if $@;
3043 }
3044
3045 #-> sub CPAN::Index::read_metadata_cache ;
3046 sub read_metadata_cache {
3047     my($self) = @_;
3048     return unless $CPAN::Config->{'cache_metadata'};
3049     return unless $CPAN::META->has_usable("Storable");
3050     my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
3051     return unless -r $metadata_file and -f $metadata_file;
3052     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3053     my $cache;
3054     eval { $cache = Storable::retrieve($metadata_file) };
3055     $CPAN::Frontend->mywarn($@) if $@;
3056     return if (!$cache || ref $cache ne 'HASH');
3057     while(my($k,$v) = each %$cache) {
3058         next unless $k =~ /^CPAN::/;
3059         $CPAN::META->{$k} = $v;
3060     }
3061     $last_time = $cache->{last_time};
3062 }
3063
3064 package CPAN::InfoObj;
3065
3066 #-> sub CPAN::InfoObj::new ;
3067 sub new { my $this = bless {}, shift; %$this = @_; $this }
3068
3069 #-> sub CPAN::InfoObj::set ;
3070 sub set {
3071     my($self,%att) = @_;
3072     my(%oldatt) = %$self;
3073     %$self = (%oldatt, %att);
3074 }
3075
3076 #-> sub CPAN::InfoObj::id ;
3077 sub id { shift->{'ID'} }
3078
3079 #-> sub CPAN::InfoObj::as_glimpse ;
3080 sub as_glimpse {
3081     my($self) = @_;
3082     my(@m);
3083     my $class = ref($self);
3084     $class =~ s/^CPAN:://;
3085     push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3086     join "", @m;
3087 }
3088
3089 #-> sub CPAN::InfoObj::as_string ;
3090 sub as_string {
3091     my($self) = @_;
3092     my(@m);
3093     my $class = ref($self);
3094     $class =~ s/^CPAN:://;
3095     push @m, $class, " id = $self->{ID}\n";
3096     for (sort keys %$self) {
3097         next if $_ eq 'ID';
3098         my $extra = "";
3099         if ($_ eq "CPAN_USERID") {
3100           $extra .= " (".$self->author;
3101           my $email; # old perls!
3102           if ($email = $CPAN::META->instance(CPAN::Author,
3103                                                 $self->{$_}
3104                                                )->email) {
3105             $extra .= " <$email>";
3106           } else {
3107             $extra .= " <no email>";
3108           }
3109           $extra .= ")";
3110         }
3111         if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
3112           push @m, sprintf "    %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
3113         } elsif (ref($self->{$_}) eq "HASH") {
3114           push @m, sprintf(
3115                            "    %-12s %s%s\n",
3116                            $_,
3117                            join(" ",keys %{$self->{$_}}),
3118                            $extra);
3119         } else {
3120           push @m, sprintf "    %-12s %s%s\n", $_, $self->{$_}, $extra;
3121         }
3122     }
3123     join "", @m, "\n";
3124 }
3125
3126 #-> sub CPAN::InfoObj::author ;
3127 sub author {
3128     my($self) = @_;
3129     $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
3130 }
3131
3132 sub dump {
3133   my($self) = @_;
3134   require Data::Dumper;
3135   Data::Dumper::Dumper($self);
3136 }
3137
3138 package CPAN::Author;
3139
3140 #-> sub CPAN::Author::as_glimpse ;
3141 sub as_glimpse {
3142     my($self) = @_;
3143     my(@m);
3144     my $class = ref($self);
3145     $class =~ s/^CPAN:://;
3146     push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3147     join "", @m;
3148 }
3149
3150 # Dead code, I would have liked to have,,, but it was never reached,,,
3151 #sub make {
3152 #    my($self) = @_;
3153 #    return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
3154 #}
3155
3156 #-> sub CPAN::Author::fullname ;
3157 sub fullname { shift->{'FULLNAME'} }
3158 *name = \&fullname;
3159
3160 #-> sub CPAN::Author::email ;
3161 sub email    { shift->{'EMAIL'} }
3162
3163 package CPAN::Distribution;
3164
3165 #-> sub CPAN::Distribution::as_string ;
3166 sub as_string {
3167   my $self = shift;
3168   $self->containsmods;
3169   $self->SUPER::as_string(@_);
3170 }
3171
3172 #-> sub CPAN::Distribution::containsmods ;
3173 sub containsmods {
3174   my $self = shift;
3175   return if exists $self->{CONTAINSMODS};
3176   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3177     my $mod_file = $mod->{CPAN_FILE} or next;
3178     my $dist_id = $self->{ID} or next;
3179     my $mod_id = $mod->{ID} or next;
3180     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3181   }
3182 }
3183
3184 #-> sub CPAN::Distribution::called_for ;
3185 sub called_for {
3186     my($self,$id) = @_;
3187     $self->{'CALLED_FOR'} = $id if defined $id;
3188     return $self->{'CALLED_FOR'};
3189 }
3190
3191 #-> sub CPAN::Distribution::get ;
3192 sub get {
3193     my($self) = @_;
3194   EXCUSE: {
3195         my @e;
3196         exists $self->{'build_dir'} and push @e,
3197             "Unwrapped into directory $self->{'build_dir'}";
3198         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3199     }
3200     my($local_file);
3201     my($local_wanted) =
3202          MM->catfile(
3203                         $CPAN::Config->{keep_source_where},
3204                         "authors",
3205                         "id",
3206                         split("/",$self->{ID})
3207                        );
3208
3209     $self->debug("Doing localize") if $CPAN::DEBUG;
3210     $local_file =
3211         CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3212             or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
3213     $self->{localfile} = $local_file;
3214     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3215     my $builddir = $CPAN::META->{cachemgr}->dir;
3216     $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3217     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3218     my $packagedir;
3219
3220     $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
3221     if ($CPAN::META->has_inst('MD5')) {
3222         $self->debug("MD5 is installed, verifying");
3223         $self->verifyMD5;
3224     } else {
3225         $self->debug("MD5 is NOT installed");
3226     }
3227     $self->debug("Removing tmp") if $CPAN::DEBUG;
3228     File::Path::rmtree("tmp");
3229     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3230     chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
3231     $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
3232     if (! $local_file) {
3233         Carp::croak "bad download, can't do anything :-(\n";
3234     } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
3235         $self->untar_me($local_file);
3236     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
3237         $self->unzip_me($local_file);
3238     } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
3239         $self->pm2dir_me($local_file);
3240     } else {
3241         $self->{archived} = "NO";
3242     }
3243     my $cwd = File::Spec->updir;
3244     chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
3245     if ($self->{archived} ne 'NO') {
3246       $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
3247       chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3248       # Let's check if the package has its own directory.
3249       my $dh = DirHandle->new(File::Spec->curdir)
3250           or Carp::croak("Couldn't opendir .: $!");
3251       my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3252       $dh->close;
3253       my ($distdir,$packagedir);
3254       if (@readdir == 1 && -d $readdir[0]) {
3255         $distdir = $readdir[0];
3256         $packagedir = MM->catdir($builddir,$distdir);
3257         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
3258         File::Path::rmtree($packagedir);
3259         rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3260       } else {
3261         my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
3262         $pragmatic_dir =~ s/\W_//g;
3263         $pragmatic_dir++ while -d "../$pragmatic_dir";
3264         $packagedir = MM->catdir($builddir,$pragmatic_dir);
3265         File::Path::mkpath($packagedir);
3266         my($f);
3267         for $f (@readdir) { # is already without "." and ".."
3268           my $to = MM->catdir($packagedir,$f);
3269           rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3270         }
3271       }
3272       $self->{'build_dir'} = $packagedir;
3273       $cwd = File::Spec->updir;
3274       chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3275
3276       $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
3277           if $CPAN::DEBUG;
3278       File::Path::rmtree("tmp");
3279       if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
3280         $CPAN::Frontend->myprint("Going to unlink $local_file\n");
3281         unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3282       }
3283       my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
3284       unless (-f $makefilepl) {
3285         my($configure) = MM->catfile($packagedir,"Configure");
3286         if (-f $configure) {
3287           # do we have anything to do?
3288           $self->{'configure'} = $configure;
3289         } elsif (-f MM->catfile($packagedir,"Makefile")) {
3290           $CPAN::Frontend->myprint(qq{
3291 Package comes with a Makefile and without a Makefile.PL.
3292 We\'ll try to build it with that Makefile then.
3293 });
3294           $self->{writemakefile} = "YES";
3295           sleep 2;
3296         } else {
3297           my $fh = FileHandle->new(">$makefilepl")
3298               or Carp::croak("Could not open >$makefilepl");
3299           my $cf = $self->called_for || "unknown";
3300           $fh->print(
3301 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3302 # because there was no Makefile.PL supplied.
3303 # Autogenerated on: }.scalar localtime().qq{
3304
3305 use ExtUtils::MakeMaker;
3306 WriteMakefile(NAME => q[$cf]);
3307
3308 });
3309           $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
3310   Writing one on our own (calling it $cf)\n});
3311         }
3312       }
3313     }
3314     return $self;
3315 }
3316
3317 sub untar_me {
3318     my($self,$local_file) = @_;
3319     $self->{archived} = "tar";
3320     if (CPAN::Tarzip->untar($local_file)) {
3321         $self->{unwrapped} = "YES";
3322     } else {
3323         $self->{unwrapped} = "NO";
3324     }
3325 }
3326
3327 sub unzip_me {
3328     my($self,$local_file) = @_;
3329     $self->{archived} = "zip";
3330     if ($CPAN::META->has_inst("Archive::Zip")) {
3331       if (CPAN::Tarzip->unzip($local_file)) {
3332         $self->{unwrapped} = "YES";
3333       } else {
3334         $self->{unwrapped} = "NO";
3335       }
3336       return;
3337     }
3338     my $unzip = $CPAN::Config->{unzip} or
3339         $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
3340     my @system = ($unzip, $local_file);
3341     if (system(@system) == 0) {
3342         $self->{unwrapped} = "YES";
3343     } else {
3344         $self->{unwrapped} = "NO";
3345     }
3346 }
3347
3348 sub pm2dir_me {
3349     my($self,$local_file) = @_;
3350     $self->{archived} = "pm";
3351     my $to = File::Basename::basename($local_file);
3352     $to =~ s/\.(gz|Z)(?!\n)\Z//;
3353     if (CPAN::Tarzip->gunzip($local_file,$to)) {
3354         $self->{unwrapped} = "YES";
3355     } else {
3356         $self->{unwrapped} = "NO";
3357     }
3358 }
3359
3360 #-> sub CPAN::Distribution::new ;
3361 sub new {
3362     my($class,%att) = @_;
3363
3364     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
3365
3366     my $this = { %att };
3367     return bless $this, $class;
3368 }
3369
3370 #-> sub CPAN::Distribution::look ;
3371 sub look {
3372     my($self) = @_;
3373
3374     if ($^O eq 'MacOS') {
3375       $self->ExtUtils::MM_MacOS::look;
3376       return;
3377     }
3378
3379     if (  $CPAN::Config->{'shell'} ) {
3380         $CPAN::Frontend->myprint(qq{
3381 Trying to open a subshell in the build directory...
3382 });
3383     } else {
3384         $CPAN::Frontend->myprint(qq{
3385 Your configuration does not define a value for subshells.
3386 Please define it with "o conf shell <your shell>"
3387 });
3388         return;
3389     }
3390     my $dist = $self->id;
3391     my $dir  = $self->dir or $self->get;
3392     $dir = $self->dir;
3393     my $getcwd;
3394     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3395     my $pwd  = CPAN->$getcwd();
3396     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3397     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3398     system($CPAN::Config->{'shell'}) == 0
3399         or $CPAN::Frontend->mydie("Subprocess shell error");
3400     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3401 }
3402
3403 sub cvs_import {
3404     my($self) = @_;
3405     $self->get;
3406     my $dir = $self->dir;
3407
3408     my $package = $self->called_for;
3409     my $module = $CPAN::META->instance('CPAN::Module', $package);
3410     my $version = $module->cpan_version; # %vd not needed
3411
3412     my $userid = $self->{CPAN_USERID};
3413
3414     my $cvs_dir = (split '/', $dir)[-1];
3415     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
3416     my $cvs_root = 
3417       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3418     my $cvs_site_perl = 
3419       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3420     if ($cvs_site_perl) {
3421         $cvs_dir = "$cvs_site_perl/$cvs_dir";
3422     }
3423     my $cvs_log = qq{"imported $package $version sources"};
3424     $version =~ s/\./_/g;
3425     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3426                "$cvs_dir", $userid, "v$version");
3427
3428     my $getcwd;
3429     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3430     my $pwd  = CPAN->$getcwd();
3431     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
3432
3433     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3434
3435     $CPAN::Frontend->myprint(qq{@cmd\n});
3436     system(@cmd) == 0 or
3437         $CPAN::Frontend->mydie("cvs import failed");
3438     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
3439 }
3440
3441 #-> sub CPAN::Distribution::readme ;
3442 sub readme {
3443     my($self) = @_;
3444     my($dist) = $self->id;
3445     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3446     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3447     my($local_file);
3448     my($local_wanted) =
3449          MM->catfile(
3450                         $CPAN::Config->{keep_source_where},
3451                         "authors",
3452                         "id",
3453                         split("/","$sans.readme"),
3454                        );
3455     $self->debug("Doing localize") if $CPAN::DEBUG;
3456     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3457                                       $local_wanted)
3458         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
3459
3460     if ($^O eq 'MacOS') {
3461         ExtUtils::MM_MacOS::launch_file($local_file);
3462         return;
3463     }
3464
3465     my $fh_pager = FileHandle->new;
3466     local($SIG{PIPE}) = "IGNORE";
3467     $fh_pager->open("|$CPAN::Config->{'pager'}")
3468         or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3469     my $fh_readme = FileHandle->new;
3470     $fh_readme->open($local_file)
3471         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3472     $CPAN::Frontend->myprint(qq{
3473 Displaying file
3474   $local_file
3475 with pager "$CPAN::Config->{'pager'}"
3476 });
3477     sleep 2;
3478     $fh_pager->print(<$fh_readme>);
3479 }
3480
3481 #-> sub CPAN::Distribution::verifyMD5 ;
3482 sub verifyMD5 {
3483     my($self) = @_;
3484   EXCUSE: {
3485         my @e;
3486         $self->{MD5_STATUS} ||= "";
3487         $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
3488         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3489     }
3490     my($lc_want,$lc_file,@local,$basename);
3491     @local = split("/",$self->{ID});
3492     pop @local;
3493     push @local, "CHECKSUMS";
3494     $lc_want =
3495         MM->catfile($CPAN::Config->{keep_source_where},
3496                       "authors", "id", @local);
3497     local($") = "/";
3498     if (
3499         -s $lc_want
3500         &&
3501         $self->MD5_check_file($lc_want)
3502        ) {
3503         return $self->{MD5_STATUS} = "OK";
3504     }
3505     $lc_file = CPAN::FTP->localize("authors/id/@local",
3506                                    $lc_want,1);
3507     unless ($lc_file) {
3508         $local[-1] .= ".gz";
3509         $lc_file = CPAN::FTP->localize("authors/id/@local",
3510                                        "$lc_want.gz",1);
3511         if ($lc_file) {
3512             $lc_file =~ s/\.gz(?!\n)\Z//;
3513             CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3514         } else {
3515             return;
3516         }
3517     }
3518     $self->MD5_check_file($lc_file);
3519 }
3520
3521 #-> sub CPAN::Distribution::MD5_check_file ;
3522 sub MD5_check_file {
3523     my($self,$chk_file) = @_;
3524     my($cksum,$file,$basename);
3525     $file = $self->{localfile};
3526     $basename = File::Basename::basename($file);
3527     my $fh = FileHandle->new;
3528     if (open $fh, $chk_file){
3529         local($/);
3530         my $eval = <$fh>;
3531         $eval =~ s/\015?\012/\n/g;
3532         close $fh;
3533         my($comp) = Safe->new();
3534         $cksum = $comp->reval($eval);
3535         if ($@) {
3536             rename $chk_file, "$chk_file.bad";
3537             Carp::confess($@) if $@;
3538         }
3539     } else {
3540         Carp::carp "Could not open $chk_file for reading";
3541     }
3542
3543     if (exists $cksum->{$basename}{md5}) {
3544         $self->debug("Found checksum for $basename:" .
3545                      "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3546
3547         open($fh, $file);
3548         binmode $fh;
3549         my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3550         $fh->close;
3551         $fh = CPAN::Tarzip->TIEHANDLE($file);
3552
3553         unless ($eq) {
3554           # had to inline it, when I tied it, the tiedness got lost on
3555           # the call to eq_MD5. (Jan 1998)
3556           my $md5 = MD5->new;
3557           my($data,$ref);
3558           $ref = \$data;
3559           while ($fh->READ($ref, 4096) > 0){
3560             $md5->add($data);
3561           }
3562           my $hexdigest = $md5->hexdigest;
3563           $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3564         }
3565
3566         if ($eq) {
3567           $CPAN::Frontend->myprint("Checksum for $file ok\n");
3568           return $self->{MD5_STATUS} = "OK";
3569         } else {
3570             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
3571                                      qq{distribution file. }.
3572                                      qq{Please investigate.\n\n}.
3573                                      $self->as_string,
3574                                      $CPAN::META->instance(
3575                                                            'CPAN::Author',
3576                                                            $self->{CPAN_USERID}
3577                                                           )->as_string);
3578
3579             my $wrap = qq{I\'d recommend removing $file. Its MD5
3580 checksum is incorrect. Maybe you have configured your \`urllist\' with
3581 a bad URL. Please check this array with \`o conf urllist\', and
3582 retry.};
3583
3584             $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3585             $CPAN::Frontend->myprint("\n\n");
3586             sleep 3;
3587             return;
3588         }
3589         # close $fh if fileno($fh);
3590     } else {
3591         $self->{MD5_STATUS} ||= "";
3592         if ($self->{MD5_STATUS} eq "NIL") {
3593             $CPAN::Frontend->myprint(qq{
3594 No md5 checksum for $basename in local $chk_file.
3595 Removing $chk_file
3596 });
3597             unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
3598             sleep 1;
3599         }
3600         $self->{MD5_STATUS} = "NIL";
3601         return;
3602     }
3603 }
3604
3605 #-> sub CPAN::Distribution::eq_MD5 ;
3606 sub eq_MD5 {
3607     my($self,$fh,$expectMD5) = @_;
3608     my $md5 = MD5->new;
3609     my($data);
3610     while (read($fh, $data, 4096)){
3611       $md5->add($data);
3612     }
3613     # $md5->addfile($fh);
3614     my $hexdigest = $md5->hexdigest;
3615     # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
3616     $hexdigest eq $expectMD5;
3617 }
3618
3619 #-> sub CPAN::Distribution::force ;
3620 sub force {
3621   my($self) = @_;
3622   $self->{'force_update'}++;
3623   for my $att (qw(
3624   MD5_STATUS archived build_dir localfile make install unwrapped
3625   writemakefile
3626  )) {
3627     delete $self->{$att};
3628   }
3629 }
3630
3631 #-> sub CPAN::Distribution::isa_perl ;
3632 sub isa_perl {
3633   my($self) = @_;
3634   my $file = File::Basename::basename($self->id);
3635   if ($file =~ m{ ^ perl
3636                   -?
3637                   (5)
3638                   ([._-])
3639                   (
3640                    \d{3}(_[0-4][0-9])?
3641                    |
3642                    \d*[24680]\.\d+
3643                   )
3644                   \.tar[._-]gz
3645                   (?!\n)\Z
3646                 }xs){
3647     return "$1.$3";
3648   } elsif ($self->{'CPAN_COMMENT'} && $self->{'CPAN_COMMENT'} =~ /isa_perl\(.+?\)/){
3649     return $1;
3650   }
3651 }
3652
3653 #-> sub CPAN::Distribution::perl ;
3654 sub perl {
3655     my($self) = @_;
3656     my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
3657     my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3658     my $pwd  = CPAN->$getcwd();
3659     my $candidate = MM->catfile($pwd,$^X);
3660     $perl ||= $candidate if MM->maybe_command($candidate);
3661     unless ($perl) {
3662         my ($component,$perl_name);
3663       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
3664             PATH_COMPONENT: foreach $component (MM->path(),
3665                                                 $Config::Config{'binexp'}) {
3666                   next unless defined($component) && $component;
3667                   my($abs) = MM->catfile($component,$perl_name);
3668                   if (MM->maybe_command($abs)) {
3669                       $perl = $abs;
3670                       last DIST_PERLNAME;
3671                   }
3672               }
3673           }
3674     }
3675     $perl;
3676 }
3677
3678 #-> sub CPAN::Distribution::make ;
3679 sub make {
3680     my($self) = @_;
3681     $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
3682     # Emergency brake if they said install Pippi and get newest perl
3683     if ($self->isa_perl) {
3684       if (
3685           $self->called_for ne $self->id && ! $self->{'force_update'}
3686          ) {
3687         # if we die here, we break bundles
3688         $CPAN::Frontend->mywarn(sprintf qq{
3689 The most recent version "%s" of the module "%s"
3690 comes with the current version of perl (%s).
3691 I\'ll build that only if you ask for something like
3692     force install %s
3693 or
3694     install %s
3695 },
3696                                $CPAN::META->instance(
3697                                                      'CPAN::Module',
3698                                                      $self->called_for
3699                                                     )->cpan_version, # %vd not needed
3700                                $self->called_for,
3701                                $self->isa_perl,
3702                                $self->called_for,
3703                                $self->id);
3704         sleep 5; return;
3705       }
3706     }
3707     $self->get;
3708   EXCUSE: {
3709         my @e;
3710         $self->{archived} eq "NO" and push @e,
3711         "Is neither a tar nor a zip archive.";
3712
3713         $self->{unwrapped} eq "NO" and push @e,
3714         "had problems unarchiving. Please build manually";
3715
3716         exists $self->{writemakefile} &&
3717             $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3718                 $1 || "Had some problem writing Makefile";
3719
3720         defined $self->{'make'} and push @e,
3721         "Has already been processed within this session";
3722
3723         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3724     }
3725     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
3726     my $builddir = $self->dir;
3727     chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3728     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3729
3730     if ($^O eq 'MacOS') {
3731         ExtUtils::MM_MacOS::make($self);
3732         return;
3733     }
3734
3735     my $system;
3736     if ($self->{'configure'}) {
3737       $system = $self->{'configure'};
3738     } else {
3739         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3740         my $switch = "";
3741 # This needs a handler that can be turned on or off:
3742 #       $switch = "-MExtUtils::MakeMaker ".
3743 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3744 #           if $] > 5.00310;
3745         $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3746     }
3747     unless (exists $self->{writemakefile}) {
3748         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3749         my($ret,$pid);
3750         $@ = "";
3751         if ($CPAN::Config->{inactivity_timeout}) {
3752             eval {
3753                 alarm $CPAN::Config->{inactivity_timeout};
3754                 local $SIG{CHLD}; # = sub { wait };
3755                 if (defined($pid = fork)) {
3756                     if ($pid) { #parent
3757                         # wait;
3758                         waitpid $pid, 0;
3759                     } else {    #child
3760                       # note, this exec isn't necessary if
3761                       # inactivity_timeout is 0. On the Mac I'd
3762                       # suggest, we set it always to 0.
3763                       exec $system;
3764                     }
3765                 } else {
3766                     $CPAN::Frontend->myprint("Cannot fork: $!");
3767                     return;
3768                 }
3769             };
3770             alarm 0;
3771             if ($@){
3772                 kill 9, $pid;
3773                 waitpid $pid, 0;
3774                 $CPAN::Frontend->myprint($@);
3775                 $self->{writemakefile} = "NO $@";
3776                 $@ = "";
3777                 return;
3778             }
3779         } else {
3780           $ret = system($system);
3781           if ($ret != 0) {
3782             $self->{writemakefile} = "NO Makefile.PL returned status $ret";
3783             return;
3784           }
3785         }
3786         if (-f "Makefile") {
3787           $self->{writemakefile} = "YES";
3788         } else {
3789           $self->{writemakefile} =
3790               qq{NO Makefile.PL refused to write a Makefile.};
3791           # It's probably worth to record the reason, so let's retry
3792           # local $/;
3793           # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
3794           # $self->{writemakefile} .= <$fh>;
3795         }
3796     }
3797     return if $CPAN::Signal;
3798     if (my @prereq = $self->needs_prereq){
3799       my $id = $self->id;
3800       $CPAN::Frontend->myprint("---- Dependencies detected ".
3801                                "during [$id] -----\n");
3802
3803       for my $p (@prereq) {
3804         $CPAN::Frontend->myprint("    $p\n");
3805       }
3806       my $follow = 0;
3807       if ($CPAN::Config->{prerequisites_policy} eq "follow") {
3808         $follow = 1;
3809       } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
3810         require ExtUtils::MakeMaker;
3811         my $answer = ExtUtils::MakeMaker::prompt(
3812 "Shall I follow them and prepend them to the queue
3813 of modules we are processing right now?", "yes");
3814         $follow = $answer =~ /^\s*y/i;
3815       } else {
3816         local($") = ", ";
3817         $CPAN::Frontend->
3818             myprint("  Ignoring dependencies on modules @prereq\n");
3819       }
3820       if ($follow) {
3821         CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
3822         return;
3823       }
3824     }
3825     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
3826     if (system($system) == 0) {
3827          $CPAN::Frontend->myprint("  $system -- OK\n");
3828          $self->{'make'} = "YES";
3829     } else {
3830          $self->{writemakefile} ||= "YES";
3831          $self->{'make'} = "NO";
3832          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3833     }
3834 }
3835
3836 #-> sub CPAN::Distribution::needs_prereq ;
3837 sub needs_prereq {
3838   my($self) = @_;
3839   return unless -f "Makefile"; # we cannot say much
3840   my $fh = FileHandle->new("<Makefile") or
3841       $CPAN::Frontend->mydie("Couldn't open Makefile: $!");
3842   local($/) = "\n";
3843
3844   #  A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
3845   #
3846   my(%p,@need);
3847   while (<$fh>) {
3848     last if /MakeMaker post_initialize section/;
3849     my($p) = m{^[\#]
3850                  \s+PREREQ_PM\s+=>\s+(.+)
3851                  }x;
3852     next unless $p;
3853     # warn "Found prereq expr[$p]";
3854
3855     #  Regexp modified by A.Speer to remember actual version of file
3856     #  PREREQ_PM hash key wants, then add to
3857     while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
3858       # In case a prereq is mentioned twice, complain.
3859       if ( defined $p{$1} ) {
3860         warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
3861       }
3862       $p{$1} = $2;
3863     }
3864     last;
3865   }
3866  NEED: while (my($module, $need_version) = each %p) {
3867     my $mo = $CPAN::META->instance("CPAN::Module",$module);
3868     # we were too demanding:
3869     # next if $mo->uptodate;
3870
3871     # We only want to install prereqs if either they're not installed
3872     # or if the installed version is too old. We cannot omit this
3873     # check, because if 'force' is in effect, nobody else will check.
3874     {
3875       local($^W) = 0;
3876       if (
3877           defined $mo->inst_file &&
3878           ! CPAN::Version->vgt($need_version, $mo->inst_version)
3879          ){
3880         CPAN->debug(sprintf "inst_file[%s]inst_version[%s]need_version[%s]",
3881                     $mo->inst_file,
3882                     $mo->inst_version,
3883                     CPAN::Version->readable($need_version)
3884                    );
3885         next NEED;
3886       }
3887     }
3888
3889     if ($self->{have_sponsored}{$module}++){
3890       # We have already sponsored it and for some reason it's still
3891       # not available. So we do nothing. Or what should we do?
3892       # if we push it again, we have a potential infinite loop
3893       next;
3894     }
3895     push @need, $module;
3896   }
3897   return @need;
3898 }
3899
3900 #-> sub CPAN::Distribution::test ;
3901 sub test {
3902     my($self) = @_;
3903     $self->make;
3904     return if $CPAN::Signal;
3905     $CPAN::Frontend->myprint("Running make test\n");
3906   EXCUSE: {
3907         my @e;
3908         exists $self->{'make'} or push @e,
3909         "Make had some problems, maybe interrupted? Won't test";
3910
3911         exists $self->{'make'} and
3912             $self->{'make'} eq 'NO' and
3913                 push @e, "Oops, make had returned bad status";
3914
3915         exists $self->{'build_dir'} or push @e, "Has no own directory";
3916         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3917     }
3918     chdir $self->{'build_dir'} or
3919         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3920     $self->debug("Changed directory to $self->{'build_dir'}")
3921         if $CPAN::DEBUG;
3922
3923     if ($^O eq 'MacOS') {
3924         ExtUtils::MM_MacOS::make_test($self);
3925         return;
3926     }
3927
3928     my $system = join " ", $CPAN::Config->{'make'}, "test";
3929     if (system($system) == 0) {
3930          $CPAN::Frontend->myprint("  $system -- OK\n");
3931          $self->{'make_test'} = "YES";
3932     } else {
3933          $self->{'make_test'} = "NO";
3934          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
3935     }
3936 }
3937
3938 #-> sub CPAN::Distribution::clean ;
3939 sub clean {
3940     my($self) = @_;
3941     $CPAN::Frontend->myprint("Running make clean\n");
3942   EXCUSE: {
3943         my @e;
3944         exists $self->{'build_dir'} or push @e, "Has no own directory";
3945         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3946     }
3947     chdir $self->{'build_dir'} or
3948         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3949     $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
3950
3951     if ($^O eq 'MacOS') {
3952         ExtUtils::MM_MacOS::make_clean($self);
3953         return;
3954     }
3955
3956     my $system = join " ", $CPAN::Config->{'make'}, "clean";
3957     if (system($system) == 0) {
3958         $CPAN::Frontend->myprint("  $system -- OK\n");
3959         $self->force;
3960     } else {
3961         # Hmmm, what to do if make clean failed?
3962     }
3963 }
3964
3965 #-> sub CPAN::Distribution::install ;
3966 sub install {
3967     my($self) = @_;
3968     $self->test;
3969     return if $CPAN::Signal;
3970     $CPAN::Frontend->myprint("Running make install\n");
3971   EXCUSE: {
3972         my @e;
3973         exists $self->{'build_dir'} or push @e, "Has no own directory";
3974
3975         exists $self->{'make'} or push @e,
3976         "Make had some problems, maybe interrupted? Won't install";
3977
3978         exists $self->{'make'} and
3979             $self->{'make'} eq 'NO' and
3980                 push @e, "Oops, make had returned bad status";
3981
3982         push @e, "make test had returned bad status, ".
3983             "won't install without force"
3984             if exists $self->{'make_test'} and
3985             $self->{'make_test'} eq 'NO' and
3986             ! $self->{'force_update'};
3987
3988         exists $self->{'install'} and push @e,
3989         $self->{'install'} eq "YES" ?
3990             "Already done" : "Already tried without success";
3991
3992         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
3993     }
3994     chdir $self->{'build_dir'} or
3995         Carp::croak("Couldn't chdir to $self->{'build_dir'}");
3996     $self->debug("Changed directory to $self->{'build_dir'}")
3997         if $CPAN::DEBUG;
3998
3999     if ($^O eq 'MacOS') {
4000         ExtUtils::MM_MacOS::make_install($self);
4001         return;
4002     }
4003
4004     my $system = join(" ", $CPAN::Config->{'make'},
4005                       "install", $CPAN::Config->{make_install_arg});
4006     my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4007     my($pipe) = FileHandle->new("$system $stderr |");
4008     my($makeout) = "";
4009     while (<$pipe>){
4010         $CPAN::Frontend->myprint($_);
4011         $makeout .= $_;
4012     }
4013     $pipe->close;
4014     if ($?==0) {
4015          $CPAN::Frontend->myprint("  $system -- OK\n");
4016          return $self->{'install'} = "YES";
4017     } else {
4018          $self->{'install'} = "NO";
4019          $CPAN::Frontend->myprint("  $system -- NOT OK\n");
4020          if ($makeout =~ /permission/s && $> > 0) {
4021              $CPAN::Frontend->myprint(qq{    You may have to su }.
4022                                       qq{to root to install the package\n});
4023          }
4024     }
4025 }
4026
4027 #-> sub CPAN::Distribution::dir ;
4028 sub dir {
4029     shift->{'build_dir'};
4030 }
4031
4032 package CPAN::Bundle;
4033
4034 #-> sub CPAN::Bundle::as_string ;
4035 sub as_string {
4036     my($self) = @_;
4037     $self->contains;
4038     # following line must be "=", not "||=" because we have a moving target
4039     $self->{INST_VERSION} = $self->inst_version; # %vd already applied
4040     return $self->SUPER::as_string;
4041 }
4042
4043 #-> sub CPAN::Bundle::contains ;
4044 sub contains {
4045   my($self) = @_;
4046   my($parsefile) = $self->inst_file;
4047   my($id) = $self->id;
4048   $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
4049   unless ($parsefile) {
4050     # Try to get at it in the cpan directory
4051     $self->debug("no parsefile") if $CPAN::DEBUG;
4052     Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
4053     my $dist = $CPAN::META->instance('CPAN::Distribution',
4054                                      $self->{CPAN_FILE});
4055     $dist->get;
4056     $self->debug($dist->as_string) if $CPAN::DEBUG;
4057     my($todir) = $CPAN::Config->{'cpan_home'};
4058     my(@me,$from,$to,$me);
4059     @me = split /::/, $self->id;
4060     $me[-1] .= ".pm";
4061     $me = MM->catfile(@me);
4062     $from = $self->find_bundle_file($dist->{'build_dir'},$me);
4063     $to = MM->catfile($todir,$me);
4064     File::Path::mkpath(File::Basename::dirname($to));
4065     File::Copy::copy($from, $to)
4066         or Carp::confess("Couldn't copy $from to $to: $!");
4067     $parsefile = $to;
4068   }
4069   my @result;
4070   my $fh = FileHandle->new;
4071   local $/ = "\n";
4072   open($fh,$parsefile) or die "Could not open '$parsefile': $!";
4073   my $in_cont = 0;
4074   $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
4075   while (<$fh>) {
4076     $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4077         m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4078     next unless $in_cont;
4079     next if /^=/;
4080     s/\#.*//;
4081     next if /^\s+$/;
4082     chomp;
4083     push @result, (split " ", $_, 2)[0];
4084   }
4085   close $fh;
4086   delete $self->{STATUS};
4087   $self->{CONTAINS} = join ", ", @result;
4088   $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4089   unless (@result) {
4090     $CPAN::Frontend->mywarn(qq{
4091 The bundle file "$parsefile" may be a broken
4092 bundlefile. It seems not to contain any bundle definition.
4093 Please check the file and if it is bogus, please delete it.
4094 Sorry for the inconvenience.
4095 });
4096   }
4097   @result;
4098 }
4099
4100 #-> sub CPAN::Bundle::find_bundle_file
4101 sub find_bundle_file {
4102     my($self,$where,$what) = @_;
4103     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
4104 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
4105 ###    my $bu = MM->catfile($where,$what);
4106 ###    return $bu if -f $bu;
4107     my $manifest = MM->catfile($where,"MANIFEST");
4108     unless (-f $manifest) {
4109         require ExtUtils::Manifest;
4110         my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
4111         my $cwd = CPAN->$getcwd();
4112         chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
4113         ExtUtils::Manifest::mkmanifest();
4114         chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
4115     }
4116     my $fh = FileHandle->new($manifest)
4117         or Carp::croak("Couldn't open $manifest: $!");
4118     local($/) = "\n";
4119     my $what2 = $what;
4120     if ($^O eq 'MacOS') {
4121       $what =~ s/^://;
4122       $what2 =~ tr|:|/|;
4123       $what2 =~ s/:Bundle://;
4124       $what2 =~ tr|:|/|;
4125     } else {
4126         $what2 =~ s|Bundle[/\\]||;
4127     }
4128     my $bu;
4129     while (<$fh>) {
4130         next if /^\s*\#/;
4131         my($file) = /(\S+)/;
4132         if ($file =~ m|\Q$what\E$|) {
4133             $bu = $file;
4134             # return MM->catfile($where,$bu); # bad
4135             last;
4136         }
4137         # retry if she managed to
4138         # have no Bundle directory
4139         $bu = $file if $file =~ m|\Q$what2\E$|;
4140     }
4141     $bu =~ tr|/|:| if $^O eq 'MacOS';
4142     return MM->catfile($where, $bu) if $bu;
4143     Carp::croak("Couldn't find a Bundle file in $where");
4144 }
4145
4146 #-> sub CPAN::Bundle::inst_file ;
4147 sub inst_file {
4148     my($self) = @_;
4149     my($me,$inst_file);
4150     ($me = $self->id) =~ s/.*://;
4151 ##    my(@me,$inst_file);
4152 ##    @me = split /::/, $self->id;
4153 ##    $me[-1] .= ".pm";
4154     $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
4155                                       "Bundle", "$me.pm");
4156 ##                                    "Bundle", @me);
4157     return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4158 #    $inst_file =
4159     $self->SUPER::inst_file;
4160 #    return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
4161 #    return $self->{'INST_FILE'}; # even if undefined?
4162 }
4163
4164 #-> sub CPAN::Bundle::rematein ;
4165 sub rematein {
4166     my($self,$meth) = @_;
4167     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
4168     my($id) = $self->id;
4169     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
4170         unless $self->inst_file || $self->{CPAN_FILE};
4171     my($s,%fail);
4172     for $s ($self->contains) {
4173         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
4174             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
4175         if ($type eq 'CPAN::Distribution') {
4176             $CPAN::Frontend->mywarn(qq{
4177 The Bundle }.$self->id.qq{ contains
4178 explicitly a file $s.
4179 });
4180             sleep 3;
4181         }
4182         # possibly noisy action:
4183         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
4184         my $obj = $CPAN::META->instance($type,$s);
4185         $obj->$meth();
4186         if ($obj->isa(CPAN::Bundle)
4187             &&
4188             exists $obj->{install_failed}
4189             &&
4190             ref($obj->{install_failed}) eq "HASH"
4191            ) {
4192           for (keys %{$obj->{install_failed}}) {
4193             $self->{install_failed}{$_} = undef; # propagate faiure up
4194                                                  # to me in a
4195                                                  # recursive call
4196             $fail{$s} = 1; # the bundle itself may have succeeded but
4197                            # not all children
4198           }
4199         } else {
4200           my $success;
4201           $success = $obj->can("uptodate") ? $obj->uptodate : 0;
4202           $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
4203           if ($success) {
4204             delete $self->{install_failed}{$s};
4205           } else {
4206             $fail{$s} = 1;
4207           }
4208         }
4209     }
4210
4211     # recap with less noise
4212     if ( $meth eq "install" ) {
4213         if (%fail) {
4214             require Text::Wrap;
4215             my $raw = sprintf(qq{Bundle summary:
4216 The following items in bundle %s had installation problems:},
4217                               $self->id
4218                              );
4219             $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
4220             $CPAN::Frontend->myprint("\n");
4221             my $paragraph = "";
4222             my %reported;
4223             for $s ($self->contains) {
4224               if ($fail{$s}){
4225                 $paragraph .= "$s ";
4226                 $self->{install_failed}{$s} = undef;
4227                 $reported{$s} = undef;
4228               }
4229             }
4230             my $report_propagated;
4231             for $s (sort keys %{$self->{install_failed}}) {
4232               next if exists $reported{$s};
4233               $paragraph .= "and the following items had problems
4234 during recursive bundle calls: " unless $report_propagated++;
4235               $paragraph .= "$s ";
4236             }
4237             $CPAN::Frontend->myprint(Text::Wrap::fill("  ","  ",$paragraph));
4238             $CPAN::Frontend->myprint("\n");
4239         } else {
4240             $self->{'install'} = 'YES';
4241         }
4242     }
4243 }
4244
4245 #sub CPAN::Bundle::xs_file
4246 sub xs_file {
4247     # If a bundle contains another that contains an xs_file we have
4248     # here, we just don't bother I suppose
4249     return 0;
4250 }
4251
4252 #-> sub CPAN::Bundle::force ;
4253 sub force   { shift->rematein('force',@_); }
4254 #-> sub CPAN::Bundle::get ;
4255 sub get     { shift->rematein('get',@_); }
4256 #-> sub CPAN::Bundle::make ;
4257 sub make    { shift->rematein('make',@_); }
4258 #-> sub CPAN::Bundle::test ;
4259 sub test    { shift->rematein('test',@_); }
4260 #-> sub CPAN::Bundle::install ;
4261 sub install {
4262   my $self = shift;
4263   $self->rematein('install',@_);
4264 }
4265 #-> sub CPAN::Bundle::clean ;
4266 sub clean   { shift->rematein('clean',@_); }
4267
4268 #-> sub CPAN::Bundle::readme ;
4269 sub readme  {
4270     my($self) = @_;
4271     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
4272 No File found for bundle } . $self->id . qq{\n}), return;
4273     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
4274     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
4275 }
4276
4277 package CPAN::Module;
4278
4279 #-> sub CPAN::Module::as_glimpse ;
4280 sub as_glimpse {
4281     my($self) = @_;
4282     my(@m);
4283     my $class = ref($self);
4284     $class =~ s/^CPAN:://;
4285     push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
4286                      $self->cpan_file);
4287     join "", @m;
4288 }
4289
4290 #-> sub CPAN::Module::as_string ;
4291 sub as_string {
4292     my($self) = @_;
4293     my(@m);
4294     CPAN->debug($self) if $CPAN::DEBUG;
4295     my $class = ref($self);
4296     $class =~ s/^CPAN:://;
4297     local($^W) = 0;
4298     push @m, $class, " id = $self->{ID}\n";
4299     my $sprintf = "    %-12s %s\n";
4300     push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
4301         if $self->{description};
4302     my $sprintf2 = "    %-12s %s (%s)\n";
4303     my($userid);
4304     if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
4305         my $author;
4306         if ($author = CPAN::Shell->expand('Author',$userid)) {
4307           my $email = "";
4308           my $m; # old perls
4309           if ($m = $author->email) {
4310             $email = " <$m>";
4311           }
4312           push @m, sprintf(
4313                            $sprintf2,
4314                            'CPAN_USERID',
4315                            $userid,
4316                            $author->fullname . $email
4317                           );
4318         }
4319     }
4320     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) # %vd not needed
4321         if $self->{CPAN_VERSION}; # %vd not needed
4322     push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
4323         if $self->{CPAN_FILE};
4324     my $sprintf3 = "    %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
4325     my(%statd,%stats,%statl,%stati);
4326     @statd{qw,? i c a b R M S,} = qw,unknown idea
4327         pre-alpha alpha beta released mature standard,;
4328     @stats{qw,? m d u n,}       = qw,unknown mailing-list
4329         developer comp.lang.perl.* none,;
4330     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
4331     @stati{qw,? f r O h,}         = qw,unknown functions
4332         references+ties object-oriented hybrid,;
4333     $statd{' '} = 'unknown';
4334     $stats{' '} = 'unknown';
4335     $statl{' '} = 'unknown';
4336     $stati{' '} = 'unknown';
4337     push @m, sprintf(
4338                      $sprintf3,
4339                      'DSLI_STATUS',
4340                      $self->{statd},
4341                      $self->{stats},
4342                      $self->{statl},
4343                      $self->{stati},
4344                      $statd{$self->{statd}},
4345                      $stats{$self->{stats}},
4346                      $statl{$self->{statl}},
4347                      $stati{$self->{stati}}
4348                     ) if $self->{statd};
4349     my $local_file = $self->inst_file;
4350     if ($local_file) {
4351       $self->{MANPAGE} ||= $self->manpage_headline($local_file);
4352     }
4353     my($item);
4354     for $item (qw/MANPAGE CONTAINS/) {
4355         push @m, sprintf($sprintf, $item, $self->{$item})
4356             if exists $self->{$item};
4357     }
4358     push @m, sprintf($sprintf, 'INST_FILE',
4359                      $local_file || "(not installed)");
4360     push @m, sprintf($sprintf, 'INST_VERSION',
4361                      $self->inst_version) if $local_file; #%vd already applied
4362     join "", @m, "\n";
4363 }
4364
4365 sub manpage_headline {
4366   my($self,$local_file) = @_;
4367   my(@local_file) = $local_file;
4368   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
4369   push @local_file, $local_file;
4370   my(@result,$locf);
4371   for $locf (@local_file) {
4372     next unless -f $locf;
4373     my $fh = FileHandle->new($locf)
4374         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
4375     my $inpod = 0;
4376     local $/ = "\n";
4377     while (<$fh>) {
4378       $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
4379           m/^=head1\s+NAME/ ? 1 : $inpod;
4380       next unless $inpod;
4381       next if /^=/;
4382       next if /^\s+$/;
4383       chomp;
4384       push @result, $_;
4385     }
4386     close $fh;
4387     last if @result;
4388   }
4389   join " ", @result;
4390 }
4391
4392 #-> sub CPAN::Module::cpan_file ;
4393 sub cpan_file    {
4394     my $self = shift;
4395     CPAN->debug($self->id) if $CPAN::DEBUG;
4396     unless (defined $self->{'CPAN_FILE'}) {
4397         CPAN::Index->reload;
4398     }
4399     if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
4400         return $self->{'CPAN_FILE'};
4401     } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
4402         my $fullname = $CPAN::META->instance(CPAN::Author,
4403                                       $self->{'userid'})->fullname;
4404         my $email = $CPAN::META->instance(CPAN::Author,
4405                                       $self->{'userid'})->email;
4406         unless (defined $fullname && defined $email) {
4407             return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
4408         }
4409         return "Contact Author $fullname <$email>";
4410     } else {
4411         return "N/A";
4412     }
4413 }
4414
4415 *name = \&cpan_file;
4416
4417 #-> sub CPAN::Module::cpan_version ;
4418 sub cpan_version {
4419     my $self = shift;
4420     $self->{'CPAN_VERSION'} = 'undef'
4421         unless defined $self->{'CPAN_VERSION'}; # I believe this is
4422                                                 # always a bug in the
4423                                                 # index and should be
4424                                                 # reported as such,
4425                                                 # but usually I find
4426                                                 # out such an error
4427                                                 # and do not want to
4428                                                 # provoke too many
4429                                                 # bugreports
4430     $self->{'CPAN_VERSION'}; # %vd not needed
4431 }
4432
4433 #-> sub CPAN::Module::force ;
4434 sub force {
4435     my($self) = @_;
4436     $self->{'force_update'}++;
4437 }
4438
4439 #-> sub CPAN::Module::rematein ;
4440 sub rematein {
4441     my($self,$meth) = @_;
4442     $self->debug($self->id) if $CPAN::DEBUG;
4443     my $cpan_file = $self->cpan_file;
4444     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
4445       $CPAN::Frontend->mywarn(sprintf qq{
4446   The module %s isn\'t available on CPAN.
4447
4448   Either the module has not yet been uploaded to CPAN, or it is
4449   temporary unavailable. Please contact the author to find out
4450   more about the status. Try ``i %s''.
4451 },
4452                               $self->id,
4453                               $self->id,
4454                              );
4455       return;
4456     }
4457     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
4458     $pack->called_for($self->id);
4459     $pack->force if exists $self->{'force_update'};
4460     $pack->$meth();
4461     delete $self->{'force_update'};
4462 }
4463
4464 #-> sub CPAN::Module::readme ;
4465 sub readme { shift->rematein('readme') }
4466 #-> sub CPAN::Module::look ;
4467 sub look { shift->rematein('look') }
4468 #-> sub CPAN::Module::cvs_import ;
4469 sub cvs_import { shift->rematein('cvs_import') }
4470 #-> sub CPAN::Module::get ;
4471 sub get    { shift->rematein('get',@_); }
4472 #-> sub CPAN::Module::make ;
4473 sub make   { shift->rematein('make') }
4474 #-> sub CPAN::Module::test ;
4475 sub test   { shift->rematein('test') }
4476 #-> sub CPAN::Module::uptodate ;
4477 sub uptodate {
4478     my($self) = @_;
4479     my($latest) = $self->cpan_version; # %vd not needed
4480     $latest ||= 0;
4481     my($inst_file) = $self->inst_file;
4482     my($have) = 0;
4483     if (defined $inst_file) {
4484         $have = $self->inst_version; # %vd already applied
4485     }
4486     local($^W)=0;
4487     if ($inst_file
4488         &&
4489         ! CPAN::Version->vgt($latest, $have)
4490        ) {
4491       return 1;
4492     }
4493     return;
4494 }
4495 #-> sub CPAN::Module::install ;
4496 sub install {
4497     my($self) = @_;
4498     my($doit) = 0;
4499     if ($self->uptodate
4500         &&
4501         not exists $self->{'force_update'}
4502        ) {
4503         $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
4504     } else {
4505         $doit = 1;
4506     }
4507     $self->rematein('install') if $doit;
4508 }
4509 #-> sub CPAN::Module::clean ;
4510 sub clean  { shift->rematein('clean') }
4511
4512 #-> sub CPAN::Module::inst_file ;
4513 sub inst_file {
4514     my($self) = @_;
4515     my($dir,@packpath);
4516     @packpath = split /::/, $self->{ID};
4517     $packpath[-1] .= ".pm";
4518     foreach $dir (@INC) {
4519         my $pmfile = MM->catfile($dir,@packpath);
4520         if (-f $pmfile){
4521             return $pmfile;
4522         }
4523     }
4524     return;
4525 }
4526
4527 #-> sub CPAN::Module::xs_file ;
4528 sub xs_file {
4529     my($self) = @_;
4530     my($dir,@packpath);
4531     @packpath = split /::/, $self->{ID};
4532     push @packpath, $packpath[-1];
4533     $packpath[-1] .= "." . $Config::Config{'dlext'};
4534     foreach $dir (@INC) {
4535         my $xsfile = MM->catfile($dir,'auto',@packpath);
4536         if (-f $xsfile){
4537             return $xsfile;
4538         }
4539     }
4540     return;
4541 }
4542
4543 #-> sub CPAN::Module::inst_version ;
4544 sub inst_version {
4545     my($self) = @_;
4546     my $parsefile = $self->inst_file or return;
4547     local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
4548     my $have;
4549     # local($SIG{__WARN__}) =  sub { warn "1. have[$have]"; };
4550
4551     # there was a bug in 5.6.0 that let lots of unini warnings out of
4552     # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
4553     # this workaround after 5.6.1 is out.
4554     local($SIG{__WARN__}) =  sub { my $w = shift;
4555                                    return if $w =~ /uninitialized/i;
4556                                    warn $w;
4557                                  };
4558     $have = MM->parse_version($parsefile) || "undef";
4559     $have =~ s/^ //; # since the %vd hack these two lines here are needed
4560     $have =~ s/ $//; # trailing whitespace happens all the time
4561
4562     # local($SIG{__WARN__}) =  sub { warn "2. have[$have]"; };
4563
4564     # Should %vd hack happen here? Must we not maintain the original
4565     # version string until it is used? Do we for printing make it
4566     # human readable? Or do we maintain it in a human readable form?
4567     # "v1.0.2"?
4568
4569     # OK, let's discuss the pros and cons:
4570     #-maintain it as string with leading v:
4571     # read index files     do nothing
4572     # compare it           use utility for compare
4573     # print it             do nothing
4574
4575     # maintain it as what is is
4576     # read index files     convert
4577     # compare it           use utility because there's still a ">" vs "gt" issue
4578     # print it             use CPAN::Version for print
4579
4580     # Seems cleaner to hold it in memory as a string starting with a "v"
4581
4582     $have = CPAN::Version->readable($have);
4583     $have =~ s/\s*//g; # stringify to float around floating point issues
4584     $have; # no stringify needed, \s* above matches always
4585 }
4586
4587 package CPAN::Tarzip;
4588
4589 # CPAN::Tarzip::gzip
4590 sub gzip {
4591   my($class,$read,$write) = @_;
4592   if ($CPAN::META->has_inst("Compress::Zlib")) {
4593     my($buffer,$fhw);
4594     $fhw = FileHandle->new($read)
4595         or $CPAN::Frontend->mydie("Could not open $read: $!");
4596     my $gz = Compress::Zlib::gzopen($write, "wb")