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