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