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