This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Mac and other portability updates from Chris Nandor.
[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
05d2a450 9$VERSION = '1.57';
5f05dabc 10
05d2a450 11# $Id: CPAN.pm,v 1.305 2000/08/16 12:42:32 k Exp $
5f05dabc 12
c356248b
AK
13# only used during development:
14$Revision = "";
05d2a450 15# $Revision = "[".substr(q$Revision: 1.305 $, 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 $@;
05d2a450 185 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
c356248b
AK
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 {
05d2a450 298 $name =~ s|^(.*)$pkg\.pm(?!\n)\Z|$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 {
05d2a450 314 if ($name =~ s{(\w{12,})\.al(?!\n)\Z}{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 {
05d2a450 998 CPAN->debug("o[$o]") if $CPAN::DEBUG;
de34a54b 999 if ($o =~ /list$/) {
05454584
AK
1000 $func = shift @args;
1001 $func ||= "";
05d2a450 1002 CPAN->debug("func[$func]") if $CPAN::DEBUG;
de34a54b 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);
05d2a450 1322 next unless $entry =~ s/\.pm(?!\n)\Z//;
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};
05d2a450
A
1439 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1440 if $v & $CPAN::DEBUG;
05454584
AK
1441 }
1442 } else {
c356248b 1443 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
10b2abe6 1444 }
05454584 1445 } else {
c356248b 1446 $CPAN::Frontend->myprint(qq{
05454584
AK
1447Known options:
1448 conf set or get configuration variables
1449 debug set or get debugging options
c356248b 1450});
5f05dabc 1451 }
5f05dabc
PP
1452}
1453
36263cb3
GS
1454sub dotdot_onreload {
1455 my($ref) = shift;
1456 sub {
1457 if ( $_[0] =~ /Subroutine (\w+) redefined/ ) {
1458 my($subr) = $1;
1459 ++$$ref;
1460 local($|) = 1;
1461 # $CPAN::Frontend->myprint(".($subr)");
1462 $CPAN::Frontend->myprint(".");
1463 return;
1464 }
1465 warn @_;
1466 };
1467}
1468
05454584
AK
1469#-> sub CPAN::Shell::reload ;
1470sub reload {
d4fd5c69
AK
1471 my($self,$command,@arg) = @_;
1472 $command ||= "";
1473 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1474 if ($command =~ /cpan/i) {
05454584
AK
1475 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1476 my $fh = FileHandle->new($INC{'CPAN.pm'});
1477 local($/);
05454584 1478 $redef = 0;
36263cb3 1479 local($SIG{__WARN__}) = dotdot_onreload(\$redef);
05454584
AK
1480 eval <$fh>;
1481 warn $@ if $@;
c356248b 1482 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
d4fd5c69 1483 } elsif ($command =~ /index/) {
2e2b7522 1484 CPAN::Index->force_reload;
d4fd5c69 1485 } else {
2e2b7522 1486 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
f14b5cec 1487index re-reads the index files\n});
05454584
AK
1488 }
1489}
1490
1491#-> sub CPAN::Shell::_binary_extensions ;
1492sub _binary_extensions {
1493 my($self) = shift @_;
1494 my(@result,$module,%seen,%need,$headerdone);
1495 for $module ($self->expand('Module','/./')) {
1496 my $file = $module->cpan_file;
1497 next if $file eq "N/A";
1498 next if $file =~ /^Contact Author/;
05d2a450
A
1499 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1500 next if $dist->isa_perl;
05454584
AK
1501 next unless $module->xs_file;
1502 local($|) = 1;
c356248b 1503 $CPAN::Frontend->myprint(".");
05454584
AK
1504 push @result, $module;
1505 }
1506# print join " | ", @result;
c356248b 1507 $CPAN::Frontend->myprint("\n");
05454584
AK
1508 return @result;
1509}
1510
1511#-> sub CPAN::Shell::recompile ;
1512sub recompile {
1513 my($self) = shift @_;
1514 my($module,@module,$cpan_file,%dist);
1515 @module = $self->_binary_extensions();
c356248b
AK
1516 for $module (@module){ # we force now and compile later, so we
1517 # don't do it twice
05454584
AK
1518 $cpan_file = $module->cpan_file;
1519 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1520 $pack->force;
1521 $dist{$cpan_file}++;
1522 }
1523 for $cpan_file (sort keys %dist) {
c356248b 1524 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
05454584
AK
1525 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1526 $pack->install;
1527 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1528 # stop a package from recompiling,
1529 # e.g. IO-1.12 when we have perl5.003_10
1530 }
1531}
1532
1533#-> sub CPAN::Shell::_u_r_common ;
1534sub _u_r_common {
1535 my($self) = shift @_;
1536 my($what) = shift @_;
1537 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1538 Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
1539 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
1540 my(@args) = @_;
1541 @args = '/./' unless @args;
c356248b
AK
1542 my(@result,$module,%seen,%need,$headerdone,
1543 $version_undefs,$version_zeroes);
1544 $version_undefs = $version_zeroes = 0;
05454584
AK
1545 my $sprintf = "%-25s %9s %9s %s\n";
1546 for $module ($self->expand('Module',@args)) {
1547 my $file = $module->cpan_file;
1548 next unless defined $file; # ??
05d2a450 1549 my($latest) = $module->cpan_version; # %vd
05454584
AK
1550 my($inst_file) = $module->inst_file;
1551 my($have);
09d9d230 1552 return if $CPAN::Signal;
05454584
AK
1553 if ($inst_file){
1554 if ($what eq "a") {
05d2a450 1555 $have = $module->inst_version; # %vd
05454584 1556 } elsif ($what eq "r") {
05d2a450 1557 $have = $module->inst_version; # %vd
05454584 1558 local($^W) = 0;
c356248b
AK
1559 if ($have eq "undef"){
1560 $version_undefs++;
1561 } elsif ($have == 0){
1562 $version_zeroes++;
1563 }
05454584 1564 next if $have >= $latest;
c356248b
AK
1565# to be pedantic we should probably say:
1566# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1567# to catch the case where CPAN has a version 0 and we have a version undef
05454584
AK
1568 } elsif ($what eq "u") {
1569 next;
1570 }
1571 } else {
1572 if ($what eq "a") {
1573 next;
1574 } elsif ($what eq "r") {
1575 next;
1576 } elsif ($what eq "u") {
1577 $have = "-";
1578 }
1579 }
1580 return if $CPAN::Signal; # this is sometimes lengthy
1581 $seen{$file} ||= 0;
1582 if ($what eq "a") {
1583 push @result, sprintf "%s %s\n", $module->id, $have;
1584 } elsif ($what eq "r") {
1585 push @result, $module->id;
1586 next if $seen{$file}++;
1587 } elsif ($what eq "u") {
1588 push @result, $module->id;
1589 next if $seen{$file}++;
1590 next if $file =~ /^Contact/;
1591 }
1592 unless ($headerdone++){
c356248b
AK
1593 $CPAN::Frontend->myprint("\n");
1594 $CPAN::Frontend->myprint(sprintf(
05454584
AK
1595 $sprintf,
1596 "Package namespace",
1597 "installed",
1598 "latest",
1599 "in CPAN file"
c356248b 1600 ));
05454584 1601 }
05d2a450
A
1602 for ($have,$latest) {
1603 if ($] >= 5.006) { # people start using v-strings
1604 local($^W) = 0;
1605 unless (/^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
1606 && "$2$4" ne ""
1607 ||
1608 /^undef$/
1609 ||
1610 /^-$/ # not installed
1611 ) {
1612 $_ = sprintf "%vd", $_;
1613 }
1614 }
1615 $_ = substr($_,0,8) if length($_) > 8;
1616 }
1617 $CPAN::Frontend->myprint(sprintf $sprintf,
1618 $module->id,
1619 $have,
1620 $latest,
1621 $file);
05454584
AK
1622 $need{$module->id}++;
1623 }
1624 unless (%need) {
1625 if ($what eq "u") {
c356248b 1626 $CPAN::Frontend->myprint("No modules found for @args\n");
05454584 1627 } elsif ($what eq "r") {
c356248b 1628 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
05454584
AK
1629 }
1630 }
c356248b
AK
1631 if ($what eq "r") {
1632 if ($version_zeroes) {
1633 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1634 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1635 qq{a version number of 0\n});
1636 }
1637 if ($version_undefs) {
1638 my $s_has = $version_undefs > 1 ? "s have" : " has";
1639 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1640 qq{parseable version number\n});
1641 }
05454584
AK
1642 }
1643 @result;
1644}
1645
1646#-> sub CPAN::Shell::r ;
1647sub r {
1648 shift->_u_r_common("r",@_);
1649}
1650
1651#-> sub CPAN::Shell::u ;
1652sub u {
1653 shift->_u_r_common("u",@_);
1654}
1655
1656#-> sub CPAN::Shell::autobundle ;
1657sub autobundle {
1658 my($self) = shift;
36263cb3 1659 CPAN::Config->load unless $CPAN::Config_loaded++;
05454584 1660 my(@bundle) = $self->_u_r_common("a",@_);
c356248b 1661 my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
05454584
AK
1662 File::Path::mkpath($todir);
1663 unless (-d $todir) {
c356248b 1664 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
05454584
AK
1665 return;
1666 }
1667 my($y,$m,$d) = (localtime)[5,4,3];
1668 $y+=1900;
1669 $m++;
1670 my($c) = 0;
1671 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
c356248b 1672 my($to) = MM->catfile($todir,"$me.pm");
05454584
AK
1673 while (-f $to) {
1674 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
c356248b 1675 $to = MM->catfile($todir,"$me.pm");
05454584
AK
1676 }
1677 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1678 $fh->print(
1679 "package Bundle::$me;\n\n",
1680 "\$VERSION = '0.01';\n\n",
1681 "1;\n\n",
1682 "__END__\n\n",
1683 "=head1 NAME\n\n",
1684 "Bundle::$me - Snapshot of installation on ",
1685 $Config::Config{'myhostname'},
1686 " on ",
1687 scalar(localtime),
1688 "\n\n=head1 SYNOPSIS\n\n",
1689 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1690 "=head1 CONTENTS\n\n",
1691 join("\n", @bundle),
1692 "\n\n=head1 CONFIGURATION\n\n",
1693 Config->myconfig,
1694 "\n\n=head1 AUTHOR\n\n",
1695 "This Bundle has been generated automatically ",
1696 "by the autobundle routine in CPAN.pm.\n",
1697 );
1698 $fh->close;
c356248b
AK
1699 $CPAN::Frontend->myprint("\nWrote bundle file
1700 $to\n\n");
05454584
AK
1701}
1702
1703#-> sub CPAN::Shell::expand ;
1704sub expand {
1705 shift;
1706 my($type,@args) = @_;
1707 my($arg,@m);
1708 for $arg (@args) {
1709 my $regex;
1710 if ($arg =~ m|^/(.*)/$|) {
1711 $regex = $1;
1712 }
1713 my $class = "CPAN::$type";
1714 my $obj;
1715 if (defined $regex) {
911a92db
GS
1716 for $obj (
1717 sort
1718 {$a->id cmp $b->id}
1719 $CPAN::META->all_objects($class)
1720 ) {
1721 unless ($obj->id){
1722 # BUG, we got an empty object somewhere
1723 CPAN->debug(sprintf(
1724 "Empty id on obj[%s]%%[%s]",
1725 $obj,
1726 join(":", %$obj)
1727 )) if $CPAN::DEBUG;
1728 next;
1729 }
1730 push @m, $obj
1731 if $obj->id =~ /$regex/i
1732 or
05454584
AK
1733 (
1734 (
911a92db
GS
1735 $] < 5.00303 ### provide sort of
1736 ### compatibility with 5.003
05454584
AK
1737 ||
1738 $obj->can('name')
1739 )
1740 &&
1741 $obj->name =~ /$regex/i
1742 );
911a92db 1743 }
05454584
AK
1744 } else {
1745 my($xarg) = $arg;
1746 if ( $type eq 'Bundle' ) {
1747 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
1748 }
1749 if ($CPAN::META->exists($class,$xarg)) {
1750 $obj = $CPAN::META->instance($class,$xarg);
1751 } elsif ($CPAN::META->exists($class,$arg)) {
1752 $obj = $CPAN::META->instance($class,$arg);
1753 } else {
1754 next;
1755 }
1756 push @m, $obj;
1757 }
1758 }
e50380aa 1759 return wantarray ? @m : $m[0];
05454584
AK
1760}
1761
1762#-> sub CPAN::Shell::format_result ;
1763sub format_result {
1764 my($self) = shift;
1765 my($type,@args) = @_;
1766 @args = '/./' unless @args;
1767 my(@result) = $self->expand($type,@args);
e50380aa 1768 my $result = @result == 1 ?
05454584
AK
1769 $result[0]->as_string :
1770 join "", map {$_->as_glimpse} @result;
1771 $result ||= "No objects of type $type found for argument @args\n";
1772 $result;
1773}
1774
c356248b
AK
1775# The only reason for this method is currently to have a reliable
1776# debugging utility that reveals which output is going through which
1777# channel. No, I don't like the colors ;-)
1778sub print_ornamented {
1779 my($self,$what,$ornament) = @_;
1780 my $longest = 0;
1781 my $ornamenting = 0; # turn the colors on
1782
1783 if ($ornamenting) {
1784 unless (defined &color) {
1785 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1786 import Term::ANSIColor "color";
1787 } else {
1788 *color = sub { return "" };
1789 }
1790 }
09d9d230
A
1791 my $line;
1792 for $line (split /\n/, $what) {
c356248b
AK
1793 $longest = length($line) if length($line) > $longest;
1794 }
1795 my $sprintf = "%-" . $longest . "s";
1796 while ($what){
1797 $what =~ s/(.*\n?)//m;
1798 my $line = $1;
1799 last unless $line;
1800 my($nl) = chomp $line ? "\n" : "";
1801 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1802 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1803 }
1804 } else {
1805 print $what;
1806 }
1807}
1808
1809sub myprint {
1810 my($self,$what) = @_;
1811 $self->print_ornamented($what, 'bold blue on_yellow');
1812}
1813
1814sub myexit {
1815 my($self,$what) = @_;
1816 $self->myprint($what);
1817 exit;
1818}
1819
1820sub mywarn {
1821 my($self,$what) = @_;
1822 $self->print_ornamented($what, 'bold red on_yellow');
1823}
1824
1825sub myconfess {
1826 my($self,$what) = @_;
1827 $self->print_ornamented($what, 'bold red on_white');
1828 Carp::confess "died";
1829}
1830
1831sub mydie {
1832 my($self,$what) = @_;
1833 $self->print_ornamented($what, 'bold red on_white');
1834 die "\n";
1835}
1836
911a92db
GS
1837sub setup_output {
1838 return if -t STDOUT;
1839 my $odef = select STDERR;
1840 $| = 1;
1841 select STDOUT;
1842 $| = 1;
1843 select $odef;
1844}
1845
05454584 1846#-> sub CPAN::Shell::rematein ;
09d9d230 1847# RE-adme||MA-ke||TE-st||IN-stall
05454584
AK
1848sub rematein {
1849 shift;
1850 my($meth,@some) = @_;
1851 my $pragma = "";
1852 if ($meth eq 'force') {
1853 $pragma = $meth;
1854 $meth = shift @some;
1855 }
911a92db 1856 setup_output();
05454584
AK
1857 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
1858 my($s,@s);
1859 foreach $s (@some) {
f610777f
A
1860 CPAN::Queue->new($s);
1861 }
1862 while ($s = CPAN::Queue->first) {
05454584
AK
1863 my $obj;
1864 if (ref $s) {
1865 $obj = $s;
1866 } elsif ($s =~ m|/|) { # looks like a file
1867 $obj = $CPAN::META->instance('CPAN::Distribution',$s);
1868 } elsif ($s =~ m|^Bundle::|) {
1869 $obj = $CPAN::META->instance('CPAN::Bundle',$s);
1870 } else {
1871 $obj = $CPAN::META->instance('CPAN::Module',$s)
1872 if $CPAN::META->exists('CPAN::Module',$s);
1873 }
1874 if (ref $obj) {
1875 CPAN->debug(
f610777f 1876 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
05454584
AK
1877 $obj->as_string.
1878 qq{\]}
1879 ) if $CPAN::DEBUG;
1880 $obj->$pragma()
1881 if
1882 $pragma
1883 &&
09d9d230
A
1884 ($] < 5.00303 || $obj->can($pragma)); ###
1885 ### compatibility
1886 ### with
1887 ### 5.003
1888 if ($]>=5.00303 && $obj->can('called_for')) {
1889 $obj->called_for($s);
1890 }
f610777f
A
1891 CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
1892 # than once in
1893 # the queue
05454584
AK
1894 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
1895 $obj = $CPAN::META->instance('CPAN::Author',$s);
c356248b
AK
1896 $CPAN::Frontend->myprint(
1897 join "",
1898 "Don't be silly, you can't $meth ",
1899 $obj->fullname,
1900 " ;-)\n"
1901 );
05454584 1902 } else {
f610777f
A
1903 $CPAN::Frontend
1904 ->myprint(qq{Warning: Cannot $meth $s, }.
1905 qq{don\'t know what it is.
e50380aa
AK
1906Try the command
1907
1908 i /$s/
1909
1910to find objects with similar identifiers.
c356248b 1911});
05454584 1912 }
f610777f 1913 CPAN::Queue->delete_first($s);
05454584
AK
1914 }
1915}
1916
1917#-> sub CPAN::Shell::force ;
1918sub force { shift->rematein('force',@_); }
1919#-> sub CPAN::Shell::get ;
1920sub get { shift->rematein('get',@_); }
1921#-> sub CPAN::Shell::readme ;
1922sub readme { shift->rematein('readme',@_); }
1923#-> sub CPAN::Shell::make ;
1924sub make { shift->rematein('make',@_); }
1925#-> sub CPAN::Shell::test ;
1926sub test { shift->rematein('test',@_); }
1927#-> sub CPAN::Shell::install ;
1928sub install { shift->rematein('install',@_); }
1929#-> sub CPAN::Shell::clean ;
1930sub clean { shift->rematein('clean',@_); }
1931#-> sub CPAN::Shell::look ;
1932sub look { shift->rematein('look',@_); }
911a92db
GS
1933#-> sub CPAN::Shell::cvs_import ;
1934sub cvs_import { shift->rematein('cvs_import',@_); }
05454584
AK
1935
1936package CPAN::FTP;
05454584
AK
1937
1938#-> sub CPAN::FTP::ftp_get ;
1939sub ftp_get {
2e2b7522
GS
1940 my($class,$host,$dir,$file,$target) = @_;
1941 $class->debug(
1942 qq[Going to fetch file [$file] from dir [$dir]
05454584
AK
1943 on host [$host] as local [$target]\n]
1944 ) if $CPAN::DEBUG;
2e2b7522
GS
1945 my $ftp = Net::FTP->new($host);
1946 return 0 unless defined $ftp;
1947 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
1948 $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
1949 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
1950 warn "Couldn't login on $host";
1951 return;
1952 }
1953 unless ( $ftp->cwd($dir) ){
1954 warn "Couldn't cwd $dir";
1955 return;
1956 }
1957 $ftp->binary;
1958 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
1959 unless ( $ftp->get($file,$target) ){
1960 warn "Couldn't fetch $file from $host\n";
1961 return;
1962 }
1963 $ftp->quit; # it's ok if this fails
1964 return 1;
05454584
AK
1965}
1966
09d9d230 1967# If more accuracy is wanted/needed, Chris Leach sent me this patch...
f610777f 1968
09d9d230
A
1969 # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
1970 # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997
1971 # leach,> ***************
1972 # leach,> *** 1562,1567 ****
1973 # leach,> --- 1562,1580 ----
1974 # leach,> return 1 if substr($url,0,4) eq "file";
1975 # leach,> return 1 unless $url =~ m|://([^/]+)|;
1976 # leach,> my $host = $1;
1977 # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
1978 # leach,> + if ($proxy) {
1979 # leach,> + $proxy =~ m|://([^/:]+)|;
1980 # leach,> + $proxy = $1;
1981 # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
1982 # leach,> + if ($noproxy) {
1983 # leach,> + if ($host !~ /$noproxy$/) {
1984 # leach,> + $host = $proxy;
1985 # leach,> + }
1986 # leach,> + } else {
1987 # leach,> + $host = $proxy;
1988 # leach,> + }
1989 # leach,> + }
1990 # leach,> require Net::Ping;
1991 # leach,> return 1 unless $Net::Ping::VERSION >= 2;
1992 # leach,> my $p;
1993
1994
1995# this is quite optimistic and returns one on several occasions where
1996# inappropriate. But this does no harm. It would do harm if we were
1997# too pessimistic (as I was before the http_proxy
c356248b
AK
1998sub is_reachable {
1999 my($self,$url) = @_;
2000 return 1; # we can't simply roll our own, firewalls may break ping
2001 return 0 unless $url;
2002 return 1 if substr($url,0,4) eq "file";
09d9d230
A
2003 return 1 unless $url =~ m|^(\w+)://([^/]+)|;
2004 my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
2005 my $host = $2;
2006 return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
c356248b
AK
2007 require Net::Ping;
2008 return 1 unless $Net::Ping::VERSION >= 2;
2009 my $p;
09d9d230
A
2010 # 1.3101 had it different: only if the first eval raised an
2011 # exception we tried it with TCP. Now we are happy if icmp wins
2012 # the order and return, we don't even check for $@. Thanks to
2013 # thayer@uis.edu for the suggestion.
c356248b 2014 eval {$p = Net::Ping->new("icmp");};
09d9d230
A
2015 return 1 if $p && ref($p) && $p->ping($host, 10);
2016 eval {$p = Net::Ping->new("tcp");};
c356248b 2017 $CPAN::Frontend->mydie($@) if $@;
09d9d230 2018 return $p->ping($host, 10);
c356248b
AK
2019}
2020
05454584 2021#-> sub CPAN::FTP::localize ;
55e314ee
AK
2022# sorry for the ugly code here, I'll clean it up as soon as Net::FTP
2023# is in the core
05454584
AK
2024sub localize {
2025 my($self,$file,$aslocal,$force) = @_;
2026 $force ||= 0;
2027 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2028 unless defined $aslocal;
55e314ee
AK
2029 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2030 if $CPAN::DEBUG;
05454584 2031
f14b5cec
JH
2032 if ($^O eq 'MacOS') {
2033 my($name, $path) = File::Basename::fileparse($aslocal, '');
2034 if (length($name) > 31) {
2035 $name =~ s/(\.(readme(\.(gz|Z))?|(tar\.)?(gz|Z)|tgz|zip|pm\.(gz|Z)))$//;
2036 my $suf = $1;
2037 my $size = 31 - length($suf);
2038 while (length($name) > $size) {
2039 chop $name;
2040 }
2041 $name .= $suf;
2042 $aslocal = File::Spec->catfile($path, $name);
2043 }
2044 }
2045
c356248b 2046 return $aslocal if -f $aslocal && -r _ && !($force & 1);
55e314ee
AK
2047 my($restore) = 0;
2048 if (-f $aslocal){
2049 rename $aslocal, "$aslocal.bak";
2050 $restore++;
2051 }
05454584
AK
2052
2053 my($aslocal_dir) = File::Basename::dirname($aslocal);
2054 File::Path::mkpath($aslocal_dir);
c356248b 2055 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
05454584 2056 qq{directory "$aslocal_dir".
c356248b
AK
2057 I\'ll continue, but if you encounter problems, they may be due
2058 to insufficient permissions.\n}) unless -w $aslocal_dir;
05454584
AK
2059
2060 # Inheritance is not easier to manage than a few if/else branches
de34a54b 2061 if ($CPAN::META->has_usable('LWP::UserAgent')) {
05454584 2062 unless ($Ua) {
55e314ee 2063 $Ua = LWP::UserAgent->new;
05454584
AK
2064 my($var);
2065 $Ua->proxy('ftp', $var)
2066 if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
2067 $Ua->proxy('http', $var)
2068 if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2069 $Ua->no_proxy($var)
2070 if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2071 }
2072 }
2073
2074 # Try the list of urls for each single object. We keep a record
2075 # where we did get a file from
c356248b 2076 my(@reordered,$last);
09d9d230 2077 $CPAN::Config->{urllist} ||= [];
c356248b
AK
2078 $last = $#{$CPAN::Config->{urllist}};
2079 if ($force & 2) { # local cpans probably out of date, don't reorder
2080 @reordered = (0..$last);
2081 } else {
2082 @reordered =
2083 sort {
2084 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
f610777f 2085 <=>
c356248b
AK
2086 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2087 or
2088 defined($Thesite)
2089 and
2090 ($b == $Thesite)
2091 <=>
2092 ($a == $Thesite)
2093 } 0..$last;
c356248b
AK
2094 }
2095 my($level,@levels);
2096 if ($Themethod) {
2097 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2098 } else {
2099 @levels = qw/easy hard hardest/;
2100 }
f14b5cec 2101 @levels = qw/easy/ if $^O eq 'MacOS';
c356248b
AK
2102 for $level (@levels) {
2103 my $method = "host$level";
2104 my @host_seq = $level eq "easy" ?
2105 @reordered : 0..$last; # reordered has CDROM up front
09d9d230 2106 @host_seq = (0) unless @host_seq;
c356248b
AK
2107 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2108 if ($ret) {
2e2b7522 2109 $Themethod = $level;
911a92db
GS
2110 my $now = time;
2111 # utime $now, $now, $aslocal; # too bad, if we do that, we
2112 # might alter a local mirror
2e2b7522
GS
2113 $self->debug("level[$level]") if $CPAN::DEBUG;
2114 return $ret;
2115 } else {
2116 unlink $aslocal;
c356248b
AK
2117 }
2118 }
2119 my(@mess);
2120 push @mess,
2121 qq{Please check, if the URLs I found in your configuration file \(}.
2122 join(", ", @{$CPAN::Config->{urllist}}).
2123 qq{\) are valid. The urllist can be edited.},
2124 qq{E.g. with ``o conf urllist push ftp://myurl/''};
2125 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2126 sleep 2;
2127 $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
2128 if ($restore) {
2129 rename "$aslocal.bak", $aslocal;
2130 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2131 $self->ls($aslocal));
2132 return $aslocal;
2133 }
2134 return;
2135}
2136
2137sub hosteasy {
2138 my($self,$host_seq,$file,$aslocal) = @_;
05454584 2139 my($i);
c356248b 2140 HOSTEASY: for $i (@$host_seq) {
09d9d230 2141 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b
AK
2142 unless ($self->is_reachable($url)) {
2143 $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
2144 sleep 2;
2145 next;
2146 }
05454584
AK
2147 $url .= "/" unless substr($url,-1) eq "/";
2148 $url .= $file;
c356248b 2149 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
05454584
AK
2150 if ($url =~ /^file:/) {
2151 my $l;
de34a54b 2152 if ($CPAN::META->has_inst('URI::URL')) {
55e314ee 2153 my $u = URI::URL->new($url);
05454584
AK
2154 $l = $u->path;
2155 } else { # works only on Unix, is poorly constructed, but
c356248b
AK
2156 # hopefully better than nothing.
2157 # RFC 1738 says fileurl BNF is
2158 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2159 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2160 # the code
36263cb3
GS
2161 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2162 $l =~ s|^file:||; # assume they
2163 # meant
2164 # file://localhost
392d8ab8 2165 $l =~ s|^/||s unless -f $l; # e.g. /P:
05454584 2166 }
c356248b
AK
2167 if ( -f $l && -r _) {
2168 $Thesite = $i;
2169 return $l;
2170 }
05454584
AK
2171 # Maybe mirror has compressed it?
2172 if (-f "$l.gz") {
d4fd5c69 2173 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
09d9d230 2174 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
c356248b
AK
2175 if ( -f $aslocal) {
2176 $Thesite = $i;
2177 return $aslocal;
2178 }
05454584
AK
2179 }
2180 }
de34a54b 2181 if ($CPAN::META->has_usable('LWP')) {
09d9d230 2182 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
AK
2183 $url
2184");
f610777f
A
2185 unless ($Ua) {
2186 require LWP::UserAgent;
2187 $Ua = LWP::UserAgent->new;
2188 }
09d9d230
A
2189 my $res = $Ua->mirror($url, $aslocal);
2190 if ($res->is_success) {
2191 $Thesite = $i;
911a92db
GS
2192 my $now = time;
2193 utime $now, $now, $aslocal; # download time is more
2194 # important than upload time
09d9d230 2195 return $aslocal;
05d2a450 2196 } elsif ($url !~ /\.gz(?!\n)\Z/) {
09d9d230
A
2197 my $gzurl = "$url.gz";
2198 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
AK
2199 $gzurl
2200");
09d9d230
A
2201 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2202 if ($res->is_success &&
2203 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2204 ) {
2205 $Thesite = $i;
2206 return $aslocal;
c356248b 2207 } else {
09d9d230 2208 # next HOSTEASY ;
05454584 2209 }
09d9d230
A
2210 } else {
2211 # Alan Burlison informed me that in firewall envs Net::FTP
2212 # can still succeed where LWP fails. So we do not skip
2213 # Net::FTP anymore when LWP is available.
2214 # next HOSTEASY ;
2215 }
2216 } else {
2217 $self->debug("LWP not installed") if $CPAN::DEBUG;
05454584
AK
2218 }
2219 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2220 # that's the nice and easy way thanks to Graham
2221 my($host,$dir,$getfile) = ($1,$2,$3);
de34a54b 2222 if ($CPAN::META->has_usable('Net::FTP')) {
05454584 2223 $dir =~ s|/+|/|g;
c356248b 2224 $CPAN::Frontend->myprint("Fetching with Net::FTP:
09d9d230 2225 $url
c356248b
AK
2226");
2227 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2228 "aslocal[$aslocal]") if $CPAN::DEBUG;
2229 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2230 $Thesite = $i;
2231 return $aslocal;
2232 }
05d2a450 2233 if ($aslocal !~ /\.gz(?!\n)\Z/) {
c356248b
AK
2234 my $gz = "$aslocal.gz";
2235 $CPAN::Frontend->myprint("Fetching with Net::FTP
09d9d230 2236 $url.gz
c356248b 2237");
2e2b7522 2238 if (CPAN::FTP->ftp_get($host,
09d9d230
A
2239 $dir,
2240 "$getfile.gz",
2241 $gz) &&
2242 CPAN::Tarzip->gunzip($gz,$aslocal)
2243 ){
c356248b
AK
2244 $Thesite = $i;
2245 return $aslocal;
2246 }
2247 }
09d9d230 2248 # next HOSTEASY;
05454584
AK
2249 }
2250 }
c356248b
AK
2251 }
2252}
05454584 2253
c356248b 2254sub hosthard {
2e2b7522 2255 my($self,$host_seq,$file,$aslocal) = @_;
05454584 2256
2e2b7522
GS
2257 # Came back if Net::FTP couldn't establish connection (or
2258 # failed otherwise) Maybe they are behind a firewall, but they
2259 # gave us a socksified (or other) ftp program...
c356248b 2260
2e2b7522 2261 my($i);
f610777f 2262 my($devnull) = $CPAN::Config->{devnull} || "";
2e2b7522
GS
2263 # < /dev/null ";
2264 my($aslocal_dir) = File::Basename::dirname($aslocal);
2265 File::Path::mkpath($aslocal_dir);
c356248b 2266 HOSTHARD: for $i (@$host_seq) {
09d9d230 2267 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b 2268 unless ($self->is_reachable($url)) {
911a92db
GS
2269 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2270 next;
c356248b
AK
2271 }
2272 $url .= "/" unless substr($url,-1) eq "/";
2273 $url .= $file;
09d9d230
A
2274 my($proto,$host,$dir,$getfile);
2275
2276 # Courtesy Mark Conty mark_conty@cargill.com change from
2277 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2278 # to
2279 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
911a92db
GS
2280 # proto not yet used
2281 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
c356248b 2282 } else {
911a92db 2283 next HOSTHARD; # who said, we could ftp anything except ftp?
c356248b 2284 }
911a92db 2285
c356248b
AK
2286 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2287 my($f,$funkyftp);
2e2b7522 2288 for $f ('lynx','ncftpget','ncftp') {
911a92db
GS
2289 next unless exists $CPAN::Config->{$f};
2290 $funkyftp = $CPAN::Config->{$f};
2291 next unless defined $funkyftp;
2292 next if $funkyftp =~ /^\s*$/;
de34a54b
JH
2293 my($asl_ungz, $asl_gz);
2294 ($asl_ungz = $aslocal) =~ s/\.gz//;
2295 $asl_gz = "$asl_ungz.gz";
2296 my($src_switch) = "";
911a92db 2297 if ($f eq "lynx"){
de34a54b 2298 $src_switch = " -source";
911a92db 2299 } elsif ($f eq "ncftp"){
de34a54b 2300 $src_switch = " -c";
911a92db
GS
2301 }
2302 my($chdir) = "";
de34a54b 2303 my($stdout_redir) = " > $asl_ungz";
911a92db
GS
2304 if ($f eq "ncftpget"){
2305 $chdir = "cd $aslocal_dir && ";
2306 $stdout_redir = "";
2307 }
2308 $CPAN::Frontend->myprint(
2309 qq[
de34a54b 2310Trying with "$funkyftp$src_switch" to get
c356248b 2311 $url
2e2b7522 2312]);
911a92db 2313 my($system) =
de34a54b 2314 "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
911a92db
GS
2315 $self->debug("system[$system]") if $CPAN::DEBUG;
2316 my($wstatus);
2317 if (($wstatus = system($system)) == 0
2318 &&
2319 ($f eq "lynx" ?
de34a54b 2320 -s $asl_ungz # lynx returns 0 on my
911a92db
GS
2321 # system even if it fails
2322 : 1
2323 )
2324 ) {
2325 if (-s $aslocal) {
2326 # Looks good
de34a54b 2327 } elsif ($asl_ungz ne $aslocal) {
911a92db
GS
2328 # test gzip integrity
2329 if (
de34a54b 2330 CPAN::Tarzip->gtest($asl_ungz)
911a92db 2331 ) {
de34a54b 2332 rename $asl_ungz, $aslocal;
911a92db 2333 } else {
de34a54b 2334 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
911a92db
GS
2335 }
2336 }
2337 $Thesite = $i;
2338 return $aslocal;
05d2a450 2339 } elsif ($url !~ /\.gz(?!\n)\Z/) {
de34a54b
JH
2340 unlink $asl_ungz if
2341 -f $asl_ungz && -s _ == 0;
911a92db
GS
2342 my $gz = "$aslocal.gz";
2343 my $gzurl = "$url.gz";
2344 $CPAN::Frontend->myprint(
2345 qq[
de34a54b 2346Trying with "$funkyftp$src_switch" to get
911a92db
GS
2347 $url.gz
2348]);
de34a54b 2349 my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
55e314ee 2350 $self->debug("system[$system]") if $CPAN::DEBUG;
05454584 2351 my($wstatus);
55e314ee
AK
2352 if (($wstatus = system($system)) == 0
2353 &&
de34a54b 2354 -s $asl_gz
55e314ee 2355 ) {
911a92db 2356 # test gzip integrity
de34a54b
JH
2357 if (CPAN::Tarzip->gtest($asl_gz)) {
2358 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2e2b7522 2359 } else {
de34a54b 2360 rename $asl_ungz, $aslocal;
2e2b7522 2361 }
911a92db
GS
2362 $Thesite = $i;
2363 return $aslocal;
05454584 2364 } else {
de34a54b 2365 unlink $asl_gz if -f $asl_gz;
911a92db
GS
2366 }
2367 } else {
2368 my $estatus = $wstatus >> 8;
2369 my $size = -f $aslocal ?
2370 ", left\n$aslocal with size ".-s _ :
2371 "\nWarning: expected file [$aslocal] doesn't exist";
2372 $CPAN::Frontend->myprint(qq{
05454584 2373System call "$system"
c356248b
AK
2374returned status $estatus (wstat $wstatus)$size
2375});
911a92db 2376 }
05454584 2377 }
c356248b
AK
2378 }
2379}
05454584 2380
c356248b
AK
2381sub hosthardest {
2382 my($self,$host_seq,$file,$aslocal) = @_;
2383
2384 my($i);
2385 my($aslocal_dir) = File::Basename::dirname($aslocal);
2386 File::Path::mkpath($aslocal_dir);
2387 HOSTHARDEST: for $i (@$host_seq) {
2388 unless (length $CPAN::Config->{'ftp'}) {
2389 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2390 last HOSTHARDEST;
2391 }
09d9d230 2392 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b
AK
2393 unless ($self->is_reachable($url)) {
2394 $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
2395 next;
2396 }
2397 $url .= "/" unless substr($url,-1) eq "/";
2398 $url .= $file;
2399 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2400 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2401 next;
2402 }
2403 my($host,$dir,$getfile) = ($1,$2,$3);
c356248b
AK
2404 my $timestamp = 0;
2405 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2406 $ctime,$blksize,$blocks) = stat($aslocal);
2407 $timestamp = $mtime ||= 0;
2408 my($netrc) = CPAN::FTP::netrc->new;
911a92db 2409 my($netrcfile) = $netrc->netrc;
c356248b
AK
2410 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2411 my $targetfile = File::Basename::basename($aslocal);
2412 my(@dialog);
2413 push(
2414 @dialog,
2415 "lcd $aslocal_dir",
2416 "cd /",
2417 map("cd $_", split "/", $dir), # RFC 1738
2418 "bin",
2419 "get $getfile $targetfile",
2420 "quit"
2421 );
911a92db 2422 if (! $netrcfile) {
c356248b
AK
2423 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2424 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2425 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2426 $netrc->hasdefault,
2427 $netrc->contains($host))) if $CPAN::DEBUG;
2428 if ($netrc->protected) {
2429 $CPAN::Frontend->myprint(qq{
05454584
AK
2430 Trying with external ftp to get
2431 $url
2432 As this requires some features that are not thoroughly tested, we\'re
2433 not sure, that we get it right....
2434
2435}
c356248b
AK
2436 );
2437 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2438 @dialog);
05454584 2439 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
c356248b 2440 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
05454584
AK
2441 $mtime ||= 0;
2442 if ($mtime > $timestamp) {
c356248b
AK
2443 $CPAN::Frontend->myprint("GOT $aslocal\n");
2444 $Thesite = $i;
05454584
AK
2445 return $aslocal;
2446 } else {
c356248b 2447 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
05454584 2448 }
c356248b
AK
2449 } else {
2450 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2451 qq{correctly protected.\n});
05454584 2452 }
c356248b
AK
2453 } else {
2454 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2455 nor does it have a default entry\n");
05454584 2456 }
36263cb3 2457
c356248b
AK
2458 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2459 # then and login manually to host, using e-mail as
2460 # password.
2461 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2462 unshift(
2463 @dialog,
2464 "open $host",
2465 "user anonymous $Config::Config{'cf_email'}"
2466 );
2467 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2468 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2469 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2470 $mtime ||= 0;
2471 if ($mtime > $timestamp) {
2472 $CPAN::Frontend->myprint("GOT $aslocal\n");
2473 $Thesite = $i;
2474 return $aslocal;
2475 } else {
2476 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
05454584 2477 }
c356248b
AK
2478 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2479 sleep 2;
e50380aa 2480 }
c356248b
AK
2481}
2482
2483sub talk_ftp {
2484 my($self,$command,@dialog) = @_;
2485 my $fh = FileHandle->new;
2486 $fh->open("|$command") or die "Couldn't open ftp: $!";
2487 foreach (@dialog) { $fh->print("$_\n") }
2488 $fh->close; # Wait for process to complete
2489 my $wstatus = $?;
2490 my $estatus = $wstatus >> 8;
2491 $CPAN::Frontend->myprint(qq{
2492Subprocess "|$command"
2493 returned status $estatus (wstat $wstatus)
2494}) if $wstatus;
05454584
AK
2495}
2496
e50380aa
AK
2497# find2perl needs modularization, too, all the following is stolen
2498# from there
09d9d230 2499# CPAN::FTP::ls
e50380aa
AK
2500sub ls {
2501 my($self,$name) = @_;
2502 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2503 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2504
2505 my($perms,%user,%group);
2506 my $pname = $name;
2507
55e314ee 2508 if ($blocks) {
e50380aa
AK
2509 $blocks = int(($blocks + 1) / 2);
2510 }
2511 else {
2512 $blocks = int(($sizemm + 1023) / 1024);
2513 }
2514
2515 if (-f _) { $perms = '-'; }
2516 elsif (-d _) { $perms = 'd'; }
2517 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2518 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2519 elsif (-p _) { $perms = 'p'; }
2520 elsif (-S _) { $perms = 's'; }
2521 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2522
2523 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2524 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2525 my $tmpmode = $mode;
2526 my $tmp = $rwx[$tmpmode & 7];
2527 $tmpmode >>= 3;
2528 $tmp = $rwx[$tmpmode & 7] . $tmp;
2529 $tmpmode >>= 3;
2530 $tmp = $rwx[$tmpmode & 7] . $tmp;
2531 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2532 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2533 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2534 $perms .= $tmp;
2535
2536 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2537 my $group = $group{$gid} || $gid;
2538
2539 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2540 my($timeyear);
2541 my($moname) = $moname[$mon];
2542 if (-M _ > 365.25 / 2) {
2543 $timeyear = $year + 1900;
2544 }
2545 else {
2546 $timeyear = sprintf("%02d:%02d", $hour, $min);
2547 }
2548
2549 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2550 $ino,
2551 $blocks,
2552 $perms,
2553 $nlink,
2554 $user,
2555 $group,
2556 $sizemm,
2557 $moname,
2558 $mday,
2559 $timeyear,
2560 $pname;
2561}
2562
05454584
AK
2563package CPAN::FTP::netrc;
2564
2565sub new {
2566 my($class) = @_;
2567 my $file = MM->catfile($ENV{HOME},".netrc");
2568
2569 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2570 $atime,$mtime,$ctime,$blksize,$blocks)
2571 = stat($file);
2572 $mode ||= 0;
2573 my $protected = 0;
2574
42d3b621
AK
2575 my($fh,@machines,$hasdefault);
2576 $hasdefault = 0;
da199366
AK
2577 $fh = FileHandle->new or die "Could not create a filehandle";
2578
2579 if($fh->open($file)){
2580 $protected = ($mode & 077) == 0;
10b2abe6 2581 local($/) = "";
42d3b621 2582 NETRC: while (<$fh>) {
da199366 2583 my(@tokens) = split " ", $_;
42d3b621
AK
2584 TOKEN: while (@tokens) {
2585 my($t) = shift @tokens;
da199366
AK
2586 if ($t eq "default"){
2587 $hasdefault++;
da199366
AK
2588 last NETRC;
2589 }
42d3b621
AK
2590 last TOKEN if $t eq "macdef";
2591 if ($t eq "machine") {
2592 push @machines, shift @tokens;
2593 }
2594 }
10b2abe6
CS
2595 }
2596 } else {
da199366 2597 $file = $hasdefault = $protected = "";
10b2abe6 2598 }
da199366 2599
10b2abe6 2600 bless {
42d3b621
AK
2601 'mach' => [@machines],
2602 'netrc' => $file,
2603 'hasdefault' => $hasdefault,
da199366 2604 'protected' => $protected,
10b2abe6
CS
2605 }, $class;
2606}
2607
42d3b621 2608sub hasdefault { shift->{'hasdefault'} }
da199366
AK
2609sub netrc { shift->{'netrc'} }
2610sub protected { shift->{'protected'} }
10b2abe6
CS
2611sub contains {
2612 my($self,$mach) = @_;
da199366
AK
2613 for ( @{$self->{'mach'}} ) {
2614 return 1 if $_ eq $mach;
2615 }
2616 return 0;
10b2abe6
CS
2617}
2618
5f05dabc 2619package CPAN::Complete;
5f05dabc 2620
36263cb3
GS
2621sub gnu_cpl {
2622 my($text, $line, $start, $end) = @_;
2623 my(@perlret) = cpl($text, $line, $start);
2624 # find longest common match. Can anybody show me how to peruse
2625 # T::R::Gnu to have this done automatically? Seems expensive.
2626 return () unless @perlret;
2627 my($newtext) = $text;
2628 for (my $i = length($text)+1;;$i++) {
2629 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2630 my $try = substr($perlret[0],0,$i);
2631 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2632 # warn "try[$try]tries[@tries]";
2633 if (@tries == @perlret) {
2634 $newtext = $try;
2635 } else {
2636 last;
2637 }
2638 }
2639 ($newtext,@perlret);
2640}
2641
55e314ee
AK
2642#-> sub CPAN::Complete::cpl ;
2643sub cpl {
5f05dabc
PP
2644 my($word,$line,$pos) = @_;
2645 $word ||= "";
2646 $line ||= "";
2647 $pos ||= 0;
2648 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2649 $line =~ s/^\s*//;
da199366
AK
2650 if ($line =~ s/^(force\s*)//) {
2651 $pos -= length($1);
2652 }
5f05dabc
PP
2653 my @return;
2654 if ($pos == 0) {
da199366
AK
2655 @return = grep(
2656 /^$word/,
2657 sort qw(
2658 ! a b d h i m o q r u autobundle clean
911a92db 2659 make test install force reload look cvs_import
da199366
AK
2660 )
2661 );
911a92db 2662 } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
5f05dabc
PP
2663 @return = ();
2664 } elsif ($line =~ /^a\s/) {
55e314ee 2665 @return = cplx('CPAN::Author',$word);
5f05dabc 2666 } elsif ($line =~ /^b\s/) {
55e314ee 2667 @return = cplx('CPAN::Bundle',$word);
5f05dabc 2668 } elsif ($line =~ /^d\s/) {
55e314ee 2669 @return = cplx('CPAN::Distribution',$word);
911a92db 2670 } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) {
55e314ee 2671 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 2672 } elsif ($line =~ /^i\s/) {
55e314ee 2673 @return = cpl_any($word);
5f05dabc 2674 } elsif ($line =~ /^reload\s/) {
55e314ee 2675 @return = cpl_reload($word,$line,$pos);
5f05dabc 2676 } elsif ($line =~ /^o\s/) {
55e314ee 2677 @return = cpl_option($word,$line,$pos);
5f05dabc
PP
2678 } else {
2679 @return = ();
2680 }
2681 return @return;
2682}
2683
55e314ee
AK
2684#-> sub CPAN::Complete::cplx ;
2685sub cplx {
5f05dabc 2686 my($class, $word) = @_;
de34a54b
JH
2687 # I believed for many years that this was sorted, today I
2688 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2689 # make it sorted again. Maybe sort was dropped when GNU-readline
2690 # support came in? The RCS file is difficult to read on that:-(
2691 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
5f05dabc
PP
2692}
2693
55e314ee
AK
2694#-> sub CPAN::Complete::cpl_any ;
2695sub cpl_any {
5f05dabc
PP
2696 my($word) = shift;
2697 return (
55e314ee
AK
2698 cplx('CPAN::Author',$word),
2699 cplx('CPAN::Bundle',$word),
2700 cplx('CPAN::Distribution',$word),
2701 cplx('CPAN::Module',$word),
5f05dabc
PP
2702 );
2703}
2704
55e314ee
AK
2705#-> sub CPAN::Complete::cpl_reload ;
2706sub cpl_reload {
5f05dabc
PP
2707 my($word,$line,$pos) = @_;
2708 $word ||= "";
2709 my(@words) = split " ", $line;
2710 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2711 my(@ok) = qw(cpan index);
e50380aa
AK
2712 return @ok if @words == 1;
2713 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
5f05dabc
PP
2714}
2715
55e314ee
AK
2716#-> sub CPAN::Complete::cpl_option ;
2717sub cpl_option {
5f05dabc
PP
2718 my($word,$line,$pos) = @_;
2719 $word ||= "";
2720 my(@words) = split " ", $line;
2721 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2722 my(@ok) = qw(conf debug);
e50380aa 2723 return @ok if @words == 1;
c356248b 2724 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
5f05dabc
PP
2725 if (0) {
2726 } elsif ($words[1] eq 'index') {
2727 return ();
2728 } elsif ($words[1] eq 'conf') {
55e314ee 2729 return CPAN::Config::cpl(@_);
5f05dabc
PP
2730 } elsif ($words[1] eq 'debug') {
2731 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2732 }
2733}
2734
2735package CPAN::Index;
5f05dabc 2736
10b2abe6 2737#-> sub CPAN::Index::force_reload ;
5f05dabc
PP
2738sub force_reload {
2739 my($class) = @_;
2740 $CPAN::Index::last_time = 0;
2741 $class->reload(1);
2742}
2743
10b2abe6 2744#-> sub CPAN::Index::reload ;
5f05dabc
PP
2745sub reload {
2746 my($cl,$force) = @_;
2747 my $time = time;
2748
c356248b
AK
2749 # XXX check if a newer one is available. (We currently read it
2750 # from time to time)
e50380aa 2751 for ($CPAN::Config->{index_expire}) {
36263cb3 2752 $_ = 0.001 unless $_ && $_ > 0.001;
e50380aa 2753 }
c356248b
AK
2754 return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
2755 and ! $force;
911a92db
GS
2756 ## IFF we are developing, it helps to wipe out the memory between
2757 ## reloads, otherwise it is not what a user expects.
2758
2759 ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
2760 ## $CPAN::META = CPAN->new;
e50380aa 2761 my($debug,$t2);
5f05dabc
PP
2762 $last_time = $time;
2763
c356248b
AK
2764 my $needshort = $^O eq "dos";
2765
f14b5cec
JH
2766 $cl->rd_authindex($cl
2767 ->reload_x(
2768 "authors/01mailrc.txt.gz",
2769 $needshort ?
2770 File::Spec->catfile('authors', '01mailrc.gz') :
2771 File::Spec->catfile('authors', '01mailrc.txt.gz'),
2772 $force));
e50380aa
AK
2773 $t2 = time;
2774 $debug = "timing reading 01[".($t2 - $time)."]";
2775 $time = $t2;
5f05dabc 2776 return if $CPAN::Signal; # this is sometimes lengthy
f14b5cec
JH
2777 $cl->rd_modpacks($cl
2778 ->reload_x(
2779 "modules/02packages.details.txt.gz",
2780 $needshort ?
2781 File::Spec->catfile('modules', '02packag.gz') :
2782 File::Spec->catfile('modules', '02packages.details.txt.gz'),
2783 $force));
e50380aa
AK
2784 $t2 = time;
2785 $debug .= "02[".($t2 - $time)."]";
2786 $time = $t2;
5f05dabc 2787 return if $CPAN::Signal; # this is sometimes lengthy
f14b5cec
JH
2788 $cl->rd_modlist($cl
2789 ->reload_x(
2790 "modules/03modlist.data.gz",
2791 $needshort ?
2792 File::Spec->catfile('modules', '03mlist.gz') :
2793 File::Spec->catfile('modules', '03modlist.data.gz'),
2794 $force));
e50380aa
AK
2795 $t2 = time;
2796 $debug .= "03[".($t2 - $time)."]";
2797 $time = $t2;
2798 CPAN->debug($debug) if $CPAN::DEBUG;
5f05dabc
PP
2799}
2800
10b2abe6 2801#-> sub CPAN::Index::reload_x ;
5f05dabc
PP
2802sub reload_x {
2803 my($cl,$wanted,$localname,$force) = @_;
c356248b 2804 $force |= 2; # means we're dealing with an index here
55e314ee
AK
2805 CPAN::Config->load; # we should guarantee loading wherever we rely
2806 # on Config XXX
c356248b
AK
2807 $localname ||= $wanted;
2808 my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
55e314ee 2809 $localname);
e50380aa
AK
2810 if (
2811 -f $abs_wanted &&
05454584 2812 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
c356248b 2813 !($force & 1)
e50380aa
AK
2814 ) {
2815 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
05454584 2816 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
e50380aa 2817 qq{day$s. I\'ll use that.});
5f05dabc
PP
2818 return $abs_wanted;
2819 } else {
c356248b 2820 $force |= 1; # means we're quite serious about it.
5f05dabc
PP
2821 }
2822 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
2823}
2824
55e314ee
AK
2825#-> sub CPAN::Index::rd_authindex ;
2826sub rd_authindex {
f14b5cec
JH
2827 my($cl, $index_target) = @_;
2828 my @lines;
c356248b 2829 return unless defined $index_target;
c356248b 2830 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230
A
2831# my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2832# while ($_ = $fh->READLINE) {
2833 # no strict 'refs';
2834 local(*FH);
2835 tie *FH, CPAN::Tarzip, $index_target;
52128c7b 2836 local($/) = "\n";
f14b5cec
JH
2837 push @lines, split /\012/ while <FH>;
2838 foreach (@lines) {
c356248b 2839 my($userid,$fullname,$email) =
f610777f 2840 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
5f05dabc
PP
2841 next unless $userid && $fullname && $email;
2842
2843 # instantiate an author object
2844 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
2845 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
2846 return if $CPAN::Signal;
2847 }
09d9d230
A
2848}
2849
2850sub userid {
2851 my($self,$dist) = @_;
2852 $dist = $self->{'id'} unless defined $dist;
2853 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
2854 $ret;
5f05dabc
PP
2855}
2856
55e314ee
AK
2857#-> sub CPAN::Index::rd_modpacks ;
2858sub rd_modpacks {
05d2a450 2859 my($self, $index_target) = @_;
f14b5cec 2860 my @lines;
c356248b 2861 return unless defined $index_target;
c356248b 2862 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 2863 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
52128c7b 2864 local($/) = "\n";
09d9d230 2865 while ($_ = $fh->READLINE) {
f14b5cec
JH
2866 s/\012/\n/g;
2867 my @ls = map {"$_\n"} split /\n/, $_;
2868 unshift @ls, "\n" x length($1) if /^(\n+)/;
2869 push @lines, @ls;
e50380aa 2870 }
de34a54b
JH
2871 # read header
2872 my $line_count;
f14b5cec
JH
2873 while (@lines) {
2874 my $shift = shift(@lines);
de34a54b
JH
2875 $shift =~ /^Line-Count:\s+(\d+)/;
2876 $line_count = $1 if $1;
f14b5cec
JH
2877 last if $shift =~ /^\s*$/;
2878 }
de34a54b 2879 if (not defined $line_count) {
05d2a450 2880
de34a54b 2881 warn qq{Warning: Your $index_target does not contain a Line-Count header.
05d2a450
A
2882Please check the validity of the index file by comparing it to more
2883than one CPAN mirror. I'll continue but problems seem likely to
2884happen.\a
de34a54b 2885};
05d2a450 2886
de34a54b
JH
2887 sleep 5;
2888 } elsif ($line_count != scalar @lines) {
2889
2890 warn sprintf qq{Warning: Your %s
2891contains a Line-Count header of %d but I see %d lines there. Please
2892check the validity of the index file by comparing it to more than one
2893CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
2894$index_target, $line_count, scalar(@lines);
2895
2896 }
f14b5cec 2897 foreach (@lines) {
5f05dabc 2898 chomp;
05d2a450
A
2899 # before 1.56 we split into 3 and discarded the rest. From
2900 # 1.57 we assign remaining text to $comment thus allowing to
2901 # influence isa_perl
2902 my($mod,$version,$dist,$comment) = split " ", $_, 4;
e50380aa 2903### $version =~ s/^\+//;
5f05dabc 2904
911a92db 2905 # if it is a bundle, instantiate a bundle object
e50380aa 2906 my($bundle,$id,$userid);
f610777f 2907
09d9d230
A
2908 if ($mod eq 'CPAN' &&
2909 ! (
f610777f
A
2910 CPAN::Queue->exists('Bundle::CPAN') ||
2911 CPAN::Queue->exists('CPAN')
09d9d230
A
2912 )
2913 ) {
e50380aa 2914 local($^W)= 0;
5f05dabc 2915 if ($version > $CPAN::VERSION){
c356248b 2916 $CPAN::Frontend->myprint(qq{
e50380aa 2917 There\'s a new CPAN.pm version (v$version) available!
911a92db 2918 [Current version is v$CPAN::VERSION]
e50380aa 2919 You might want to try
09d9d230 2920 install Bundle::CPAN
5f05dabc 2921 reload cpan
c356248b 2922 without quitting the current session. It should be a seamless upgrade
05454584 2923 while we are running...
c356248b 2924});
05454584 2925 sleep 2;
c356248b 2926 $CPAN::Frontend->myprint(qq{\n});
5f05dabc 2927 }
05454584 2928 last if $CPAN::Signal;
e50380aa
AK
2929 } elsif ($mod =~ /^Bundle::(.*)/) {
2930 $bundle = $1;
5f05dabc 2931 }
05454584 2932
05454584
AK
2933 if ($bundle){
2934 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
2e2b7522 2935 # warn "made mod[$mod]a bundle";
c356248b
AK
2936 # Let's make it a module too, because bundles have so much
2937 # in common with modules
2938 $CPAN::META->instance('CPAN::Module',$mod);
2e2b7522 2939 # warn "made mod[$mod]a module";
c356248b 2940
05454584
AK
2941# This "next" makes us faster but if the job is running long, we ignore
2942# rereads which is bad. So we have to be a bit slower again.
2943# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
2944# next;
c356248b
AK
2945
2946 }
2947 else {
05454584
AK
2948 # instantiate a module object
2949 $id = $CPAN::META->instance('CPAN::Module',$mod);
5f05dabc 2950 }
5f05dabc 2951
e50380aa 2952 if ($id->cpan_file ne $dist){
05d2a450 2953 $userid = $self->userid($dist);
e50380aa
AK
2954 $id->set(
2955 'CPAN_USERID' => $userid,
05d2a450
A
2956 'CPAN_VERSION' => $version, # %vd
2957 'CPAN_FILE' => $dist,
2958 'CPAN_COMMENT' => $comment,
e50380aa
AK
2959 );
2960 }
05454584
AK
2961
2962 # instantiate a distribution object
911a92db
GS
2963 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
2964 # we do not need CONTAINSMODS unless we do something with
2965 # this dist, so we better produce it on demand.
2966
2967 ## my $obj = $CPAN::META->instance(
2968 ## 'CPAN::Distribution' => $dist
2969 ## );
2970 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
2971 } else {
2972 $CPAN::META->instance(
2973 'CPAN::Distribution' => $dist
2974 )->set(
2975 'CPAN_USERID' => $userid
2976 );
5f05dabc 2977 }
05454584
AK
2978
2979 return if $CPAN::Signal;
5f05dabc 2980 }
09d9d230 2981 undef $fh;
5f05dabc
PP
2982}
2983
55e314ee
AK
2984#-> sub CPAN::Index::rd_modlist ;
2985sub rd_modlist {
05454584 2986 my($cl,$index_target) = @_;
c356248b 2987 return unless defined $index_target;
c356248b 2988 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230
A
2989 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
2990 my @eval;
52128c7b 2991 local($/) = "\n";
09d9d230 2992 while ($_ = $fh->READLINE) {
f14b5cec
JH
2993 s/\012/\n/g;
2994 my @ls = map {"$_\n"} split /\n/, $_;
2995 unshift @ls, "\n" x length($1) if /^(\n+)/;
2996 push @eval, @ls;
2997 }
2998 while (@eval) {
2999 my $shift = shift(@eval);
3000 if ($shift =~ /^Date:\s+(.*)/){
e50380aa
AK
3001 return if $date_of_03 eq $1;
3002 ($date_of_03) = $1;
3003 }
f14b5cec 3004 last if $shift =~ /^\s*$/;
05454584 3005 }
09d9d230
A
3006 undef $fh;
3007 push @eval, q{CPAN::Modulelist->data;};
05454584
AK
3008 local($^W) = 0;
3009 my($comp) = Safe->new("CPAN::Safe1");
09d9d230 3010 my($eval) = join("", @eval);
05454584
AK
3011 my $ret = $comp->reval($eval);
3012 Carp::confess($@) if $@;
3013 return if $CPAN::Signal;
3014 for (keys %$ret) {
3015 my $obj = $CPAN::META->instance(CPAN::Module,$_);
3016 $obj->set(%{$ret->{$_}});
3017 return if $CPAN::Signal;
3018 }
3019}
5f05dabc 3020
05454584 3021package CPAN::InfoObj;
5f05dabc 3022
05454584
AK
3023#-> sub CPAN::InfoObj::new ;
3024sub new { my $this = bless {}, shift; %$this = @_; $this }
5f05dabc 3025
05454584
AK
3026#-> sub CPAN::InfoObj::set ;
3027sub set {
3028 my($self,%att) = @_;
3029 my(%oldatt) = %$self;
3030 %$self = (%oldatt, %att);
da199366
AK
3031}
3032
05454584
AK
3033#-> sub CPAN::InfoObj::id ;
3034sub id { shift->{'ID'} }
5f05dabc 3035
05454584
AK
3036#-> sub CPAN::InfoObj::as_glimpse ;
3037sub as_glimpse {
5f05dabc 3038 my($self) = @_;
05454584
AK
3039 my(@m);
3040 my $class = ref($self);
3041 $class =~ s/^CPAN:://;
3042 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3043 join "", @m;
5f05dabc
PP
3044}
3045
05454584
AK
3046#-> sub CPAN::InfoObj::as_string ;
3047sub as_string {
3048 my($self) = @_;
3049 my(@m);
3050 my $class = ref($self);
3051 $class =~ s/^CPAN:://;
3052 push @m, $class, " id = $self->{ID}\n";
3053 for (sort keys %$self) {
3054 next if $_ eq 'ID';
3055 my $extra = "";
09d9d230
A
3056 if ($_ eq "CPAN_USERID") {
3057 $extra .= " (".$self->author;
3058 my $email; # old perls!
3059 if ($email = $CPAN::META->instance(CPAN::Author,
3060 $self->{$_}
3061 )->email) {
3062 $extra .= " <$email>";
3063 } else {
3064 $extra .= " <no email>";
3065 }
3066 $extra .= ")";
3067 }
3068 if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
911a92db
GS
3069 push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
3070 } elsif (ref($self->{$_}) eq "HASH") {
3071 push @m, sprintf(
3072 " %-12s %s%s\n",
3073 $_,
3074 join(" ",keys %{$self->{$_}}),
3075 $extra);
5f05dabc 3076 } else {
911a92db 3077 push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
05454584 3078 }
5f05dabc 3079 }
05454584 3080 join "", @m, "\n";
5f05dabc
PP
3081}
3082
05454584
AK
3083#-> sub CPAN::InfoObj::author ;
3084sub author {
3085 my($self) = @_;
3086 $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
5f05dabc
PP
3087}
3088
36263cb3
GS
3089sub dump {
3090 my($self) = @_;
3091 require Data::Dumper;
3092 Data::Dumper::Dumper($self);
3093}
3094
05454584 3095package CPAN::Author;
05454584
AK
3096
3097#-> sub CPAN::Author::as_glimpse ;
3098sub as_glimpse {
5f05dabc 3099 my($self) = @_;
05454584
AK
3100 my(@m);
3101 my $class = ref($self);
3102 $class =~ s/^CPAN:://;
3103 push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
3104 join "", @m;
5f05dabc
PP
3105}
3106
05454584
AK
3107# Dead code, I would have liked to have,,, but it was never reached,,,
3108#sub make {
3109# my($self) = @_;
3110# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
3111#}
5f05dabc 3112
05454584
AK
3113#-> sub CPAN::Author::fullname ;
3114sub fullname { shift->{'FULLNAME'} }
3115*name = \&fullname;
36263cb3 3116
05454584
AK
3117#-> sub CPAN::Author::email ;
3118sub email { shift->{'EMAIL'} }
5f05dabc 3119
05454584 3120package CPAN::Distribution;
5f05dabc 3121
911a92db
GS
3122#-> sub CPAN::Distribution::as_string ;
3123sub as_string {
3124 my $self = shift;
3125 $self->containsmods;
3126 $self->SUPER::as_string(@_);
3127}
3128
3129#-> sub CPAN::Distribution::containsmods ;
3130sub containsmods {
3131 my $self = shift;
3132 return if exists $self->{CONTAINSMODS};
3133 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
3134 my $mod_file = $mod->{CPAN_FILE} or next;
3135 my $dist_id = $self->{ID} or next;
3136 my $mod_id = $mod->{ID} or next;
3137 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3138 }
3139}
3140
05454584
AK
3141#-> sub CPAN::Distribution::called_for ;
3142sub called_for {
3143 my($self,$id) = @_;
3144 $self->{'CALLED_FOR'} = $id if defined $id;
3145 return $self->{'CALLED_FOR'};
5f05dabc
PP
3146}
3147
05454584
AK
3148#-> sub CPAN::Distribution::get ;
3149sub get {
5f05dabc 3150 my($self) = @_;
da199366
AK
3151 EXCUSE: {
3152 my @e;
05454584
AK
3153 exists $self->{'build_dir'} and push @e,
3154 "Unwrapped into directory $self->{'build_dir'}";
c356248b 3155 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
da199366 3156 }
05454584
AK
3157 my($local_file);
3158 my($local_wanted) =
c356248b 3159 MM->catfile(
05454584
AK
3160 $CPAN::Config->{keep_source_where},
3161 "authors",
3162 "id",
3163 split("/",$self->{ID})
3164 );
3165
3166 $self->debug("Doing localize") if $CPAN::DEBUG;
c356248b
AK
3167 $local_file =
3168 CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
3169 or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
05454584
AK
3170 $self->{localfile} = $local_file;
3171 my $builddir = $CPAN::META->{cachemgr}->dir;
3172 $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
3173 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3174 my $packagedir;
3175
3176 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
55e314ee
AK
3177 if ($CPAN::META->has_inst('MD5')) {
3178 $self->debug("MD5 is installed, verifying");
05454584 3179 $self->verifyMD5;
55e314ee
AK
3180 } else {
3181 $self->debug("MD5 is NOT installed");
3182 }
3183 $self->debug("Removing tmp") if $CPAN::DEBUG;
3184 File::Path::rmtree("tmp");
3185 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
05d2a450 3186 chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
55e314ee 3187 $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
c356248b
AK
3188 if (! $local_file) {
3189 Carp::croak "bad download, can't do anything :-(\n";
05d2a450 3190 } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
55e314ee 3191 $self->untar_me($local_file);
05d2a450 3192 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
55e314ee 3193 $self->unzip_me($local_file);
05d2a450 3194 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
55e314ee
AK
3195 $self->pm2dir_me($local_file);
3196 } else {
3197 $self->{archived} = "NO";
5f05dabc 3198 }
05d2a450
A
3199 my $cwd = File::Spec->updir;
3200 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
55e314ee 3201 if ($self->{archived} ne 'NO') {
05d2a450
A
3202 $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
3203 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3204 # Let's check if the package has its own directory.
3205 my $dh = DirHandle->new(File::Spec->curdir)
3206 or Carp::croak("Couldn't opendir .: $!");
3207 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3208 $dh->close;
3209 my ($distdir,$packagedir);
3210 if (@readdir == 1 && -d $readdir[0]) {
3211 $distdir = $readdir[0];
3212 $packagedir = MM->catdir($builddir,$distdir);
3213 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
3214 File::Path::rmtree($packagedir);
3215 rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
3216 } else {
3217 my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
3218 $pragmatic_dir =~ s/\W_//g;
3219 $pragmatic_dir++ while -d "../$pragmatic_dir";
3220 $packagedir = MM->catdir($builddir,$pragmatic_dir);
3221 File::Path::mkpath($packagedir);
3222 my($f);
3223 for $f (@readdir) { # is already without "." and ".."
3224 my $to = MM->catdir($packagedir,$f);
3225 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
3226 }
3227 }
3228 $self->{'build_dir'} = $packagedir;
3229 $cwd = File::Spec->updir;
3230 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
3231
3232 $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
3233 if $CPAN::DEBUG;
3234 File::Path::rmtree("tmp");
3235 if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
3236 $CPAN::Frontend->myprint("Going to unlink $local_file\n");
3237 unlink $local_file or Carp::carp "Couldn't unlink $local_file";
3238 }
3239 my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
3240 unless (-f $makefilepl) {
3241 my($configure) = MM->catfile($packagedir,"Configure");
3242 if (-f $configure) {
3243 # do we have anything to do?
3244 $self->{'configure'} = $configure;
3245 } elsif (-f MM->catfile($packagedir,"Makefile")) {
3246 $CPAN::Frontend->myprint(qq{
09d9d230
A
3247Package comes with a Makefile and without a Makefile.PL.
3248We\'ll try to build it with that Makefile then.
3249});
05d2a450
A
3250 $self->{writemakefile} = "YES";
3251 sleep 2;
3252 } else {
3253 my $fh = FileHandle->new(">$makefilepl")
3254 or Carp::croak("Could not open >$makefilepl");
3255 my $cf = $self->called_for || "unknown";
3256 $fh->print(
55e314ee
AK
3257qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3258# because there was no Makefile.PL supplied.
05454584 3259# Autogenerated on: }.scalar localtime().qq{
55e314ee 3260
09d9d230
A
3261use ExtUtils::MakeMaker;
3262WriteMakefile(NAME => q[$cf]);
55e314ee 3263
05454584 3264});
05d2a450 3265 $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
09d9d230 3266 Writing one on our own (calling it $cf)\n});
05d2a450
A
3267 }
3268 }
5f05dabc 3269 }
05454584 3270 return $self;
5f05dabc
PP
3271}
3272
55e314ee
AK
3273sub untar_me {
3274 my($self,$local_file) = @_;
3275 $self->{archived} = "tar";
09d9d230 3276 if (CPAN::Tarzip->untar($local_file)) {
55e314ee
AK
3277 $self->{unwrapped} = "YES";
3278 } else {
3279 $self->{unwrapped} = "NO";
3280 }
3281}
3282
3283sub unzip_me {
3284 my($self,$local_file) = @_;
05d2a450 3285 $self->{archived} = "zip";
de34a54b 3286 if ($CPAN::META->has_inst("Archive::Zip")) {
05d2a450
A
3287 if (CPAN::Tarzip->unzip($local_file)) {
3288 $self->{unwrapped} = "YES";
3289 } else {
3290 $self->{unwrapped} = "NO";
3291 }
3292 return;
de34a54b
JH
3293 }
3294 my $unzip = $CPAN::Config->{unzip} or
3295 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
de34a54b
JH
3296 my @system = ($unzip, $local_file);
3297 if (system(@system) == 0) {
55e314ee
AK
3298 $self->{unwrapped} = "YES";
3299 } else {
3300 $self->{unwrapped} = "NO";
3301 }
3302}
3303
3304sub pm2dir_me {
3305 my($self,$local_file) = @_;
3306 $self->{archived} = "pm";
3307 my $to = File::Basename::basename($local_file);
05d2a450 3308 $to =~ s/\.(gz|Z)(?!\n)\Z//;
09d9d230 3309 if (CPAN::Tarzip->gunzip($local_file,$to)) {
55e314ee
AK
3310 $self->{unwrapped} = "YES";
3311 } else {
3312 $self->{unwrapped} = "NO";
3313 }
3314}
3315
05454584
AK
3316#-> sub CPAN::Distribution::new ;
3317sub new {
3318 my($class,%att) = @_;
5f05dabc 3319
05454584 3320 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5f05dabc 3321
05454584
AK
3322 my $this = { %att };
3323 return bless $this, $class;
5f05dabc
PP
3324}
3325
05454584
AK
3326#-> sub CPAN::Distribution::look ;
3327sub look {
5f05dabc 3328 my($self) = @_;
36263cb3
GS
3329
3330 if ($^O eq 'MacOS') {
3331 $self->ExtUtils::MM_MacOS::look;
3332 return;
3333 }
3334
05454584 3335 if ( $CPAN::Config->{'shell'} ) {
c356248b 3336 $CPAN::Frontend->myprint(qq{
05454584 3337Trying to open a subshell in the build directory...
c356248b 3338});
05454584 3339 } else {
c356248b 3340 $CPAN::Frontend->myprint(qq{
05454584
AK
3341Your configuration does not define a value for subshells.
3342Please define it with "o conf shell <your shell>"
c356248b 3343});
05454584 3344 return;
5f05dabc 3345 }
05454584
AK
3346 my $dist = $self->id;
3347 my $dir = $self->dir or $self->get;
3348 $dir = $self->dir;
e50380aa
AK
3349 my $getcwd;
3350 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
55e314ee 3351 my $pwd = CPAN->$getcwd();
05d2a450 3352 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
c356248b
AK
3353 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3354 system($CPAN::Config->{'shell'}) == 0
3355 or $CPAN::Frontend->mydie("Subprocess shell error");
05d2a450 3356 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
5f05dabc
PP
3357}
3358
911a92db
GS
3359sub cvs_import {
3360 my($self) = @_;
3361 $self->get;
3362 my $dir = $self->dir;
3363
3364 my $package = $self->called_for;
3365 my $module = $CPAN::META->instance('CPAN::Module', $package);
05d2a450 3366 my $version = $module->cpan_version; # %vd
911a92db
GS
3367
3368 my $userid = $self->{CPAN_USERID};
3369
3370 my $cvs_dir = (split '/', $dir)[-1];
05d2a450 3371 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
911a92db
GS
3372 my $cvs_root =
3373 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
3374 my $cvs_site_perl =
3375 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
3376 if ($cvs_site_perl) {
3377 $cvs_dir = "$cvs_site_perl/$cvs_dir";
3378 }
3379 my $cvs_log = qq{"imported $package $version sources"};
3380 $version =~ s/\./_/g;
3381 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
3382 "$cvs_dir", $userid, "v$version");
3383
3384 my $getcwd;
3385 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
3386 my $pwd = CPAN->$getcwd();
05d2a450 3387 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
911a92db
GS
3388
3389 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
3390
3391 $CPAN::Frontend->myprint(qq{@cmd\n});
de34a54b 3392 system(@cmd) == 0 or
911a92db 3393 $CPAN::Frontend->mydie("cvs import failed");
05d2a450 3394 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
911a92db
GS
3395}
3396
05454584
AK
3397#-> sub CPAN::Distribution::readme ;
3398sub readme {
5f05dabc 3399 my($self) = @_;
05454584
AK
3400 my($dist) = $self->id;
3401 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
3402 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
3403 my($local_file);
3404 my($local_wanted) =
c356248b 3405 MM->catfile(
05454584
AK
3406 $CPAN::Config->{keep_source_where},
3407 "authors",
3408 "id",
3409 split("/","$sans.readme"),
3410 );
3411 $self->debug("Doing localize") if $CPAN::DEBUG;
c356248b
AK
3412 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
3413 $local_wanted)
3414 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
f14b5cec
JH
3415
3416 if ($^O eq 'MacOS') {
3417 ExtUtils::MM_MacOS::launch_file($local_file);
3418 return;
3419 }
3420
05454584 3421 my $fh_pager = FileHandle->new;
c356248b 3422 local($SIG{PIPE}) = "IGNORE";
05454584
AK
3423 $fh_pager->open("|$CPAN::Config->{'pager'}")
3424 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
3425 my $fh_readme = FileHandle->new;
c356248b
AK
3426 $fh_readme->open($local_file)
3427 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
3428 $CPAN::Frontend->myprint(qq{
3429Displaying file
3430 $local_file
3431with pager "$CPAN::Config->{'pager'}"
3432});
3433 sleep 2;
05454584 3434 $fh_pager->print(<$fh_readme>);
5f05dabc
PP
3435}
3436
05454584
AK
3437#-> sub CPAN::Distribution::verifyMD5 ;
3438sub verifyMD5 {
5f05dabc 3439 my($self) = @_;
05454584
AK
3440 EXCUSE: {
3441 my @e;
3442 $self->{MD5_STATUS} ||= "";
3443 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
c356248b 3444 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 3445 }
55e314ee
AK
3446 my($lc_want,$lc_file,@local,$basename);
3447 @local = split("/",$self->{ID});
3448 pop @local;
05454584 3449 push @local, "CHECKSUMS";
55e314ee 3450 $lc_want =
c356248b 3451 MM->catfile($CPAN::Config->{keep_source_where},
55e314ee 3452 "authors", "id", @local);
05454584
AK
3453 local($") = "/";
3454 if (
c356248b 3455 -s $lc_want
05454584 3456 &&
55e314ee 3457 $self->MD5_check_file($lc_want)
05454584
AK
3458 ) {
3459 return $self->{MD5_STATUS} = "OK";
3460 }
55e314ee 3461 $lc_file = CPAN::FTP->localize("authors/id/@local",
c356248b 3462 $lc_want,1);
55e314ee 3463 unless ($lc_file) {
05454584 3464 $local[-1] .= ".gz";
55e314ee 3465 $lc_file = CPAN::FTP->localize("authors/id/@local",
c356248b
AK
3466 "$lc_want.gz",1);
3467 if ($lc_file) {
05d2a450 3468 $lc_file =~ s/\.gz(?!\n)\Z//;
09d9d230 3469 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
c356248b
AK
3470 } else {
3471 return;
3472 }
05454584 3473 }
55e314ee 3474 $self->MD5_check_file($lc_file);
5f05dabc
PP
3475}
3476
05454584
AK
3477#-> sub CPAN::Distribution::MD5_check_file ;
3478sub MD5_check_file {
55e314ee
AK
3479 my($self,$chk_file) = @_;
3480 my($cksum,$file,$basename);
c356248b 3481 $file = $self->{localfile};
55e314ee
AK
3482 $basename = File::Basename::basename($file);
3483 my $fh = FileHandle->new;
55e314ee 3484 if (open $fh, $chk_file){
c356248b 3485 local($/);
05454584 3486 my $eval = <$fh>;
f14b5cec 3487 $eval =~ s/\015?\012/\n/g;
05454584
AK
3488 close $fh;
3489 my($comp) = Safe->new();
3490 $cksum = $comp->reval($eval);
55e314ee
AK
3491 if ($@) {
3492 rename $chk_file, "$chk_file.bad";
3493 Carp::confess($@) if $@;
3494 }
3495 } else {
3496 Carp::carp "Could not open $chk_file for reading";
3497 }
09d9d230
A
3498
3499 if (exists $cksum->{$basename}{md5}) {
55e314ee 3500 $self->debug("Found checksum for $basename:" .
09d9d230
A
3501 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
3502
3503 open($fh, $file);
3504 binmode $fh;
3505 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
3506 $fh->close;
3507 $fh = CPAN::Tarzip->TIEHANDLE($file);
3508
3509 unless ($eq) {
3510 # had to inline it, when I tied it, the tiedness got lost on
3511 # the call to eq_MD5. (Jan 1998)
3512 my $md5 = MD5->new;
3513 my($data,$ref);
3514 $ref = \$data;
36263cb3 3515 while ($fh->READ($ref, 4096) > 0){
09d9d230
A
3516 $md5->add($data);
3517 }
3518 my $hexdigest = $md5->hexdigest;
3519 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
3520 }
3521
3522 if ($eq) {
3523 $CPAN::Frontend->myprint("Checksum for $file ok\n");
3524 return $self->{MD5_STATUS} = "OK";
05454584 3525 } else {
de34a54b 3526 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
c356248b
AK
3527 qq{distribution file. }.
3528 qq{Please investigate.\n\n}.
3529 $self->as_string,
3530 $CPAN::META->instance(
3531 'CPAN::Author',
3532 $self->{CPAN_USERID}
3533 )->as_string);
de34a54b
JH
3534
3535 my $wrap = qq{I\'d recommend removing $file. Its MD5
3536checksum is incorrect. Maybe you have configured your \`urllist\' with
3537a bad URL. Please check this array with \`o conf urllist\', and
55e314ee 3538retry.};
de34a54b 3539
c356248b
AK
3540 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
3541 $CPAN::Frontend->myprint("\n\n");
55e314ee 3542 sleep 3;
05454584 3543 return;
5f05dabc 3544 }
09d9d230 3545 # close $fh if fileno($fh);
5f05dabc 3546 } else {
55e314ee
AK
3547 $self->{MD5_STATUS} ||= "";
3548 if ($self->{MD5_STATUS} eq "NIL") {
c356248b
AK
3549 $CPAN::Frontend->myprint(qq{
3550No md5 checksum for $basename in local $chk_file.
3551Removing $chk_file
3552});
3553 unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
55e314ee
AK
3554 sleep 1;
3555 }
3556 $self->{MD5_STATUS} = "NIL";
3557 return;
5f05dabc
PP
3558 }
3559}
3560
05454584
AK
3561#-> sub CPAN::Distribution::eq_MD5 ;
3562sub eq_MD5 {
3563 my($self,$fh,$expectMD5) = @_;
55e314ee 3564 my $md5 = MD5->new;
09d9d230
A
3565 my($data);
3566 while (read($fh, $data, 4096)){
3567 $md5->add($data);
3568 }
3569 # $md5->addfile($fh);
05454584 3570 my $hexdigest = $md5->hexdigest;
09d9d230 3571 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
05454584
AK
3572 $hexdigest eq $expectMD5;
3573}
5f05dabc 3574
05454584 3575#-> sub CPAN::Distribution::force ;
5f05dabc 3576sub force {
f610777f
A
3577 my($self) = @_;
3578 $self->{'force_update'}++;
3579 for my $att (qw(
3580 MD5_STATUS archived build_dir localfile make install unwrapped
36263cb3 3581 writemakefile
f610777f
A
3582 )) {
3583 delete $self->{$att};
3584 }
5f05dabc
PP
3585}
3586
de34a54b 3587#-> sub CPAN::Distribution::isa_perl ;
09d9d230
A
3588sub isa_perl {
3589 my($self) = @_;
3590 my $file = File::Basename::basename($self->id);
05d2a450
A
3591 if ($file =~ m{ ^ perl
3592 -?
3593 (5)
3594 ([._-])
3595 (
3596 \d{3}(_[0-4][0-9])?
3597 |
3598 \d*[24680]\.\d+
3599 )
3600 \.tar[._-]gz
3601 (?!\n)\Z
3602 }xs){
3603 return "$1.$3";
3604 } elsif ($self->{'CPAN_COMMENT'} && $self->{'CPAN_COMMENT'} =~ /isa_perl\(.+?\)/){
3605 return $1;
3606 }
09d9d230
A
3607}
3608
d4fd5c69
AK
3609#-> sub CPAN::Distribution::perl ;
3610sub perl {
3611 my($self) = @_;
3612 my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
e50380aa 3613 my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
55e314ee 3614 my $pwd = CPAN->$getcwd();
c356248b 3615 my $candidate = MM->catfile($pwd,$^X);
e50380aa 3616 $perl ||= $candidate if MM->maybe_command($candidate);
d4fd5c69
AK
3617 unless ($perl) {
3618 my ($component,$perl_name);
911a92db 3619 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
c356248b
AK
3620 PATH_COMPONENT: foreach $component (MM->path(),
3621 $Config::Config{'binexp'}) {
d4fd5c69
AK
3622 next unless defined($component) && $component;
3623 my($abs) = MM->catfile($component,$perl_name);
3624 if (MM->maybe_command($abs)) {
3625 $perl = $abs;
3626 last DIST_PERLNAME;
3627 }
3628 }
3629 }
3630 }
3631 $perl;
3632}
3633
05454584
AK
3634#-> sub CPAN::Distribution::make ;
3635sub make {
3636 my($self) = @_;
c356248b 3637 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
09d9d230
A
3638 # Emergency brake if they said install Pippi and get newest perl
3639 if ($self->isa_perl) {
3640 if (
3641 $self->called_for ne $self->id && ! $self->{'force_update'}
3642 ) {
de34a54b
JH
3643 # if we die here, we break bundles
3644 $CPAN::Frontend->mywarn(sprintf qq{
09d9d230
A
3645The most recent version "%s" of the module "%s"
3646comes with the current version of perl (%s).
3647I\'ll build that only if you ask for something like
3648 force install %s
3649or
3650 install %s
3651},
3652 $CPAN::META->instance(
3653 'CPAN::Module',
3654 $self->called_for
05d2a450 3655 )->cpan_version, # %vd
09d9d230
A
3656 $self->called_for,
3657 $self->isa_perl,
3658 $self->called_for,
3659 $self->id);
de34a54b 3660 sleep 5; return;
09d9d230
A
3661 }
3662 }
05454584
AK
3663 $self->get;
3664 EXCUSE: {
3665 my @e;
3666 $self->{archived} eq "NO" and push @e,
3667 "Is neither a tar nor a zip archive.";
5f05dabc 3668
d4fd5c69 3669 $self->{unwrapped} eq "NO" and push @e,
05454584
AK
3670 "had problems unarchiving. Please build manually";
3671
3672 exists $self->{writemakefile} &&
36263cb3
GS
3673 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
3674 $1 || "Had some problem writing Makefile";
05454584
AK
3675
3676 defined $self->{'make'} and push @e,
3677 "Has already been processed within this session";
3678
c356248b 3679 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5f05dabc 3680 }
c356248b 3681 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
05454584
AK
3682 my $builddir = $self->dir;
3683 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
3684 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
3685
f14b5cec
JH
3686 if ($^O eq 'MacOS') {
3687 ExtUtils::MM_MacOS::make($self);
3688 return;
3689 }
3690
05454584
AK
3691 my $system;
3692 if ($self->{'configure'}) {
09d9d230 3693 $system = $self->{'configure'};
5f05dabc 3694 } else {
d4fd5c69
AK
3695 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
3696 my $switch = "";
3697# This needs a handler that can be turned on or off:
3698# $switch = "-MExtUtils::MakeMaker ".
3699# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
3700# if $] > 5.00310;
3701 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
3702 }
09d9d230 3703 unless (exists $self->{writemakefile}) {
e50380aa
AK
3704 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
3705 my($ret,$pid);