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