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