This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[ID 20000324.040] minor fix to perlhpux.pod
[perl5.git] / lib / CPAN.pm
CommitLineData
5f05dabc 1package CPAN;
36263cb3
GS
2use vars qw{$Try_autoload
3 $Revision
c356248b 4 $META $Signal $Cwd $End
de34a54b 5 $Suppress_readline
09d9d230 6 $Frontend $Defaultsite
36263cb3 7 }; #};
5f05dabc 8
11860a17 9$VERSION = '1.56';
5f05dabc 10
de34a54b 11# $Id: CPAN.pm,v 1.303 2000/08/01 15:57:15 k Exp $
5f05dabc 12
c356248b
AK
13# only used during development:
14$Revision = "";
de34a54b 15# $Revision = "[".substr(q$Revision: 1.303 $, 10)."]";
5f05dabc
PP
16
17use Carp ();
18use Config ();
19use Cwd ();
20use DirHandle;
21use Exporter ();
2e2b7522 22use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
5f05dabc 23use File::Basename ();
10b2abe6 24use File::Copy ();
5f05dabc
PP
25use File::Find;
26use File::Path ();
da199366 27use FileHandle ();
5f05dabc 28use Safe ();
10b2abe6 29use Text::ParseWords ();
05454584 30use Text::Wrap;
f14b5cec 31use File::Spec;
de34a54b
JH
32no lib "."; # we need to run chdir all over and we would get at wrong
33 # libraries there
5f05dabc 34
5f05dabc
PP
35END { $End++; &cleanup; }
36
2e2b7522 37%CPAN::DEBUG = qw[
5f05dabc
PP
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
09d9d230 51 Tarzip 8192
2e2b7522 52];
5f05dabc
PP
53
54$CPAN::DEBUG ||= 0;
da199366 55$CPAN::Signal ||= 0;
c356248b 56$CPAN::Frontend ||= "CPAN::Shell";
09d9d230 57$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
5f05dabc
PP
58
59package CPAN;
de34a54b 60use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term);
5f05dabc
PP
61use strict qw(vars);
62
2e2b7522 63@CPAN::ISA = qw(CPAN::Debug Exporter);
5f05dabc 64
55e314ee 65@EXPORT = qw(
911a92db 66 autobundle bundle expand force get cvs_import
da199366
AK
67 install make readme recompile shell test clean
68 );
5f05dabc 69
55e314ee
AK
70#-> sub CPAN::AUTOLOAD ;
71sub AUTOLOAD {
72 my($l) = $AUTOLOAD;
73 $l =~ s/.*:://;
74 my(%EXPORT);
75 @EXPORT{@EXPORT} = '';
36263cb3 76 CPAN::Config->load unless $CPAN::Config_loaded++;
55e314ee
AK
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;
c356248b
AK
83# } else {
84# $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
55e314ee 85 }
c356248b
AK
86 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
87 qq{Type ? for help.
88});
55e314ee
AK
89 }
90}
91
92#-> sub CPAN::shell ;
93sub shell {
36263cb3 94 my($self) = @_;
911a92db 95 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
36263cb3 96 CPAN::Config->load unless $CPAN::Config_loaded++;
55e314ee
AK
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');
36263cb3
GS
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 }
911a92db
GS
118 # $term->OUT is autoflushed anyway
119 my $odef = select STDERR;
120 $| = 1;
121 select STDOUT;
122 $| = 1;
123 select $odef;
55e314ee
AK
124 }
125
126 no strict;
127 $META->checklock();
128 my $getcwd;
129 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
130 my $cwd = CPAN->$getcwd();
911a92db
GS
131 my $try_detect_readline;
132 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
55e314ee
AK
133 my $rl_avail = $Suppress_readline ? "suppressed" :
134 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
135 "available (try ``install Bundle::CPAN'')";
136
c356248b
AK
137 $CPAN::Frontend->myprint(
138 qq{
139cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
140ReadLine support $rl_avail
55e314ee 141
c356248b
AK
142}) unless $CPAN::Config->{'inhibit_startup_message'} ;
143 my($continuation) = "";
55e314ee
AK
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 }
c356248b 152 $_ = "$continuation$_" if $continuation;
55e314ee
AK
153 s/^\s+//;
154 next if /^$/;
2e2b7522 155 $_ = 'h' if /^\s*\?/;
09d9d230 156 if (/^(?:q(?:uit)?|bye|exit)$/i) {
c356248b
AK
157 last;
158 } elsif (s/\\$//s) {
159 chomp;
160 $continuation = $_;
161 $prompt = " > ";
162 } elsif (/^\!/) {
55e314ee
AK
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 $@;
c356248b
AK
171 $continuation = "";
172 $prompt = "cpan> ";
55e314ee
AK
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 $@;
c356248b
AK
185 chdir $cwd;
186 $CPAN::Frontend->myprint("\n");
187 $continuation = "";
188 $prompt = "cpan> ";
55e314ee
AK
189 }
190 } continue {
09d9d230 191 $Signal=0;
36263cb3
GS
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;
911a92db
GS
202 $CPAN::Frontend->myprint("\n$redef subroutines in ".
203 "Term::ReadLine redefined\n");
36263cb3
GS
204 goto &shell;
205 }
206 }
55e314ee
AK
207 }
208}
209
210package CPAN::CacheMgr;
c356248b 211@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
55e314ee
AK
212use File::Find;
213
214package CPAN::Config;
215import ExtUtils::MakeMaker 'neatvalue';
216use 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
224package CPAN::FTP;
c356248b 225use vars qw($Ua $Thesite $Themethod);
55e314ee
AK
226@CPAN::FTP::ISA = qw(CPAN::Debug);
227
228package CPAN::Complete;
229@CPAN::Complete::ISA = qw(CPAN::Debug);
230
231package CPAN::Index;
232use vars qw($last_time $date_of_03);
233@CPAN::Index::ISA = qw(CPAN::Debug);
234$last_time ||= 0;
235$date_of_03 ||= 0;
236
237package CPAN::InfoObj;
238@CPAN::InfoObj::ISA = qw(CPAN::Debug);
239
240package CPAN::Author;
241@CPAN::Author::ISA = qw(CPAN::InfoObj);
242
243package CPAN::Distribution;
244@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
245
246package CPAN::Bundle;
247@CPAN::Bundle::ISA = qw(CPAN::Module);
248
249package CPAN::Module;
250@CPAN::Module::ISA = qw(CPAN::InfoObj);
10b2abe6 251
55e314ee
AK
252package CPAN::Shell;
253use vars qw($AUTOLOAD $redef @ISA);
254@CPAN::Shell::ISA = qw(CPAN::Debug);
255
256#-> sub CPAN::Shell::AUTOLOAD ;
257sub AUTOLOAD {
258 my($autoload) = $AUTOLOAD;
c356248b 259 my $class = shift(@_);
09d9d230 260 # warn "autoload[$autoload] class[$class]";
55e314ee
AK
261 $autoload =~ s/.*:://;
262 if ($autoload =~ /^w/) {
263 if ($CPAN::META->has_inst('CPAN::WAIT')) {
c356248b 264 CPAN::WAIT->$autoload(@_);
55e314ee 265 } else {
c356248b 266 $CPAN::Frontend->mywarn(qq{
55e314ee
AK
267Commands starting with "w" require CPAN::WAIT to be installed.
268Please consider installing CPAN::WAIT to use the fulltext index.
f610777f 269For this you just need to type
55e314ee 270 install CPAN::WAIT
c356248b 271});
55e314ee
AK
272 }
273 } else {
274 my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
275 if ($ok) {
276 goto &$AUTOLOAD;
c356248b
AK
277# } else {
278# $CPAN::Frontend->mywarn("Could not autoload $autoload");
55e314ee 279 }
c356248b
AK
280 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
281 qq{Type ? for help.
282});
55e314ee
AK
283 }
284}
285
286#-> CPAN::Shell::try_dot_al
287sub 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 {
11860a17 298 $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|s;
f610777f 299 $name = undef unless (-r $name);
55e314ee
AK
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 {
11860a17 314 if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
55e314ee
AK
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 {
2e2b7522 325
36263cb3 326 $ok = 1;
2e2b7522 327
55e314ee
AK
328 }
329 $@ = $save;
c356248b 330# my $lm = Carp::longmess();
55e314ee
AK
331# warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
332 return $ok;
333}
334
55e314ee
AK
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
343if ($CPAN::Try_autoload) {
36263cb3 344 my $p;
c356248b 345 for $p (qw(
55e314ee
AK
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
09d9d230
A
354package CPAN::Tarzip;
355use vars qw($AUTOLOAD @ISA);
356@CPAN::Tarzip::ISA = qw(CPAN::Debug);
357
358package CPAN::Queue;
f610777f 359
f14b5cec
JH
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
f610777f
A
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
f14b5cec
JH
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
f610777f
A
404
405use vars qw{ @All };
406
09d9d230
A
407sub new {
408 my($class,$mod) = @_;
f610777f
A
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;
f610777f
A
414}
415
416sub first {
417 my $obj = $All[0];
418 $obj->{mod};
419}
420
421sub 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
432sub 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(
445qq{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
456sub 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
464sub 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]";
09d9d230 469}
55e314ee 470
36263cb3
GS
471sub nullify_queue {
472 @All = ();
473}
474
475
476
55e314ee
AK
477package CPAN;
478
2e2b7522 479$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
55e314ee 480
55e314ee
AK
4811;
482
483# __END__ # uncomment this and AutoSplit version 1.01 will split it
10b2abe6
CS
484
485#-> sub CPAN::autobundle ;
5f05dabc 486sub autobundle;
10b2abe6 487#-> sub CPAN::bundle ;
5f05dabc 488sub bundle;
10b2abe6 489#-> sub CPAN::expand ;
5f05dabc 490sub expand;
10b2abe6 491#-> sub CPAN::force ;
5f05dabc 492sub force;
10b2abe6 493#-> sub CPAN::install ;
5f05dabc 494sub install;
10b2abe6 495#-> sub CPAN::make ;
5f05dabc 496sub make;
10b2abe6 497#-> sub CPAN::clean ;
5f05dabc 498sub clean;
10b2abe6 499#-> sub CPAN::test ;
5f05dabc
PP
500sub test;
501
10b2abe6 502#-> sub CPAN::all ;
36263cb3 503sub all_objects {
5f05dabc 504 my($mgr,$class) = @_;
36263cb3 505 CPAN::Config->load unless $CPAN::Config_loaded++;
5f05dabc
PP
506 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
507 CPAN::Index->reload;
508 values %{ $META->{$class} };
509}
36263cb3 510*all = \&all_objects;
5f05dabc
PP
511
512# Called by shell, not in batch mode. Not clean XXX
10b2abe6 513#-> sub CPAN::checklock ;
5f05dabc
PP
514sub checklock {
515 my($self) = @_;
c356248b 516 my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
5f05dabc 517 if (-f $lockfile && -M _ > 0) {
da199366 518 my $fh = FileHandle->new($lockfile);
5f05dabc
PP
519 my $other = <$fh>;
520 $fh->close;
521 if (defined $other && $other) {
522 chomp $other;
523 return if $$==$other; # should never happen
c356248b
AK
524 $CPAN::Frontend->mywarn(
525 qq{
526There seems to be running another CPAN process ($other). Contacting...
527});
5f05dabc 528 if (kill 0, $other) {
c356248b
AK
529 $CPAN::Frontend->mydie(qq{Other job is running.
530You may want to kill it and delete the lockfile, maybe. On UNIX try:
531 kill $other
532 rm $lockfile
533});
5f05dabc 534 } elsif (-w $lockfile) {
e50380aa 535 my($ans) =
5f05dabc 536 ExtUtils::MakeMaker::prompt
05454584
AK
537 (qq{Other job not responding. Shall I overwrite }.
538 qq{the lockfile? (Y/N)},"y");
c356248b
AK
539 $CPAN::Frontend->myexit("Ok, bye\n")
540 unless $ans =~ /^y/i;
5f05dabc
PP
541 } else {
542 Carp::croak(
05454584
AK
543 qq{Lockfile $lockfile not writeable by you. }.
544 qq{Cannot proceed.\n}.
5f05dabc
PP
545 qq{ On UNIX try:\n}.
546 qq{ rm $lockfile\n}.
547 qq{ and then rerun us.\n}
548 );
549 }
550 }
551 }
36263cb3
GS
552 my $dotcpan = $CPAN::Config->{cpan_home};
553 eval { File::Path::mkpath($dotcpan);};
554 if ($@) {
555 # A special case at least for Jarkko.
556 my $firsterror = $@;
557 my $seconderror;
558 my $symlinkcpan;
559 if (-l $dotcpan) {
560 $symlinkcpan = readlink $dotcpan;
561 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
562 eval { File::Path::mkpath($symlinkcpan); };
563 if ($@) {
564 $seconderror = $@;
565 } else {
566 $CPAN::Frontend->mywarn(qq{
567Working directory $symlinkcpan created.
568});
569 }
570 }
571 unless (-d $dotcpan) {
572 my $diemess = qq{
573Your configuration suggests "$dotcpan" as your
574CPAN.pm working directory. I could not create this directory due
575to this error: $firsterror\n};
576 $diemess .= qq{
577As "$dotcpan" is a symlink to "$symlinkcpan",
578I tried to create that, but I failed with this error: $seconderror
579} if $seconderror;
580 $diemess .= qq{
581Please make sure the directory exists and is writable.
582};
583 $CPAN::Frontend->mydie($diemess);
584 }
585 }
5f05dabc 586 my $fh;
da199366 587 unless ($fh = FileHandle->new(">$lockfile")) {
911a92db 588 if ($! =~ /Permission/) {
5f05dabc 589 my $incc = $INC{'CPAN/Config.pm'};
05454584 590 my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
c356248b 591 $CPAN::Frontend->myprint(qq{
5f05dabc
PP
592
593Your configuration suggests that CPAN.pm should use a working
594directory of
595 $CPAN::Config->{cpan_home}
596Unfortunately we could not create the lock file
597 $lockfile
598due to permission problems.
599
600Please make sure that the configuration variable
601 \$CPAN::Config->{cpan_home}
602points to a directory where you can write a .lock file. You can set
603this variable in either
604 $incc
605or
606 $myincc
607
c356248b 608});
5f05dabc 609 }
c356248b 610 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
5f05dabc 611 }
c356248b 612 $fh->print($$, "\n");
5f05dabc
PP
613 $self->{LOCK} = $lockfile;
614 $fh->close;
c356248b 615 $SIG{'TERM'} = sub {
2e2b7522
GS
616 &cleanup;
617 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
c356248b 618 };
da199366 619 $SIG{'INT'} = sub {
09d9d230
A
620 # no blocks!!!
621 &cleanup if $Signal;
622 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
623 print "Caught SIGINT\n";
624 $Signal++;
da199366 625 };
911a92db
GS
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
5f05dabc 647 $SIG{'__DIE__'} = \&cleanup;
e50380aa 648 $self->debug("Signal handler set.") if $CPAN::DEBUG;
5f05dabc
PP
649}
650
10b2abe6 651#-> sub CPAN::DESTROY ;
5f05dabc
PP
652sub DESTROY {
653 &cleanup; # need an eval?
654}
655
55e314ee
AK
656#-> sub CPAN::cwd ;
657sub cwd {Cwd::cwd();}
658
659#-> sub CPAN::getcwd ;
660sub getcwd {Cwd::getcwd();}
661
10b2abe6 662#-> sub CPAN::exists ;
5f05dabc
PP
663sub exists {
664 my($mgr,$class,$id) = @_;
665 CPAN::Index->reload;
e50380aa 666 ### Carp::croak "exists called without class argument" unless $class;
5f05dabc
PP
667 $id ||= "";
668 exists $META->{$class}{$id};
669}
670
09d9d230
A
671#-> sub CPAN::delete ;
672sub delete {
673 my($mgr,$class,$id) = @_;
674 delete $META->{$class}{$id};
675}
676
de34a54b
JH
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
680sub 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
55e314ee
AK
714#-> sub CPAN::has_inst
715sub has_inst {
716 my($self,$mod,$message) = @_;
717 Carp::croak("CPAN->has_inst() called without an argument")
718 unless defined $mod;
de34a54b
JH
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;
55e314ee
AK
727 }
728 my $file = $mod;
c356248b 729 my $obj;
55e314ee
AK
730 $file =~ s|::|/|g;
731 $file =~ s|/|\\|g if $^O eq 'MSWin32';
732 $file .= ".pm";
c356248b 733 if ($INC{$file}) {
f14b5cec
JH
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
55e314ee 739 return 1;
55e314ee 740 } elsif (eval { require $file }) {
c356248b
AK
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
f14b5cec 745
c356248b
AK
746 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
747 if ($mod eq "CPAN::WAIT") {
748 push @CPAN::Shell::ISA, CPAN::WAIT;
749 }
55e314ee
AK
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
5f05dabc 756
55e314ee
AK
757};
758 sleep 2;
c356248b
AK
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;
f14b5cec
JH
766 } else {
767 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
05454584 768 }
55e314ee 769 return 0;
05454584
AK
770}
771
10b2abe6 772#-> sub CPAN::instance ;
5f05dabc
PP
773sub instance {
774 my($mgr,$class,$id) = @_;
775 CPAN::Index->reload;
5f05dabc
PP
776 $id ||= "";
777 $META->{$class}{$id} ||= $class->new(ID => $id );
778}
779
10b2abe6 780#-> sub CPAN::new ;
5f05dabc
PP
781sub new {
782 bless {}, shift;
783}
784
10b2abe6 785#-> sub CPAN::cleanup ;
5f05dabc 786sub cleanup {
2e2b7522
GS
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)';
5f05dabc 802 }
2e2b7522
GS
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");
5f05dabc
PP
811}
812
05454584 813package CPAN::CacheMgr;
5f05dabc 814
05454584
AK
815#-> sub CPAN::CacheMgr::as_string ;
816sub as_string {
817 eval { require Data::Dumper };
818 if ($@) {
819 return shift->SUPER::as_string;
5f05dabc 820 } else {
05454584 821 return Data::Dumper::Dumper(shift);
5f05dabc
PP
822 }
823}
824
05454584
AK
825#-> sub CPAN::CacheMgr::cachesize ;
826sub cachesize {
827 shift->{DU};
5f05dabc 828}
5f05dabc 829
09d9d230
A
830sub 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}
5f05dabc 845
05454584
AK
846#-> sub CPAN::CacheMgr::dir ;
847sub dir {
848 shift->{ID};
849}
850
851#-> sub CPAN::CacheMgr::entries ;
852sub entries {
853 my($self,$dir) = @_;
55e314ee 854 return unless defined $dir;
e50380aa 855 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
05454584 856 $dir ||= $self->{ID};
e50380aa
AK
857 my $getcwd;
858 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
55e314ee 859 my($cwd) = CPAN->$getcwd();
05454584 860 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
f14b5cec
JH
861 my $dh = DirHandle->new(File::Spec->curdir)
862 or Carp::croak("Couldn't opendir $dir: $!");
05454584
AK
863 my(@entries);
864 for ($dh->read) {
865 next if $_ eq "." || $_ eq "..";
866 if (-f $_) {
c356248b 867 push @entries, MM->catfile($dir,$_);
05454584 868 } elsif (-d _) {
c356248b 869 push @entries, MM->catdir($dir,$_);
5f05dabc 870 } else {
c356248b 871 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
5f05dabc 872 }
5f05dabc 873 }
05454584 874 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
e50380aa 875 sort { -M $b <=> -M $a} @entries;
5f05dabc
PP
876}
877
05454584
AK
878#-> sub CPAN::CacheMgr::disk_usage ;
879sub disk_usage {
880 my($self,$dir) = @_;
09d9d230
A
881 return if exists $self->{SIZE}{$dir};
882 return if $CPAN::Signal;
883 my($Du) = 0;
05454584
AK
884 find(
885 sub {
f14b5cec
JH
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($_);
911a92db 891 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
f14b5cec
JH
892 } else {
893 $Du += (-s _);
894 }
05454584
AK
895 },
896 $dir
897 );
09d9d230 898 return if $CPAN::Signal;
05454584
AK
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;
05454584 903 $self->{DU};
5f05dabc
PP
904}
905
05454584
AK
906#-> sub CPAN::CacheMgr::force_clean_cache ;
907sub force_clean_cache {
908 my($self,$dir) = @_;
09d9d230 909 return unless -e $dir;
05454584
AK
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};
5f05dabc
PP
915}
916
05454584
AK
917#-> sub CPAN::CacheMgr::new ;
918sub new {
919 my $class = shift;
e50380aa
AK
920 my $time = time;
921 my($debug,$t2);
922 $debug = "";
05454584
AK
923 my $self = {
924 ID => $CPAN::Config->{'build_dir'},
925 MAX => $CPAN::Config->{'build_cache'},
f610777f 926 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
05454584
AK
927 DU => 0
928 };
929 File::Path::mkpath($self->{ID});
930 my $dh = DirHandle->new($self->{ID});
931 bless $self, $class;
f610777f
A
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 ;
941sub 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';
09d9d230
A
946 $CPAN::Frontend->myprint(
947 sprintf("Scanning cache %s for sizes\n",
948 $self->{ID}));
f610777f 949 my $e;
09d9d230 950 for $e ($self->entries($self->{ID})) {
05454584 951 next if $e eq ".." || $e eq ".";
05454584 952 $self->disk_usage($e);
09d9d230 953 return if $CPAN::Signal;
5f05dabc 954 }
09d9d230 955 $self->tidyup;
5f05dabc
PP
956}
957
05454584
AK
958package CPAN::Debug;
959
960#-> sub CPAN::Debug::debug ;
961sub 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/.*:://;
55e314ee 968 $arg = "" unless defined $arg;
c356248b 969 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
05454584 970 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
55e314ee 971 if ($arg and ref $arg) {
05454584
AK
972 eval { require Data::Dumper };
973 if ($@) {
c356248b 974 $CPAN::Frontend->myprint($arg->as_string);
05454584 975 } else {
c356248b 976 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
5f05dabc
PP
977 }
978 } else {
c356248b 979 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
5f05dabc 980 }
05454584
AK
981 }
982}
983
984package CPAN::Config;
05454584
AK
985
986#-> sub CPAN::Config::edit ;
de34a54b 987# returns true on successful action
05454584
AK
988sub 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 {
de34a54b
JH
998 CPAN->debug("o[$o]");
999 if ($o =~ /list$/) {
05454584
AK
1000 $func = shift @args;
1001 $func ||= "";
de34a54b
JH
1002 CPAN->debug("func[$func]");
1003 my $changed;
05454584
AK
1004 # Let's avoid eval, it's easier to comprehend without.
1005 if ($func eq "push") {
1006 push @{$CPAN::Config->{$o}}, @args;
de34a54b 1007 $changed = 1;
05454584
AK
1008 } elsif ($func eq "pop") {
1009 pop @{$CPAN::Config->{$o}};
de34a54b 1010 $changed = 1;
05454584
AK
1011 } elsif ($func eq "shift") {
1012 shift @{$CPAN::Config->{$o}};
de34a54b 1013 $changed = 1;
05454584
AK
1014 } elsif ($func eq "unshift") {
1015 unshift @{$CPAN::Config->{$o}}, @args;
de34a54b 1016 $changed = 1;
05454584
AK
1017 } elsif ($func eq "splice") {
1018 splice @{$CPAN::Config->{$o}}, @args;
de34a54b 1019 $changed = 1;
05454584
AK
1020 } elsif (@args) {
1021 $CPAN::Config->{$o} = [@args];
de34a54b 1022 $changed = 1;
05454584 1023 } else {
c356248b
AK
1024 $CPAN::Frontend->myprint(
1025 join "",
1026 " $o ",
1027 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
1028 "\n"
05454584
AK
1029 );
1030 }
de34a54b
JH
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;
05454584
AK
1037 } else {
1038 $CPAN::Config->{$o} = $args[0] if defined $args[0];
c356248b
AK
1039 $CPAN::Frontend->myprint(" $o " .
1040 (defined $CPAN::Config->{$o} ?
1041 $CPAN::Config->{$o} : "UNDEFINED"));
5f05dabc 1042 }
5f05dabc 1043 }
05454584
AK
1044}
1045
1046#-> sub CPAN::Config::commit ;
1047sub commit {
1048 my($self,$configpm) = @_;
1049 unless (defined $configpm){
1050 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1051 $configpm ||= $INC{"CPAN/Config.pm"};
2e2b7522 1052 $configpm || Carp::confess(q{
05454584
AK
1053CPAN::Config::commit called without an argument.
1054Please 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");
5f05dabc
PP
1063 }
1064 }
05454584 1065
de34a54b
JH
1066 my $msg;
1067 $msg = <<EOF unless $configpm =~ /MyConfig/;
05454584 1068
09d9d230 1069# This is CPAN.pm's systemwide configuration file. This file provides
55e314ee
AK
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.
05454584
AK
1073
1074EOF
1075 $msg ||= "\n";
1076 my($fh) = FileHandle->new;
f610777f 1077 rename $configpm, "$configpm~" if -f $configpm;
05454584 1078 open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
c356248b 1079 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
05454584
AK
1080 foreach (sort keys %$CPAN::Config) {
1081 $fh->print(
1082 " '$_' => ",
1083 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1084 ",\n"
1085 );
5f05dabc 1086 }
05454584 1087
c356248b 1088 $fh->print("};\n1;\n__END__\n");
05454584
AK
1089 close $fh;
1090
1091 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1092 #chmod $mode, $configpm;
e50380aa 1093###why was that so? $self->defaults;
c356248b 1094 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
05454584 1095 1;
5f05dabc
PP
1096}
1097
05454584
AK
1098*default = \&defaults;
1099#-> sub CPAN::Config::defaults ;
1100sub defaults {
1101 my($self) = @_;
1102 $self->unload;
1103 $self->load;
1104 1;
5f05dabc
PP
1105}
1106
05454584
AK
1107sub 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;
5f05dabc
PP
1116}
1117
05454584
AK
1118#-> sub CPAN::Config::load ;
1119sub load {
e50380aa
AK
1120 my($self) = shift;
1121 my(@miss);
f610777f 1122 use Carp;
c356248b
AK
1123 eval {require CPAN::Config;}; # We eval because of some
1124 # MakeMaker problems
09d9d230
A
1125 unless ($dot_cpan++){
1126 unshift @INC, MM->catdir($ENV{HOME},".cpan");
1127 eval {require CPAN::MyConfig;}; # where you can override
c356248b 1128 # system wide settings
09d9d230
A
1129 shift @INC;
1130 }
e50380aa 1131 return unless @miss = $self->not_loaded;
c356248b 1132 # XXX better check for arrayrefs too
e50380aa 1133 require CPAN::FirstTime;
55e314ee 1134 my($configpm,$fh,$redo,$theycalled);
e50380aa 1135 $redo ||= "";
55e314ee 1136 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
e50380aa
AK
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($") = ", ";
f610777f 1187 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
e50380aa
AK
1188We have to reconfigure CPAN.pm due to following uninitialized parameters:
1189
1190@miss
f610777f 1191END
c356248b 1192 $CPAN::Frontend->myprint(qq{
05454584 1193$configpm initialized.
c356248b 1194});
e50380aa
AK
1195 sleep 2;
1196 CPAN::FirstTime::init($configpm);
5f05dabc
PP
1197}
1198
e50380aa
AK
1199#-> sub CPAN::Config::not_loaded ;
1200sub not_loaded {
1201 my(@miss);
05454584 1202 for (qw(
f610777f
A
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
05454584 1207 )) {
e50380aa 1208 push @miss, $_ unless defined $CPAN::Config->{$_};
5f05dabc 1209 }
e50380aa 1210 return @miss;
5f05dabc
PP
1211}
1212
05454584
AK
1213#-> sub CPAN::Config::unload ;
1214sub unload {
1215 delete $INC{'CPAN/MyConfig.pm'};
1216 delete $INC{'CPAN/Config.pm'};
5f05dabc
PP
1217}
1218
05454584
AK
1219#-> sub CPAN::Config::help ;
1220sub help {
2e2b7522 1221 $CPAN::Frontend->myprint(q[
05454584
AK
1222Known 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
5f05dabc 1226
911a92db
GS
1227You may edit key values in the follow fashion (the "o" is a literal
1228letter o):
5f05dabc 1229
05454584 1230 o conf build_cache 15
5f05dabc 1231
05454584 1232 o conf build_dir "/foo/bar"
5f05dabc 1233
05454584 1234 o conf urllist shift
5f05dabc 1235
05454584 1236 o conf urllist unshift ftp://ftp.foo.bar/
5f05dabc 1237
2e2b7522 1238]);
05454584
AK
1239 undef; #don't reprint CPAN::Config
1240}
5f05dabc 1241
55e314ee
AK
1242#-> sub CPAN::Config::cpl ;
1243sub cpl {
05454584
AK
1244 my($word,$line,$pos) = @_;
1245 $word ||= "";
c356248b
AK
1246 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1247 my(@words) = split " ", substr($line,0,$pos+1);
1248 if (
09d9d230
A
1249 defined($words[2])
1250 and
1251 (
1252 $words[2] =~ /list$/ && @words == 3
1253 ||
1254 $words[2] =~ /list$/ && @words == 4 && length($word)
1255 )
c356248b
AK
1256 ) {
1257 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1258 } elsif (@words >= 4) {
1259 return ();
1260 }
05454584
AK
1261 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1262 return grep /^\Q$word\E/, @o_conf;
1263}
1264
1265package CPAN::Shell;
5f05dabc 1266
05454584
AK
1267#-> sub CPAN::Shell::h ;
1268sub h {
1269 my($class,$about) = @_;
1270 if (defined $about) {
c356248b 1271 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
05454584 1272 } else {
c356248b 1273 $CPAN::Frontend->myprint(q{
911a92db
GS
1274Display 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
1283Download, 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
1292Other
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});
05454584
AK
1297 }
1298}
da199366 1299
09d9d230
A
1300*help = \&h;
1301
05454584 1302#-> sub CPAN::Shell::a ;
de34a54b
JH
1303sub 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}
05454584
AK
1311#-> sub CPAN::Shell::b ;
1312sub b {
1313 my($self,@which) = @_;
1314 CPAN->debug("which[@which]") if $CPAN::DEBUG;
55e314ee 1315 my($incdir,$bdir,$dh);
05454584 1316 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
c356248b 1317 $bdir = MM->catdir($incdir,"Bundle");
05454584
AK
1318 if ($dh = DirHandle->new($bdir)) { # may fail
1319 my($entry);
1320 for $entry ($dh->read) {
c356248b 1321 next if -d MM->catdir($bdir,$entry);
11860a17 1322 next unless $entry =~ s/\.pm$//;
05454584
AK
1323 $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
1324 }
1325 }
1326 }
c356248b 1327 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
05454584
AK
1328}
1329#-> sub CPAN::Shell::d ;
c356248b 1330sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
05454584 1331#-> sub CPAN::Shell::m ;
f610777f
A
1332sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1333 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1334}
da199366 1335
05454584
AK
1336#-> sub CPAN::Shell::i ;
1337sub 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 }
e50380aa 1347 my $result = @result == 1 ?
05454584
AK
1348 $result[0]->as_string :
1349 join "", map {$_->as_glimpse} @result;
1350 $result ||= "No objects found of any type for argument @args\n";
c356248b 1351 $CPAN::Frontend->myprint($result);
da199366 1352}
da199366 1353
05454584
AK
1354#-> sub CPAN::Shell::o ;
1355sub 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);
09d9d230
A
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");
05454584
AK
1371 for $k (sort keys %CPAN::Config::can) {
1372 $v = $CPAN::Config::can{$k};
c356248b 1373 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
05454584 1374 }
c356248b 1375 $CPAN::Frontend->myprint("\n");
05454584
AK
1376 for $k (sort keys %$CPAN::Config) {
1377 $v = $CPAN::Config->{$k};
1378 if (ref $v) {
de34a54b 1379 my(@report) = ref $v eq "ARRAY" ? @$v : %$v;
c356248b
AK
1380 $CPAN::Frontend->myprint(
1381 join(
1382 "",
1383 sprintf(
1384 " %-18s\n",
1385 $k
1386 ),
de34a54b 1387 map {"\t$_\n"} @report
c356248b
AK
1388 )
1389 );
10b2abe6 1390 } else {
c356248b 1391 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
da199366 1392 }
10b2abe6 1393 }
c356248b 1394 $CPAN::Frontend->myprint("\n");
05454584 1395 } elsif (!CPAN::Config->edit(@o_what)) {
c356248b 1396 $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
5f05dabc 1397 }
05454584
AK
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 += $_;
10b2abe6 1412 }
05454584 1413 $CPAN::DEBUG = $max;
10b2abe6 1414 } else {
d4fd5c69 1415 my($known) = 0;
05454584
AK
1416 for (keys %CPAN::DEBUG) {
1417 next unless lc($_) eq lc($what);
1418 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
d4fd5c69 1419 $known = 1;
10b2abe6 1420 }
c356248b
AK
1421 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1422 unless $known;
10b2abe6
CS
1423 }
1424 }
05454584 1425 } else {
911a92db
GS
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");
05454584
AK
1433 }
1434 if ($CPAN::DEBUG) {
c356248b 1435 $CPAN::Frontend->myprint("Options set for debugging:\n");
05454584
AK
1436 my($k,$v);
1437 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1438 $v = $CPAN::DEBUG{$k};
c356248b 1439 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
05454584
AK
1440 }
1441 } else {
c356248b 1442 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
10b2abe6 1443 }
05454584 1444 } else {
c356248b 1445 $CPAN::Frontend->myprint(qq{
05454584
AK
1446Known options:
1447 conf set or get configuration variables
1448 debug set or get debugging options
c356248b 1449});
5f05dabc 1450 }
5f05dabc
PP
1451}
1452
36263cb3
GS
1453sub dotdot_onreload {
1454 my($ref) = shift;
1455 sub {
1456 if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1457 my($subr) = $1;
1458 ++$$ref;
1459 local($|) = 1;
1460 # $CPAN::Frontend->myprint(".($subr)");
1461 $CPAN::Frontend->myprint(".");
1462 return;
1463 }
1464 warn @_;
1465 };
1466}
1467
05454584
AK
1468#-> sub CPAN::Shell::reload ;
1469sub reload {
d4fd5c69
AK
1470 my($self,$command,@arg) = @_;
1471 $command ||= "";
1472 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1473 if ($command =~ /cpan/i) {
05454584
AK
1474 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1475 my $fh = FileHandle->new($INC{'CPAN.pm'});
1476 local($/);
05454584 1477 $redef = 0;
36263cb3 1478 local($SIG{__WARN__}) = dotdot_onreload(\$redef);
05454584
AK
1479 eval <$fh>;
1480 warn $@ if $@;
c356248b 1481 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
d4fd5c69 1482 } elsif ($command =~ /index/) {
2e2b7522 1483 CPAN::Index->force_reload;
d4fd5c69 1484 } else {
2e2b7522 1485 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
f14b5cec 1486index re-reads the index files\n});
05454584
AK
1487 }
1488}
1489
1490#-> sub CPAN::Shell::_binary_extensions ;
1491sub _binary_extensions {
1492 my($self) = shift @_;
1493 my(@result,$module,%seen,%need,$headerdone);
de34a54b
JH
1494 my $isaperl = q{ perl
1495 -?
1496 5[._-]
1497 (
1498 \\d{3}(_[0-4][0-9])?
1499 |
1500 \\d*[24680]\\.\\d+
1501 )
11860a17 1502 \\.tar[._-]gz$
de34a54b 1503 };
05454584
AK
1504 for $module ($self->expand('Module','/./')) {
1505 my $file = $module->cpan_file;
1506 next if $file eq "N/A";
1507 next if $file =~ /^Contact Author/;
de34a54b 1508 next if $file =~ / $isaperl /x;
05454584
AK
1509 next unless $module->xs_file;
1510 local($|) = 1;
c356248b 1511 $CPAN::Frontend->myprint(".");
05454584
AK
1512 push @result, $module;
1513 }
1514# print join " | ", @result;
c356248b 1515 $CPAN::Frontend->myprint("\n");
05454584
AK
1516 return @result;
1517}
1518
1519#-> sub CPAN::Shell::recompile ;
1520sub recompile {
1521 my($self) = shift @_;
1522 my($module,@module,$cpan_file,%dist);
1523 @module = $self->_binary_extensions();
c356248b
AK
1524 for $module (@module){ # we force now and compile later, so we
1525 # don't do it twice
05454584
AK
1526 $cpan_file = $module->cpan_file;
1527 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1528 $pack->force;
1529 $dist{$cpan_file}++;
1530 }
1531 for $cpan_file (sort keys %dist) {
c356248b 1532 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
05454584
AK
1533 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1534 $pack->install;
1535 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1536 # stop a package from recompiling,
1537 # e.g. IO-1.12 when we have perl5.003_10
1538 }
1539}
1540
1541#-> sub CPAN::Shell::_u_r_common ;
1542sub _u_r_common {
1543 my($self) = shift @_;
1544 my($what) = shift @_;
1545 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1546 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1547 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1548 my(@args) = @_;
1549 @args = '/./' unless @args;
c356248b
AK
1550 my(@result,$module,%seen,%need,$headerdone,
1551 $version_undefs,$version_zeroes);
1552 $version_undefs = $version_zeroes = 0;
05454584
AK
1553 my $sprintf = "%-25s %9s %9s %s\n";
1554 for $module ($self->expand('Module',@args)) {
1555 my $file = $module->cpan_file;
1556 next unless defined $file; # ??
c356248b 1557 my($latest) = $module->cpan_version;
05454584
AK
1558 my($inst_file) = $module->inst_file;
1559 my($have);
09d9d230 1560 return if $CPAN::Signal;
05454584
AK
1561 if ($inst_file){
1562 if ($what eq "a") {
1563 $have = $module->inst_version;
1564 } elsif ($what eq "r") {
1565 $have = $module->inst_version;
1566 local($^W) = 0;
c356248b
AK
1567 if ($have eq "undef"){
1568 $version_undefs++;
1569 } elsif ($have == 0){
1570 $version_zeroes++;
1571 }
05454584 1572 next if $have >= $latest;
c356248b
AK
1573# to be pedantic we should probably say:
1574# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1575# to catch the case where CPAN has a version 0 and we have a version undef
05454584
AK
1576 } elsif ($what eq "u") {
1577 next;
1578 }
1579 } else {
1580 if ($what eq "a") {
1581 next;
1582 } elsif ($what eq "r") {
1583 next;
1584 } elsif ($what eq "u") {
1585 $have = "-";
1586 }
1587 }
1588 return if $CPAN::Signal; # this is sometimes lengthy
1589 $seen{$file} ||= 0;
1590 if ($what eq "a") {
1591 push @result, sprintf "%s %s\n", $module->id, $have;
1592 } elsif ($what eq "r") {
1593 push @result, $module->id;
1594 next if $seen{$file}++;
1595 } elsif ($what eq "u") {
1596 push @result, $module->id;
1597 next if $seen{$file}++;
1598 next if $file =~ /^Contact/;
1599 }
1600 unless ($headerdone++){
c356248b
AK
1601 $CPAN::Frontend->myprint("\n");
1602 $CPAN::Frontend->myprint(sprintf(
05454584
AK
1603 $sprintf,
1604 "Package namespace",
1605 "installed",
1606 "latest",
1607 "in CPAN file"
c356248b 1608 ));
05454584
AK
1609 }
1610 $latest = substr($latest,0,8) if length($latest) > 8;
1611 $have = substr($have,0,8) if length($have) > 8;
c356248b 1612 $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
05454584
AK
1613 $need{$module->id}++;
1614 }
1615 unless (%need) {
1616 if ($what eq "u") {
c356248b 1617 $CPAN::Frontend->myprint("No modules found for @args\n");
05454584 1618 } elsif ($what eq "r") {
c356248b 1619 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
05454584
AK
1620 }
1621 }
c356248b
AK
1622 if ($what eq "r") {
1623 if ($version_zeroes) {
1624 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1625 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1626 qq{a version number of 0\n});
1627 }
1628 if ($version_undefs) {
1629 my $s_has = $version_undefs > 1 ? "s have" : " has";
1630 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1631 qq{parseable version number\n});
1632 }
05454584
AK
1633 }
1634 @result;
1635}
1636
1637#-> sub CPAN::Shell::r ;
1638sub r {
1639 shift->_u_r_common("r",@_);
1640}
1641
1642#-> sub CPAN::Shell::u ;
1643sub u {
1644 shift->_u_r_common("u",@_);
1645}
1646
1647#-> sub CPAN::Shell::autobundle ;
1648sub autobundle {
1649 my($self) = shift;
36263cb3 1650 CPAN::Config->load unless $CPAN::Config_loaded++;
05454584 1651 my(@bundle) = $self->_u_r_common("a",@_);
c356248b 1652 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
05454584
AK
1653 File::Path::mkpath($todir);
1654 unless (-d $todir) {
c356248b 1655 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
05454584
AK
1656 return;
1657 }
1658 my($y,$m,$d) = (localtime)[5,4,3];
1659 $y+=1900;
1660 $m++;
1661 my($c) = 0;
1662 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
c356248b 1663 my($to) = MM->catfile($todir,"$me.pm");
05454584
AK
1664 while (-f $to) {
1665 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
c356248b 1666 $to = MM->catfile($todir,"$me.pm");
05454584
AK
1667 }
1668 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1669 $fh->print(
1670 "package Bundle::$me;\n\n",
1671 "\$VERSION = '0.01';\n\n",
1672 "1;\n\n",
1673 "__END__\n\n",
1674 "=head1 NAME\n\n",
1675 "Bundle::$me - Snapshot of installation on ",
1676 $Config::Config{'myhostname'},
1677 " on ",
1678 scalar(localtime),
1679 "\n\n=head1 SYNOPSIS\n\n",
1680 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1681 "=head1 CONTENTS\n\n",
1682 join("\n", @bundle),
1683 "\n\n=head1 CONFIGURATION\n\n",
1684 Config->myconfig,
1685 "\n\n=head1 AUTHOR\n\n",
1686 "This Bundle has been generated automatically ",
1687 "by the autobundle routine in CPAN.pm.\n",
1688 );
1689 $fh->close;
c356248b
AK
1690 $CPAN::Frontend->myprint("\nWrote bundle file
1691 $to\n\n");
05454584
AK
1692}
1693
1694#-> sub CPAN::Shell::expand ;
1695sub expand {
1696 shift;
1697 my($type,@args) = @_;
1698 my($arg,@m);
1699 for $arg (@args) {
1700 my $regex;
1701 if ($arg =~ m|^/(.*)/$|) {
1702 $regex = $1;
1703 }
1704 my $class = "CPAN::$type";
1705 my $obj;
1706 if (defined $regex) {
911a92db
GS
1707 for $obj (
1708 sort
1709 {$a->id cmp $b->id}
1710 $CPAN::META->all_objects($class)
1711 ) {
1712 unless ($obj->id){
1713 # BUG, we got an empty object somewhere
1714 CPAN->debug(sprintf(
1715 "Empty id on obj[%s]%%[%s]",
1716 $obj,
1717 join(":", %$obj)
1718 )) if $CPAN::DEBUG;
1719 next;
1720 }
1721 push @m, $obj
1722 if $obj->id =~ /$regex/i
1723 or
05454584
AK
1724 (
1725 (
911a92db
GS
1726 $] < 5.00303 ### provide sort of
1727 ### compatibility with 5.003
05454584
AK
1728 ||
1729 $obj->can('name')
1730 )
1731 &&
1732 $obj->name =~ /$regex/i
1733 );
911a92db 1734 }
05454584
AK
1735 } else {
1736 my($xarg) = $arg;
1737 if ( $type eq 'Bundle' ) {
1738 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1739 }
1740 if ($CPAN::META->exists($class,$xarg)) {
1741 $obj = $CPAN::META->instance($class,$xarg);
1742 } elsif ($CPAN::META->exists($class,$arg)) {
1743 $obj = $CPAN::META->instance($class,$arg);
1744 } else {
1745 next;
1746 }
1747 push @m, $obj;
1748 }
1749 }
e50380aa 1750 return wantarray ? @m : $m[0];
05454584
AK
1751}
1752
1753#-> sub CPAN::Shell::format_result ;
1754sub format_result {
1755 my($self) = shift;
1756 my($type,@args) = @_;
1757 @args = '/./' unless @args;
1758 my(@result) = $self->expand($type,@args);
e50380aa 1759 my $result = @result == 1 ?
05454584
AK
1760 $result[0]->as_string :
1761 join "", map {$_->as_glimpse} @result;
1762 $result ||= "No objects of type $type found for argument @args\n";
1763 $result;
1764}
1765
c356248b
AK
1766# The only reason for this method is currently to have a reliable
1767# debugging utility that reveals which output is going through which
1768# channel. No, I don't like the colors ;-)
1769sub print_ornamented {
1770 my($self,$what,$ornament) = @_;
1771 my $longest = 0;
1772 my $ornamenting = 0; # turn the colors on
1773
1774 if ($ornamenting) {
1775 unless (defined &color) {
1776 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1777 import Term::ANSIColor "color";
1778 } else {
1779 *color = sub { return "" };
1780 }
1781 }
09d9d230
A
1782 my $line;
1783 for $line (split /\n/, $what) {
c356248b
AK
1784 $longest = length($line) if length($line) > $longest;
1785 }
1786 my $sprintf = "%-" . $longest . "s";
1787 while ($what){
1788 $what =~ s/(.*\n?)//m;
1789 my $line = $1;
1790 last unless $line;
1791 my($nl) = chomp $line ? "\n" : "";
1792 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1793 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1794 }
1795 } else {
1796 print $what;
1797 }
1798}
1799
1800sub myprint {
1801 my($self,$what) = @_;
1802 $self->print_ornamented($what, 'bold blue on_yellow');
1803}
1804
1805sub myexit {
1806 my($self,$what) = @_;
1807 $self->myprint($what);
1808 exit;
1809}
1810
1811sub mywarn {
1812 my($self,$what) = @_;
1813 $self->print_ornamented($what, 'bold red on_yellow');
1814}
1815
1816sub myconfess {
1817 my($self,$what) = @_;
1818 $self->print_ornamented($what, 'bold red on_white');
1819 Carp::confess "died";
1820}
1821
1822sub mydie {
1823 my($self,$what) = @_;
1824 $self->print_ornamented($what, 'bold red on_white');
1825 die "\n";
1826}
1827
911a92db
GS
1828sub setup_output {
1829 return if -t STDOUT;
1830 my $odef = select STDERR;
1831 $| = 1;
1832 select STDOUT;
1833 $| = 1;
1834 select $odef;
1835}
1836
05454584 1837#-> sub CPAN::Shell::rematein ;
09d9d230 1838# RE-adme||MA-ke||TE-st||IN-stall
05454584
AK
1839sub rematein {
1840 shift;
1841 my($meth,@some) = @_;
1842 my $pragma = "";
1843 if ($meth eq 'force') {
1844 $pragma = $meth;
1845 $meth = shift @some;
1846 }
911a92db 1847 setup_output();
05454584
AK
1848 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1849 my($s,@s);
1850 foreach $s (@some) {
f610777f
A
1851 CPAN::Queue->new($s);
1852 }
1853 while ($s = CPAN::Queue->first) {
05454584
AK
1854 my $obj;
1855 if (ref $s) {
1856 $obj = $s;
1857 } elsif ($s =~ m|/|) { # looks like a file
1858 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1859 } elsif ($s =~ m|^Bundle::|) {
1860 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1861 } else {
1862 $obj = $CPAN::META->instance('CPAN::Module',$s)
1863 if $CPAN::META->exists('CPAN::Module',$s);
1864 }
1865 if (ref $obj) {
1866 CPAN->debug(
f610777f 1867 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
05454584
AK
1868 $obj->as_string.
1869 qq{\]}
1870 ) if $CPAN::DEBUG;
1871 $obj->$pragma()
1872 if
1873 $pragma
1874 &&
09d9d230
A
1875 ($] < 5.00303 || $obj->can($pragma)); ###
1876 ### compatibility
1877 ### with
1878 ### 5.003
1879 if ($]>=5.00303 && $obj->can('called_for')) {
1880 $obj->called_for($s);
1881 }
f610777f
A
1882 CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1883 # than once in
1884 # the queue
05454584
AK
1885 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1886 $obj = $CPAN::META->instance('CPAN::Author',$s);
c356248b
AK
1887 $CPAN::Frontend->myprint(
1888 join "",
1889 "Don't be silly, you can't $meth ",
1890 $obj->fullname,
1891 " ;-)\n"
1892 );
05454584 1893 } else {
f610777f
A
1894 $CPAN::Frontend
1895 ->myprint(qq{Warning: Cannot $meth $s, }.
1896 qq{don\'t know what it is.
e50380aa
AK
1897Try the command
1898
1899 i /$s/
1900
1901to find objects with similar identifiers.
c356248b 1902});
05454584 1903 }
f610777f 1904 CPAN::Queue->delete_first($s);
05454584
AK
1905 }
1906}
1907
1908#-> sub CPAN::Shell::force ;
1909sub force { shift->rematein('force',@_); }
1910#-> sub CPAN::Shell::get ;
1911sub get { shift->rematein('get',@_); }
1912#-> sub CPAN::Shell::readme ;
1913sub readme { shift->rematein('readme',@_); }
1914#-> sub CPAN::Shell::make ;
1915sub make { shift->rematein('make',@_); }
1916#-> sub CPAN::Shell::test ;
1917sub test { shift->rematein('test',@_); }
1918#-> sub CPAN::Shell::install ;
1919sub install { shift->rematein('install',@_); }
1920#-> sub CPAN::Shell::clean ;
1921sub clean { shift->rematein('clean',@_); }
1922#-> sub CPAN::Shell::look ;
1923sub look { shift->rematein('look',@_); }
911a92db
GS
1924#-> sub CPAN::Shell::cvs_import ;
1925sub cvs_import { shift->rematein('cvs_import',@_); }
05454584
AK
1926
1927package CPAN::FTP;
05454584
AK
1928
1929#-> sub CPAN::FTP::ftp_get ;
1930sub ftp_get {
2e2b7522
GS
1931 my($class,$host,$dir,$file,$target) = @_;
1932 $class->debug(
1933 qq[Going to fetch file [$file] from dir [$dir]
05454584
AK
1934 on host [$host] as local [$target]\n]
1935 ) if $CPAN::DEBUG;
2e2b7522
GS
1936 my $ftp = Net::FTP->new($host);
1937 return 0 unless defined $ftp;
1938 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1939 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1940 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1941 warn "Couldn't login on $host";
1942 return;
1943 }
1944 unless ( $ftp->cwd($dir) ){
1945 warn "Couldn't cwd $dir";
1946 return;
1947 }
1948 $ftp->binary;
1949 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1950 unless ( $ftp->get($file,$target) ){
1951 warn "Couldn't fetch $file from $host\n";
1952 return;
1953 }
1954 $ftp->quit; # it's ok if this fails
1955 return 1;
05454584
AK
1956}
1957
09d9d230 1958# If more accuracy is wanted/needed, Chris Leach sent me this patch...
f610777f 1959
09d9d230
A
1960 # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
1961 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997
1962 # leach,> ***************
1963 # leach,> *** 1562,1567 ****
1964 # leach,> --- 1562,1580 ----
1965 # leach,> return 1 if substr($url,0,4) eq "file";
1966 # leach,> return 1 unless $url =~ m|://([^/]+)|;
1967 # leach,> my $host = $1;
1968 # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1969 # leach,> + if ($proxy) {
1970 # leach,> + $proxy =~ m|://([^/:]+)|;
1971 # leach,> + $proxy = $1;
1972 # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1973 # leach,> + if ($noproxy) {
1974 # leach,> + if ($host !~ /$noproxy$/) {
1975 # leach,> + $host = $proxy;
1976 # leach,> + }
1977 # leach,> + } else {
1978 # leach,> + $host = $proxy;
1979 # leach,> + }
1980 # leach,> + }
1981 # leach,> require Net::Ping;
1982 # leach,> return 1 unless $Net::Ping::VERSION >= 2;
1983 # leach,> my $p;
1984
1985
1986# this is quite optimistic and returns one on several occasions where
1987# inappropriate. But this does no harm. It would do harm if we were
1988# too pessimistic (as I was before the http_proxy
c356248b
AK
1989sub is_reachable {
1990 my($self,$url) = @_;
1991 return 1; # we can't simply roll our own, firewalls may break ping
1992 return 0 unless $url;
1993 return 1 if substr($url,0,4) eq "file";
09d9d230
A
1994 return 1 unless $url =~ m|^(\w+)://([^/]+)|;
1995 my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
1996 my $host = $2;
1997 return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
c356248b
AK
1998 require Net::Ping;
1999 return 1 unless $Net::Ping::VERSION >= 2;
2000 my $p;
09d9d230
A
2001 # 1.3101 had it different: only if the first eval raised an
2002 # exception we tried it with TCP. Now we are happy if icmp wins
2003 # the order and return, we don't even check for $@. Thanks to
2004 # thayer@uis.edu for the suggestion.
c356248b 2005 eval {$p = Net::Ping->new("icmp");};
09d9d230
A
2006 return 1 if $p && ref($p) && $p->ping($host, 10);
2007 eval {$p = Net::Ping->new("tcp");};
c356248b 2008 $CPAN::Frontend->mydie($@) if $@;
09d9d230 2009 return $p->ping($host, 10);
c356248b
AK
2010}
2011
05454584 2012#-> sub CPAN::FTP::localize ;
55e314ee
AK
2013# sorry for the ugly code here, I'll clean it up as soon as Net::FTP
2014# is in the core
05454584
AK
2015sub localize {
2016 my($self,$file,$aslocal,$force) = @_;
2017 $force ||= 0;
2018 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2019 unless defined $aslocal;
55e314ee
AK
2020 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2021 if $CPAN::DEBUG;
05454584 2022
f14b5cec
JH
2023 if ($^O eq 'MacOS') {
2024 my($name, $path) = File::Basename::fileparse($aslocal, '');
2025 if (length($name) > 31) {
2026 $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
2027 my $suf = $1;
2028 my $size = 31 - length($suf);
2029 while (length($name) > $size) {
2030 chop $name;
2031 }
2032 $name .= $suf;
2033 $aslocal = File::Spec->catfile($path, $name);
2034 }
2035 }
2036
c356248b 2037 return $aslocal if -f $aslocal && -r _ && !($force & 1);
55e314ee
AK
2038 my($restore) = 0;
2039 if (-f $aslocal){
2040 rename $aslocal, "$aslocal.bak";
2041 $restore++;
2042 }
05454584
AK
2043
2044 my($aslocal_dir) = File::Basename::dirname($aslocal);
2045 File::Path::mkpath($aslocal_dir);
c356248b 2046 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
05454584 2047 qq{directory "$aslocal_dir".
c356248b
AK
2048 I\'ll continue, but if you encounter problems, they may be due
2049 to insufficient permissions.\n}) unless -w $aslocal_dir;
05454584
AK
2050
2051 # Inheritance is not easier to manage than a few if/else branches
de34a54b 2052 if ($CPAN::META->has_usable('LWP::UserAgent')) {
05454584 2053 unless ($Ua) {
55e314ee 2054 $Ua = LWP::UserAgent->new;
05454584
AK
2055 my($var);
2056 $Ua->proxy('ftp', $var)
2057 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
2058 $Ua->proxy('http', $var)
2059 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2060 $Ua->no_proxy($var)
2061 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2062 }
2063 }
2064
2065 # Try the list of urls for each single object. We keep a record
2066 # where we did get a file from
c356248b 2067 my(@reordered,$last);
09d9d230 2068 $CPAN::Config->{urllist} ||= [];
c356248b
AK
2069 $last = $#{$CPAN::Config->{urllist}};
2070 if ($force & 2) { # local cpans probably out of date, don't reorder
2071 @reordered = (0..$last);
2072 } else {
2073 @reordered =
2074 sort {
2075 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
f610777f 2076 <=>
c356248b
AK
2077 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2078 or
2079 defined($Thesite)
2080 and
2081 ($b == $Thesite)
2082 <=>
2083 ($a == $Thesite)
2084 } 0..$last;
c356248b
AK
2085 }
2086 my($level,@levels);
2087 if ($Themethod) {
2088 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2089 } else {
2090 @levels = qw/easy hard hardest/;
2091 }
f14b5cec 2092 @levels = qw/easy/ if $^O eq 'MacOS';
c356248b
AK
2093 for $level (@levels) {
2094 my $method = "host$level";
2095 my @host_seq = $level eq "easy" ?
2096 @reordered : 0..$last; # reordered has CDROM up front
09d9d230 2097 @host_seq = (0) unless @host_seq;
c356248b
AK
2098 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2099 if ($ret) {
2e2b7522 2100 $Themethod = $level;
911a92db
GS
2101 my $now = time;
2102 # utime $now, $now, $aslocal; # too bad, if we do that, we
2103 # might alter a local mirror
2e2b7522
GS
2104 $self->debug("level[$level]") if $CPAN::DEBUG;
2105 return $ret;
2106 } else {
2107 unlink $aslocal;
c356248b
AK
2108 }
2109 }
2110 my(@mess);
2111 push @mess,
2112 qq{Please check, if the URLs I found in your configuration file \(}.
2113 join(", ", @{$CPAN::Config->{urllist}}).
2114 qq{\) are valid. The urllist can be edited.},
2115 qq{E.g. with ``o conf urllist push ftp://myurl/''};
2116 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2117 sleep 2;
2118 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
2119 if ($restore) {
2120 rename "$aslocal.bak", $aslocal;
2121 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2122 $self->ls($aslocal));
2123 return $aslocal;
2124 }
2125 return;
2126}
2127
2128sub hosteasy {
2129 my($self,$host_seq,$file,$aslocal) = @_;
05454584 2130 my($i);
c356248b 2131 HOSTEASY: for $i (@$host_seq) {
09d9d230 2132 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b
AK
2133 unless ($self->is_reachable($url)) {
2134 $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
2135 sleep 2;
2136 next;
2137 }
05454584
AK
2138 $url .= "/" unless substr($url,-1) eq "/";
2139 $url .= $file;
c356248b 2140 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
05454584
AK
2141 if ($url =~ /^file:/) {
2142 my $l;
de34a54b 2143 if ($CPAN::META->has_inst('URI::URL')) {
55e314ee 2144 my $u = URI::URL->new($url);
05454584
AK
2145 $l = $u->path;
2146 } else { # works only on Unix, is poorly constructed, but
c356248b
AK
2147 # hopefully better than nothing.
2148 # RFC 1738 says fileurl BNF is
2149 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2150 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2151 # the code
36263cb3
GS
2152 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2153 $l =~ s|^file:||; # assume they
2154 # meant
2155 # file://localhost
392d8ab8 2156 $l =~ s|^/||s unless -f $l; # e.g. /P:
05454584 2157 }
c356248b
AK
2158 if ( -f $l && -r _) {
2159 $Thesite = $i;
2160 return $l;
2161 }
05454584
AK
2162 # Maybe mirror has compressed it?
2163 if (-f "$l.gz") {
d4fd5c69 2164 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
09d9d230 2165 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
c356248b
AK
2166 if ( -f $aslocal) {
2167 $Thesite = $i;
2168 return $aslocal;
2169 }
05454584
AK
2170 }
2171 }
de34a54b 2172 if ($CPAN::META->has_usable('LWP')) {
09d9d230 2173 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
AK
2174 $url
2175");
f610777f
A
2176 unless ($Ua) {
2177 require LWP::UserAgent;
2178 $Ua = LWP::UserAgent->new;
2179 }
09d9d230
A
2180 my $res = $Ua->mirror($url, $aslocal);
2181 if ($res->is_success) {
2182 $Thesite = $i;
911a92db
GS
2183 my $now = time;
2184 utime $now, $now, $aslocal; # download time is more
2185 # important than upload time
09d9d230 2186 return $aslocal;
11860a17 2187 } elsif ($url !~ /\.gz$/) {
09d9d230
A
2188 my $gzurl = "$url.gz";
2189 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
AK
2190 $gzurl
2191");
09d9d230
A
2192 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2193 if ($res->is_success &&
2194 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2195 ) {
2196 $Thesite = $i;
2197 return $aslocal;
c356248b 2198 } else {
09d9d230 2199 # next HOSTEASY ;
05454584 2200 }
09d9d230
A
2201 } else {
2202 # Alan Burlison informed me that in firewall envs Net::FTP
2203 # can still succeed where LWP fails. So we do not skip
2204 # Net::FTP anymore when LWP is available.
2205 # next HOSTEASY ;
2206 }
2207 } else {
2208 $self->debug("LWP not installed") if $CPAN::DEBUG;
05454584
AK
2209 }
2210 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2211 # that's the nice and easy way thanks to Graham
2212 my($host,$dir,$getfile) = ($1,$2,$3);
de34a54b 2213 if ($CPAN::META->has_usable('Net::FTP')) {
05454584 2214 $dir =~ s|/+|/|g;
c356248b 2215 $CPAN::Frontend->myprint("Fetching with Net::FTP:
09d9d230 2216 $url
c356248b
AK
2217");
2218 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2219 "aslocal[$aslocal]") if $CPAN::DEBUG;
2220 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2221 $Thesite = $i;
2222 return $aslocal;
2223 }
11860a17 2224 if ($aslocal !~ /\.gz$/) {
c356248b
AK
2225 my $gz = "$aslocal.gz";
2226 $CPAN::Frontend->myprint("Fetching with Net::FTP
09d9d230 2227 $url.gz
c356248b 2228");
2e2b7522 2229 if (CPAN::FTP->ftp_get($host,
09d9d230
A
2230 $dir,
2231 "$getfile.gz",
2232 $gz) &&
2233 CPAN::Tarzip->gunzip($gz,$aslocal)
2234 ){
c356248b
AK
2235 $Thesite = $i;
2236 return $aslocal;
2237 }
2238 }
09d9d230 2239 # next HOSTEASY;
05454584
AK
2240 }
2241 }
c356248b
AK
2242 }
2243}
05454584 2244
c356248b 2245sub hosthard {
2e2b7522 2246 my($self,$host_seq,$file,$aslocal) = @_;
05454584 2247
2e2b7522
GS
2248 # Came back if Net::FTP couldn't establish connection (or
2249 # failed otherwise) Maybe they are behind a firewall, but they
2250 # gave us a socksified (or other) ftp program...
c356248b 2251
2e2b7522 2252 my($i);
f610777f 2253 my($devnull) = $CPAN::Config->{devnull} || "";
2e2b7522
GS
2254 # < /dev/null ";
2255 my($aslocal_dir) = File::Basename::dirname($aslocal);
2256 File::Path::mkpath($aslocal_dir);
c356248b 2257 HOSTHARD: for $i (@$host_seq) {
09d9d230 2258 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b 2259 unless ($self->is_reachable($url)) {
911a92db
GS
2260 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2261 next;
c356248b
AK
2262 }
2263 $url .= "/" unless substr($url,-1) eq "/";
2264 $url .= $file;
09d9d230
A
2265 my($proto,$host,$dir,$getfile);
2266
2267 # Courtesy Mark Conty mark_conty@cargill.com change from
2268 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2269 # to
2270 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
911a92db
GS
2271 # proto not yet used
2272 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
c356248b 2273 } else {
911a92db 2274 next HOSTHARD; # who said, we could ftp anything except ftp?
c356248b 2275 }
911a92db 2276
c356248b
AK
2277 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2278 my($f,$funkyftp);
2e2b7522 2279 for $f ('lynx','ncftpget','ncftp') {
911a92db
GS
2280 next unless exists $CPAN::Config->{$f};
2281 $funkyftp = $CPAN::Config->{$f};
2282 next unless defined $funkyftp;
2283 next if $funkyftp =~ /^\s*$/;
de34a54b
JH
2284 my($asl_ungz, $asl_gz);
2285 ($asl_ungz = $aslocal) =~ s/\.gz//;
2286 $asl_gz = "$asl_ungz.gz";
2287 my($src_switch) = "";
911a92db 2288 if ($f eq "lynx"){
de34a54b 2289 $src_switch = " -source";
911a92db 2290 } elsif ($f eq "ncftp"){
de34a54b 2291 $src_switch = " -c";
911a92db
GS
2292 }
2293 my($chdir) = "";
de34a54b 2294 my($stdout_redir) = " > $asl_ungz";
911a92db
GS
2295 if ($f eq "ncftpget"){
2296 $chdir = "cd $aslocal_dir && ";
2297 $stdout_redir = "";
2298 }
2299 $CPAN::Frontend->myprint(
2300 qq[
de34a54b 2301Trying with "$funkyftp$src_switch" to get
c356248b 2302 $url
2e2b7522 2303]);
911a92db 2304 my($system) =
de34a54b 2305 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
911a92db
GS
2306 $self->debug("system[$system]") if $CPAN::DEBUG;
2307 my($wstatus);
2308 if (($wstatus = system($system)) == 0
2309 &&
2310 ($f eq "lynx" ?
de34a54b 2311 -s $asl_ungz # lynx returns 0 on my
911a92db
GS
2312 # system even if it fails
2313 : 1
2314 )
2315 ) {
2316 if (-s $aslocal) {
2317 # Looks good
de34a54b 2318 } elsif ($asl_ungz ne $aslocal) {
911a92db
GS
2319 # test gzip integrity
2320 if (
de34a54b 2321 CPAN::Tarzip->gtest($asl_ungz)
911a92db 2322 ) {
de34a54b 2323 rename $asl_ungz, $aslocal;
911a92db 2324 } else {
de34a54b 2325 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
911a92db
GS
2326 }
2327 }
2328 $Thesite = $i;
2329 return $aslocal;
11860a17 2330 } elsif ($url !~ /\.gz$/) {
de34a54b
JH
2331 unlink $asl_ungz if
2332 -f $asl_ungz && -s _ == 0;
911a92db
GS
2333 my $gz = "$aslocal.gz";
2334 my $gzurl = "$url.gz";
2335 $CPAN::Frontend->myprint(
2336 qq[
de34a54b 2337Trying with "$funkyftp$src_switch" to get
911a92db
GS
2338 $url.gz
2339]);
de34a54b 2340 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
55e314ee 2341 $self->debug("system[$system]") if $CPAN::DEBUG;
05454584 2342 my($wstatus);
55e314ee
AK
2343 if (($wstatus = system($system)) == 0
2344 &&
de34a54b 2345 -s $asl_gz
55e314ee 2346 ) {
911a92db 2347 # test gzip integrity
de34a54b
JH
2348 if (CPAN::Tarzip->gtest($asl_gz)) {
2349 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2e2b7522 2350 } else {
de34a54b 2351 rename $asl_ungz, $aslocal;
2e2b7522 2352 }
911a92db
GS
2353 $Thesite = $i;
2354 return $aslocal;
05454584 2355 } else {
de34a54b 2356 unlink $asl_gz if -f $asl_gz;
911a92db
GS
2357 }
2358 } else {
2359 my $estatus = $wstatus >> 8;
2360 my $size = -f $aslocal ?
2361 ", left\n$aslocal with size ".-s _ :
2362 "\nWarning: expected file [$aslocal] doesn't exist";
2363 $CPAN::Frontend->myprint(qq{
05454584 2364System call "$system"
c356248b
AK
2365returned status $estatus (wstat $wstatus)$size
2366});
911a92db 2367 }
05454584 2368 }
c356248b
AK
2369 }
2370}
05454584 2371
c356248b
AK
2372sub hosthardest {
2373 my($self,$host_seq,$file,$aslocal) = @_;
2374
2375 my($i);
2376 my($aslocal_dir) = File::Basename::dirname($aslocal);
2377 File::Path::mkpath($aslocal_dir);
2378 HOSTHARDEST: for $i (@$host_seq) {
2379 unless (length $CPAN::Config->{'ftp'}) {
2380 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2381 last HOSTHARDEST;
2382 }
09d9d230 2383 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b
AK
2384 unless ($self->is_reachable($url)) {
2385 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2386 next;
2387 }
2388 $url .= "/" unless substr($url,-1) eq "/";
2389 $url .= $file;
2390 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2391 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2392 next;
2393 }
2394 my($host,$dir,$getfile) = ($1,$2,$3);
c356248b
AK
2395 my $timestamp = 0;
2396 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2397 $ctime,$blksize,$blocks) = stat($aslocal);
2398 $timestamp = $mtime ||= 0;
2399 my($netrc) = CPAN::FTP::netrc->new;
911a92db 2400 my($netrcfile) = $netrc->netrc;
c356248b
AK
2401 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2402 my $targetfile = File::Basename::basename($aslocal);
2403 my(@dialog);
2404 push(
2405 @dialog,
2406 "lcd $aslocal_dir",
2407 "cd /",
2408 map("cd $_", split "/", $dir), # RFC 1738
2409 "bin",
2410 "get $getfile $targetfile",
2411 "quit"
2412 );
911a92db 2413 if (! $netrcfile) {
c356248b
AK
2414 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2415 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2416 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2417 $netrc->hasdefault,
2418 $netrc->contains($host))) if $CPAN::DEBUG;
2419 if ($netrc->protected) {
2420 $CPAN::Frontend->myprint(qq{
05454584
AK
2421 Trying with external ftp to get
2422 $url
2423 As this requires some features that are not thoroughly tested, we\'re
2424 not sure, that we get it right....
2425
2426}
c356248b
AK
2427 );
2428 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2429 @dialog);
05454584 2430 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
c356248b 2431 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
05454584
AK
2432 $mtime ||= 0;
2433 if ($mtime > $timestamp) {
c356248b
AK
2434 $CPAN::Frontend->myprint("GOT $aslocal\n");
2435 $Thesite = $i;
05454584
AK
2436 return $aslocal;
2437 } else {
c356248b 2438 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
05454584 2439 }
c356248b
AK
2440 } else {
2441 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2442 qq{correctly protected.\n});
05454584 2443 }
c356248b
AK
2444 } else {
2445 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2446 nor does it have a default entry\n");
05454584 2447 }
36263cb3 2448
c356248b
AK
2449 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2450 # then and login manually to host, using e-mail as
2451 # password.
2452 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2453 unshift(
2454 @dialog,
2455 "open $host",
2456 "user anonymous $Config::Config{'cf_email'}"
2457 );
2458 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2459 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2460 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2461 $mtime ||= 0;
2462 if ($mtime > $timestamp) {
2463 $CPAN::Frontend->myprint("GOT $aslocal\n");
2464 $Thesite = $i;
2465 return $aslocal;
2466 } else {
2467 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
05454584 2468 }
c356248b
AK
2469 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2470 sleep 2;
e50380aa 2471 }
c356248b
AK
2472}
2473
2474sub talk_ftp {
2475 my($self,$command,@dialog) = @_;
2476 my $fh = FileHandle->new;
2477 $fh->open("|$command") or die "Couldn't open ftp: $!";
2478 foreach (@dialog) { $fh->print("$_\n") }
2479 $fh->close; # Wait for process to complete
2480 my $wstatus = $?;
2481 my $estatus = $wstatus >> 8;
2482 $CPAN::Frontend->myprint(qq{
2483Subprocess "|$command"
2484 returned status $estatus (wstat $wstatus)
2485}) if $wstatus;
05454584
AK
2486}
2487
e50380aa
AK
2488# find2perl needs modularization, too, all the following is stolen
2489# from there
09d9d230 2490# CPAN::FTP::ls
e50380aa
AK
2491sub ls {
2492 my($self,$name) = @_;
2493 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2494 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2495
2496 my($perms,%user,%group);
2497 my $pname = $name;
2498
55e314ee 2499 if ($blocks) {
e50380aa
AK
2500 $blocks = int(($blocks + 1) / 2);
2501 }
2502 else {
2503 $blocks = int(($sizemm + 1023) / 1024);
2504 }
2505
2506 if (-f _) { $perms = '-'; }
2507 elsif (-d _) { $perms = 'd'; }
2508 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2509 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2510 elsif (-p _) { $perms = 'p'; }
2511 elsif (-S _) { $perms = 's'; }
2512 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2513
2514 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2515 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2516 my $tmpmode = $mode;
2517 my $tmp = $rwx[$tmpmode & 7];
2518 $tmpmode >>= 3;
2519 $tmp = $rwx[$tmpmode & 7] . $tmp;
2520 $tmpmode >>= 3;
2521 $tmp = $rwx[$tmpmode & 7] . $tmp;
2522 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2523 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2524 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2525 $perms .= $tmp;
2526
2527 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2528 my $group = $group{$gid} || $gid;
2529
2530 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2531 my($timeyear);
2532 my($moname) = $moname[$mon];
2533 if (-M _ > 365.25 / 2) {
2534 $timeyear = $year + 1900;
2535 }
2536 else {
2537 $timeyear = sprintf("%02d:%02d", $hour, $min);
2538 }
2539
2540 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2541 $ino,
2542 $blocks,
2543 $perms,
2544 $nlink,
2545 $user,
2546 $group,
2547 $sizemm,
2548 $moname,
2549 $mday,
2550 $timeyear,
2551 $pname;
2552}
2553
05454584
AK
2554package CPAN::FTP::netrc;
2555
2556sub new {
2557 my($class) = @_;
2558 my $file = MM->catfile($ENV{HOME},".netrc");
2559
2560 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2561 $atime,$mtime,$ctime,$blksize,$blocks)
2562 = stat($file);
2563 $mode ||= 0;
2564 my $protected = 0;
2565
42d3b621
AK
2566 my($fh,@machines,$hasdefault);
2567 $hasdefault = 0;
da199366
AK
2568 $fh = FileHandle->new or die "Could not create a filehandle";
2569
2570 if($fh->open($file)){
2571 $protected = ($mode & 077) == 0;
10b2abe6 2572 local($/) = "";
42d3b621 2573 NETRC: while (<$fh>) {
da199366 2574 my(@tokens) = split " ", $_;
42d3b621
AK
2575 TOKEN: while (@tokens) {
2576 my($t) = shift @tokens;
da199366
AK
2577 if ($t eq "default"){
2578 $hasdefault++;
da199366
AK
2579 last NETRC;
2580 }
42d3b621
AK
2581 last TOKEN if $t eq "macdef";
2582 if ($t eq "machine") {
2583 push @machines, shift @tokens;
2584 }
2585 }
10b2abe6
CS
2586 }
2587 } else {
da199366 2588 $file = $hasdefault = $protected = "";
10b2abe6 2589 }
da199366 2590
10b2abe6 2591 bless {
42d3b621
AK
2592 'mach' => [@machines],
2593 'netrc' => $file,
2594 'hasdefault' => $hasdefault,
da199366 2595 'protected' => $protected,
10b2abe6
CS
2596 }, $class;
2597}
2598
42d3b621 2599sub hasdefault { shift->{'hasdefault'} }
da199366
AK
2600sub netrc { shift->{'netrc'} }
2601sub protected { shift->{'protected'} }
10b2abe6
CS
2602sub contains {
2603 my($self,$mach) = @_;
da199366
AK
2604 for ( @{$self->{'mach'}} ) {
2605 return 1 if $_ eq $mach;
2606 }
2607 return 0;
10b2abe6
CS
2608}
2609
5f05dabc 2610package CPAN::Complete;
5f05dabc 2611
36263cb3
GS
2612sub gnu_cpl {
2613 my($text, $line, $start, $end) = @_;
2614 my(@perlret) = cpl($text, $line, $start);
2615 # find longest common match. Can anybody show me how to peruse
2616 # T::R::Gnu to have this done automatically? Seems expensive.
2617 return () unless @perlret;
2618 my($newtext) = $text;
2619 for (my $i = length($text)+1;;$i++) {
2620 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2621 my $try = substr($perlret[0],0,$i);
2622 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2623 # warn "try[$try]tries[@tries]";
2624 if (@tries == @perlret) {
2625 $newtext = $try;
2626 } else {
2627 last;
2628 }
2629 }
2630 ($newtext,@perlret);
2631}
2632
55e314ee
AK
2633#-> sub CPAN::Complete::cpl ;
2634sub cpl {
5f05dabc
PP
2635 my($word,$line,$pos) = @_;
2636 $word ||= "";
2637 $line ||= "";
2638 $pos ||= 0;
2639 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2640 $line =~ s/^\s*//;
da199366
AK
2641 if ($line =~ s/^(force\s*)//) {
2642 $pos -= length($1);
2643 }
5f05dabc
PP
2644 my @return;
2645 if ($pos == 0) {
da199366
AK
2646 @return = grep(
2647 /^$word/,
2648 sort qw(
2649 ! a b d h i m o q r u autobundle clean
911a92db 2650 make test install force reload look cvs_import
da199366
AK
2651 )
2652 );
911a92db 2653 } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
5f05dabc
PP
2654 @return = ();
2655 } elsif ($line =~ /^a\s/) {
55e314ee 2656 @return = cplx('CPAN::Author',$word);
5f05dabc 2657 } elsif ($line =~ /^b\s/) {
55e314ee 2658 @return = cplx('CPAN::Bundle',$word);
5f05dabc 2659 } elsif ($line =~ /^d\s/) {
55e314ee 2660 @return = cplx('CPAN::Distribution',$word);
911a92db 2661 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) {
55e314ee 2662 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 2663 } elsif ($line =~ /^i\s/) {
55e314ee 2664 @return = cpl_any($word);
5f05dabc 2665 } elsif ($line =~ /^reload\s/) {
55e314ee 2666 @return = cpl_reload($word,$line,$pos);
5f05dabc 2667 } elsif ($line =~ /^o\s/) {
55e314ee 2668 @return = cpl_option($word,$line,$pos);
5f05dabc
PP
2669 } else {
2670 @return = ();
2671 }
2672 return @return;
2673}
2674
55e314ee
AK
2675#-> sub CPAN::Complete::cplx ;
2676sub cplx {
5f05dabc 2677 my($class, $word) = @_;
de34a54b
JH
2678 # I believed for many years that this was sorted, today I
2679 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2680 # make it sorted again. Maybe sort was dropped when GNU-readline
2681 # support came in? The RCS file is difficult to read on that:-(
2682 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
5f05dabc
PP
2683}
2684
55e314ee
AK
2685#-> sub CPAN::Complete::cpl_any ;
2686sub cpl_any {
5f05dabc
PP
2687 my($word) = shift;
2688 return (
55e314ee
AK
2689 cplx('CPAN::Author',$word),
2690 cplx('CPAN::Bundle',$word),
2691 cplx('CPAN::Distribution',$word),
2692 cplx('CPAN::Module',$word),
5f05dabc
PP
2693 );
2694}
2695
55e314ee
AK
2696#-> sub CPAN::Complete::cpl_reload ;
2697sub cpl_reload {
5f05dabc
PP
2698 my($word,$line,$pos) = @_;
2699 $word ||= "";
2700 my(@words) = split " ", $line;
2701 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2702 my(@ok) = qw(cpan index);
e50380aa
AK
2703 return @ok if @words == 1;
2704 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
5f05dabc
PP
2705}
2706
55e314ee
AK
2707#-> sub CPAN::Complete::cpl_option ;
2708sub cpl_option {
5f05dabc
PP
2709 my($word,$line,$pos) = @_;
2710 $word ||= "";
2711 my(@words) = split " ", $line;
2712 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2713 my(@ok) = qw(conf debug);
e50380aa 2714 return @ok if @words == 1;
c356248b 2715 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
5f05dabc
PP
2716 if (0) {
2717 } elsif ($words[1] eq 'index') {
2718 return ();
2719 } elsif ($words[1] eq 'conf') {
55e314ee 2720 return CPAN::Config::cpl(@_);
5f05dabc
PP
2721 } elsif ($words[1] eq 'debug') {
2722 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2723 }
2724}
2725
2726package CPAN::Index;
5f05dabc 2727
10b2abe6 2728#-> sub CPAN::Index::force_reload ;
5f05dabc
PP
2729sub force_reload {
2730 my($class) = @_;
2731 $CPAN::Index::last_time = 0;
2732 $class->reload(1);
2733}
2734
10b2abe6 2735#-> sub CPAN::Index::reload ;
5f05dabc
PP
2736sub reload {
2737 my($cl,$force) = @_;
2738 my $time = time;
2739
c356248b
AK
2740 # XXX check if a newer one is available. (We currently read it
2741 # from time to time)
e50380aa 2742 for ($CPAN::Config->{index_expire}) {
36263cb3 2743 $_ = 0.001 unless $_ && $_ > 0.001;
e50380aa 2744 }
c356248b
AK
2745 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2746 and ! $force;
911a92db
GS
2747 ## IFF we are developing, it helps to wipe out the memory between
2748 ## reloads, otherwise it is not what a user expects.
2749
2750 ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2751 ## $CPAN::META = CPAN->new;
e50380aa 2752 my($debug,$t2);
5f05dabc
PP
2753 $last_time = $time;
2754
c356248b
AK
2755 my $needshort = $^O eq "dos";
2756
f14b5cec
JH
2757 $cl->rd_authindex($cl
2758 ->reload_x(
2759 "authors/01mailrc.txt.gz",
2760 $needshort ?
2761 File::Spec->catfile('authors', '01mailrc.gz') :
2762 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2763 $force));
e50380aa
AK
2764 $t2 = time;
2765 $debug = "timing reading 01[".($t2 - $time)."]";
2766 $time = $t2;
5f05dabc 2767 return if $CPAN::Signal; # this is sometimes lengthy
f14b5cec
JH
2768 $cl->rd_modpacks($cl
2769 ->reload_x(
2770 "modules/02packages.details.txt.gz",
2771 $needshort ?
2772 File::Spec->catfile('modules', '02packag.gz') :
2773 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2774 $force));
e50380aa
AK
2775 $t2 = time;
2776 $debug .= "02[".($t2 - $time)."]";
2777 $time = $t2;
5f05dabc 2778 return if $CPAN::Signal; # this is sometimes lengthy
f14b5cec
JH
2779 $cl->rd_modlist($cl
2780 ->reload_x(
2781 "modules/03modlist.data.gz",
2782 $needshort ?
2783 File::Spec->catfile('modules', '03mlist.gz') :
2784 File::Spec->catfile('modules', '03modlist.data.gz'),
2785 $force));
e50380aa
AK
2786 $t2 = time;
2787 $debug .= "03[".($t2 - $time)."]";
2788 $time = $t2;
2789 CPAN->debug($debug) if $CPAN::DEBUG;
5f05dabc
PP
2790}
2791
10b2abe6 2792#-> sub CPAN::Index::reload_x ;
5f05dabc
PP
2793sub reload_x {
2794 my($cl,$wanted,$localname,$force) = @_;
c356248b 2795 $force |= 2; # means we're dealing with an index here
55e314ee
AK
2796 CPAN::Config->load; # we should guarantee loading wherever we rely
2797 # on Config XXX
c356248b
AK
2798 $localname ||= $wanted;
2799 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
55e314ee 2800 $localname);
e50380aa
AK
2801 if (
2802 -f $abs_wanted &&
05454584 2803 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
c356248b 2804 !($force & 1)
e50380aa
AK
2805 ) {
2806 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
05454584 2807 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
e50380aa 2808 qq{day$s. I\'ll use that.});
5f05dabc
PP
2809 return $abs_wanted;
2810 } else {
c356248b 2811 $force |= 1; # means we're quite serious about it.
5f05dabc
PP
2812 }
2813 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2814}
2815
55e314ee
AK
2816#-> sub CPAN::Index::rd_authindex ;
2817sub rd_authindex {
f14b5cec
JH
2818 my($cl, $index_target) = @_;
2819 my @lines;
c356248b 2820 return unless defined $index_target;
c356248b 2821 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230
A
2822# my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2823# while ($_ = $fh->READLINE) {
2824 # no strict 'refs';
2825 local(*FH);
2826 tie *FH, CPAN::Tarzip, $index_target;
52128c7b 2827 local($/) = "\n";
f14b5cec
JH
2828 push @lines, split /\012/ while <FH>;
2829 foreach (@lines) {
c356248b 2830 my($userid,$fullname,$email) =
f610777f 2831 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
5f05dabc
PP
2832 next unless $userid && $fullname && $email;
2833
2834 # instantiate an author object
2835 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2836 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2837 return if $CPAN::Signal;
2838 }
09d9d230
A
2839}
2840
2841sub userid {
2842 my($self,$dist) = @_;
2843 $dist = $self->{'id'} unless defined $dist;
2844 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2845 $ret;
5f05dabc
PP
2846}
2847
55e314ee
AK
2848#-> sub CPAN::Index::rd_modpacks ;
2849sub rd_modpacks {
f14b5cec
JH
2850 my($cl, $index_target) = @_;
2851 my @lines;
c356248b 2852 return unless defined $index_target;
c356248b 2853 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 2854 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
52128c7b 2855 local($/) = "\n";
09d9d230 2856 while ($_ = $fh->READLINE) {
f14b5cec
JH
2857 s/\012/\n/g;
2858 my @ls = map {"$_\n"} split /\n/, $_;
2859 unshift @ls, "\n" x length($1) if /^(\n+)/;
2860 push @lines, @ls;
e50380aa 2861 }
de34a54b
JH
2862 # read header
2863 my $line_count;
f14b5cec
JH
2864 while (@lines) {
2865 my $shift = shift(@lines);
de34a54b
JH
2866 $shift =~ /^Line-Count:\s+(\d+)/;
2867 $line_count = $1 if $1;
f14b5cec
JH
2868 last if $shift =~ /^\s*$/;
2869 }
de34a54b
JH
2870 if (not defined $line_count) {
2871 warn qq{Warning: Your $index_target does not contain a Line-Count header.
2872Please check the validity of the index file by comparing it to more than one CPAN
2873mirror. I'll continue but problems seem likely to happen.\a
2874};
2875 sleep 5;
2876 } elsif ($line_count != scalar @lines) {
2877
2878 warn sprintf qq{Warning: Your %s
2879contains a Line-Count header of %d but I see %d lines there. Please
2880check the validity of the index file by comparing it to more than one
2881CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
2882$index_target, $line_count, scalar(@lines);
2883
2884 }
f14b5cec 2885 foreach (@lines) {
5f05dabc
PP
2886 chomp;
2887 my($mod,$version,$dist) = split;
e50380aa 2888### $version =~ s/^\+//;
5f05dabc 2889
911a92db 2890 # if it is a bundle, instantiate a bundle object
e50380aa 2891 my($bundle,$id,$userid);
f610777f 2892
09d9d230
A
2893 if ($mod eq 'CPAN' &&
2894 ! (
f610777f
A
2895 CPAN::Queue->exists('Bundle::CPAN') ||
2896 CPAN::Queue->exists('CPAN')
09d9d230
A
2897 )
2898 ) {
e50380aa 2899 local($^W)= 0;
5f05dabc 2900 if ($version > $CPAN::VERSION){
c356248b 2901 $CPAN::Frontend->myprint(qq{
e50380aa 2902 There\'s a new CPAN.pm version (v$version) available!
911a92db 2903 [Current version is v$CPAN::VERSION]
e50380aa 2904 You might want to try
09d9d230 2905 install Bundle::CPAN
5f05dabc 2906 reload cpan
c356248b 2907 without quitting the current session. It should be a seamless upgrade
05454584 2908 while we are running...
c356248b 2909});
05454584 2910 sleep 2;
c356248b 2911 $CPAN::Frontend->myprint(qq{\n});
5f05dabc 2912 }
05454584 2913 last if $CPAN::Signal;
e50380aa
AK
2914 } elsif ($mod =~ /^Bundle::(.*)/) {
2915 $bundle = $1;
5f05dabc 2916 }
05454584 2917
05454584
AK
2918 if ($bundle){
2919 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2e2b7522 2920 # warn "made mod[$mod]a bundle";
c356248b
AK
2921 # Let's make it a module too, because bundles have so much
2922 # in common with modules
2923 $CPAN::META->instance('CPAN::Module',$mod);
2e2b7522 2924 # warn "made mod[$mod]a module";
c356248b 2925
05454584
AK
2926# This "next" makes us faster but if the job is running long, we ignore
2927# rereads which is bad. So we have to be a bit slower again.
2928# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2929# next;
c356248b
AK
2930
2931 }
2932 else {
05454584
AK
2933 # instantiate a module object
2934 $id = $CPAN::META->instance('CPAN::Module',$mod);
5f05dabc 2935 }
5f05dabc 2936
e50380aa 2937 if ($id->cpan_file ne $dist){
09d9d230 2938 $userid = $cl->userid($dist);
e50380aa
AK
2939 $id->set(
2940 'CPAN_USERID' => $userid,
2941 'CPAN_VERSION' => $version,
2942 'CPAN_FILE' => $dist
2943 );
2944 }
05454584
AK
2945
2946 # instantiate a distribution object
911a92db
GS
2947 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2948 # we do not need CONTAINSMODS unless we do something with
2949 # this dist, so we better produce it on demand.
2950
2951 ## my $obj = $CPAN::META->instance(
2952 ## 'CPAN::Distribution' => $dist
2953 ## );
2954 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
2955 } else {
2956 $CPAN::META->instance(
2957 'CPAN::Distribution' => $dist
2958 )->set(
2959 'CPAN_USERID' => $userid
2960 );
5f05dabc 2961 }
05454584
AK
2962
2963 return if $CPAN::Signal;
5f05dabc 2964 }
09d9d230 2965 undef $fh;
5f05dabc
PP
2966}
2967
55e314ee
AK
2968#-> sub CPAN::Index::rd_modlist ;
2969sub rd_modlist {
05454584 2970 my($cl,$index_target) = @_;
c356248b 2971 return unless defined $index_target;
c356248b 2972 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230
A
2973 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2974 my @eval;
52128c7b 2975 local($/) = "\n";
09d9d230 2976 while ($_ = $fh->READLINE) {
f14b5cec
JH
2977 s/\012/\n/g;
2978 my @ls = map {"$_\n"} split /\n/, $_;
2979 unshift @ls, "\n" x length($1) if /^(\n+)/;
2980 push @eval, @ls;
2981 }
2982 while (@eval) {
2983 my $shift = shift(@eval);
2984 if ($shift =~ /^Date:\s+(.*)/){
e50380aa
AK
2985 return if $date_of_03 eq $1;
2986 ($date_of_03) = $1;
2987 }
f14b5cec 2988 last if $shift =~ /^\s*$/;
05454584 2989 }
09d9d230
A
2990 undef $fh;
2991 push @eval, q{CPAN::Modulelist->data;};
05454584
AK
2992 local($^W) = 0;
2993 my($comp) = Safe->new("CPAN::Safe1");
09d9d230 2994 my($eval) = join("", @eval);
05454584
AK
2995 my $ret = $comp->reval($eval);
2996 Carp::confess($@) if $@;
2997 return if $CPAN::Signal;
2998 for (keys %$ret) {
2999 my $obj = $CPAN::META->instance(CPAN::Module,$_);
3000 $obj->set(%{$ret->{$_}});
3001 return if $CPAN::Signal;
3002 }
3003}
5f05dabc 3004
05454584 3005package CPAN::InfoObj;
5f05dabc 3006
05454584
AK
3007#-> sub CPAN::InfoObj::new ;
3008sub new { my $this = bless {}, shift; %$this = @_; $this }
5f05dabc 3009
05454584
AK
3010#-> sub CPAN::InfoObj::set ;
3011sub set {
3012 my($self,%att) = @_;
3013 my(%oldatt) = %$self;
3014 %$self = (%oldatt, %att);
da199366
AK
3015}
3016
05454584
AK
3017#-> sub CPAN::InfoObj::id ;
3018sub id { shift->{'ID'} }
5f05dabc 3019
05454584
AK
3020#-> sub CPAN::InfoObj::as_glimpse ;
3021sub as_glimpse {
5f05dabc 3022 my($self) = @_;
05454584
AK
3023 my(@m);
3024 my $class = ref($self);
3025 $class =~ s/^CPAN:://;
3026 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3027 join "", @m;
5f05dabc
PP
3028}
3029
05454584
AK
3030#-> sub CPAN::InfoObj::as_string ;
3031sub as_string {
3032 my($self) = @_;
3033 my(@m);
3034 my $class = ref($self);
3035 $class =~ s/^CPAN:://;
3036 push @m, $class, " id = $self->{ID}\n";
3037 for (sort keys %$self) {
3038 next if $_ eq 'ID';
3039 my $extra = "";
09d9d230
A
3040 if ($_ eq "CPAN_USERID") {
3041 $extra .= " (".$self->author;
3042 my $email; # old perls!
3043 if ($email = $CPAN::META->instance(CPAN::Author,
3044 $self->{$_}
3045 )->email) {
3046 $extra .= " <$email>";
3047 } else {
3048 $extra .= " <no email>";
3049 }
3050 $extra .= ")";
3051 }
3052 if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
911a92db
GS
3053 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
3054 } elsif (ref($self->{$_}) eq "HASH") {
3055 push @m, sprintf(
3056 " %-12s %s%s\n",
3057 $_,
3058 join(" ",keys %{$self->{$_}}),
3059 $extra);
5f05dabc 3060 } else {
911a92db 3061 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
05454584 3062 }
5f05dabc 3063 }
05454584 3064 join "", @m, "\n";
5f05dabc
PP
3065}
3066
05454584
AK
3067#-> sub CPAN::InfoObj::author ;
3068sub author {
3069 my($self) = @_;
3070 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
5f05dabc
PP
3071}
3072
36263cb3
GS
3073sub dump {
3074 my($self) = @_;
3075 require Data::Dumper;
3076 Data::Dumper::Dumper($self);
3077}
3078
05454584 3079package CPAN::Author;
05454584
AK
3080
3081#-> sub CPAN::Author::as_glimpse ;
3082sub as_glimpse {
5f05dabc 3083 my($self) = @_;
05454584
AK
3084 my(@m);
3085 my $class = ref($self);
3086 $class =~ s/^CPAN:://;
3087 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3088 join "", @m;
5f05dabc
PP
3089}
3090
05454584
AK
3091# Dead code, I would have liked to have,,, but it was never reached,,,
3092#sub make {
3093# my($self) = @_;
3094# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
3095#}
5f05dabc 3096
05454584
AK
3097#-> sub CPAN::Author::fullname ;
3098sub fullname { shift->{'FULLNAME'} }
3099*name = \&fullname;
36263cb3 3100
05454584
AK
3101#-> sub CPAN::Author::email ;
3102sub email { shift->{'EMAIL'} }
5f05dabc 3103
05454584 3104package CPAN::Distribution;
5f05dabc 3105
911a92db
GS
3106#-> sub CPAN::Distribution::as_string ;
3107sub as_string {
3108 my $self = shift;
3109 $self->containsmods;
3110 $self->SUPER::as_string(@_);
3111}
3112
3113#-> sub CPAN::Distribution::containsmods ;
3114sub containsmods {
3115 my $self = shift;
3116 return if exists $self->{CONTAINSMODS};
3117 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3118 my $mod_file = $mod->{CPAN_FILE} or next;
3119 my $dist_id = $self->{ID} or next;
3120 my $mod_id = $mod->{ID} or next;
3121 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3122 }
3123}
3124
05454584
AK
3125#-> sub CPAN::Distribution::called_for ;
3126sub called_for {
3127 my($self,$id) = @_;
3128 $self->{'CALLED_FOR'} = $id if defined $id;
3129 return $self->{'CALLED_FOR'};
5f05dabc
PP
3130}
3131
05454584
AK
3132#-> sub CPAN::Distribution::get ;
3133sub get {
5f05dabc 3134 my($self) = @_;
da199366
AK
3135 EXCUSE: {
3136 my @e;
05454584
AK
3137 exists $self->{'build_dir'} and push @e,
3138 "Unwrapped into directory $self->{'build_dir'}";
c356248b 3139 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
da199366 3140 }
05454584
AK
3141 my($local_file);
3142 my($local_wanted) =
c356248b 3143 MM->catfile(
05454584
AK
3144 $CPAN::Config->{keep_source_where},
3145 "authors",
3146 "id",
3147 split("/",$self->{ID})
3148 );
3149
3150 $self->debug("Doing localize") if $CPAN::DEBUG;
c356248b
AK
3151 $local_file =
3152 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3153 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
05454584
AK
3154 $self->{localfile} = $local_file;
3155 my $builddir = $CPAN::META->{cachemgr}->dir;
3156 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3157 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3158 my $packagedir;
3159
3160 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
55e314ee
AK
3161 if ($CPAN::META->has_inst('MD5')) {
3162 $self->debug("MD5 is installed, verifying");
05454584 3163 $self->verifyMD5;
55e314ee
AK
3164 } else {
3165 $self->debug("MD5 is NOT installed");
3166 }
3167 $self->debug("Removing tmp") if $CPAN::DEBUG;
3168 File::Path::rmtree("tmp");
3169 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
3170 chdir "tmp";
3171 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
c356248b
AK
3172 if (! $local_file) {
3173 Carp::croak "bad download, can't do anything :-(\n";
11860a17 3174 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
55e314ee 3175 $self->untar_me($local_file);
11860a17 3176 } elsif ( $local_file =~ /\.zip$/i ) {
55e314ee 3177 $self->unzip_me($local_file);
11860a17 3178 } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
55e314ee
AK
3179 $self->pm2dir_me($local_file);
3180 } else {
3181 $self->{archived} = "NO";
5f05dabc 3182 }
f14b5cec 3183 chdir File::Spec->updir;
55e314ee 3184 if ($self->{archived} ne 'NO') {
f14b5cec 3185 chdir File::Spec->catdir(File::Spec->curdir, "tmp");
05454584 3186 # Let's check if the package has its own directory.
f14b5cec
JH
3187 my $dh = DirHandle->new(File::Spec->curdir)
3188 or Carp::croak("Couldn't opendir .: $!");
11860a17 3189 my @readdir = grep $_ !~ /^\.\.?$/s, $dh->read; ### MAC??
55e314ee 3190 $dh->close;
05454584
AK
3191 my ($distdir,$packagedir);
3192 if (@readdir == 1 && -d $readdir[0]) {
3193 $distdir = $readdir[0];
c356248b
AK
3194 $packagedir = MM->catdir($builddir,$distdir);
3195 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
05454584
AK
3196 File::Path::rmtree($packagedir);
3197 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3198 } else {
3199 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
3200 $pragmatic_dir =~ s/\W_//g;
3201 $pragmatic_dir++ while -d "../$pragmatic_dir";
c356248b 3202 $packagedir = MM->catdir($builddir,$pragmatic_dir);
05454584
AK
3203 File::Path::mkpath($packagedir);
3204 my($f);
3205 for $f (@readdir) { # is already without "." and ".."
c356248b 3206 my $to = MM->catdir($packagedir,$f);
05454584
AK
3207 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3208 }
3209 }
3210 $self->{'build_dir'} = $packagedir;
f14b5cec 3211 chdir File::Spec->updir;
55e314ee 3212
05454584
AK
3213 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
3214 if $CPAN::DEBUG;
3215 File::Path::rmtree("tmp");
3216 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
c356248b 3217 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
05454584
AK
3218 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3219 }
c356248b 3220 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
05454584 3221 unless (-f $makefilepl) {
09d9d230
A
3222 my($configure) = MM->catfile($packagedir,"Configure");
3223 if (-f $configure) {
3224 # do we have anything to do?
3225 $self->{'configure'} = $configure;
3226 } elsif (-f MM->catfile($packagedir,"Makefile")) {
3227 $CPAN::Frontend->myprint(qq{
3228Package comes with a Makefile and without a Makefile.PL.
3229We\'ll try to build it with that Makefile then.
3230});
3231 $self->{writemakefile} = "YES";
3232 sleep 2;
3233 } else {
3234 my $fh = FileHandle->new(">$makefilepl")
3235 or Carp::croak("Could not open >$makefilepl");
3236 my $cf = $self->called_for || "unknown";
3237 $fh->print(
55e314ee
AK
3238qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3239# because there was no Makefile.PL supplied.
05454584 3240# Autogenerated on: }.scalar localtime().qq{
55e314ee 3241
09d9d230
A
3242use ExtUtils::MakeMaker;
3243WriteMakefile(NAME => q[$cf]);
55e314ee 3244
05454584 3245});
09d9d230
A
3246 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
3247 Writing one on our own (calling it $cf)\n});
05454584
AK
3248 }
3249 }
5f05dabc 3250 }
05454584 3251 return $self;
5f05dabc
PP
3252}
3253
55e314ee
AK
3254sub untar_me {
3255 my($self,$local_file) = @_;
3256 $self->{archived} = "tar";
09d9d230 3257 if (CPAN::Tarzip->untar($local_file)) {
55e314ee
AK
3258 $self->{unwrapped} = "YES";
3259 } else {
3260 $self->{unwrapped} = "NO";
3261 }
3262}
3263
3264sub unzip_me {
3265 my($self,$local_file) = @_;
de34a54b
JH
3266 if ($CPAN::META->has_inst("Archive::Zip")) {
3267 $CPAN::Frontend->mywarn("Archive::Zip not yet supported. ".
3268 "Will use external unzip");
3269 }
3270 my $unzip = $CPAN::Config->{unzip} or
3271 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
55e314ee 3272 $self->{archived} = "zip";
de34a54b
JH
3273 my @system = ($unzip, $local_file);
3274 if (system(@system) == 0) {
55e314ee
AK
3275 $self->{unwrapped} = "YES";
3276 } else {
3277 $self->{unwrapped} = "NO";
3278 }
3279}
3280
3281sub pm2dir_me {
3282 my($self,$local_file) = @_;
3283 $self->{archived} = "pm";
3284 my $to = File::Basename::basename($local_file);
11860a17 3285 $to =~ s/\.(gz|Z)$//;
09d9d230 3286 if (CPAN::Tarzip->gunzip($local_file,$to)) {
55e314ee
AK
3287 $self->{unwrapped} = "YES";
3288 } else {
3289 $self->{unwrapped} = "NO";
3290 }
3291}
3292
05454584
AK
3293#-> sub CPAN::Distribution::new ;
3294sub new {
3295 my($class,%att) = @_;
5f05dabc 3296
05454584 3297 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5f05dabc 3298
05454584
AK
3299 my $this = { %att };
3300 return bless $this, $class;
5f05dabc
PP
3301}
3302
05454584
AK
3303#-> sub CPAN::Distribution::look ;
3304sub look {
5f05dabc 3305 my($self) = @_;
36263cb3
GS
3306
3307 if ($^O eq 'MacOS') {
3308 $self->ExtUtils::MM_MacOS::look;
3309 return;
3310 }
3311
05454584 3312 if ( $CPAN::Config->{'shell'} ) {
c356248b 3313 $CPAN::Frontend->myprint(qq{
05454584 3314Trying to open a subshell in the build directory...
c356248b 3315});
05454584 3316 } else {
c356248b 3317 $CPAN::Frontend->myprint(qq{
05454584
AK
3318Your configuration does not define a value for subshells.
3319Please define it with "o conf shell <your shell>"
c356248b 3320});
05454584 3321 return;
5f05dabc 3322 }
05454584
AK
3323 my $dist = $self->id;
3324 my $dir = $self->dir or $self->get;
3325 $dir = $self->dir;
e50380aa
AK
3326 my $getcwd;
3327 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
55e314ee 3328 my $pwd = CPAN->$getcwd();
05454584 3329 chdir($dir);
c356248b
AK
3330 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3331 system($CPAN::Config->{'shell'}) == 0
3332 or $CPAN::Frontend->mydie("Subprocess shell error");
05454584 3333 chdir($pwd);
5f05dabc
PP
3334}
3335
911a92db
GS
3336sub cvs_import {
3337 my($self) = @_;
3338 $self->get;
3339 my $dir = $self->dir;
3340
3341 my $package = $self->called_for;
3342 my $module = $CPAN::META->instance('CPAN::Module', $package);
3343 my $version = $module->cpan_version;
3344
3345 my $userid = $self->{CPAN_USERID};
3346
3347 my $cvs_dir = (split '/', $dir)[-1];
11860a17 3348 $cvs_dir =~ s/-\d+[^-]+$//;
911a92db
GS
3349 my $cvs_root =
3350 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3351 my $cvs_site_perl =
3352 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3353 if ($cvs_site_perl) {
3354 $cvs_dir = "$cvs_site_perl/$cvs_dir";
3355 }
3356 my $cvs_log = qq{"imported $package $version sources"};
3357 $version =~ s/\./_/g;
3358 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3359 "$cvs_dir", $userid, "v$version");
3360
3361 my $getcwd;
3362 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3363 my $pwd = CPAN->$getcwd();
3364 chdir($dir);
3365
3366 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3367
3368 $CPAN::Frontend->myprint(qq{@cmd\n});
de34a54b 3369 system(@cmd) == 0 or
911a92db
GS
3370 $CPAN::Frontend->mydie("cvs import failed");
3371 chdir($pwd);
3372}
3373
05454584
AK
3374#-> sub CPAN::Distribution::readme ;
3375sub readme {
5f05dabc 3376 my($self) = @_;
05454584
AK
3377 my($dist) = $self->id;
3378 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3379 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3380 my($local_file);
3381 my($local_wanted) =
c356248b 3382 MM->catfile(
05454584
AK
3383 $CPAN::Config->{keep_source_where},
3384 "authors",
3385 "id",
3386 split("/","$sans.readme"),
3387 );
3388 $self->debug("Doing localize") if $CPAN::DEBUG;
c356248b
AK
3389 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3390 $local_wanted)
3391 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
f14b5cec
JH
3392
3393 if ($^O eq 'MacOS') {
3394 ExtUtils::MM_MacOS::launch_file($local_file);
3395 return;
3396 }
3397
05454584 3398 my $fh_pager = FileHandle->new;
c356248b 3399 local($SIG{PIPE}) = "IGNORE";
05454584
AK
3400 $fh_pager->open("|$CPAN::Config->{'pager'}")
3401 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3402 my $fh_readme = FileHandle->new;
c356248b
AK
3403 $fh_readme->open($local_file)
3404 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3405 $CPAN::Frontend->myprint(qq{
3406Displaying file
3407 $local_file
3408with pager "$CPAN::Config->{'pager'}"
3409});
3410 sleep 2;
05454584 3411 $fh_pager->print(<$fh_readme>);
5f05dabc
PP
3412}
3413
05454584
AK
3414#-> sub CPAN::Distribution::verifyMD5 ;
3415sub verifyMD5 {
5f05dabc 3416 my($self) = @_;
05454584
AK
3417 EXCUSE: {
3418 my @e;
3419 $self->{MD5_STATUS} ||= "";
3420 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
c356248b 3421 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 3422 }
55e314ee
AK
3423 my($lc_want,$lc_file,@local,$basename);
3424 @local = split("/",$self->{ID});
3425 pop @local;
05454584 3426 push @local, "CHECKSUMS";
55e314ee 3427 $lc_want =
c356248b 3428 MM->catfile($CPAN::Config->{keep_source_where},
55e314ee 3429 "authors", "id", @local);
05454584
AK
3430 local($") = "/";
3431 if (
c356248b 3432 -s $lc_want
05454584 3433 &&
55e314ee 3434 $self->MD5_check_file($lc_want)
05454584
AK
3435 ) {
3436 return $self->{MD5_STATUS} = "OK";
3437 }
55e314ee 3438 $lc_file = CPAN::FTP->localize("authors/id/@local",
c356248b 3439 $lc_want,1);
55e314ee 3440 unless ($lc_file) {
05454584 3441 $local[-1] .= ".gz";
55e314ee 3442 $lc_file = CPAN::FTP->localize("authors/id/@local",
c356248b
AK
3443 "$lc_want.gz",1);
3444 if ($lc_file) {
11860a17 3445 $lc_file =~ s/\.gz$//;
09d9d230 3446 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
c356248b
AK
3447 } else {
3448 return;
3449 }
05454584 3450 }
55e314ee 3451 $self->MD5_check_file($lc_file);
5f05dabc
PP
3452}
3453
05454584
AK
3454#-> sub CPAN::Distribution::MD5_check_file ;
3455sub MD5_check_file {
55e314ee
AK
3456 my($self,$chk_file) = @_;
3457 my($cksum,$file,$basename);
c356248b 3458 $file = $self->{localfile};
55e314ee
AK
3459 $basename = File::Basename::basename($file);
3460 my $fh = FileHandle->new;
55e314ee 3461 if (open $fh, $chk_file){
c356248b 3462 local($/);
05454584 3463 my $eval = <$fh>;
f14b5cec 3464 $eval =~ s/\015?\012/\n/g;
05454584
AK
3465 close $fh;
3466 my($comp) = Safe->new();
3467 $cksum = $comp->reval($eval);
55e314ee
AK
3468 if ($@) {
3469 rename $chk_file, "$chk_file.bad";
3470 Carp::confess($@) if $@;
3471 }
3472 } else {
3473 Carp::carp "Could not open $chk_file for reading";
3474 }
09d9d230
A
3475
3476 if (exists $cksum->{$basename}{md5}) {
55e314ee 3477 $self->debug("Found checksum for $basename:" .
09d9d230
A
3478 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3479
3480 open($fh, $file);
3481 binmode $fh;
3482 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3483 $fh->close;
3484 $fh = CPAN::Tarzip->TIEHANDLE($file);
3485
3486 unless ($eq) {
3487 # had to inline it, when I tied it, the tiedness got lost on
3488 # the call to eq_MD5. (Jan 1998)
3489 my $md5 = MD5->new;
3490 my($data,$ref);
3491 $ref = \$data;
36263cb3 3492 while ($fh->READ($ref, 4096) > 0){
09d9d230
A
3493 $md5->add($data);
3494 }
3495 my $hexdigest = $md5->hexdigest;
3496 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3497 }
3498
3499 if ($eq) {
3500 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3501 return $self->{MD5_STATUS} = "OK";
05454584 3502 } else {
de34a54b 3503 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
c356248b
AK
3504 qq{distribution file. }.
3505 qq{Please investigate.\n\n}.
3506 $self->as_string,
3507 $CPAN::META->instance(
3508 'CPAN::Author',
3509 $self->{CPAN_USERID}
3510 )->as_string);
de34a54b
JH
3511
3512 my $wrap = qq{I\'d recommend removing $file. Its MD5
3513checksum is incorrect. Maybe you have configured your \`urllist\' with
3514a bad URL. Please check this array with \`o conf urllist\', and
55e314ee 3515retry.};
de34a54b 3516
c356248b
AK
3517 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3518 $CPAN::Frontend->myprint("\n\n");
55e314ee 3519 sleep 3;
05454584 3520 return;
5f05dabc 3521 }
09d9d230 3522 # close $fh if fileno($fh);
5f05dabc 3523 } else {
55e314ee
AK
3524 $self->{MD5_STATUS} ||= "";
3525 if ($self->{MD5_STATUS} eq "NIL") {
c356248b
AK
3526 $CPAN::Frontend->myprint(qq{
3527No md5 checksum for $basename in local $chk_file.
3528Removing $chk_file
3529});
3530 unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
55e314ee
AK
3531 sleep 1;
3532 }
3533 $self->{MD5_STATUS} = "NIL";
3534 return;
5f05dabc
PP
3535 }
3536}
3537
05454584
AK
3538#-> sub CPAN::Distribution::eq_MD5 ;
3539sub eq_MD5 {
3540 my($self,$fh,$expectMD5) = @_;
55e314ee 3541 my $md5 = MD5->new;
09d9d230
A
3542 my($data);
3543 while (read($fh, $data, 4096)){
3544 $md5->add($data);
3545 }
3546 # $md5->addfile($fh);
05454584 3547 my $hexdigest = $md5->hexdigest;
09d9d230 3548 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
05454584
AK
3549 $hexdigest eq $expectMD5;
3550}
5f05dabc 3551
05454584 3552#-> sub CPAN::Distribution::force ;
5f05dabc 3553sub force {
f610777f
A
3554 my($self) = @_;
3555 $self->{'force_update'}++;
3556 for my $att (qw(
3557 MD5_STATUS archived build_dir localfile make install unwrapped
36263cb3 3558 writemakefile
f610777f
A
3559 )) {
3560 delete $self->{$att};
3561 }
5f05dabc
PP
3562}
3563
de34a54b 3564#-> sub CPAN::Distribution::isa_perl ;
09d9d230
A
3565sub isa_perl {
3566 my($self) = @_;
3567 my $file = File::Basename::basename($self->id);
3568 return unless $file =~ m{ ^ perl
de34a54b 3569 -?
09d9d230
A
3570 (5)
3571 ([._-])
de34a54b
JH
3572 (
3573 \d{3}(_[0-4][0-9])?
3574 |
3575 \d*[24680]\.\d+
3576 )
09d9d230 3577 \.tar[._-]gz
11860a17 3578 $
392d8ab8 3579 }xs;
09d9d230
A
3580 "$1.$3";
3581}
3582
d4fd5c69
AK
3583#-> sub CPAN::Distribution::perl ;
3584sub perl {
3585 my($self) = @_;
3586 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
e50380aa 3587 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
55e314ee 3588 my $pwd = CPAN->$getcwd();
c356248b 3589 my $candidate = MM->catfile($pwd,$^X);
e50380aa 3590 $perl ||= $candidate if MM->maybe_command($candidate);
d4fd5c69
AK
3591 unless ($perl) {
3592 my ($component,$perl_name);
911a92db 3593 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
c356248b
AK
3594 PATH_COMPONENT: foreach $component (MM->path(),
3595 $Config::Config{'binexp'}) {
d4fd5c69
AK
3596 next unless defined($component) && $component;
3597 my($abs) = MM->catfile($component,$perl_name);
3598 if (MM->maybe_command($abs)) {
3599 $perl = $abs;
3600 last DIST_PERLNAME;
3601 }
3602 }
3603 }
3604 }
3605 $perl;
3606}
3607
05454584
AK
3608#-> sub CPAN::Distribution::make ;
3609sub make {
3610 my($self) = @_;
c356248b 3611 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
09d9d230
A
3612 # Emergency brake if they said install Pippi and get newest perl
3613 if ($self->isa_perl) {
3614 if (
3615 $self->called_for ne $self->id && ! $self->{'force_update'}
3616 ) {
de34a54b
JH
3617 # if we die here, we break bundles
3618 $CPAN::Frontend->mywarn(sprintf qq{
09d9d230
A
3619The most recent version "%s" of the module "%s"
3620comes with the current version of perl (%s).
3621I\'ll build that only if you ask for something like
3622 force install %s
3623or
3624 install %s
3625},
3626 $CPAN::META->instance(
3627 'CPAN::Module',
3628 $self->called_for
3629 )->cpan_version,
3630 $self->called_for,
3631 $self->isa_perl,
3632 $self->called_for,
3633 $self->id);
de34a54b 3634 sleep 5; return;
09d9d230
A
3635 }
3636 }
05454584
AK
3637 $self->get;
3638 EXCUSE: {
3639 my @e;
3640 $self->{archived} eq "NO" and push @e,
3641 "Is neither a tar nor a zip archive.";
5f05dabc 3642
d4fd5c69 3643 $self->{unwrapped} eq "NO" and push @e,
05454584
AK
3644 "had problems unarchiving. Please build manually";
3645
3646 exists $self->{writemakefile} &&
36263cb3
GS
3647 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3648 $1 || "Had some problem writing Makefile";
05454584
AK
3649
3650 defined $self->{'make'} and push @e,
3651 "Has already been processed within this session";
3652
c356248b 3653 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5f05dabc 3654 }
c356248b 3655 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
05454584
AK
3656 my $builddir = $self->dir;
3657 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3658 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3659
f14b5cec
JH
3660 if ($^O eq 'MacOS') {
3661 ExtUtils::MM_MacOS::make($self);
3662 return;
3663 }
3664
05454584
AK
3665 my $system;
3666 if ($self->{'configure'}) {
09d9d230 3667 $system = $self->{'configure'};
5f05dabc 3668 } else {
d4fd5c69
AK
3669 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3670 my $switch = "";
3671# This needs a handler that can be turned on or off:
3672# $switch = "-MExtUtils::MakeMaker ".
3673# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3674# if $] > 5.00310;
3675 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3676 }
09d9d230 3677 unless (exists $self->{writemakefile}) {
e50380aa
AK
3678 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3679 my($ret,$pid);
3680 $@ = "";
3681 if ($CPAN::Config->{inactivity_timeout}) {
3682 eval {
3683 alarm $CPAN::Config->{inactivity_timeout};
f14b5cec 3684 local $SIG{CHLD}; # = sub { wait };
e50380aa
AK
3685 if (defined($pid = fork)) {
3686 if ($pid) { #parent
f14b5cec
JH
3687 # wait;
3688 waitpid $pid, 0;
e50380aa 3689 } else { #child
09d9d230
A
3690 # note, this exec isn't necessary if
3691 # inactivity_timeout is 0. On the Mac I'd
3692 # suggest, we set it always to 0.
3693 exec $system;
e50380aa
AK
3694 }
3695 } else {
c356248b 3696 $CPAN::Frontend->myprint("Cannot fork: $!");
e50380aa 3697 return;
05454584 3698 }
e50380aa
AK
3699 };
3700 alarm 0;
3701 if ($@){
3702 kill 9, $pid;
3703 waitpid $pid, 0;
c356248b 3704 $CPAN::Frontend->myprint($@);