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