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