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