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