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