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