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
Doc patches: assorted minor nits
[perl5.git] / lib / CPAN.pm
CommitLineData
c4d24d4c 1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
5f05dabc 2package CPAN;
0362b508
JH		 3$VERSION = '1.61';
4# $Id: CPAN.pm,v 1.390 2002/05/07 10:04:58 k Exp $
5f05dabc 5
c356248b
A		 6# only used during development:
7$Revision = "";
0362b508 8# $Revision = "[".substr(q$Revision: 1.390 $, 10)."]";
5f05dabc 9
10use Carp ();
11use Config ();
12use Cwd ();
13use DirHandle;
14use Exporter ();
2e2b7522 15use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
5f05dabc 16use File::Basename ();
10b2abe6 17use File::Copy ();
5f05dabc 18use File::Find;
19use File::Path ();
da199366 20use FileHandle ();
5f05dabc 21use Safe ();
10b2abe6 22use Text::ParseWords ();
05454584 23use Text::Wrap;
f14b5cec 24use File::Spec;
0dfa0441 25use Sys::Hostname;
de34a54b
JH		 26no lib "."; # we need to run chdir all over and we would get at wrong
27 # libraries there
5f05dabc 28
be708cc0
JH		 29require Mac::BuildTools if $^O eq 'MacOS';
30
5f05dabc 31END { $End++; &cleanup; }
32
2e2b7522 33%CPAN::DEBUG = qw[
5f05dabc 34 CPAN 1
35 Index 2
36 InfoObj 4
37 Author 8
38 Distribution 16
39 Bundle 32
40 Module 64
41 CacheMgr 128
42 Complete 256
43 FTP 512
44 Shell 1024
45 Eval 2048
46 Config 4096
09d9d230 47 Tarzip 8192
5e05dca5 48 Version 16384
6d29edf5 49 Queue 32768
2e2b7522 50];
5f05dabc 51
52$CPAN::DEBUG ||= 0;
da199366 53$CPAN::Signal ||= 0;
c356248b 54$CPAN::Frontend ||= "CPAN::Shell";
09d9d230 55$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
5f05dabc 56
57package CPAN;
5f05dabc 58use strict qw(vars);
59
6d29edf5 60use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
9d61fa1d 61 $Revision $Signal $End $Suppress_readline $Frontend
5a5fac02 62 $Defaultsite $Have_warned);
6d29edf5 63
2e2b7522 64@CPAN::ISA = qw(CPAN::Debug Exporter);
5f05dabc 65
55e314ee 66@EXPORT = qw(
911a92db 67 autobundle bundle expand force get cvs_import
da199366
A		 68 install make readme recompile shell test clean
69 );
5f05dabc 70
55e314ee
A		 71#-> sub CPAN::AUTOLOAD ;
72sub AUTOLOAD {
73 my($l) = $AUTOLOAD;
74 $l =~ s/.*:://;
75 my(%EXPORT);
76 @EXPORT{@EXPORT} = '';
36263cb3 77 CPAN::Config->load unless $CPAN::Config_loaded++;
55e314ee
A		 78 if (exists $EXPORT{$l}){
79 CPAN::Shell->$l(@_);
80 } else {
c356248b
A		 81 $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
82 qq{Type ? for help.
83});
55e314ee
A		 84 }
85}
86
87#-> sub CPAN::shell ;
88sub shell {
36263cb3 89 my($self) = @_;
911a92db 90 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
36263cb3 91 CPAN::Config->load unless $CPAN::Config_loaded++;
55e314ee 92
9d61fa1d
A		 93 my $oprompt = shift || "cpan> ";
94 my $prompt = $oprompt;
95 my $commandline = shift || "";
5e05dca5 96
55e314ee
A		 97 local($^W) = 1;
98 unless ($Suppress_readline) {
99 require Term::ReadLine;
9d61fa1d
A		 100 if (! $term
101 or
102 $term->ReadLine eq "Term::ReadLine::Stub"
103 ) {
104 $term = Term::ReadLine->new('CPAN Monitor');
105 }
36263cb3
GS		 106 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
107 my $attribs = $term->Attribs;
36263cb3
GS		 108 $attribs->{attempted_completion_function} = sub {
109 &CPAN::Complete::gnu_cpl;
110 }
36263cb3
GS		 111 } else {
112 $readline::rl_completion_function =
113 $readline::rl_completion_function = 'CPAN::Complete::cpl';
114 }
911a92db
GS		 115 # $term->OUT is autoflushed anyway
116 my $odef = select STDERR;
117 $| = 1;
118 select STDOUT;
119 $| = 1;
120 select $odef;
55e314ee
A		 121 }
122
6d29edf5 123 # no strict; # I do not recall why no strict was here (2000-09-03)
55e314ee 124 $META->checklock();
9d61fa1d 125 my $cwd = CPAN::anycwd();
911a92db
GS		 126 my $try_detect_readline;
127 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
55e314ee
A		 128 my $rl_avail = $Suppress_readline ? "suppressed" :
129 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
c4d24d4c 130 "available (try 'install Bundle::CPAN')";
55e314ee 131
c356248b 132 $CPAN::Frontend->myprint(
6d29edf5
JH		 133 sprintf qq{
134cpan shell -- CPAN exploration and modules installation (v%s%s)
135ReadLine support %s
55e314ee 136
6d29edf5
JH		 137},
138 $CPAN::VERSION,
139 $CPAN::Revision,
140 $rl_avail
141 )
142 unless $CPAN::Config->{'inhibit_startup_message'} ;
c356248b 143 my($continuation) = "";
8d97e4a1 144 SHELLCOMMAND: while () {
55e314ee
A		 145 if ($Suppress_readline) {
146 print $prompt;
8d97e4a1 147 last SHELLCOMMAND unless defined ($_ = <> );
55e314ee
A		 148 chomp;
149 } else {
8d97e4a1
JH		 150 last SHELLCOMMAND unless
151 defined ($_ = $term->readline($prompt, $commandline));
55e314ee 152 }
c356248b 153 $_ = "$continuation$_" if $continuation;
55e314ee 154 s/^\s+//;
8d97e4a1 155 next SHELLCOMMAND if /^$/;
2e2b7522 156 $_ = 'h' if /^\s*\?/;
09d9d230 157 if (/^(?:q(?:uit)?|bye|exit)$/i) {
8d97e4a1 158 last SHELLCOMMAND;
c356248b
A		 159 } elsif (s/\\$//s) {
160 chomp;
161 $continuation = $_;
162 $prompt = " > ";
163 } elsif (/^\!/) {
55e314ee
A		 164 s/^\!//;
165 my($eval) = $_;
166 package CPAN::Eval;
167 use vars qw($import_done);
168 CPAN->import(':DEFAULT') unless $import_done++;
169 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
170 eval($eval);
171 warn $@ if $@;
c356248b 172 $continuation = "";
9d61fa1d 173 $prompt = $oprompt;
55e314ee
A		 174 } elsif (/./) {
175 my(@line);
176 if ($] < 5.00322) { # parsewords had a bug until recently
177 @line = split;
178 } else {
179 eval { @line = Text::ParseWords::shellwords($_) };
8d97e4a1
JH		 180 warn($@), next SHELLCOMMAND if $@;
181 warn("Text::Parsewords could not parse the line [$_]"),
182 next SHELLCOMMAND unless @line;
55e314ee
A		 183 }
184 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
185 my $command = shift @line;
186 eval { CPAN::Shell->$command(@line) };
187 warn $@ if $@;
05d2a450 188 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
c356248b
A		 189 $CPAN::Frontend->myprint("\n");
190 $continuation = "";
9d61fa1d 191 $prompt = $oprompt;
55e314ee
A		 192 }
193 } continue {
9d61fa1d
A		 194 $commandline = ""; # I do want to be able to pass a default to
195 # shell, but on the second command I see no
196 # use in that
09d9d230 197 $Signal=0;
36263cb3
GS		 198 CPAN::Queue->nullify_queue;
199 if ($try_detect_readline) {
200 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
201 ||
202 $CPAN::META->has_inst("Term::ReadLine::Perl")
203 ) {
204 delete $INC{"Term/ReadLine.pm"};
6d29edf5
JH		 205 my $redef = 0;
206 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
36263cb3 207 require Term::ReadLine;
911a92db
GS		 208 $CPAN::Frontend->myprint("\n$redef subroutines in ".
209 "Term::ReadLine redefined\n");
9d61fa1d 210 @_ = ($oprompt,"");
36263cb3
GS		 211 goto &shell;
212 }
213 }
55e314ee 214 }
9d61fa1d 215 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
55e314ee
A		 216}
217
218package CPAN::CacheMgr;
c356248b 219@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
55e314ee
A		 220use File::Find;
221
222package CPAN::Config;
55e314ee
A		 223use vars qw(%can $dot_cpan);
224
225%can = (
226 'commit' => "Commit changes to disk",
227 'defaults' => "Reload defaults from disk",
228 'init' => "Interactive setting of all options",
229);
230
231package CPAN::FTP;
c356248b 232use vars qw($Ua $Thesite $Themethod);
55e314ee
A		 233@CPAN::FTP::ISA = qw(CPAN::Debug);
234
c049f953
JH		 235package CPAN::LWP::UserAgent;
236use vars qw(@ISA $USER $PASSWD $SETUPDONE);
237# we delay requiring LWP::UserAgent and setting up inheritence until we need it
238
55e314ee
A		 239package CPAN::Complete;
240@CPAN::Complete::ISA = qw(CPAN::Debug);
9d61fa1d
A		 241@CPAN::Complete::COMMANDS = sort qw(
242 ! a b d h i m o q r u autobundle clean dump
8d97e4a1
JH		 243 make test install force readme reload look
244 cvs_import ls
9d61fa1d 245) unless @CPAN::Complete::COMMANDS;
55e314ee
A		 246
247package CPAN::Index;
c049f953 248use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
55e314ee 249@CPAN::Index::ISA = qw(CPAN::Debug);
c049f953
JH		 250$LAST_TIME ||= 0;
251$DATE_OF_03 ||= 0;
6d29edf5
JH		 252# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
253sub PROTOCOL { 2.0 }
55e314ee
A		 254
255package CPAN::InfoObj;
256@CPAN::InfoObj::ISA = qw(CPAN::Debug);
257
258package CPAN::Author;
259@CPAN::Author::ISA = qw(CPAN::InfoObj);
260
261package CPAN::Distribution;
262@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
263
264package CPAN::Bundle;
265@CPAN::Bundle::ISA = qw(CPAN::Module);
266
267package CPAN::Module;
268@CPAN::Module::ISA = qw(CPAN::InfoObj);
10b2abe6 269
55e314ee 270package CPAN::Shell;
8d97e4a1 271use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
55e314ee 272@CPAN::Shell::ISA = qw(CPAN::Debug);
9d61fa1d 273$COLOR_REGISTERED ||= 0;
8d97e4a1 274$PRINT_ORNAMENTING ||= 0;
55e314ee
A		 275
276#-> sub CPAN::Shell::AUTOLOAD ;
277sub AUTOLOAD {
278 my($autoload) = $AUTOLOAD;
c356248b 279 my $class = shift(@_);
09d9d230 280 # warn "autoload[$autoload] class[$class]";
55e314ee
A		 281 $autoload =~ s/.*:://;
282 if ($autoload =~ /^w/) {
283 if ($CPAN::META->has_inst('CPAN::WAIT')) {
c356248b 284 CPAN::WAIT->$autoload(@_);
55e314ee 285 } else {
c356248b 286 $CPAN::Frontend->mywarn(qq{
55e314ee
A		 287Commands starting with "w" require CPAN::WAIT to be installed.
288Please consider installing CPAN::WAIT to use the fulltext index.
f610777f 289For this you just need to type
55e314ee 290 install CPAN::WAIT
c356248b 291});
55e314ee
A		 292 }
293 } else {
c356248b
A		 294 $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
295 qq{Type ? for help.
296});
55e314ee
A		 297 }
298}
299
09d9d230 300package CPAN::Tarzip;
8d97e4a1 301use vars qw($AUTOLOAD @ISA $BUGHUNTING);
09d9d230 302@CPAN::Tarzip::ISA = qw(CPAN::Debug);
8d97e4a1 303$BUGHUNTING = 0; # released code must have turned off
09d9d230
A		 304
305package CPAN::Queue;
f610777f 306
f14b5cec
JH		 307# One use of the queue is to determine if we should or shouldn't
308# announce the availability of a new CPAN module
309
310# Now we try to use it for dependency tracking. For that to happen
f610777f
A		 311# we need to draw a dependency tree and do the leaves first. This can
312# easily be reached by running CPAN.pm recursively, but we don't want
313# to waste memory and run into deep recursion. So what we can do is
f14b5cec
JH		 314# this:
315
316# CPAN::Queue is the package where the queue is maintained. Dependencies
317# often have high priority and must be brought to the head of the queue,
318# possibly by jumping the queue if they are already there. My first code
319# attempt tried to be extremely correct. Whenever a module needed
320# immediate treatment, I either unshifted it to the front of the queue,
321# or, if it was already in the queue, I spliced and let it bypass the
322# others. This became a too correct model that made it impossible to put
323# an item more than once into the queue. Why would you need that? Well,
324# you need temporary duplicates as the manager of the queue is a loop
325# that
326#
327# (1) looks at the first item in the queue without shifting it off
328#
329# (2) cares for the item
330#
331# (3) removes the item from the queue, *even if its agenda failed and
332# even if the item isn't the first in the queue anymore* (that way
333# protecting against never ending queues)
334#
335# So if an item has prerequisites, the installation fails now, but we
336# want to retry later. That's easy if we have it twice in the queue.
337#
338# I also expect insane dependency situations where an item gets more
339# than two lives in the queue. Simplest example is triggered by 'install
340# Foo Foo Foo'. People make this kind of mistakes and I don't want to
341# get in the way. I wanted the queue manager to be a dumb servant, not
342# one that knows everything.
343#
344# Who would I tell in this model that the user wants to be asked before
345# processing? I can't attach that information to the module object,
346# because not modules are installed but distributions. So I'd have to
347# tell the distribution object that it should ask the user before
348# processing. Where would the question be triggered then? Most probably
349# in CPAN::Distribution::rematein.
350# Hope that makes sense, my head is a bit off:-) -- AK
f610777f
A		 351
352use vars qw{ @All };
353
6d29edf5 354# CPAN::Queue::new ;
09d9d230 355sub new {
6d29edf5
JH		 356 my($class,$s) = @_;
357 my $self = bless { qmod => $s }, $class;
f610777f 358 push @All, $self;
f610777f 359 return $self;
f610777f
A		 360}
361
6d29edf5 362# CPAN::Queue::first ;
f610777f
A		 363sub first {
364 my $obj = $All[0];
6d29edf5 365 $obj->{qmod};
f610777f
A		 366}
367
6d29edf5 368# CPAN::Queue::delete_first ;
f610777f
A		 369sub delete_first {
370 my($class,$what) = @_;
371 my $i;
372 for my $i (0..$#All) {
6d29edf5 373 if ( $All[$i]->{qmod} eq $what ) {
f610777f
A		 374 splice @All, $i, 1;
375 return;
376 }
377 }
378}
379
6d29edf5 380# CPAN::Queue::jumpqueue ;
f610777f 381sub jumpqueue {
6d29edf5
JH		 382 my $class = shift;
383 my @what = @_;
384 CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
385 join(",",map {$_->{qmod}} @All),
386 join(",",@what)
387 )) if $CPAN::DEBUG;
f610777f 388 WHAT: for my $what (reverse @what) {
6d29edf5
JH		 389 my $jumped = 0;
390 for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
391 CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
392 if ($All[$i]->{qmod} eq $what){
393 $jumped++;
394 if ($jumped > 100) { # one's OK if e.g. just
395 # processing now; more are OK if
396 # user typed it several times
397 $CPAN::Frontend->mywarn(
f610777f
A		 398qq{Object [$what] queued more than 100 times, ignoring}
399 );
6d29edf5
JH		 400 next WHAT;
401 }
402 }
403 }
404 my $obj = bless { qmod => $what }, $class;
405 unshift @All, $obj;
f610777f 406 }
6d29edf5
JH		 407 CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
408 join(",",map {$_->{qmod}} @All),
409 join(",",@what)
410 )) if $CPAN::DEBUG;
f610777f
A		 411}
412
6d29edf5 413# CPAN::Queue::exists ;
f610777f
A		 414sub exists {
415 my($self,$what) = @_;
6d29edf5
JH		 416 my @all = map { $_->{qmod} } @All;
417 my $exists = grep { $_->{qmod} eq $what } @All;
418 # warn "in exists what[$what] all[@all] exists[$exists]";
f610777f
A		 419 $exists;
420}
421
6d29edf5 422# CPAN::Queue::delete ;
f610777f
A		 423sub delete {
424 my($self,$mod) = @_;
6d29edf5 425 @All = grep { $_->{qmod} ne $mod } @All;
09d9d230 426}
55e314ee 427
6d29edf5 428# CPAN::Queue::nullify_queue ;
36263cb3
GS		 429sub nullify_queue {
430 @All = ();
431}
432
433
434
55e314ee
A		 435package CPAN;
436
2e2b7522 437$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
55e314ee 438
6d29edf5
JH		 439# from here on only subs.
440################################################################################
55e314ee 441
6d29edf5 442#-> sub CPAN::all_objects ;
36263cb3 443sub all_objects {
5f05dabc 444 my($mgr,$class) = @_;
36263cb3 445 CPAN::Config->load unless $CPAN::Config_loaded++;
5f05dabc 446 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
447 CPAN::Index->reload;
6d29edf5 448 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
5f05dabc 449}
36263cb3 450*all = \&all_objects;
5f05dabc 451
c4d24d4c
A		 452# Called by shell, not in batch mode. In batch mode I see no risk in
453# having many processes updating something as installations are
454# continually checked at runtime. In shell mode I suspect it is
455# unintentional to open more than one shell at a time
456
10b2abe6 457#-> sub CPAN::checklock ;
5f05dabc 458sub checklock {
459 my($self) = @_;
5de3f0da 460 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
5f05dabc 461 if (-f $lockfile && -M _ > 0) {
6d29edf5
JH		 462 my $fh = FileHandle->new($lockfile) or
463 $CPAN::Frontend->mydie("Could not open $lockfile: $!");
0dfa0441
JH		 464 my $otherpid = <$fh>;
465 my $otherhost = <$fh>;
5f05dabc 466 $fh->close;
0dfa0441
JH		 467 if (defined $otherpid && $otherpid) {
468 chomp $otherpid;
469 }
470 if (defined $otherhost && $otherhost) {
471 chomp $otherhost;
472 }
473 my $thishost = hostname();
474 if (defined $otherhost && defined $thishost &&
475 $otherhost ne '' && $thishost ne '' &&
476 $otherhost ne $thishost) {
477 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
478 "reports other host $otherhost and other process $otherpid.\n".
479 "Cannot proceed.\n"));
480 }
481 elsif (defined $otherpid && $otherpid) {
482 return if $$ == $otherpid; # should never happen
c356248b
A		 483 $CPAN::Frontend->mywarn(
484 qq{
0dfa0441 485There seems to be running another CPAN process (pid $otherpid). Contacting...
c356248b 486});
0dfa0441 487 if (kill 0, $otherpid) {
c356248b
A		 488 $CPAN::Frontend->mydie(qq{Other job is running.
489You may want to kill it and delete the lockfile, maybe. On UNIX try:
0dfa0441 490 kill $otherpid
c356248b
A		 491 rm $lockfile
492});
5f05dabc 493 } elsif (-w $lockfile) {
e50380aa 494 my($ans) =
5f05dabc 495 ExtUtils::MakeMaker::prompt
05454584
A		 496 (qq{Other job not responding. Shall I overwrite }.
497 qq{the lockfile? (Y/N)},"y");
c356248b
A		 498 $CPAN::Frontend->myexit("Ok, bye\n")
499 unless $ans =~ /^y/i;
5f05dabc 500 } else {
501 Carp::croak(
05454584
A		 502 qq{Lockfile $lockfile not writeable by you. }.
503 qq{Cannot proceed.\n}.
5f05dabc 504 qq{ On UNIX try:\n}.
505 qq{ rm $lockfile\n}.
506 qq{ and then rerun us.\n}
507 );
508 }
6d29edf5 509 } else {
0dfa0441 510 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
6d29edf5 511 "reports other process with ID ".
0dfa0441 512 "$otherpid. Cannot proceed.\n"));
6d29edf5 513 }
5f05dabc 514 }
36263cb3
GS		 515 my $dotcpan = $CPAN::Config->{cpan_home};
516 eval { File::Path::mkpath($dotcpan);};
517 if ($@) {
518 # A special case at least for Jarkko.
519 my $firsterror = $@;
520 my $seconderror;
521 my $symlinkcpan;
522 if (-l $dotcpan) {
523 $symlinkcpan = readlink $dotcpan;
524 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
525 eval { File::Path::mkpath($symlinkcpan); };
526 if ($@) {
527 $seconderror = $@;
528 } else {
529 $CPAN::Frontend->mywarn(qq{
530Working directory $symlinkcpan created.
531});
532 }
533 }
534 unless (-d $dotcpan) {
535 my $diemess = qq{
536Your configuration suggests "$dotcpan" as your
537CPAN.pm working directory. I could not create this directory due
538to this error: $firsterror\n};
539 $diemess .= qq{
540As "$dotcpan" is a symlink to "$symlinkcpan",
541I tried to create that, but I failed with this error: $seconderror
542} if $seconderror;
543 $diemess .= qq{
544Please make sure the directory exists and is writable.
545};
546 $CPAN::Frontend->mydie($diemess);
547 }
548 }
5f05dabc 549 my $fh;
da199366 550 unless ($fh = FileHandle->new(">$lockfile")) {
911a92db 551 if ($! =~ /Permission/) {
5f05dabc 552 my $incc = $INC{'CPAN/Config.pm'};
5de3f0da 553 my $myincc = File::Spec->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
c356248b 554 $CPAN::Frontend->myprint(qq{
5f05dabc 555
556Your configuration suggests that CPAN.pm should use a working
557directory of
558 $CPAN::Config->{cpan_home}
559Unfortunately we could not create the lock file
560 $lockfile
561due to permission problems.
562
563Please make sure that the configuration variable
564 \$CPAN::Config->{cpan_home}
565points to a directory where you can write a .lock file. You can set
566this variable in either
567 $incc
568or
569 $myincc
570
c356248b 571});
5f05dabc 572 }
c356248b 573 $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
5f05dabc 574 }
c356248b 575 $fh->print($$, "\n");
0dfa0441 576 $fh->print(hostname(), "\n");
5f05dabc 577 $self->{LOCK} = $lockfile;
578 $fh->close;
6d29edf5 579 $SIG{TERM} = sub {
2e2b7522
GS		 580 &cleanup;
581 $CPAN::Frontend->mydie("Got SIGTERM, leaving");
c356248b 582 };
6d29edf5 583 $SIG{INT} = sub {
09d9d230
A		 584 # no blocks!!!
585 &cleanup if $Signal;
586 $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
587 print "Caught SIGINT\n";
588 $Signal++;
da199366 589 };
911a92db
GS		 590
591# From: Larry Wall <larry@wall.org>
592# Subject: Re: deprecating SIGDIE
593# To: perl5-porters@perl.org
594# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
595#
596# The original intent of __DIE__ was only to allow you to substitute one
597# kind of death for another on an application-wide basis without respect
598# to whether you were in an eval or not. As a global backstop, it should
599# not be used any more lightly (or any more heavily :-) than class
600# UNIVERSAL. Any attempt to build a general exception model on it should
601# be politely squashed. Any bug that causes every eval {} to have to be
602# modified should be not so politely squashed.
603#
604# Those are my current opinions. It is also my optinion that polite
605# arguments degenerate to personal arguments far too frequently, and that
606# when they do, it's because both people wanted it to, or at least didn't
607# sufficiently want it not to.
608#
609# Larry
610
6d29edf5
JH		 611 # global backstop to cleanup if we should really die
612 $SIG{__DIE__} = \&cleanup;
e50380aa 613 $self->debug("Signal handler set.") if $CPAN::DEBUG;
5f05dabc 614}
615
10b2abe6 616#-> sub CPAN::DESTROY ;
5f05dabc 617sub DESTROY {
618 &cleanup; # need an eval?
619}
620
9d61fa1d
A		 621#-> sub CPAN::anycwd ;
622sub anycwd () {
623 my $getcwd;
624 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
625 CPAN->$getcwd();
626}
627
55e314ee
A		 628#-> sub CPAN::cwd ;
629sub cwd {Cwd::cwd();}
630
631#-> sub CPAN::getcwd ;
632sub getcwd {Cwd::getcwd();}
633
10b2abe6 634#-> sub CPAN::exists ;
5f05dabc 635sub exists {
636 my($mgr,$class,$id) = @_;
9d61fa1d 637 CPAN::Config->load unless $CPAN::Config_loaded++;
5f05dabc 638 CPAN::Index->reload;
e50380aa 639 ### Carp::croak "exists called without class argument" unless $class;
5f05dabc 640 $id ||= "";
6d29edf5
JH		 641 exists $META->{readonly}{$class}{$id} or
642 exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
5f05dabc 643}
644
09d9d230
A		 645#-> sub CPAN::delete ;
646sub delete {
647 my($mgr,$class,$id) = @_;
6d29edf5
JH		 648 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
649 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
09d9d230
A		 650}
651
de34a54b
JH		 652#-> sub CPAN::has_usable
653# has_inst is sometimes too optimistic, we should replace it with this
654# has_usable whenever a case is given
655sub has_usable {
656 my($self,$mod,$message) = @_;
657 return 1 if $HAS_USABLE->{$mod};
658 my $has_inst = $self->has_inst($mod,$message);
659 return unless $has_inst;
6d29edf5
JH		 660 my $usable;
661 $usable = {
662 LWP => [ # we frequently had "Can't locate object
663 # method "new" via package "LWP::UserAgent" at
664 # (eval 69) line 2006
665 sub {require LWP},
666 sub {require LWP::UserAgent},
667 sub {require HTTP::Request},
668 sub {require URI::URL},
669 ],
670 Net::FTP => [
671 sub {require Net::FTP},
672 sub {require Net::Config},
673 ]
674 };
675 if ($usable->{$mod}) {
676 for my $c (0..$#{$usable->{$mod}}) {
677 my $code = $usable->{$mod}[$c];
de34a54b
JH		 678 my $ret = eval { &$code() };
679 if ($@) {
680 warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
681 return;
682 }
683 }
684 }
685 return $HAS_USABLE->{$mod} = 1;
686}
687
55e314ee
A		 688#-> sub CPAN::has_inst
689sub has_inst {
690 my($self,$mod,$message) = @_;
691 Carp::croak("CPAN->has_inst() called without an argument")
692 unless defined $mod;
de34a54b
JH		 693 if (defined $message && $message eq "no"
694 ||
6d29edf5 695 exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
de34a54b
JH		 696 ||
697 exists $CPAN::Config->{dontload_hash}{$mod}
698 ) {
6d29edf5 699 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
de34a54b 700 return 0;
55e314ee
A		 701 }
702 my $file = $mod;
c356248b 703 my $obj;
55e314ee
A		 704 $file =~ s|::|/|g;
705 $file =~ s|/|\\|g if $^O eq 'MSWin32';
706 $file .= ".pm";
c356248b 707 if ($INC{$file}) {
f14b5cec
JH		 708 # checking %INC is wrong, because $INC{LWP} may be true
709 # although $INC{"URI/URL.pm"} may have failed. But as
710 # I really want to say "bla loaded OK", I have to somehow
711 # cache results.
712 ### warn "$file in %INC"; #debug
55e314ee 713 return 1;
55e314ee 714 } elsif (eval { require $file }) {
c356248b
A		 715 # eval is good: if we haven't yet read the database it's
716 # perfect and if we have installed the module in the meantime,
717 # it tries again. The second require is only a NOOP returning
718 # 1 if we had success, otherwise it's retrying
f14b5cec 719
c356248b
A		 720 $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
721 if ($mod eq "CPAN::WAIT") {
722 push @CPAN::Shell::ISA, CPAN::WAIT;
723 }
55e314ee
A		 724 return 1;
725 } elsif ($mod eq "Net::FTP") {
6d29edf5 726 $CPAN::Frontend->mywarn(qq{
55e314ee
A		 727 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
728 if you just type
729 install Bundle::libnet
5f05dabc 730
5a5fac02
JH		 731}) unless $Have_warned->{"Net::FTP"}++;
732 sleep 3;
5b6aeab6 733 } elsif ($mod eq "Digest::MD5"){
c356248b 734 $CPAN::Frontend->myprint(qq{
5b6aeab6
GA		 735 CPAN: MD5 security checks disabled because Digest::MD5 not installed.
736 Please consider installing the Digest::MD5 module.
c356248b
A		 737
738});
739 sleep 2;
f14b5cec
JH		 740 } else {
741 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
05454584 742 }
55e314ee 743 return 0;
05454584
A		 744}
745
10b2abe6 746#-> sub CPAN::instance ;
5f05dabc 747sub instance {
748 my($mgr,$class,$id) = @_;
749 CPAN::Index->reload;
5f05dabc 750 $id ||= "";
6d29edf5
JH		 751 # unsafe meta access, ok?
752 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
753 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
5f05dabc 754}
755
10b2abe6 756#-> sub CPAN::new ;
5f05dabc 757sub new {
758 bless {}, shift;
759}
760
10b2abe6 761#-> sub CPAN::cleanup ;
5f05dabc 762sub cleanup {
2e2b7522
GS		 763 # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
764 local $SIG{__DIE__} = '';
765 my($message) = @_;
766 my $i = 0;
767 my $ineval = 0;
768 if (
769 0 && # disabled, try reload cpan with it
770 $] > 5.004_60 # thereabouts
771 ) {
772 $ineval = $^S;
773 } else {
774 my($subroutine);
775 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
776 $ineval = 1, last if
777 $subroutine eq '(eval)';
5f05dabc 778 }
2e2b7522
GS		 779 }
780 return if $ineval && !$End;
6d29edf5
JH		 781 return unless defined $META->{LOCK}; # unsafe meta access, ok
782 return unless -f $META->{LOCK}; # unsafe meta access, ok
783 unlink $META->{LOCK}; # unsafe meta access, ok
2e2b7522
GS		 784 # require Carp;
785 # Carp::cluck("DEBUGGING");
786 $CPAN::Frontend->mywarn("Lockfile removed.\n");
5f05dabc 787}
788
4c070e31
IZ		 789sub is_tested {
790 my($self,$what) = @_;
791 $self->{is_tested}{$what} = 1;
792}
793
794sub is_installed {
795 my($self,$what) = @_;
796 delete $self->{is_tested}{$what};
797}
798
799sub set_perl5lib {
800 my($self) = @_;
0362b508 801 $self->{is_tested} ||= {};
4c070e31
IZ		 802 return unless %{$self->{is_tested}};
803 my $env = $ENV{PERL5LIB};
804 $env = $ENV{PERLLIB} unless defined $env;
805 my @env;
806 push @env, $env if defined $env and length $env;
807 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
808 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
809 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
810}
811
05454584 812package CPAN::CacheMgr;
5f05dabc 813
05454584
A		 814#-> sub CPAN::CacheMgr::as_string ;
815sub as_string {
816 eval { require Data::Dumper };
817 if ($@) {
818 return shift->SUPER::as_string;
5f05dabc 819 } else {
05454584 820 return Data::Dumper::Dumper(shift);
5f05dabc 821 }
822}
823
05454584
A		 824#-> sub CPAN::CacheMgr::cachesize ;
825sub cachesize {
826 shift->{DU};
5f05dabc 827}
5f05dabc 828
c4d24d4c 829#-> sub CPAN::CacheMgr::tidyup ;
09d9d230
A		 830sub tidyup {
831 my($self) = @_;
832 return unless -d $self->{ID};
833 while ($self->{DU} > $self->{'MAX'} ) {
834 my($toremove) = shift @{$self->{FIFO}};
835 $CPAN::Frontend->myprint(sprintf(
836 "Deleting from cache".
837 ": $toremove (%.1f>%.1f MB)\n",
838 $self->{DU}, $self->{'MAX'})
839 );
840 return if $CPAN::Signal;
841 $self->force_clean_cache($toremove);
842 return if $CPAN::Signal;
843 }
844}
5f05dabc 845
05454584
A		 846#-> sub CPAN::CacheMgr::dir ;
847sub dir {
848 shift->{ID};
849}
850
851#-> sub CPAN::CacheMgr::entries ;
852sub entries {
853 my($self,$dir) = @_;
55e314ee 854 return unless defined $dir;
e50380aa 855 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
05454584 856 $dir ||= $self->{ID};
9d61fa1d 857 my($cwd) = CPAN::anycwd();
05454584 858 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
f14b5cec
JH		 859 my $dh = DirHandle->new(File::Spec->curdir)
860 or Carp::croak("Couldn't opendir $dir: $!");
05454584
A		 861 my(@entries);
862 for ($dh->read) {
863 next if $_ eq "." || $_ eq "..";
864 if (-f $_) {
5de3f0da 865 push @entries, File::Spec->catfile($dir,$_);
05454584 866 } elsif (-d _) {
5de3f0da 867 push @entries, File::Spec->catdir($dir,$_);
5f05dabc 868 } else {
c356248b 869 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
5f05dabc 870 }
5f05dabc 871 }
05454584 872 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
e50380aa 873 sort { -M $b <=> -M $a} @entries;
5f05dabc 874}
875
05454584
A		 876#-> sub CPAN::CacheMgr::disk_usage ;
877sub disk_usage {
878 my($self,$dir) = @_;
09d9d230
A		 879 return if exists $self->{SIZE}{$dir};
880 return if $CPAN::Signal;
881 my($Du) = 0;
05454584
A		 882 find(
883 sub {
f14b5cec
JH		 884 $File::Find::prune++ if $CPAN::Signal;
885 return if -l $_;
886 if ($^O eq 'MacOS') {
887 require Mac::Files;
888 my $cat = Mac::Files::FSpGetCatInfo($_);
911a92db 889 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
f14b5cec
JH		 890 } else {
891 $Du += (-s _);
892 }
05454584
A		 893 },
894 $dir
895 );
09d9d230 896 return if $CPAN::Signal;
05454584
A		 897 $self->{SIZE}{$dir} = $Du/1024/1024;
898 push @{$self->{FIFO}}, $dir;
899 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
900 $self->{DU} += $Du/1024/1024;
05454584 901 $self->{DU};
5f05dabc 902}
903
05454584
A		 904#-> sub CPAN::CacheMgr::force_clean_cache ;
905sub force_clean_cache {
906 my($self,$dir) = @_;
09d9d230 907 return unless -e $dir;
05454584
A		 908 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
909 if $CPAN::DEBUG;
910 File::Path::rmtree($dir);
911 $self->{DU} -= $self->{SIZE}{$dir};
912 delete $self->{SIZE}{$dir};
5f05dabc 913}
914
05454584
A		 915#-> sub CPAN::CacheMgr::new ;
916sub new {
917 my $class = shift;
e50380aa
A		 918 my $time = time;
919 my($debug,$t2);
920 $debug = "";
05454584
A		 921 my $self = {
922 ID => $CPAN::Config->{'build_dir'},
923 MAX => $CPAN::Config->{'build_cache'},
f610777f 924 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
05454584
A		 925 DU => 0
926 };
927 File::Path::mkpath($self->{ID});
928 my $dh = DirHandle->new($self->{ID});
929 bless $self, $class;
f610777f
A		 930 $self->scan_cache;
931 $t2 = time;
932 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
933 $time = $t2;
934 CPAN->debug($debug) if $CPAN::DEBUG;
935 $self;
936}
937
938#-> sub CPAN::CacheMgr::scan_cache ;
939sub scan_cache {
940 my $self = shift;
941 return if $self->{SCAN} eq 'never';
942 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
943 unless $self->{SCAN} eq 'atstart';
09d9d230
A		 944 $CPAN::Frontend->myprint(
945 sprintf("Scanning cache %s for sizes\n",
946 $self->{ID}));
f610777f 947 my $e;
09d9d230 948 for $e ($self->entries($self->{ID})) {
05454584 949 next if $e eq ".." || $e eq ".";
05454584 950 $self->disk_usage($e);
09d9d230 951 return if $CPAN::Signal;
5f05dabc 952 }
09d9d230 953 $self->tidyup;
5f05dabc 954}
955
05454584
A		 956package CPAN::Debug;
957
958#-> sub CPAN::Debug::debug ;
959sub debug {
960 my($self,$arg) = @_;
961 my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
962 # Complete, caller(1)
963 # eg readline
964 ($caller) = caller(0);
965 $caller =~ s/.*:://;
55e314ee 966 $arg = "" unless defined $arg;
c356248b 967 my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
05454584 968 if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
55e314ee 969 if ($arg and ref $arg) {
05454584
A		 970 eval { require Data::Dumper };
971 if ($@) {
c356248b 972 $CPAN::Frontend->myprint($arg->as_string);
05454584 973 } else {
c356248b 974 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
5f05dabc 975 }
976 } else {
c356248b 977 $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
5f05dabc 978 }
05454584
A		 979 }
980}
981
982package CPAN::Config;
05454584
A		 983
984#-> sub CPAN::Config::edit ;
de34a54b 985# returns true on successful action
05454584 986sub edit {
5e05dca5 987 my($self,@args) = @_;
05454584 988 return unless @args;
5e05dca5 989 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
05454584
A		 990 my($o,$str,$func,$args,$key_exists);
991 $o = shift @args;
992 if($can{$o}) {
5e05dca5 993 $self->$o(@args);
05454584
A		 994 return 1;
995 } else {
05d2a450 996 CPAN->debug("o[$o]") if $CPAN::DEBUG;
de34a54b 997 if ($o =~ /list$/) {
05454584
A		 998 $func = shift @args;
999 $func ||= "";
05d2a450 1000 CPAN->debug("func[$func]") if $CPAN::DEBUG;
de34a54b 1001 my $changed;
05454584
A		 1002 # Let's avoid eval, it's easier to comprehend without.
1003 if ($func eq "push") {
1004 push @{$CPAN::Config->{$o}}, @args;
de34a54b 1005 $changed = 1;
05454584
A		 1006 } elsif ($func eq "pop") {
1007 pop @{$CPAN::Config->{$o}};
de34a54b 1008 $changed = 1;
05454584
A		 1009 } elsif ($func eq "shift") {
1010 shift @{$CPAN::Config->{$o}};
de34a54b 1011 $changed = 1;
05454584
A		 1012 } elsif ($func eq "unshift") {
1013 unshift @{$CPAN::Config->{$o}}, @args;
de34a54b 1014 $changed = 1;
05454584
A		 1015 } elsif ($func eq "splice") {
1016 splice @{$CPAN::Config->{$o}}, @args;
de34a54b 1017 $changed = 1;
05454584
A		 1018 } elsif (@args) {
1019 $CPAN::Config->{$o} = [@args];
de34a54b 1020 $changed = 1;
05454584 1021 } else {
5e05dca5 1022 $self->prettyprint($o);
05454584 1023 }
de34a54b
JH		 1024 if ($o eq "urllist" && $changed) {
1025 # reset the cached values
1026 undef $CPAN::FTP::Thesite;
1027 undef $CPAN::FTP::Themethod;
1028 }
1029 return $changed;
05454584
A		 1030 } else {
1031 $CPAN::Config->{$o} = $args[0] if defined $args[0];
5e05dca5 1032 $self->prettyprint($o);
5f05dabc 1033 }
5f05dabc 1034 }
05454584
A		 1035}
1036
5e05dca5
A		 1037sub prettyprint {
1038 my($self,$k) = @_;
1039 my $v = $CPAN::Config->{$k};
1040 if (ref $v) {
1041 my(@report) = ref $v eq "ARRAY" ?
1042 @$v :
1043 map { sprintf(" %-18s => %s\n",
1044 $_,
1045 defined $v->{$_} ? $v->{$_} : "UNDEFINED"
1046 )} keys %$v;
1047 $CPAN::Frontend->myprint(
1048 join(
1049 "",
1050 sprintf(
1051 " %-18s\n",
1052 $k
1053 ),
1054 map {"\t$_\n"} @report
1055 )
1056 );
1057 } elsif (defined $v) {
1058 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
1059 } else {
1060 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
1061 }
1062}
1063
05454584
A		 1064#-> sub CPAN::Config::commit ;
1065sub commit {
1066 my($self,$configpm) = @_;
1067 unless (defined $configpm){
1068 $configpm ||= $INC{"CPAN/MyConfig.pm"};
1069 $configpm ||= $INC{"CPAN/Config.pm"};
2e2b7522 1070 $configpm || Carp::confess(q{
05454584
A		 1071CPAN::Config::commit called without an argument.
1072Please specify a filename where to save the configuration or try
1073"o conf init" to have an interactive course through configing.
1074});
1075 }
1076 my($mode);
1077 if (-f $configpm) {
1078 $mode = (stat $configpm)[2];
1079 if ($mode && ! -w _) {
1080 Carp::confess("$configpm is not writable");
5f05dabc 1081 }
1082 }
05454584 1083
de34a54b
JH		 1084 my $msg;
1085 $msg = <<EOF unless $configpm =~ /MyConfig/;
05454584 1086
09d9d230 1087# This is CPAN.pm's systemwide configuration file. This file provides
55e314ee
A		 1088# defaults for users, and the values can be changed in a per-user
1089# configuration file. The user-config file is being looked for as
1090# ~/.cpan/CPAN/MyConfig.pm.
05454584
A		 1091
1092EOF
1093 $msg ||= "\n";
1094 my($fh) = FileHandle->new;
f610777f 1095 rename $configpm, "$configpm~" if -f $configpm;
6d29edf5 1096 open $fh, ">$configpm" or
9d61fa1d 1097 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
c356248b 1098 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
05454584
A		 1099 foreach (sort keys %$CPAN::Config) {
1100 $fh->print(
1101 " '$_' => ",
1102 ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
1103 ",\n"
1104 );
5f05dabc 1105 }
05454584 1106
c356248b 1107 $fh->print("};\n1;\n__END__\n");
05454584
A		 1108 close $fh;
1109
1110 #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
1111 #chmod $mode, $configpm;
e50380aa 1112###why was that so? $self->defaults;
c356248b 1113 $CPAN::Frontend->myprint("commit: wrote $configpm\n");
05454584 1114 1;
5f05dabc 1115}
1116
05454584
A		 1117*default = \&defaults;
1118#-> sub CPAN::Config::defaults ;
1119sub defaults {
1120 my($self) = @_;
1121 $self->unload;
1122 $self->load;
1123 1;
5f05dabc 1124}
1125
05454584
A		 1126sub init {
1127 my($self) = @_;
1128 undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
1129 # have the least
1130 # important
1131 # variable
1132 # undefined
1133 $self->load;
1134 1;
5f05dabc 1135}
1136
c076f9f6
RB		 1137# This is a piece of repeated code that is abstracted here for
1138# maintainability. RMB
1139#
1140sub _configpmtest {
1141 my($configpmdir, $configpmtest) = @_;
1142 if (-w $configpmtest) {
1143 return $configpmtest;
1144 } elsif (-w $configpmdir) {
1145 #_#_# following code dumped core on me with 5.003_11, a.k.
1146 my $configpm_bak = "$configpmtest.bak";
1147 unlink $configpm_bak if -f $configpm_bak;
1148 if( -f $configpmtest ) {
1149 if( rename $configpmtest, $configpm_bak ) {
1150 $CPAN::Frontend->mywarn(<<END)
1151Old configuration file $configpmtest
1152 moved to $configpm_bak
1153END
1154 }
1155 }
1156 my $fh = FileHandle->new;
1157 if ($fh->open(">$configpmtest")) {
1158 $fh->print("1;\n");
1159 return $configpmtest;
1160 } else {
1161 # Should never happen
1162 Carp::confess("Cannot open >$configpmtest");
1163 }
1164 } else { return }
1165}
1166
05454584
A		 1167#-> sub CPAN::Config::load ;
1168sub load {
e50380aa
A		 1169 my($self) = shift;
1170 my(@miss);
f610777f 1171 use Carp;
c356248b
A		 1172 eval {require CPAN::Config;}; # We eval because of some
1173 # MakeMaker problems
09d9d230 1174 unless ($dot_cpan++){
5de3f0da 1175 unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
09d9d230 1176 eval {require CPAN::MyConfig;}; # where you can override
c356248b 1177 # system wide settings
09d9d230
A		 1178 shift @INC;
1179 }
c4d24d4c
A		 1180 return unless @miss = $self->missing_config_data;
1181
e50380aa 1182 require CPAN::FirstTime;
55e314ee 1183 my($configpm,$fh,$redo,$theycalled);
e50380aa 1184 $redo ||= "";
55e314ee 1185 $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
e50380aa
A		 1186 if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
1187 $configpm = $INC{"CPAN/Config.pm"};
1188 $redo++;
1189 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
1190 $configpm = $INC{"CPAN/MyConfig.pm"};
1191 $redo++;
1192 } else {
1193 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
5de3f0da
DR		 1194 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
1195 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
e50380aa 1196 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
c076f9f6 1197 $configpm = _configpmtest($configpmdir,$configpmtest);
e50380aa
A		 1198 }
1199 unless ($configpm) {
5de3f0da 1200 $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
e50380aa 1201 File::Path::mkpath($configpmdir);
5de3f0da 1202 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
c076f9f6
RB		 1203 $configpm = _configpmtest($configpmdir,$configpmtest);
1204 unless ($configpm) {
e50380aa
A		 1205 Carp::confess(qq{WARNING: CPAN.pm is unable to }.
1206 qq{create a configuration file.});
1207 }
1208 }
1209 }
1210 local($") = ", ";
f610777f 1211 $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
e50380aa
A		 1212We have to reconfigure CPAN.pm due to following uninitialized parameters:
1213
1214@miss
f610777f 1215END
c356248b 1216 $CPAN::Frontend->myprint(qq{
05454584 1217$configpm initialized.
c356248b 1218});
e50380aa
A		 1219 sleep 2;
1220 CPAN::FirstTime::init($configpm);
5f05dabc 1221}
1222
c4d24d4c
A		 1223#-> sub CPAN::Config::missing_config_data ;
1224sub missing_config_data {
e50380aa 1225 my(@miss);
c4d24d4c
A		 1226 for (
1227 "cpan_home", "keep_source_where", "build_dir", "build_cache",
5a5fac02
JH		 1228 "scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
1229 "pager",
c4d24d4c
A		 1230 "makepl_arg", "make_arg", "make_install_arg", "urllist",
1231 "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
1232 "prerequisites_policy",
5a5fac02 1233 "cache_metadata",
c4d24d4c 1234 ) {
e50380aa 1235 push @miss, $_ unless defined $CPAN::Config->{$_};
5f05dabc 1236 }
e50380aa 1237 return @miss;
5f05dabc 1238}
1239
05454584
A		 1240#-> sub CPAN::Config::unload ;
1241sub unload {
1242 delete $INC{'CPAN/MyConfig.pm'};
1243 delete $INC{'CPAN/Config.pm'};
5f05dabc 1244}
1245
05454584
A		 1246#-> sub CPAN::Config::help ;
1247sub help {
2e2b7522 1248 $CPAN::Frontend->myprint(q[
05454584
A		 1249Known options:
1250 defaults reload default config values from disk
1251 commit commit session changes to disk
1252 init go through a dialog to set all parameters
5f05dabc 1253
911a92db
GS		 1254You may edit key values in the follow fashion (the "o" is a literal
1255letter o):
5f05dabc 1256
05454584 1257 o conf build_cache 15
5f05dabc 1258
05454584 1259 o conf build_dir "/foo/bar"
5f05dabc 1260
05454584 1261 o conf urllist shift
5f05dabc 1262
05454584 1263 o conf urllist unshift ftp://ftp.foo.bar/
5f05dabc 1264
2e2b7522 1265]);
05454584
A		 1266 undef; #don't reprint CPAN::Config
1267}
5f05dabc 1268
55e314ee
A		 1269#-> sub CPAN::Config::cpl ;
1270sub cpl {
05454584
A		 1271 my($word,$line,$pos) = @_;
1272 $word ||= "";
c356248b
A		 1273 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
1274 my(@words) = split " ", substr($line,0,$pos+1);
1275 if (
09d9d230
A		 1276 defined($words[2])
1277 and
1278 (
1279 $words[2] =~ /list$/ && @words == 3
1280 ||
1281 $words[2] =~ /list$/ && @words == 4 && length($word)
1282 )
c356248b
A		 1283 ) {
1284 return grep /^\Q$word\E/, qw(splice shift unshift pop push);
1285 } elsif (@words >= 4) {
1286 return ();
1287 }
05454584
A		 1288 my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
1289 return grep /^\Q$word\E/, @o_conf;
1290}
1291
1292package CPAN::Shell;
5f05dabc 1293
05454584
A		 1294#-> sub CPAN::Shell::h ;
1295sub h {
1296 my($class,$about) = @_;
1297 if (defined $about) {
c356248b 1298 $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
05454584 1299 } else {
c356248b 1300 $CPAN::Frontend->myprint(q{
911a92db 1301Display Information
c049f953
JH		 1302 command argument description
1303 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
1304 i WORD or /REGEXP/ about anything of above
1305 r NONE reinstall recommendations
1306 ls AUTHOR about files in the author's directory
911a92db
GS		 1307
1308Download, Test, Make, Install...
1309 get download
1310 make make (implies get)
c049f953
JH		 1311 test MODULES, make test (implies make)
1312 install DISTS, BUNDLES make install (implies test)
911a92db
GS		 1313 clean make clean
1314 look open subshell in these dists' directories
1315 readme display these dists' README files
1316
1317Other
1318 h,? display this menu ! perl-code eval a perl command
1319 o conf [opt] set and query options q quit the cpan shell
1320 reload cpan load CPAN.pm again reload index load newer indices
1321 autobundle Snapshot force cmd unconditionally do cmd});
05454584
A		 1322 }
1323}
da199366 1324
09d9d230
A		 1325*help = \&h;
1326
05454584 1327#-> sub CPAN::Shell::a ;
de34a54b
JH		 1328sub a {
1329 my($self,@arg) = @_;
1330 # authors are always UPPERCASE
1331 for (@arg) {
c049f953 1332 $_ = uc $_ unless /=/;
de34a54b
JH		 1333 }
1334 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1335}
6d29edf5 1336
8d97e4a1
JH		 1337#-> sub CPAN::Shell::ls ;
1338sub ls {
1339 my($self,@arg) = @_;
c049f953 1340 my @accept;
8d97e4a1 1341 for (@arg) {
c049f953
JH		 1342 unless (/^[A-Z\-]+$/i) {
1343 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
1344 next;
1345 }
1346 push @accept, uc $_;
8d97e4a1 1347 }
c049f953 1348 for my $a (@accept){
8d97e4a1
JH		 1349 my $author = $self->expand('Author',$a) or die "No author found for $a";
1350 $author->ls;
1351 }
1352}
6d29edf5 1353
8d97e4a1 1354#-> sub CPAN::Shell::local_bundles ;
6d29edf5 1355sub local_bundles {
05454584 1356 my($self,@which) = @_;
55e314ee 1357 my($incdir,$bdir,$dh);
05454584 1358 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8d97e4a1
JH		 1359 my @bbase = "Bundle";
1360 while (my $bbase = shift @bbase) {
5de3f0da 1361 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
8d97e4a1
JH		 1362 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1363 if ($dh = DirHandle->new($bdir)) { # may fail
1364 my($entry);
1365 for $entry ($dh->read) {
c049f953 1366 next if $entry =~ /^\./;
5de3f0da 1367 if (-d File::Spec->catdir($bdir,$entry)){
8d97e4a1
JH		 1368 push @bbase, "$bbase\::$entry";
1369 } else {
1370 next unless $entry =~ s/\.pm(?!\n)\Z//;
1371 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1372 }
1373 }
1374 }
1375 }
05454584 1376 }
6d29edf5
JH		 1377}
1378
1379#-> sub CPAN::Shell::b ;
1380sub b {
1381 my($self,@which) = @_;
1382 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1383 $self->local_bundles;
c356248b 1384 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
05454584 1385}
6d29edf5 1386
05454584 1387#-> sub CPAN::Shell::d ;
c356248b 1388sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
6d29edf5 1389
05454584 1390#-> sub CPAN::Shell::m ;
f610777f
A		 1391sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1392 $CPAN::Frontend->myprint(shift->format_result('Module',@_));
1393}
da199366 1394
05454584
A		 1395#-> sub CPAN::Shell::i ;
1396sub i {
1397 my($self) = shift;
1398 my(@args) = @_;
1399 my(@type,$type,@m);
1400 @type = qw/Author Bundle Distribution Module/;
1401 @args = '/./' unless @args;
1402 my(@result);
1403 for $type (@type) {
1404 push @result, $self->expand($type,@args);
1405 }
8d97e4a1 1406 my $result = @result == 1 ?
05454584 1407 $result[0]->as_string :
8d97e4a1
JH		 1408 @result == 0 ?
1409 "No objects found of any type for argument @args\n" :
1410 join("",
1411 (map {$_->as_glimpse} @result),
1412 scalar @result, " items found\n",
1413 );
c356248b 1414 $CPAN::Frontend->myprint($result);
da199366 1415}
da199366 1416
05454584 1417#-> sub CPAN::Shell::o ;
5e05dca5 1418
6d29edf5
JH		 1419# CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
1420# should have been called set and 'o debug' maybe 'set debug'
05454584
A		 1421sub o {
1422 my($self,$o_type,@o_what) = @_;
1423 $o_type ||= "";
1424 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1425 if ($o_type eq 'conf') {
1426 shift @o_what if @o_what && $o_what[0] eq 'help';
5e05dca5 1427 if (!@o_what) { # print all things, "o conf"
05454584 1428 my($k,$v);
09d9d230
A		 1429 $CPAN::Frontend->myprint("CPAN::Config options");
1430 if (exists $INC{'CPAN/Config.pm'}) {
1431 $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
1432 }
1433 if (exists $INC{'CPAN/MyConfig.pm'}) {
1434 $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
1435 }
1436 $CPAN::Frontend->myprint(":\n");
05454584
A		 1437 for $k (sort keys %CPAN::Config::can) {
1438 $v = $CPAN::Config::can{$k};
c356248b 1439 $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
05454584 1440 }
c356248b 1441 $CPAN::Frontend->myprint("\n");
05454584 1442 for $k (sort keys %$CPAN::Config) {
5e05dca5 1443 CPAN::Config->prettyprint($k);
10b2abe6 1444 }
c356248b 1445 $CPAN::Frontend->myprint("\n");
05454584 1446 } elsif (!CPAN::Config->edit(@o_what)) {
6d29edf5
JH		 1447 $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
1448 qq{edit options\n\n});
5f05dabc 1449 }
05454584
A		 1450 } elsif ($o_type eq 'debug') {
1451 my(%valid);
1452 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1453 if (@o_what) {
1454 while (@o_what) {
1455 my($what) = shift @o_what;
8d97e4a1
JH		 1456 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1457 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1458 next;
1459 }
05454584
A		 1460 if ( exists $CPAN::DEBUG{$what} ) {
1461 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1462 } elsif ($what =~ /^\d/) {
1463 $CPAN::DEBUG = $what;
1464 } elsif (lc $what eq 'all') {
1465 my($max) = 0;
1466 for (values %CPAN::DEBUG) {
1467 $max += $_;
10b2abe6 1468 }
05454584 1469 $CPAN::DEBUG = $max;
10b2abe6 1470 } else {
d4fd5c69 1471 my($known) = 0;
05454584
A		 1472 for (keys %CPAN::DEBUG) {
1473 next unless lc($_) eq lc($what);
1474 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
d4fd5c69 1475 $known = 1;
10b2abe6 1476 }
c356248b
A		 1477 $CPAN::Frontend->myprint("unknown argument [$what]\n")
1478 unless $known;
10b2abe6
CS		 1479 }
1480 }
05454584 1481 } else {
911a92db
GS		 1482 my $raw = "Valid options for debug are ".
1483 join(", ",sort(keys %CPAN::DEBUG), 'all').
1484 qq{ or a number. Completion works on the options. }.
1485 qq{Case is ignored.};
1486 require Text::Wrap;
1487 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1488 $CPAN::Frontend->myprint("\n\n");
05454584
A		 1489 }
1490 if ($CPAN::DEBUG) {
c356248b 1491 $CPAN::Frontend->myprint("Options set for debugging:\n");
05454584
A		 1492 my($k,$v);
1493 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1494 $v = $CPAN::DEBUG{$k};
05d2a450
A		 1495 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
1496 if $v & $CPAN::DEBUG;
05454584
A		 1497 }
1498 } else {
c356248b 1499 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
10b2abe6 1500 }
05454584 1501 } else {
c356248b 1502 $CPAN::Frontend->myprint(qq{
05454584
A		 1503Known options:
1504 conf set or get configuration variables
1505 debug set or get debugging options
c356248b 1506});
5f05dabc 1507 }
5f05dabc 1508}
1509
6d29edf5 1510sub paintdots_onreload {
36263cb3
GS		 1511 my($ref) = shift;
1512 sub {
6d29edf5 1513 if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
36263cb3
GS		 1514 my($subr) = $1;
1515 ++$$ref;
1516 local($|) = 1;
1517 # $CPAN::Frontend->myprint(".($subr)");
1518 $CPAN::Frontend->myprint(".");
1519 return;
1520 }
1521 warn @_;
1522 };
1523}
1524
05454584
A		 1525#-> sub CPAN::Shell::reload ;
1526sub reload {
d4fd5c69
A		 1527 my($self,$command,@arg) = @_;
1528 $command ||= "";
1529 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1530 if ($command =~ /cpan/i) {
05454584
A		 1531 CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
1532 my $fh = FileHandle->new($INC{'CPAN.pm'});
1533 local($/);
6d29edf5
JH		 1534 my $redef = 0;
1535 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
05454584
A		 1536 eval <$fh>;
1537 warn $@ if $@;
c356248b 1538 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
d4fd5c69 1539 } elsif ($command =~ /index/) {
2e2b7522 1540 CPAN::Index->force_reload;
d4fd5c69 1541 } else {
2e2b7522 1542 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
f14b5cec 1543index re-reads the index files\n});
05454584
A		 1544 }
1545}
1546
1547#-> sub CPAN::Shell::_binary_extensions ;
1548sub _binary_extensions {
1549 my($self) = shift @_;
1550 my(@result,$module,%seen,%need,$headerdone);
1551 for $module ($self->expand('Module','/./')) {
1552 my $file = $module->cpan_file;
1553 next if $file eq "N/A";
1554 next if $file =~ /^Contact Author/;
05d2a450
A		 1555 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1556 next if $dist->isa_perl;
05454584
A		 1557 next unless $module->xs_file;
1558 local($|) = 1;
c356248b 1559 $CPAN::Frontend->myprint(".");
05454584
A		 1560 push @result, $module;
1561 }
1562# print join " | ", @result;
c356248b 1563 $CPAN::Frontend->myprint("\n");
05454584
A		 1564 return @result;
1565}
1566
1567#-> sub CPAN::Shell::recompile ;
1568sub recompile {
1569 my($self) = shift @_;
1570 my($module,@module,$cpan_file,%dist);
1571 @module = $self->_binary_extensions();
c356248b
A		 1572 for $module (@module){ # we force now and compile later, so we
1573 # don't do it twice
05454584
A		 1574 $cpan_file = $module->cpan_file;
1575 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1576 $pack->force;
1577 $dist{$cpan_file}++;
1578 }
1579 for $cpan_file (sort keys %dist) {
c356248b 1580 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
05454584
A		 1581 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1582 $pack->install;
1583 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1584 # stop a package from recompiling,
1585 # e.g. IO-1.12 when we have perl5.003_10
1586 }
1587}
1588
1589#-> sub CPAN::Shell::_u_r_common ;
1590sub _u_r_common {
1591 my($self) = shift @_;
1592 my($what) = shift @_;
1593 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
c4d24d4c
A		 1594 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1595 $what && $what =~ /^[aru]$/;
05454584
A		 1596 my(@args) = @_;
1597 @args = '/./' unless @args;
c356248b
A		 1598 my(@result,$module,%seen,%need,$headerdone,
1599 $version_undefs,$version_zeroes);
1600 $version_undefs = $version_zeroes = 0;
9d61fa1d 1601 my $sprintf = "%s%-25s%s %9s %9s %s\n";
6d29edf5
JH		 1602 my @expand = $self->expand('Module',@args);
1603 my $expand = scalar @expand;
1604 if (0) { # Looks like noise to me, was very useful for debugging
1605 # for metadata cache
1606 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1607 }
1608 for $module (@expand) {
05454584
A		 1609 my $file = $module->cpan_file;
1610 next unless defined $file; # ??
6d29edf5 1611 my($latest) = $module->cpan_version;
05454584
A		 1612 my($inst_file) = $module->inst_file;
1613 my($have);
09d9d230 1614 return if $CPAN::Signal;
05454584
A		 1615 if ($inst_file){
1616 if ($what eq "a") {
6d29edf5 1617 $have = $module->inst_version;
05454584 1618 } elsif ($what eq "r") {
6d29edf5 1619 $have = $module->inst_version;
05454584 1620 local($^W) = 0;
c356248b
A		 1621 if ($have eq "undef"){
1622 $version_undefs++;
1623 } elsif ($have == 0){
1624 $version_zeroes++;
1625 }
5e05dca5 1626 next unless CPAN::Version->vgt($latest, $have);
c356248b
A		 1627# to be pedantic we should probably say:
1628# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1629# to catch the case where CPAN has a version 0 and we have a version undef
05454584
A		 1630 } elsif ($what eq "u") {
1631 next;
1632 }
1633 } else {
1634 if ($what eq "a") {
1635 next;
1636 } elsif ($what eq "r") {
1637 next;
1638 } elsif ($what eq "u") {
1639 $have = "-";
1640 }
1641 }
1642 return if $CPAN::Signal; # this is sometimes lengthy
1643 $seen{$file} ||= 0;
1644 if ($what eq "a") {
1645 push @result, sprintf "%s %s\n", $module->id, $have;
1646 } elsif ($what eq "r") {
1647 push @result, $module->id;
1648 next if $seen{$file}++;
1649 } elsif ($what eq "u") {
1650 push @result, $module->id;
1651 next if $seen{$file}++;
1652 next if $file =~ /^Contact/;
1653 }
1654 unless ($headerdone++){
c356248b
A		 1655 $CPAN::Frontend->myprint("\n");
1656 $CPAN::Frontend->myprint(sprintf(
9d61fa1d
A		 1657 $sprintf,
1658 "",
1659 "Package namespace",
1660 "",
1661 "installed",
1662 "latest",
1663 "in CPAN file"
1664 ));
05454584 1665 }
9d61fa1d
A		 1666 my $color_on = "";
1667 my $color_off = "";
1668 if (
1669 $COLOR_REGISTERED
1670 &&
1671 $CPAN::META->has_inst("Term::ANSIColor")
1672 &&
1673 $module->{RO}{description}
1674 ) {
1675 $color_on = Term::ANSIColor::color("green");
1676 $color_off = Term::ANSIColor::color("reset");
1677 }
05d2a450 1678 $CPAN::Frontend->myprint(sprintf $sprintf,
9d61fa1d 1679 $color_on,
05d2a450 1680 $module->id,
9d61fa1d 1681 $color_off,
05d2a450
A		 1682 $have,
1683 $latest,
1684 $file);
05454584
A		 1685 $need{$module->id}++;
1686 }
1687 unless (%need) {
1688 if ($what eq "u") {
c356248b 1689 $CPAN::Frontend->myprint("No modules found for @args\n");
05454584 1690 } elsif ($what eq "r") {
c356248b 1691 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
05454584
A		 1692 }
1693 }
c356248b
A		 1694 if ($what eq "r") {
1695 if ($version_zeroes) {
1696 my $s_has = $version_zeroes > 1 ? "s have" : " has";
1697 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1698 qq{a version number of 0\n});
1699 }
1700 if ($version_undefs) {
1701 my $s_has = $version_undefs > 1 ? "s have" : " has";
1702 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1703 qq{parseable version number\n});
1704 }
05454584
A		 1705 }
1706 @result;
1707}
1708
1709#-> sub CPAN::Shell::r ;
1710sub r {
1711 shift->_u_r_common("r",@_);
1712}
1713
1714#-> sub CPAN::Shell::u ;
1715sub u {
1716 shift->_u_r_common("u",@_);
1717}
1718
1719#-> sub CPAN::Shell::autobundle ;
1720sub autobundle {
1721 my($self) = shift;
36263cb3 1722 CPAN::Config->load unless $CPAN::Config_loaded++;
05454584 1723 my(@bundle) = $self->_u_r_common("a",@_);
5de3f0da 1724 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
05454584
A		 1725 File::Path::mkpath($todir);
1726 unless (-d $todir) {
c356248b 1727 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
05454584
A		 1728 return;
1729 }
1730 my($y,$m,$d) = (localtime)[5,4,3];
1731 $y+=1900;
1732 $m++;
1733 my($c) = 0;
1734 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
5de3f0da 1735 my($to) = File::Spec->catfile($todir,"$me.pm");
05454584
A		 1736 while (-f $to) {
1737 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
5de3f0da 1738 $to = File::Spec->catfile($todir,"$me.pm");
05454584
A		 1739 }
1740 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
1741 $fh->print(
1742 "package Bundle::$me;\n\n",
1743 "\$VERSION = '0.01';\n\n",
1744 "1;\n\n",
1745 "__END__\n\n",
1746 "=head1 NAME\n\n",
1747 "Bundle::$me - Snapshot of installation on ",
1748 $Config::Config{'myhostname'},
1749 " on ",
1750 scalar(localtime),
1751 "\n\n=head1 SYNOPSIS\n\n",
1752 "perl -MCPAN -e 'install Bundle::$me'\n\n",
1753 "=head1 CONTENTS\n\n",
1754 join("\n", @bundle),
1755 "\n\n=head1 CONFIGURATION\n\n",
1756 Config->myconfig,
1757 "\n\n=head1 AUTHOR\n\n",
1758 "This Bundle has been generated automatically ",
1759 "by the autobundle routine in CPAN.pm.\n",
1760 );
1761 $fh->close;
c356248b
A		 1762 $CPAN::Frontend->myprint("\nWrote bundle file
1763 $to\n\n");
05454584
A		 1764}
1765
6d29edf5
JH		 1766#-> sub CPAN::Shell::expandany ;
1767sub expandany {
1768 my($self,$s) = @_;
1769 CPAN->debug("s[$s]") if $CPAN::DEBUG;
1770 if ($s =~ m|/|) { # looks like a file
8d97e4a1 1771 $s = CPAN::Distribution->normalize($s);
6d29edf5
JH		 1772 return $CPAN::META->instance('CPAN::Distribution',$s);
1773 # Distributions spring into existence, not expand
1774 } elsif ($s =~ m|^Bundle::|) {
1775 $self->local_bundles; # scanning so late for bundles seems
1776 # both attractive and crumpy: always
1777 # current state but easy to forget
1778 # somewhere
1779 return $self->expand('Bundle',$s);
1780 } else {
1781 return $self->expand('Module',$s)
1782 if $CPAN::META->exists('CPAN::Module',$s);
1783 }
1784 return;
1785}
1786
05454584
A		 1787#-> sub CPAN::Shell::expand ;
1788sub expand {
1789 shift;
1790 my($type,@args) = @_;
1791 my($arg,@m);
8d97e4a1 1792 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
05454584 1793 for $arg (@args) {
6d29edf5 1794 my($regex,$command);
05454584
A		 1795 if ($arg =~ m|^/(.*)/$|) {
1796 $regex = $1;
8d97e4a1
JH		 1797 } elsif ($arg =~ m/=/) {
1798 $command = 1;
6d29edf5 1799 }
05454584
A		 1800 my $class = "CPAN::$type";
1801 my $obj;
8d97e4a1
JH		 1802 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
1803 $class,
1804 defined $regex ? $regex : "UNDEFINED",
1805 $command || "UNDEFINED",
1806 ) if $CPAN::DEBUG;
05454584 1807 if (defined $regex) {
6d29edf5
JH		 1808 for $obj (
1809 sort
1810 {$a->id cmp $b->id}
1811 $CPAN::META->all_objects($class)
1812 ) {
1813 unless ($obj->id){
1814 # BUG, we got an empty object somewhere
8d97e4a1 1815 require Data::Dumper;
6d29edf5 1816 CPAN->debug(sprintf(
8d97e4a1 1817 "Bug in CPAN: Empty id on obj[%s][%s]",
6d29edf5 1818 $obj,
8d97e4a1 1819 Data::Dumper::Dumper($obj)
6d29edf5
JH		 1820 )) if $CPAN::DEBUG;
1821 next;
1822 }
1823 push @m, $obj
1824 if $obj->id =~ /$regex/i
1825 or
1826 (
1827 (
1828 $] < 5.00303 ### provide sort of
1829 ### compatibility with 5.003
1830 ||
1831 $obj->can('name')
1832 )
1833 &&
1834 $obj->name =~ /$regex/i
1835 );
1836 }
1837 } elsif ($command) {
8d97e4a1
JH		 1838 die "equal sign in command disabled (immature interface), ".
1839 "you can set
1840 ! \$CPAN::Shell::ADVANCED_QUERY=1
1841to enable it. But please note, this is HIGHLY EXPERIMENTAL code
1842that may go away anytime.\n"
1843 unless $ADVANCED_QUERY;
1844 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
1845 my($matchcrit) = $criterion =~ m/^~(.+)/;
6d29edf5
JH		 1846 for my $self (
1847 sort
1848 {$a->id cmp $b->id}
1849 $CPAN::META->all_objects($class)
1850 ) {
8d97e4a1
JH		 1851 my $lhs = $self->$method() or next; # () for 5.00503
1852 if ($matchcrit) {
1853 push @m, $self if $lhs =~ m/$matchcrit/;
1854 } else {
1855 push @m, $self if $lhs eq $criterion;
1856 }
6d29edf5 1857 }
05454584
A		 1858 } else {
1859 my($xarg) = $arg;
1860 if ( $type eq 'Bundle' ) {
1861 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
8d97e4a1
JH		 1862 } elsif ($type eq "Distribution") {
1863 $xarg = CPAN::Distribution->normalize($arg);
1864 }
05454584
A		 1865 if ($CPAN::META->exists($class,$xarg)) {
1866 $obj = $CPAN::META->instance($class,$xarg);
1867 } elsif ($CPAN::META->exists($class,$arg)) {
1868 $obj = $CPAN::META->instance($class,$arg);
1869 } else {
1870 next;
1871 }
1872 push @m, $obj;
1873 }
1874 }
e50380aa 1875 return wantarray ? @m : $m[0];
05454584
A		 1876}
1877
1878#-> sub CPAN::Shell::format_result ;
1879sub format_result {
1880 my($self) = shift;
1881 my($type,@args) = @_;
1882 @args = '/./' unless @args;
1883 my(@result) = $self->expand($type,@args);
8d97e4a1 1884 my $result = @result == 1 ?
05454584 1885 $result[0]->as_string :
8d97e4a1
JH		 1886 @result == 0 ?
1887 "No objects of type $type found for argument @args\n" :
1888 join("",
1889 (map {$_->as_glimpse} @result),
1890 scalar @result, " items found\n",
1891 );
05454584
A		 1892 $result;
1893}
1894
c356248b
A		 1895# The only reason for this method is currently to have a reliable
1896# debugging utility that reveals which output is going through which
1897# channel. No, I don't like the colors ;-)
8d97e4a1
JH		 1898
1899#-> sub CPAN::Shell::print_ornameted ;
c356248b
A		 1900sub print_ornamented {
1901 my($self,$what,$ornament) = @_;
1902 my $longest = 0;
8d97e4a1 1903 return unless defined $what;
c356248b 1904
8d97e4a1
JH		 1905 if ($CPAN::Config->{term_is_latin}){
1906 # courtesy jhi:
1907 $what
1908 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
1909 }
1910 if ($PRINT_ORNAMENTING) {
c356248b
A		 1911 unless (defined &color) {
1912 if ($CPAN::META->has_inst("Term::ANSIColor")) {
1913 import Term::ANSIColor "color";
1914 } else {
1915 *color = sub { return "" };
1916 }
1917 }
09d9d230
A		 1918 my $line;
1919 for $line (split /\n/, $what) {
c356248b
A		 1920 $longest = length($line) if length($line) > $longest;
1921 }
1922 my $sprintf = "%-" . $longest . "s";
1923 while ($what){
1924 $what =~ s/(.*\n?)//m;
1925 my $line = $1;
1926 last unless $line;
1927 my($nl) = chomp $line ? "\n" : "";
1928 # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
1929 print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
1930 }
1931 } else {
1932 print $what;
1933 }
1934}
1935
1936sub myprint {
1937 my($self,$what) = @_;
8d97e4a1 1938
c356248b
A		 1939 $self->print_ornamented($what, 'bold blue on_yellow');
1940}
1941
1942sub myexit {
1943 my($self,$what) = @_;
1944 $self->myprint($what);
1945 exit;
1946}
1947
1948sub mywarn {
1949 my($self,$what) = @_;
1950 $self->print_ornamented($what, 'bold red on_yellow');
1951}
1952
1953sub myconfess {
1954 my($self,$what) = @_;
1955 $self->print_ornamented($what, 'bold red on_white');
1956 Carp::confess "died";
1957}
1958
1959sub mydie {
1960 my($self,$what) = @_;
1961 $self->print_ornamented($what, 'bold red on_white');
1962 die "\n";
1963}
1964
911a92db
GS		 1965sub setup_output {
1966 return if -t STDOUT;
1967 my $odef = select STDERR;
1968 $| = 1;
1969 select STDOUT;
1970 $| = 1;
1971 select $odef;
1972}
1973
05454584 1974#-> sub CPAN::Shell::rematein ;
09d9d230 1975# RE-adme||MA-ke||TE-st||IN-stall
05454584
A		 1976sub rematein {
1977 shift;
1978 my($meth,@some) = @_;
1979 my $pragma = "";
1980 if ($meth eq 'force') {
1981 $pragma = $meth;
1982 $meth = shift @some;
1983 }
911a92db 1984 setup_output();
05454584 1985 CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
6d29edf5
JH		 1986
1987 # Here is the place to set "test_count" on all involved parties to
1988 # 0. We then can pass this counter on to the involved
1989 # distributions and those can refuse to test if test_count > X. In
1990 # the first stab at it we could use a 1 for "X".
1991
1992 # But when do I reset the distributions to start with 0 again?
1993 # Jost suggested to have a random or cycling interaction ID that
1994 # we pass through. But the ID is something that is just left lying
1995 # around in addition to the counter, so I'd prefer to set the
1996 # counter to 0 now, and repeat at the end of the loop. But what
1997 # about dependencies? They appear later and are not reset, they
1998 # enter the queue but not its copy. How do they get a sensible
1999 # test_count?
2000
2001 # construct the queue
2002 my($s,@s,@qcopy);
05454584
A		 2003 foreach $s (@some) {
2004 my $obj;
2005 if (ref $s) {
6d29edf5 2006 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
05454584 2007 $obj = $s;
c4d24d4c 2008 } elsif ($s =~ m|^/|) { # looks like a regexp
6d29edf5
JH		 2009 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2010 "not supported\n");
2011 sleep 2;
2012 next;
05454584 2013 } else {
6d29edf5
JH		 2014 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2015 $obj = CPAN::Shell->expandany($s);
05454584
A		 2016 }
2017 if (ref $obj) {
6d29edf5 2018 $obj->color_cmd_tmps(0,1);
c049f953 2019 CPAN::Queue->new($obj->id);
6d29edf5 2020 push @qcopy, $obj;
05454584
A		 2021 } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
2022 $obj = $CPAN::META->instance('CPAN::Author',$s);
8d97e4a1
JH		 2023 if ($meth eq "dump") {
2024 $obj->dump;
2025 } else {
2026 $CPAN::Frontend->myprint(
2027 join "",
2028 "Don't be silly, you can't $meth ",
2029 $obj->fullname,
2030 " ;-)\n"
2031 );
2032 sleep 2;
2033 }
05454584 2034 } else {
f610777f
A		 2035 $CPAN::Frontend
2036 ->myprint(qq{Warning: Cannot $meth $s, }.
2037 qq{don\'t know what it is.
e50380aa
A		 2038Try the command
2039
2040 i /$s/
2041
6d29edf5 2042to find objects with matching identifiers.
c356248b 2043});
6d29edf5
JH		 2044 sleep 2;
2045 }
2046 }
2047
2048 # queuerunner (please be warned: when I started to change the
2049 # queue to hold objects instead of names, I made one or two
2050 # mistakes and never found which. I reverted back instead)
2051 while ($s = CPAN::Queue->first) {
2052 my $obj;
2053 if (ref $s) {
2054 $obj = $s; # I do not believe, we would survive if this happened
2055 } else {
2056 $obj = CPAN::Shell->expandany($s);
05454584 2057 }
6d29edf5
JH		 2058 if ($pragma
2059 &&
2060 ($] < 5.00303 || $obj->can($pragma))){
2061 ### compatibility with 5.003
2062 $obj->$pragma($meth); # the pragma "force" in
2063 # "CPAN::Distribution" must know
2064 # what we are intending
2065 }
2066 if ($]>=5.00303 && $obj->can('called_for')) {
2067 $obj->called_for($s);
2068 }
2069 CPAN->debug(
2070 qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
2071 $obj->as_string.
2072 qq{\]}
2073 ) if $CPAN::DEBUG;
2074
2075 if ($obj->$meth()){
2076 CPAN::Queue->delete($s);
2077 } else {
2078 CPAN->debug("failed");
2079 }
2080
2081 $obj->undelay;
f610777f 2082 CPAN::Queue->delete_first($s);
05454584 2083 }
6d29edf5
JH		 2084 for my $obj (@qcopy) {
2085 $obj->color_cmd_tmps(0,0);
2086 }
05454584
A		 2087}
2088
6d29edf5
JH		 2089#-> sub CPAN::Shell::dump ;
2090sub dump { shift->rematein('dump',@_); }
05454584
A		 2091#-> sub CPAN::Shell::force ;
2092sub force { shift->rematein('force',@_); }
2093#-> sub CPAN::Shell::get ;
2094sub get { shift->rematein('get',@_); }
2095#-> sub CPAN::Shell::readme ;
2096sub readme { shift->rematein('readme',@_); }
2097#-> sub CPAN::Shell::make ;
2098sub make { shift->rematein('make',@_); }
2099#-> sub CPAN::Shell::test ;
2100sub test { shift->rematein('test',@_); }
2101#-> sub CPAN::Shell::install ;
2102sub install { shift->rematein('install',@_); }
2103#-> sub CPAN::Shell::clean ;
2104sub clean { shift->rematein('clean',@_); }
2105#-> sub CPAN::Shell::look ;
2106sub look { shift->rematein('look',@_); }
911a92db
GS		 2107#-> sub CPAN::Shell::cvs_import ;
2108sub cvs_import { shift->rematein('cvs_import',@_); }
05454584 2109
c049f953
JH		 2110package CPAN::LWP::UserAgent;
2111
2112sub config {
2113 return if $SETUPDONE;
2114 if ($CPAN::META->has_usable('LWP::UserAgent')) {
2115 require LWP::UserAgent;
2116 @ISA = qw(Exporter LWP::UserAgent);
2117 $SETUPDONE++;
2118 } else {
e662ec5f 2119 $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
c049f953
JH		 2120 }
2121}
2122
2123sub get_basic_credentials {
2124 my($self, $realm, $uri, $proxy) = @_;
2125 return unless $proxy;
2126 if ($USER && $PASSWD) {
2127 } elsif (defined $CPAN::Config->{proxy_user} &&
2128 defined $CPAN::Config->{proxy_pass}) {
2129 $USER = $CPAN::Config->{proxy_user};
2130 $PASSWD = $CPAN::Config->{proxy_pass};
2131 } else {
2132 require ExtUtils::MakeMaker;
2133 ExtUtils::MakeMaker->import(qw(prompt));
2134 $USER = prompt("Proxy authentication needed!
2135 (Note: to permanently configure username and password run
2136 o conf proxy_user your_username
2137 o conf proxy_pass your_password
2138 )\nUsername:");
2139 if ($CPAN::META->has_inst("Term::ReadKey")) {
2140 Term::ReadKey::ReadMode("noecho");
2141 } else {
2142 $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
2143 }
2144 $PASSWD = prompt("Password:");
2145 if ($CPAN::META->has_inst("Term::ReadKey")) {
2146 Term::ReadKey::ReadMode("restore");
2147 }
2148 $CPAN::Frontend->myprint("\n\n");
2149 }
2150 return($USER,$PASSWD);
2151}
2152
2153sub mirror {
2154 my($self,$url,$aslocal) = @_;
2155 my $result = $self->SUPER::mirror($url,$aslocal);
2156 if ($result->code == 407) {
2157 undef $USER;
2158 undef $PASSWD;
2159 $result = $self->SUPER::mirror($url,$aslocal);
2160 }
2161 $result;
2162}
2163
05454584 2164package CPAN::FTP;
05454584
A		 2165
2166#-> sub CPAN::FTP::ftp_get ;
2167sub ftp_get {
2e2b7522
GS		 2168 my($class,$host,$dir,$file,$target) = @_;
2169 $class->debug(
2170 qq[Going to fetch file [$file] from dir [$dir]
05454584
A		 2171 on host [$host] as local [$target]\n]
2172 ) if $CPAN::DEBUG;
2e2b7522
GS		 2173 my $ftp = Net::FTP->new($host);
2174 return 0 unless defined $ftp;
2175 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
6d29edf5 2176 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2e2b7522
GS		 2177 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2178 warn "Couldn't login on $host";
2179 return;
2180 }
2181 unless ( $ftp->cwd($dir) ){
2182 warn "Couldn't cwd $dir";
2183 return;
2184 }
2185 $ftp->binary;
2186 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2187 unless ( $ftp->get($file,$target) ){
2188 warn "Couldn't fetch $file from $host\n";
2189 return;
2190 }
2191 $ftp->quit; # it's ok if this fails
2192 return 1;
05454584
A		 2193}
2194
09d9d230 2195# If more accuracy is wanted/needed, Chris Leach sent me this patch...
f610777f 2196
6d29edf5
JH		 2197 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
2198 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
2199 # > ***************
2200 # > *** 1562,1567 ****
2201 # > --- 1562,1580 ----
2202 # > return 1 if substr($url,0,4) eq "file";
2203 # > return 1 unless $url =~ m|://([^/]+)|;
2204 # > my $host = $1;
2205 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2206 # > + if ($proxy) {
2207 # > + $proxy =~ m|://([^/:]+)|;
2208 # > + $proxy = $1;
2209 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2210 # > + if ($noproxy) {
2211 # > + if ($host !~ /$noproxy$/) {
2212 # > + $host = $proxy;
2213 # > + }
2214 # > + } else {
2215 # > + $host = $proxy;
2216 # > + }
2217 # > + }
2218 # > require Net::Ping;
2219 # > return 1 unless $Net::Ping::VERSION >= 2;
2220 # > my $p;
09d9d230
A		 2221
2222
05454584
A		 2223#-> sub CPAN::FTP::localize ;
2224sub localize {
2225 my($self,$file,$aslocal,$force) = @_;
2226 $force ||= 0;
2227 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2228 unless defined $aslocal;
55e314ee
A		 2229 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2230 if $CPAN::DEBUG;
05454584 2231
f14b5cec 2232 if ($^O eq 'MacOS') {
6d29edf5
JH		 2233 # Comment by AK on 2000-09-03: Uniq short filenames would be
2234 # available in CHECKSUMS file
f14b5cec
JH		 2235 my($name, $path) = File::Basename::fileparse($aslocal, '');
2236 if (length($name) > 31) {
6d29edf5
JH		 2237 $name =~ s/(
2238 \.(
2239 readme(\.(gz|Z))? |
2240 (tar\.)?(gz|Z) |
2241 tgz |
2242 zip |
2243 pm\.(gz|Z)
2244 )
2245 )$//x;
f14b5cec
JH		 2246 my $suf = $1;
2247 my $size = 31 - length($suf);
2248 while (length($name) > $size) {
2249 chop $name;
2250 }
2251 $name .= $suf;
2252 $aslocal = File::Spec->catfile($path, $name);
2253 }
2254 }
2255
c356248b 2256 return $aslocal if -f $aslocal && -r _ && !($force & 1);
55e314ee
A		 2257 my($restore) = 0;
2258 if (-f $aslocal){
2259 rename $aslocal, "$aslocal.bak";
2260 $restore++;
2261 }
05454584
A		 2262
2263 my($aslocal_dir) = File::Basename::dirname($aslocal);
2264 File::Path::mkpath($aslocal_dir);
c356248b 2265 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
05454584 2266 qq{directory "$aslocal_dir".
c356248b
A		 2267 I\'ll continue, but if you encounter problems, they may be due
2268 to insufficient permissions.\n}) unless -w $aslocal_dir;
05454584
A		 2269
2270 # Inheritance is not easier to manage than a few if/else branches
de34a54b 2271 if ($CPAN::META->has_usable('LWP::UserAgent')) {
05454584 2272 unless ($Ua) {
c049f953
JH		 2273 CPAN::LWP::UserAgent->config;
2274 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
d8773709 2275 if ($@) {
e662ec5f 2276 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@")
d8773709
JH		 2277 if $CPAN::DEBUG;
2278 } else {
2279 my($var);
2280 $Ua->proxy('ftp', $var)
2281 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2282 $Ua->proxy('http', $var)
2283 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
c049f953
JH		 2284
2285
2286# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2287#
2288# > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2289# > use ones that require basic autorization.
2290#
2291# > Example of when I use it manually in my own stuff:
2292#
2293# > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2294# > $req->proxy_authorization_basic("username","password");
2295# > $res = $ua->request($req);
2296#
2297
d8773709
JH		 2298 $Ua->no_proxy($var)
2299 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2300 }
05454584
A		 2301 }
2302 }
c4d24d4c 2303 $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
6d29edf5
JH		 2304 $ENV{http_proxy} = $CPAN::Config->{http_proxy}
2305 if $CPAN::Config->{http_proxy};
c4d24d4c 2306 $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
05454584
A		 2307
2308 # Try the list of urls for each single object. We keep a record
2309 # where we did get a file from
c356248b 2310 my(@reordered,$last);
09d9d230 2311 $CPAN::Config->{urllist} ||= [];
909b20b5
MJD		 2312 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2313 warn "Malformed urllist; ignoring. Configuration file corrupt?\n";
2314 }
c356248b
A		 2315 $last = $#{$CPAN::Config->{urllist}};
2316 if ($force & 2) { # local cpans probably out of date, don't reorder
2317 @reordered = (0..$last);
2318 } else {
2319 @reordered =
2320 sort {
2321 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
f610777f 2322 <=>
c356248b
A		 2323 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2324 or
2325 defined($Thesite)
2326 and
2327 ($b == $Thesite)
2328 <=>
2329 ($a == $Thesite)
2330 } 0..$last;
c356248b 2331 }
c4d24d4c 2332 my(@levels);
c356248b
A		 2333 if ($Themethod) {
2334 @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2335 } else {
2336 @levels = qw/easy hard hardest/;
2337 }
f14b5cec 2338 @levels = qw/easy/ if $^O eq 'MacOS';
c4d24d4c
A		 2339 my($levelno);
2340 for $levelno (0..$#levels) {
2341 my $level = $levels[$levelno];
c356248b
A		 2342 my $method = "host$level";
2343 my @host_seq = $level eq "easy" ?
2344 @reordered : 0..$last; # reordered has CDROM up front
09d9d230 2345 @host_seq = (0) unless @host_seq;
c356248b
A		 2346 my $ret = $self->$method(\@host_seq,$file,$aslocal);
2347 if ($ret) {
2e2b7522 2348 $Themethod = $level;
911a92db
GS		 2349 my $now = time;
2350 # utime $now, $now, $aslocal; # too bad, if we do that, we
2351 # might alter a local mirror
2e2b7522
GS		 2352 $self->debug("level[$level]") if $CPAN::DEBUG;
2353 return $ret;
2354 } else {
2355 unlink $aslocal;
c4d24d4c 2356 last if $CPAN::Signal; # need to cleanup
c356248b
A		 2357 }
2358 }
c4d24d4c
A		 2359 unless ($CPAN::Signal) {
2360 my(@mess);
2361 push @mess,
2362 qq{Please check, if the URLs I found in your configuration file \(}.
2363 join(", ", @{$CPAN::Config->{urllist}}).
2364 qq{\) are valid. The urllist can be edited.},
2365 qq{E.g. with 'o conf urllist push ftp://myurl/'};
2366 $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
2367 sleep 2;
8d97e4a1 2368 $CPAN::Frontend->myprint("Could not fetch $file\n");
c4d24d4c 2369 }
c356248b
A		 2370 if ($restore) {
2371 rename "$aslocal.bak", $aslocal;
2372 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2373 $self->ls($aslocal));
2374 return $aslocal;
2375 }
2376 return;
2377}
2378
2379sub hosteasy {
2380 my($self,$host_seq,$file,$aslocal) = @_;
05454584 2381 my($i);
c356248b 2382 HOSTEASY: for $i (@$host_seq) {
c4d24d4c 2383 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
05454584
A		 2384 $url .= "/" unless substr($url,-1) eq "/";
2385 $url .= $file;
c356248b 2386 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
05454584
A		 2387 if ($url =~ /^file:/) {
2388 my $l;
de34a54b 2389 if ($CPAN::META->has_inst('URI::URL')) {
55e314ee 2390 my $u = URI::URL->new($url);
05454584
A		 2391 $l = $u->path;
2392 } else { # works only on Unix, is poorly constructed, but
c356248b
A		 2393 # hopefully better than nothing.
2394 # RFC 1738 says fileurl BNF is
2395 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2396 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2397 # the code
36263cb3
GS		 2398 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2399 $l =~ s|^file:||; # assume they
2400 # meant
2401 # file://localhost
392d8ab8 2402 $l =~ s|^/||s unless -f $l; # e.g. /P:
c049f953 2403 $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
05454584 2404 }
c356248b
A		 2405 if ( -f $l && -r _) {
2406 $Thesite = $i;
2407 return $l;
2408 }
05454584
A		 2409 # Maybe mirror has compressed it?
2410 if (-f "$l.gz") {
d4fd5c69 2411 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
09d9d230 2412 CPAN::Tarzip->gunzip("$l.gz", $aslocal);
c356248b
A		 2413 if ( -f $aslocal) {
2414 $Thesite = $i;
2415 return $aslocal;
2416 }
05454584
A		 2417 }
2418 }
c4d24d4c 2419 if ($CPAN::META->has_usable('LWP')) {
09d9d230 2420 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
A		 2421 $url
2422");
f610777f 2423 unless ($Ua) {
c049f953
JH		 2424 CPAN::LWP::UserAgent->config;
2425 eval { $Ua = CPAN::LWP::UserAgent->new; };
2426 if ($@) {
e662ec5f 2427 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@");
c049f953 2428 }
f610777f 2429 }
09d9d230
A		 2430 my $res = $Ua->mirror($url, $aslocal);
2431 if ($res->is_success) {
2432 $Thesite = $i;
911a92db
GS		 2433 my $now = time;
2434 utime $now, $now, $aslocal; # download time is more
2435 # important than upload time
09d9d230 2436 return $aslocal;
05d2a450 2437 } elsif ($url !~ /\.gz(?!\n)\Z/) {
09d9d230
A		 2438 my $gzurl = "$url.gz";
2439 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
A		 2440 $gzurl
2441");
09d9d230
A		 2442 $res = $Ua->mirror($gzurl, "$aslocal.gz");
2443 if ($res->is_success &&
2444 CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
2445 ) {
2446 $Thesite = $i;
2447 return $aslocal;
05454584 2448 }
09d9d230 2449 } else {
c049f953
JH		 2450 $CPAN::Frontend->myprint(sprintf(
2451 "LWP failed with code[%s] message[%s]\n",
2452 $res->code,
2453 $res->message,
2454 ));
c4d24d4c
A		 2455 # Alan Burlison informed me that in firewall environments
2456 # Net::FTP can still succeed where LWP fails. So we do not
2457 # skip Net::FTP anymore when LWP is available.
09d9d230
A		 2458 }
2459 } else {
c049f953 2460 $CPAN::Frontend->myprint("LWP not available\n");
05454584 2461 }
c4d24d4c 2462 return if $CPAN::Signal;
05454584
A		 2463 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2464 # that's the nice and easy way thanks to Graham
2465 my($host,$dir,$getfile) = ($1,$2,$3);
de34a54b 2466 if ($CPAN::META->has_usable('Net::FTP')) {
05454584 2467 $dir =~ s|/+|/|g;
c356248b 2468 $CPAN::Frontend->myprint("Fetching with Net::FTP:
09d9d230 2469 $url
c356248b
A		 2470");
2471 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
2472 "aslocal[$aslocal]") if $CPAN::DEBUG;
2473 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
2474 $Thesite = $i;
2475 return $aslocal;
2476 }
05d2a450 2477 if ($aslocal !~ /\.gz(?!\n)\Z/) {
c356248b
A		 2478 my $gz = "$aslocal.gz";
2479 $CPAN::Frontend->myprint("Fetching with Net::FTP
09d9d230 2480 $url.gz
c356248b 2481");
2e2b7522 2482 if (CPAN::FTP->ftp_get($host,
09d9d230
A		 2483 $dir,
2484 "$getfile.gz",
2485 $gz) &&
2486 CPAN::Tarzip->gunzip($gz,$aslocal)
2487 ){
c356248b
A		 2488 $Thesite = $i;
2489 return $aslocal;
2490 }
2491 }
09d9d230 2492 # next HOSTEASY;
05454584
A		 2493 }
2494 }
c4d24d4c 2495 return if $CPAN::Signal;
c356248b
A		 2496 }
2497}
05454584 2498
c356248b 2499sub hosthard {
2e2b7522 2500 my($self,$host_seq,$file,$aslocal) = @_;
05454584 2501
2e2b7522
GS		 2502 # Came back if Net::FTP couldn't establish connection (or
2503 # failed otherwise) Maybe they are behind a firewall, but they
2504 # gave us a socksified (or other) ftp program...
c356248b 2505
2e2b7522 2506 my($i);
f610777f 2507 my($devnull) = $CPAN::Config->{devnull} || "";
2e2b7522
GS		 2508 # < /dev/null ";
2509 my($aslocal_dir) = File::Basename::dirname($aslocal);
2510 File::Path::mkpath($aslocal_dir);
c356248b 2511 HOSTHARD: for $i (@$host_seq) {
09d9d230 2512 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b
A		 2513 $url .= "/" unless substr($url,-1) eq "/";
2514 $url .= $file;
09d9d230
A		 2515 my($proto,$host,$dir,$getfile);
2516
2517 # Courtesy Mark Conty mark_conty@cargill.com change from
2518 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2519 # to
2520 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
911a92db
GS		 2521 # proto not yet used
2522 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
c356248b 2523 } else {
911a92db 2524 next HOSTHARD; # who said, we could ftp anything except ftp?
c356248b 2525 }
5a5fac02
JH		 2526 next HOSTHARD if $proto eq "file"; # file URLs would have had
2527 # success above. Likely a bogus URL
911a92db 2528
c356248b
A		 2529 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
2530 my($f,$funkyftp);
9d61fa1d 2531 for $f ('lynx','ncftpget','ncftp','wget') {
911a92db
GS		 2532 next unless exists $CPAN::Config->{$f};
2533 $funkyftp = $CPAN::Config->{$f};
2534 next unless defined $funkyftp;
2535 next if $funkyftp =~ /^\s*$/;
de34a54b
JH		 2536 my($asl_ungz, $asl_gz);
2537 ($asl_ungz = $aslocal) =~ s/\.gz//;
2538 $asl_gz = "$asl_ungz.gz";
2539 my($src_switch) = "";
911a92db 2540 if ($f eq "lynx"){
de34a54b 2541 $src_switch = " -source";
911a92db 2542 } elsif ($f eq "ncftp"){
de34a54b 2543 $src_switch = " -c";
9d61fa1d
A		 2544 } elsif ($f eq "wget"){
2545 $src_switch = " -O -";
911a92db
GS		 2546 }
2547 my($chdir) = "";
de34a54b 2548 my($stdout_redir) = " > $asl_ungz";
911a92db
GS		 2549 if ($f eq "ncftpget"){
2550 $chdir = "cd $aslocal_dir && ";
2551 $stdout_redir = "";
2552 }
2553 $CPAN::Frontend->myprint(
2554 qq[
de34a54b 2555Trying with "$funkyftp$src_switch" to get
c356248b 2556 $url
2e2b7522 2557]);
911a92db 2558 my($system) =
e662ec5f 2559 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
911a92db
GS		 2560 $self->debug("system[$system]") if $CPAN::DEBUG;
2561 my($wstatus);
2562 if (($wstatus = system($system)) == 0
2563 &&
2564 ($f eq "lynx" ?
5a5fac02 2565 -s $asl_ungz # lynx returns 0 when it fails somewhere
911a92db
GS		 2566 : 1
2567 )
2568 ) {
2569 if (-s $aslocal) {
2570 # Looks good
de34a54b 2571 } elsif ($asl_ungz ne $aslocal) {
911a92db 2572 # test gzip integrity
5a5fac02
JH		 2573 if (CPAN::Tarzip->gtest($asl_ungz)) {
2574 # e.g. foo.tar is gzipped --> foo.tar.gz
2575 rename $asl_ungz, $aslocal;
911a92db 2576 } else {
5a5fac02 2577 CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
911a92db
GS		 2578 }
2579 }
2580 $Thesite = $i;
2581 return $aslocal;
05d2a450 2582 } elsif ($url !~ /\.gz(?!\n)\Z/) {
de34a54b
JH		 2583 unlink $asl_ungz if
2584 -f $asl_ungz && -s _ == 0;
911a92db
GS		 2585 my $gz = "$aslocal.gz";
2586 my $gzurl = "$url.gz";
2587 $CPAN::Frontend->myprint(
2588 qq[
de34a54b 2589Trying with "$funkyftp$src_switch" to get
911a92db
GS		 2590 $url.gz
2591]);
e662ec5f 2592 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
55e314ee 2593 $self->debug("system[$system]") if $CPAN::DEBUG;
05454584 2594 my($wstatus);
55e314ee
A		 2595 if (($wstatus = system($system)) == 0
2596 &&
de34a54b 2597 -s $asl_gz
55e314ee 2598 ) {
911a92db 2599 # test gzip integrity
de34a54b 2600 if (CPAN::Tarzip->gtest($asl_gz)) {
5a5fac02 2601 CPAN::Tarzip->gunzip($asl_gz,$aslocal);
2e2b7522 2602 } else {
5a5fac02
JH		 2603 # somebody uncompressed file for us?
2604 rename $asl_ungz, $aslocal;
2e2b7522 2605 }
911a92db
GS		 2606 $Thesite = $i;
2607 return $aslocal;
05454584 2608 } else {
de34a54b 2609 unlink $asl_gz if -f $asl_gz;
911a92db
GS		 2610 }
2611 } else {
2612 my $estatus = $wstatus >> 8;
2613 my $size = -f $aslocal ?
2614 ", left\n$aslocal with size ".-s _ :
2615 "\nWarning: expected file [$aslocal] doesn't exist";
2616 $CPAN::Frontend->myprint(qq{
05454584 2617System call "$system"
c356248b
A		 2618returned status $estatus (wstat $wstatus)$size
2619});
911a92db 2620 }
c4d24d4c
A		 2621 return if $CPAN::Signal;
2622 } # lynx,ncftpget,ncftp
2623 } # host
c356248b 2624}
05454584 2625
c356248b
A		 2626sub hosthardest {
2627 my($self,$host_seq,$file,$aslocal) = @_;
2628
2629 my($i);
2630 my($aslocal_dir) = File::Basename::dirname($aslocal);
2631 File::Path::mkpath($aslocal_dir);
2632 HOSTHARDEST: for $i (@$host_seq) {
2633 unless (length $CPAN::Config->{'ftp'}) {
2634 $CPAN::Frontend->myprint("No external ftp command available\n\n");
2635 last HOSTHARDEST;
2636 }
09d9d230 2637 my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
c356248b
A		 2638 $url .= "/" unless substr($url,-1) eq "/";
2639 $url .= $file;
2640 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
2641 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
2642 next;
2643 }
2644 my($host,$dir,$getfile) = ($1,$2,$3);
c356248b
A		 2645 my $timestamp = 0;
2646 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
2647 $ctime,$blksize,$blocks) = stat($aslocal);
2648 $timestamp = $mtime ||= 0;
2649 my($netrc) = CPAN::FTP::netrc->new;
911a92db 2650 my($netrcfile) = $netrc->netrc;
c356248b
A		 2651 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
2652 my $targetfile = File::Basename::basename($aslocal);
2653 my(@dialog);
2654 push(
2655 @dialog,
2656 "lcd $aslocal_dir",
2657 "cd /",
2658 map("cd $_", split "/", $dir), # RFC 1738
2659 "bin",
2660 "get $getfile $targetfile",
2661 "quit"
2662 );
911a92db 2663 if (! $netrcfile) {
c356248b
A		 2664 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
2665 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
2666 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
2667 $netrc->hasdefault,
2668 $netrc->contains($host))) if $CPAN::DEBUG;
2669 if ($netrc->protected) {
2670 $CPAN::Frontend->myprint(qq{
05454584
A		 2671 Trying with external ftp to get
2672 $url
2673 As this requires some features that are not thoroughly tested, we\'re
2674 not sure, that we get it right....
2675
2676}
c356248b
A		 2677 );
2678 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
2679 @dialog);
05454584 2680 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
c356248b 2681 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
05454584
A		 2682 $mtime ||= 0;
2683 if ($mtime > $timestamp) {
c356248b
A		 2684 $CPAN::Frontend->myprint("GOT $aslocal\n");
2685 $Thesite = $i;
05454584
A		 2686 return $aslocal;
2687 } else {
c356248b 2688 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
05454584 2689 }
c4d24d4c 2690 return if $CPAN::Signal;
c356248b
A		 2691 } else {
2692 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
2693 qq{correctly protected.\n});
05454584 2694 }
c356248b
A		 2695 } else {
2696 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
2697 nor does it have a default entry\n");
05454584 2698 }
36263cb3 2699
c356248b
A		 2700 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
2701 # then and login manually to host, using e-mail as
2702 # password.
2703 $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
2704 unshift(
2705 @dialog,
2706 "open $host",
2707 "user anonymous $Config::Config{'cf_email'}"
2708 );
2709 $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
2710 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2711 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
2712 $mtime ||= 0;
2713 if ($mtime > $timestamp) {
2714 $CPAN::Frontend->myprint("GOT $aslocal\n");
2715 $Thesite = $i;
2716 return $aslocal;
2717 } else {
2718 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
05454584 2719 }
c4d24d4c 2720 return if $CPAN::Signal;
c356248b
A		 2721 $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
2722 sleep 2;
c4d24d4c 2723 } # host
c356248b
A		 2724}
2725
2726sub talk_ftp {
2727 my($self,$command,@dialog) = @_;
2728 my $fh = FileHandle->new;
2729 $fh->open("|$command") or die "Couldn't open ftp: $!";
2730 foreach (@dialog) { $fh->print("$_\n") }
2731 $fh->close; # Wait for process to complete
2732 my $wstatus = $?;
2733 my $estatus = $wstatus >> 8;
2734 $CPAN::Frontend->myprint(qq{
2735Subprocess "|$command"
2736 returned status $estatus (wstat $wstatus)
2737}) if $wstatus;
05454584
A		 2738}
2739
e50380aa
A		 2740# find2perl needs modularization, too, all the following is stolen
2741# from there
09d9d230 2742# CPAN::FTP::ls
e50380aa
A		 2743sub ls {
2744 my($self,$name) = @_;
2745 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
2746 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
2747
2748 my($perms,%user,%group);
2749 my $pname = $name;
2750
55e314ee 2751 if ($blocks) {
e50380aa
A		 2752 $blocks = int(($blocks + 1) / 2);
2753 }
2754 else {
2755 $blocks = int(($sizemm + 1023) / 1024);
2756 }
2757
2758 if (-f _) { $perms = '-'; }
2759 elsif (-d _) { $perms = 'd'; }
2760 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
2761 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
2762 elsif (-p _) { $perms = 'p'; }
2763 elsif (-S _) { $perms = 's'; }
2764 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
2765
2766 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
2767 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
2768 my $tmpmode = $mode;
2769 my $tmp = $rwx[$tmpmode & 7];
2770 $tmpmode >>= 3;
2771 $tmp = $rwx[$tmpmode & 7] . $tmp;
2772 $tmpmode >>= 3;
2773 $tmp = $rwx[$tmpmode & 7] . $tmp;
2774 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
2775 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
2776 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
2777 $perms .= $tmp;
2778
2779 my $user = $user{$uid} || $uid; # too lazy to implement lookup
2780 my $group = $group{$gid} || $gid;
2781
2782 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
2783 my($timeyear);
2784 my($moname) = $moname[$mon];
2785 if (-M _ > 365.25 / 2) {
2786 $timeyear = $year + 1900;
2787 }
2788 else {
2789 $timeyear = sprintf("%02d:%02d", $hour, $min);
2790 }
2791
2792 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
2793 $ino,
2794 $blocks,
2795 $perms,
2796 $nlink,
2797 $user,
2798 $group,
2799 $sizemm,
2800 $moname,
2801 $mday,
2802 $timeyear,
2803 $pname;
2804}
2805
05454584
A		 2806package CPAN::FTP::netrc;
2807
2808sub new {
2809 my($class) = @_;
5de3f0da 2810 my $file = File::Spec->catfile($ENV{HOME},".netrc");
05454584
A		 2811
2812 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2813 $atime,$mtime,$ctime,$blksize,$blocks)
2814 = stat($file);
2815 $mode ||= 0;
2816 my $protected = 0;
2817
42d3b621
A		 2818 my($fh,@machines,$hasdefault);
2819 $hasdefault = 0;
da199366
A		 2820 $fh = FileHandle->new or die "Could not create a filehandle";
2821
2822 if($fh->open($file)){
2823 $protected = ($mode & 077) == 0;
10b2abe6 2824 local($/) = "";
42d3b621 2825 NETRC: while (<$fh>) {
da199366 2826 my(@tokens) = split " ", $_;
42d3b621
A		 2827 TOKEN: while (@tokens) {
2828 my($t) = shift @tokens;
da199366
A		 2829 if ($t eq "default"){
2830 $hasdefault++;
da199366
A		 2831 last NETRC;
2832 }
42d3b621
A		 2833 last TOKEN if $t eq "macdef";
2834 if ($t eq "machine") {
2835 push @machines, shift @tokens;
2836 }
2837 }
10b2abe6
CS		 2838 }
2839 } else {
da199366 2840 $file = $hasdefault = $protected = "";
10b2abe6 2841 }
da199366 2842
10b2abe6 2843 bless {
42d3b621
A		 2844 'mach' => [@machines],
2845 'netrc' => $file,
2846 'hasdefault' => $hasdefault,
da199366 2847 'protected' => $protected,
10b2abe6
CS		 2848 }, $class;
2849}
2850
9d61fa1d 2851# CPAN::FTP::hasdefault;
42d3b621 2852sub hasdefault { shift->{'hasdefault'} }
da199366
A		 2853sub netrc { shift->{'netrc'} }
2854sub protected { shift->{'protected'} }
10b2abe6
CS		 2855sub contains {
2856 my($self,$mach) = @_;
da199366
A		 2857 for ( @{$self->{'mach'}} ) {
2858 return 1 if $_ eq $mach;
2859 }
2860 return 0;
10b2abe6
CS		 2861}
2862
5f05dabc 2863package CPAN::Complete;
5f05dabc 2864
36263cb3
GS		 2865sub gnu_cpl {
2866 my($text, $line, $start, $end) = @_;
2867 my(@perlret) = cpl($text, $line, $start);
2868 # find longest common match. Can anybody show me how to peruse
2869 # T::R::Gnu to have this done automatically? Seems expensive.
2870 return () unless @perlret;
2871 my($newtext) = $text;
2872 for (my $i = length($text)+1;;$i++) {
2873 last unless length($perlret[0]) && length($perlret[0]) >= $i;
2874 my $try = substr($perlret[0],0,$i);
2875 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
2876 # warn "try[$try]tries[@tries]";
2877 if (@tries == @perlret) {
2878 $newtext = $try;
2879 } else {
2880 last;
2881 }
2882 }
2883 ($newtext,@perlret);
2884}
2885
55e314ee
A		 2886#-> sub CPAN::Complete::cpl ;
2887sub cpl {
5f05dabc 2888 my($word,$line,$pos) = @_;
2889 $word ||= "";
2890 $line ||= "";
2891 $pos ||= 0;
2892 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2893 $line =~ s/^\s*//;
da199366
A		 2894 if ($line =~ s/^(force\s*)//) {
2895 $pos -= length($1);
2896 }
5f05dabc 2897 my @return;
2898 if ($pos == 0) {
9d61fa1d 2899 @return = grep /^$word/, @CPAN::Complete::COMMANDS;
c049f953 2900 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
5f05dabc 2901 @return = ();
8d97e4a1
JH		 2902 } elsif ($line =~ /^(a|ls)\s/) {
2903 @return = cplx('CPAN::Author',uc($word));
5f05dabc 2904 } elsif ($line =~ /^b\s/) {
8d97e4a1 2905 CPAN::Shell->local_bundles;
55e314ee 2906 @return = cplx('CPAN::Bundle',$word);
5f05dabc 2907 } elsif ($line =~ /^d\s/) {
55e314ee 2908 @return = cplx('CPAN::Distribution',$word);
6d29edf5 2909 } elsif ($line =~ m/^(
c049f953 2910 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
6d29edf5 2911 )\s/x ) {
d8773709
JH		 2912 if ($word =~ /^Bundle::/) {
2913 CPAN::Shell->local_bundles;
2914 }
55e314ee 2915 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 2916 } elsif ($line =~ /^i\s/) {
55e314ee 2917 @return = cpl_any($word);
5f05dabc 2918 } elsif ($line =~ /^reload\s/) {
55e314ee 2919 @return = cpl_reload($word,$line,$pos);
5f05dabc 2920 } elsif ($line =~ /^o\s/) {
55e314ee 2921 @return = cpl_option($word,$line,$pos);
9d61fa1d
A		 2922 } elsif ($line =~ m/^\S+\s/ ) {
2923 # fallback for future commands and what we have forgotten above
2924 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 2925 } else {
2926 @return = ();
2927 }
2928 return @return;
2929}
2930
55e314ee
A		 2931#-> sub CPAN::Complete::cplx ;
2932sub cplx {
5f05dabc 2933 my($class, $word) = @_;
de34a54b
JH		 2934 # I believed for many years that this was sorted, today I
2935 # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
2936 # make it sorted again. Maybe sort was dropped when GNU-readline
2937 # support came in? The RCS file is difficult to read on that:-(
2938 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
5f05dabc 2939}
2940
55e314ee
A		 2941#-> sub CPAN::Complete::cpl_any ;
2942sub cpl_any {
5f05dabc 2943 my($word) = shift;
2944 return (
55e314ee
A		 2945 cplx('CPAN::Author',$word),
2946 cplx('CPAN::Bundle',$word),
2947 cplx('CPAN::Distribution',$word),
2948 cplx('CPAN::Module',$word),
5f05dabc 2949 );
2950}
2951
55e314ee
A		 2952#-> sub CPAN::Complete::cpl_reload ;
2953sub cpl_reload {
5f05dabc 2954 my($word,$line,$pos) = @_;
2955 $word ||= "";
2956 my(@words) = split " ", $line;
2957 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2958 my(@ok) = qw(cpan index);
e50380aa
A		 2959 return @ok if @words == 1;
2960 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
5f05dabc 2961}
2962
55e314ee
A		 2963#-> sub CPAN::Complete::cpl_option ;
2964sub cpl_option {
5f05dabc 2965 my($word,$line,$pos) = @_;
2966 $word ||= "";
2967 my(@words) = split " ", $line;
2968 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
2969 my(@ok) = qw(conf debug);
e50380aa 2970 return @ok if @words == 1;
c356248b 2971 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
5f05dabc 2972 if (0) {
2973 } elsif ($words[1] eq 'index') {
2974 return ();
2975 } elsif ($words[1] eq 'conf') {
55e314ee 2976 return CPAN::Config::cpl(@_);
5f05dabc 2977 } elsif ($words[1] eq 'debug') {
2978 return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
2979 }
2980}
2981
2982package CPAN::Index;
5f05dabc 2983
10b2abe6 2984#-> sub CPAN::Index::force_reload ;
5f05dabc 2985sub force_reload {
2986 my($class) = @_;
c049f953 2987 $CPAN::Index::LAST_TIME = 0;
5f05dabc 2988 $class->reload(1);
2989}
2990
10b2abe6 2991#-> sub CPAN::Index::reload ;
5f05dabc 2992sub reload {
2993 my($cl,$force) = @_;
2994 my $time = time;
2995
c356248b
A		 2996 # XXX check if a newer one is available. (We currently read it
2997 # from time to time)
e50380aa 2998 for ($CPAN::Config->{index_expire}) {
36263cb3 2999 $_ = 0.001 unless $_ && $_ > 0.001;
e50380aa 3000 }
9d61fa1d
A		 3001 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3002 # debug here when CPAN doesn't seem to read the Metadata
3003 require Carp;
3004 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3005 }
3006 unless ($CPAN::META->{PROTOCOL}) {
3007 $cl->read_metadata_cache;
3008 $CPAN::META->{PROTOCOL} ||= "1.0";
3009 }
6d29edf5
JH		 3010 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
3011 # warn "Setting last_time to 0";
c049f953 3012 $LAST_TIME = 0; # No warning necessary
6d29edf5 3013 }
c049f953 3014 return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
c356248b 3015 and ! $force;
6d29edf5
JH		 3016 if (0) {
3017 # IFF we are developing, it helps to wipe out the memory
3018 # between reloads, otherwise it is not what a user expects.
3019 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3020 $CPAN::META = CPAN->new;
3021 }
3022 {
3023 my($debug,$t2);
c049f953 3024 local $LAST_TIME = $time;
6d29edf5
JH		 3025 local $CPAN::META->{PROTOCOL} = PROTOCOL;
3026
3027 my $needshort = $^O eq "dos";
3028
3029 $cl->rd_authindex($cl
3030 ->reload_x(
3031 "authors/01mailrc.txt.gz",
3032 $needshort ?
3033 File::Spec->catfile('authors', '01mailrc.gz') :
3034 File::Spec->catfile('authors', '01mailrc.txt.gz'),
3035 $force));
3036 $t2 = time;
3037 $debug = "timing reading 01[".($t2 - $time)."]";
3038 $time = $t2;
3039 return if $CPAN::Signal; # this is sometimes lengthy
3040 $cl->rd_modpacks($cl
3041 ->reload_x(
3042 "modules/02packages.details.txt.gz",
3043 $needshort ?
3044 File::Spec->catfile('modules', '02packag.gz') :
3045 File::Spec->catfile('modules', '02packages.details.txt.gz'),
3046 $force));
3047 $t2 = time;
3048 $debug .= "02[".($t2 - $time)."]";
3049 $time = $t2;
3050 return if $CPAN::Signal; # this is sometimes lengthy
3051 $cl->rd_modlist($cl
3052 ->reload_x(
3053 "modules/03modlist.data.gz",
3054 $needshort ?
3055 File::Spec->catfile('modules', '03mlist.gz') :
3056 File::Spec->catfile('modules', '03modlist.data.gz'),
3057 $force));
3058 $cl->write_metadata_cache;
3059 $t2 = time;
3060 $debug .= "03[".($t2 - $time)."]";
3061 $time = $t2;
3062 CPAN->debug($debug) if $CPAN::DEBUG;
3063 }
c049f953 3064 $LAST_TIME = $time;
6d29edf5 3065 $CPAN::META->{PROTOCOL} = PROTOCOL;
5f05dabc 3066}
3067
10b2abe6 3068#-> sub CPAN::Index::reload_x ;
5f05dabc 3069sub reload_x {
3070 my($cl,$wanted,$localname,$force) = @_;
c356248b 3071 $force |= 2; # means we're dealing with an index here
55e314ee
A		 3072 CPAN::Config->load; # we should guarantee loading wherever we rely
3073 # on Config XXX
c356248b 3074 $localname ||= $wanted;
5de3f0da
DR		 3075 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3076 $localname);
e50380aa
A		 3077 if (
3078 -f $abs_wanted &&
05454584 3079 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
c356248b 3080 !($force & 1)
e50380aa
A		 3081 ) {
3082 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
05454584 3083 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
e50380aa 3084 qq{day$s. I\'ll use that.});
5f05dabc 3085 return $abs_wanted;
3086 } else {
c356248b 3087 $force |= 1; # means we're quite serious about it.
5f05dabc 3088 }
3089 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3090}
3091
55e314ee
A		 3092#-> sub CPAN::Index::rd_authindex ;
3093sub rd_authindex {
f14b5cec
JH		 3094 my($cl, $index_target) = @_;
3095 my @lines;
c356248b 3096 return unless defined $index_target;
c356248b 3097 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230
A		 3098 local(*FH);
3099 tie *FH, CPAN::Tarzip, $index_target;
52128c7b 3100 local($/) = "\n";
f14b5cec
JH		 3101 push @lines, split /\012/ while <FH>;
3102 foreach (@lines) {
c356248b 3103 my($userid,$fullname,$email) =
f610777f 3104 m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
5f05dabc 3105 next unless $userid && $fullname && $email;
3106
3107 # instantiate an author object
3108 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3109 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3110 return if $CPAN::Signal;
3111 }
09d9d230
A		 3112}
3113
3114sub userid {
3115 my($self,$dist) = @_;
3116 $dist = $self->{'id'} unless defined $dist;
3117 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3118 $ret;
5f05dabc 3119}
3120
55e314ee
A		 3121#-> sub CPAN::Index::rd_modpacks ;
3122sub rd_modpacks {
05d2a450 3123 my($self, $index_target) = @_;
f14b5cec 3124 my @lines;
c356248b 3125 return unless defined $index_target;
c356248b 3126 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 3127 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
52128c7b 3128 local($/) = "\n";
09d9d230 3129 while ($_ = $fh->READLINE) {
f14b5cec
JH		 3130 s/\012/\n/g;
3131 my @ls = map {"$_\n"} split /\n/, $_;
3132 unshift @ls, "\n" x length($1) if /^(\n+)/;
3133 push @lines, @ls;
e50380aa 3134 }
de34a54b 3135 # read header
c049f953 3136 my($line_count,$last_updated);
f14b5cec
JH		 3137 while (@lines) {
3138 my $shift = shift(@lines);
3139 last if $shift =~ /^\s*$/;
c049f953
JH		 3140 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3141 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
f14b5cec 3142 }
de34a54b 3143 if (not defined $line_count) {
05d2a450 3144
de34a54b 3145 warn qq{Warning: Your $index_target does not contain a Line-Count header.
05d2a450
A		 3146Please check the validity of the index file by comparing it to more
3147than one CPAN mirror. I'll continue but problems seem likely to
3148happen.\a
de34a54b 3149};
05d2a450 3150
de34a54b
JH		 3151 sleep 5;
3152 } elsif ($line_count != scalar @lines) {
3153
3154 warn sprintf qq{Warning: Your %s
3155contains a Line-Count header of %d but I see %d lines there. Please
3156check the validity of the index file by comparing it to more than one
3157CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3158$index_target, $line_count, scalar(@lines);
3159
3160 }
c049f953
JH		 3161 if (not defined $last_updated) {
3162
3163 warn qq{Warning: Your $index_target does not contain a Last-Updated header.
3164Please check the validity of the index file by comparing it to more
3165than one CPAN mirror. I'll continue but problems seem likely to
3166happen.\a
3167};
3168
3169 sleep 5;
3170 } else {
3171
3172 $CPAN::Frontend
3173 ->myprint(sprintf qq{ Database was generated on %s\n},
3174 $last_updated);
3175 $DATE_OF_02 = $last_updated;
3176
3177 if ($CPAN::META->has_inst(HTTP::Date)) {
3178 require HTTP::Date;
3179 my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
3180 if ($age > 30) {
3181
3182 $CPAN::Frontend
3183 ->mywarn(sprintf
3184 qq{Warning: This index file is %d days old.
3185 Please check the host you chose as your CPAN mirror for staleness.
3186 I'll continue but problems seem likely to happen.\a\n},
3187 $age);
3188
3189 }
3190 } else {
3191 $CPAN::Frontend->myprint(" HTTP::Date not available\n");
3192 }
3193 }
3194
3195
c4d24d4c
A		 3196 # A necessity since we have metadata_cache: delete what isn't
3197 # there anymore
3198 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3199 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3200 my(%exists);
f14b5cec 3201 foreach (@lines) {
5f05dabc 3202 chomp;
05d2a450
A		 3203 # before 1.56 we split into 3 and discarded the rest. From
3204 # 1.57 we assign remaining text to $comment thus allowing to
3205 # influence isa_perl
3206 my($mod,$version,$dist,$comment) = split " ", $_, 4;
e50380aa 3207 my($bundle,$id,$userid);
f610777f 3208
09d9d230
A		 3209 if ($mod eq 'CPAN' &&
3210 ! (
f610777f
A		 3211 CPAN::Queue->exists('Bundle::CPAN') ||
3212 CPAN::Queue->exists('CPAN')
09d9d230
A		 3213 )
3214 ) {
c4d24d4c
A		 3215 local($^W)= 0;
3216 if ($version > $CPAN::VERSION){
3217 $CPAN::Frontend->myprint(qq{
3218 There's a new CPAN.pm version (v$version) available!
911a92db 3219 [Current version is v$CPAN::VERSION]
e50380aa 3220 You might want to try
09d9d230 3221 install Bundle::CPAN
5f05dabc 3222 reload cpan
c356248b 3223 without quitting the current session. It should be a seamless upgrade
05454584 3224 while we are running...
c4d24d4c
A		 3225}); #});
3226 sleep 2;
c356248b 3227 $CPAN::Frontend->myprint(qq{\n});
5f05dabc 3228 }
05454584 3229 last if $CPAN::Signal;
e50380aa
A		 3230 } elsif ($mod =~ /^Bundle::(.*)/) {
3231 $bundle = $1;
5f05dabc 3232 }
05454584 3233
05454584
A		 3234 if ($bundle){
3235 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
c356248b 3236 # Let's make it a module too, because bundles have so much
6d29edf5
JH		 3237 # in common with modules.
3238
3239 # Changed in 1.57_63: seems like memory bloat now without
3240 # any value, so commented out
3241
3242 # $CPAN::META->instance('CPAN::Module',$mod);
c356248b 3243
c4d24d4c 3244 } else {
c356248b 3245
05454584
A		 3246 # instantiate a module object
3247 $id = $CPAN::META->instance('CPAN::Module',$mod);
c4d24d4c 3248
5f05dabc 3249 }
5f05dabc 3250
5e05dca5
A		 3251 if ($id->cpan_file ne $dist){ # update only if file is
3252 # different. CPAN prohibits same
3253 # name with different version
05d2a450 3254 $userid = $self->userid($dist);
e50380aa
A		 3255 $id->set(
3256 'CPAN_USERID' => $userid,
6d29edf5 3257 'CPAN_VERSION' => $version,
05d2a450 3258 'CPAN_FILE' => $dist,
e50380aa
A		 3259 );
3260 }
05454584
A		 3261
3262 # instantiate a distribution object
911a92db
GS		 3263 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3264 # we do not need CONTAINSMODS unless we do something with
3265 # this dist, so we better produce it on demand.
3266
3267 ## my $obj = $CPAN::META->instance(
3268 ## 'CPAN::Distribution' => $dist
3269 ## );
3270 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3271 } else {
3272 $CPAN::META->instance(
3273 'CPAN::Distribution' => $dist
3274 )->set(
6d29edf5
JH		 3275 'CPAN_USERID' => $userid,
3276 'CPAN_COMMENT' => $comment,
911a92db 3277 );
5f05dabc 3278 }
c4d24d4c
A		 3279 if ($secondtime) {
3280 for my $name ($mod,$dist) {
6d29edf5 3281 CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
c4d24d4c
A		 3282 $exists{$name} = undef;
3283 }
3284 }
05454584 3285 return if $CPAN::Signal;
5f05dabc 3286 }
09d9d230 3287 undef $fh;
c4d24d4c
A		 3288 if ($secondtime) {
3289 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3290 for my $o ($CPAN::META->all_objects($class)) {
3291 next if exists $exists{$o->{ID}};
3292 $CPAN::META->delete($class,$o->{ID});
6d29edf5
JH		 3293 CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3294 if $CPAN::DEBUG;
c4d24d4c
A		 3295 }
3296 }
3297 }
5f05dabc 3298}
3299
55e314ee
A		 3300#-> sub CPAN::Index::rd_modlist ;
3301sub rd_modlist {
05454584 3302 my($cl,$index_target) = @_;
c356248b 3303 return unless defined $index_target;
c356248b 3304 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230
A		 3305 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3306 my @eval;
52128c7b 3307 local($/) = "\n";
09d9d230 3308 while ($_ = $fh->READLINE) {
f14b5cec
JH		 3309 s/\012/\n/g;
3310 my @ls = map {"$_\n"} split /\n/, $_;
3311 unshift @ls, "\n" x length($1) if /^(\n+)/;
3312 push @eval, @ls;
3313 }
3314 while (@eval) {
3315 my $shift = shift(@eval);
3316 if ($shift =~ /^Date:\s+(.*)/){
c049f953
JH		 3317 return if $DATE_OF_03 eq $1;
3318 ($DATE_OF_03) = $1;
e50380aa 3319 }
f14b5cec 3320 last if $shift =~ /^\s*$/;
05454584 3321 }
09d9d230
A		 3322 undef $fh;
3323 push @eval, q{CPAN::Modulelist->data;};
05454584
A		 3324 local($^W) = 0;
3325 my($comp) = Safe->new("CPAN::Safe1");
09d9d230 3326 my($eval) = join("", @eval);
05454584
A		 3327 my $ret = $comp->reval($eval);
3328 Carp::confess($@) if $@;
3329 return if $CPAN::Signal;
3330 for (keys %$ret) {
9d61fa1d 3331 my $obj = $CPAN::META->instance("CPAN::Module",$_);
6d29edf5 3332 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
05454584
A		 3333 $obj->set(%{$ret->{$_}});
3334 return if $CPAN::Signal;
3335 }
3336}
5f05dabc 3337
5e05dca5
A		 3338#-> sub CPAN::Index::write_metadata_cache ;
3339sub write_metadata_cache {
3340 my($self) = @_;
3341 return unless $CPAN::Config->{'cache_metadata'};
3342 return unless $CPAN::META->has_usable("Storable");
3343 my $cache;
3344 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
3345 CPAN::Distribution)) {
6d29edf5 3346 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5e05dca5 3347 }
5de3f0da 3348 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
c049f953
JH		 3349 $cache->{last_time} = $LAST_TIME;
3350 $cache->{DATE_OF_02} = $DATE_OF_02;
6d29edf5
JH		 3351 $cache->{PROTOCOL} = PROTOCOL;
3352 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
c4d24d4c 3353 eval { Storable::nstore($cache, $metadata_file) };
6d29edf5 3354 $CPAN::Frontend->mywarn($@) if $@;
5e05dca5
A		 3355}
3356
3357#-> sub CPAN::Index::read_metadata_cache ;
3358sub read_metadata_cache {
3359 my($self) = @_;
3360 return unless $CPAN::Config->{'cache_metadata'};
3361 return unless $CPAN::META->has_usable("Storable");
5de3f0da 3362 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5e05dca5
A		 3363 return unless -r $metadata_file and -f $metadata_file;
3364 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
3365 my $cache;
3366 eval { $cache = Storable::retrieve($metadata_file) };
3367 $CPAN::Frontend->mywarn($@) if $@;
6d29edf5 3368 if (!$cache || ref $cache ne 'HASH'){
c049f953 3369 $LAST_TIME = 0;
6d29edf5
JH		 3370 return;
3371 }
3372 if (exists $cache->{PROTOCOL}) {
3373 if (PROTOCOL > $cache->{PROTOCOL}) {
3374 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
3375 "with protocol v%s, requiring v%s",
3376 $cache->{PROTOCOL},
3377 PROTOCOL)
3378 );
3379 return;
3380 }
3381 } else {
3382 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
3383 "with protocol v1.0");
3384 return;
3385 }
3386 my $clcnt = 0;
3387 my $idcnt = 0;
3388 while(my($class,$v) = each %$cache) {
3389 next unless $class =~ /^CPAN::/;
3390 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
3391 while (my($id,$ro) = each %$v) {
3392 $CPAN::META->{readwrite}{$class}{$id} ||=
3393 $class->new(ID=>$id, RO=>$ro);
3394 $idcnt++;
c4d24d4c 3395 }
6d29edf5 3396 $clcnt++;
5e05dca5 3397 }
6d29edf5
JH		 3398 unless ($clcnt) { # sanity check
3399 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
3400 return;
3401 }
3402 if ($idcnt < 1000) {
3403 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
3404 "in $metadata_file\n");
3405 return;
3406 }
3407 $CPAN::META->{PROTOCOL} ||=
3408 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
3409 # does initialize to some protocol
c049f953
JH		 3410 $LAST_TIME = $cache->{last_time};
3411 $DATE_OF_02 = $cache->{DATE_OF_02};
d5a05a34
RB		 3412 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
3413 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
c049f953 3414 return;
5e05dca5
A		 3415}
3416
05454584 3417package CPAN::InfoObj;
5f05dabc 3418
6d29edf5
JH		 3419# Accessors
3420sub cpan_userid { shift->{RO}{CPAN_USERID} }
c049f953 3421sub id { shift->{ID}; }
6d29edf5 3422
05454584 3423#-> sub CPAN::InfoObj::new ;
6d29edf5
JH		 3424sub new {
3425 my $this = bless {}, shift;
3426 %$this = @_;
3427 $this
3428}
3429
3430# The set method may only be used by code that reads index data or
3431# otherwise "objective" data from the outside world. All session
3432# related material may do anything else with instance variables but
3433# must not touch the hash under the RO attribute. The reason is that
3434# the RO hash gets written to Metadata file and is thus persistent.
5f05dabc 3435
05454584
A		 3436#-> sub CPAN::InfoObj::set ;
3437sub set {
3438 my($self,%att) = @_;
6d29edf5
JH		 3439 my $class = ref $self;
3440
3441 # This must be ||=, not ||, because only if we write an empty
3442 # reference, only then the set method will write into the readonly
3443 # area. But for Distributions that spring into existence, maybe
3444 # because of a typo, we do not like it that they are written into
3445 # the readonly area and made permanent (at least for a while) and
3446 # that is why we do not "allow" other places to call ->set.
8d97e4a1
JH		 3447 unless ($self->id) {
3448 CPAN->debug("Bug? Empty ID, rejecting");
3449 return;
3450 }
6d29edf5
JH		 3451 my $ro = $self->{RO} =
3452 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
da199366 3453
6d29edf5
JH		 3454 while (my($k,$v) = each %att) {
3455 $ro->{$k} = $v;
3456 }
3457}
5f05dabc 3458
05454584
A		 3459#-> sub CPAN::InfoObj::as_glimpse ;
3460sub as_glimpse {
5f05dabc 3461 my($self) = @_;
05454584
A		 3462 my(@m);
3463 my $class = ref($self);
3464 $class =~ s/^CPAN:://;
3465 push @m, sprintf "%-15s %s\n", $class, $self->{ID};
3466 join "", @m;
5f05dabc 3467}
3468
05454584
A		 3469#-> sub CPAN::InfoObj::as_string ;
3470sub as_string {
3471 my($self) = @_;
3472 my(@m);
3473 my $class = ref($self);
3474 $class =~ s/^CPAN:://;
3475 push @m, $class, " id = $self->{ID}\n";
6d29edf5
JH		 3476 for (sort keys %{$self->{RO}}) {
3477 # next if m/^(ID|RO)$/;
05454584 3478 my $extra = "";
09d9d230 3479 if ($_ eq "CPAN_USERID") {
9d61fa1d
A		 3480 $extra .= " (".$self->author;
3481 my $email; # old perls!
3482 if ($email = $CPAN::META->instance("CPAN::Author",
3483 $self->cpan_userid
3484 )->email) {
3485 $extra .= " <$email>";
3486 } else {
3487 $extra .= " <no email>";
3488 }
3489 $extra .= ")";
3490 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
3491 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
3492 next;
3493 }
6d29edf5
JH		 3494 next unless defined $self->{RO}{$_};
3495 push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
3496 }
3497 for (sort keys %$self) {
3498 next if m/^(ID|RO)$/;
3499 if (ref($self->{$_}) eq "ARRAY") {
3500 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
911a92db
GS		 3501 } elsif (ref($self->{$_}) eq "HASH") {
3502 push @m, sprintf(
6d29edf5 3503 " %-12s %s\n",
911a92db
GS		 3504 $_,
3505 join(" ",keys %{$self->{$_}}),
6d29edf5 3506 );
5f05dabc 3507 } else {
6d29edf5 3508 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
05454584 3509 }
5f05dabc 3510 }
05454584 3511 join "", @m, "\n";
5f05dabc 3512}
3513
05454584
A		 3514#-> sub CPAN::InfoObj::author ;
3515sub author {
3516 my($self) = @_;
9d61fa1d 3517 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5f05dabc 3518}
3519
6d29edf5 3520#-> sub CPAN::InfoObj::dump ;
36263cb3
GS		 3521sub dump {
3522 my($self) = @_;
3523 require Data::Dumper;
6d29edf5 3524 print Data::Dumper::Dumper($self);
36263cb3
GS		 3525}
3526
05454584 3527package CPAN::Author;
05454584 3528
c049f953
JH		 3529#-> sub CPAN::Author::id
3530sub id {
3531 my $self = shift;
3532 my $id = $self->{ID};
3533 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
3534 $id;
3535}
3536
05454584
A		 3537#-> sub CPAN::Author::as_glimpse ;
3538sub as_glimpse {
5f05dabc 3539 my($self) = @_;
05454584
A		 3540 my(@m);
3541 my $class = ref($self);
3542 $class =~ s/^CPAN:://;
c049f953
JH		 3543 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
3544 $class,
3545 $self->{ID},
3546 $self->fullname,
3547 $self->email);
05454584 3548 join "", @m;
5f05dabc 3549}
3550
05454584 3551#-> sub CPAN::Author::fullname ;
9d61fa1d 3552sub fullname {
8d97e4a1 3553 shift->{RO}{FULLNAME};
9d61fa1d 3554}
05454584 3555*name = \&fullname;
36263cb3 3556
05454584 3557#-> sub CPAN::Author::email ;
8d97e4a1
JH		 3558sub email { shift->{RO}{EMAIL}; }
3559
d8773709 3560#-> sub CPAN::Author::ls ;
8d97e4a1
JH		 3561sub ls {
3562 my $self = shift;
3563 my $id = $self->id;
3564
3565 # adapted from CPAN::Distribution::verifyMD5 ;
c049f953
JH		 3566 my(@csf); # chksumfile
3567 @csf = $self->id =~ /(.)(.)(.*)/;
3568 $csf[1] = join "", @csf[0,1];
3569 $csf[2] = join "", @csf[1,2];
3570 my(@dl);
3571 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
3572 unless (grep {$_->[2] eq $csf[1]} @dl) {
3573 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3574 return;
3575 }
3576 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
3577 unless (grep {$_->[2] eq $csf[2]} @dl) {
3578 $CPAN::Frontend->myprint("No files in the directory of $id\n");
3579 return;
3580 }
3581 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
3582 $CPAN::Frontend->myprint(join "", map {
d8773709 3583 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
c049f953 3584 } sort { $a->[2] cmp $b->[2] } @dl);
8d97e4a1
JH		 3585}
3586
c049f953 3587# returns an array of arrays, the latter contain (size,mtime,filename)
d8773709 3588#-> sub CPAN::Author::dir_listing ;
8d97e4a1
JH		 3589sub dir_listing {
3590 my $self = shift;
3591 my $chksumfile = shift;
c049f953 3592 my $recursive = shift;
8d97e4a1 3593 my $lc_want =
5de3f0da
DR		 3594 File::Spec->catfile($CPAN::Config->{keep_source_where},
3595 "authors", "id", @$chksumfile);
8d97e4a1 3596 local($") = "/";
c049f953
JH		 3597 # connect "force" argument with "index_expire".
3598 my $force = 0;
3599 if (my @stat = stat $lc_want) {
3600 $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
3601 }
8d97e4a1 3602 my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
c049f953 3603 $lc_want,$force);
8d97e4a1
JH		 3604 unless ($lc_file) {
3605 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
3606 $chksumfile->[-1] .= ".gz";
3607 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
c049f953 3608 "$lc_want.gz",1);
8d97e4a1
JH		 3609 if ($lc_file) {
3610 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
3611 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
3612 } else {
3613 return;
3614 }
3615 }
3616
3617 # adapted from CPAN::Distribution::MD5_check_file ;
3618 my $fh = FileHandle->new;
3619 my($cksum);
3620 if (open $fh, $lc_file){
3621 local($/);
3622 my $eval = <$fh>;
3623 $eval =~ s/\015?\012/\n/g;
3624 close $fh;
3625 my($comp) = Safe->new();
3626 $cksum = $comp->reval($eval);
3627 if ($@) {
3628 rename $lc_file, "$lc_file.bad";
3629 Carp::confess($@) if $@;
3630 }
3631 } else {
3632 Carp::carp "Could not open $lc_file for reading";
3633 }
3634 my(@result,$f);
3635 for $f (sort keys %$cksum) {
3636 if (exists $cksum->{$f}{isdir}) {
c049f953
JH		 3637 if ($recursive) {
3638 my(@dir) = @$chksumfile;
3639 pop @dir;
3640 push @dir, $f, "CHECKSUMS";
3641 push @result, map {
3642 [$_->[0], $_->[1], "$f/$_->[2]"]
3643 } $self->dir_listing(\@dir,1);
3644 } else {
3645 push @result, [ 0, "-", $f ];
3646 }
8d97e4a1
JH		 3647 } else {
3648 push @result, [
3649 ($cksum->{$f}{"size"}||0),
3650 $cksum->{$f}{"mtime"}||"---",
3651 $f
3652 ];
3653 }
3654 }
3655 @result;
3656}
5f05dabc 3657
05454584 3658package CPAN::Distribution;
5f05dabc 3659
6d29edf5
JH		 3660# Accessors
3661sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
3662
3663sub undelay {
3664 my $self = shift;
3665 delete $self->{later};
3666}
3667
d8773709 3668# CPAN::Distribution::normalize
8d97e4a1
JH		 3669sub normalize {
3670 my($self,$s) = @_;
d8773709 3671 $s = $self->id unless defined $s;
c049f953
JH		 3672 if (
3673 $s =~ tr|/|| == 1
3674 or
3675 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
3676 ) {
3677 return $s if $s =~ m:^N/A|^Contact Author: ;
8d97e4a1
JH		 3678 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
3679 $CPAN::Frontend->mywarn("Strange distribution name [$s]");
3680 CPAN->debug("s[$s]") if $CPAN::DEBUG;
3681 }
3682 $s;
3683}
3684
6d29edf5
JH		 3685#-> sub CPAN::Distribution::color_cmd_tmps ;
3686sub color_cmd_tmps {
3687 my($self) = shift;
3688 my($depth) = shift || 0;
3689 my($color) = shift || 0;
3690 # a distribution needs to recurse into its prereq_pms
3691
3692 return if exists $self->{incommandcolor}
3693 && $self->{incommandcolor}==$color;
3694 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
3695 "color_cmd_tmps depth[%s] self[%s] id[%s]",
3696 $depth,
3697 $self,
3698 $self->id
3699 )) if $depth>=100;
3700 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
3701 my $prereq_pm = $self->prereq_pm;
3702 if (defined $prereq_pm) {
3703 for my $pre (keys %$prereq_pm) {
3704 my $premo = CPAN::Shell->expand("Module",$pre);
3705 $premo->color_cmd_tmps($depth+1,$color);
3706 }
3707 }
3708 if ($color==0) {
3709 delete $self->{sponsored_mods};
3710 delete $self->{badtestcnt};
3711 }
3712 $self->{incommandcolor} = $color;
3713}
3714
911a92db
GS		 3715#-> sub CPAN::Distribution::as_string ;
3716sub as_string {
3717 my $self = shift;
3718 $self->containsmods;
3719 $self->SUPER::as_string(@_);
3720}
3721
3722#-> sub CPAN::Distribution::containsmods ;
3723sub containsmods {
3724 my $self = shift;
9d61fa1d
A		 3725 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
3726 my $dist_id = $self->{ID};
911a92db 3727 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6d29edf5 3728 my $mod_file = $mod->cpan_file or next;
911a92db 3729 my $mod_id = $mod->{ID} or next;
6d29edf5
JH		 3730 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
3731 # sleep 1;
911a92db
GS		 3732 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
3733 }
9d61fa1d 3734 keys %{$self->{CONTAINSMODS}};
911a92db
GS		 3735}
3736
d8773709
JH		 3737#-> sub CPAN::Distribution::uptodate ;
3738sub uptodate {
3739 my($self) = @_;
3740 my $c;
3741 foreach $c ($self->containsmods) {
3742 my $obj = CPAN::Shell->expandany($c);
3743 return 0 unless $obj->uptodate;
3744 }
3745 return 1;
3746}
3747
05454584
A		 3748#-> sub CPAN::Distribution::called_for ;
3749sub called_for {
3750 my($self,$id) = @_;
6d29edf5
JH		 3751 $self->{CALLED_FOR} = $id if defined $id;
3752 return $self->{CALLED_FOR};
5f05dabc 3753}
3754
c049f953 3755#-> sub CPAN::Distribution::safe_chdir ;
d8773709
JH		 3756sub safe_chdir {
3757 my($self,$todir) = @_;
3758 # we die if we cannot chdir and we are debuggable
3759 Carp::confess("safe_chdir called without todir argument")
3760 unless defined $todir and length $todir;
3761 if (chdir $todir) {
3762 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
3763 if $CPAN::DEBUG;
3764 } else {
3765 my $cwd = CPAN::anycwd();
3766 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
3767 qq{to todir[$todir]: $!});
3768 }
3769}
3770
05454584
A		 3771#-> sub CPAN::Distribution::get ;
3772sub get {
5f05dabc 3773 my($self) = @_;
da199366
A		 3774 EXCUSE: {
3775 my @e;
05454584 3776 exists $self->{'build_dir'} and push @e,
c4d24d4c 3777 "Is already unwrapped into directory $self->{'build_dir'}";
c356248b 3778 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
da199366 3779 }
d8773709
JH		 3780 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
3781
3782 #
3783 # Get the file on local disk
3784 #
3785
05454584
A		 3786 my($local_file);
3787 my($local_wanted) =
5de3f0da
DR		 3788 File::Spec->catfile(
3789 $CPAN::Config->{keep_source_where},
3790 "authors",
3791 "id",
3792 split("/",$self->id)
3793 );
05454584
A		 3794
3795 $self->debug("Doing localize") if $CPAN::DEBUG;
c049f953
JH		 3796 unless ($local_file =
3797 CPAN::FTP->localize("authors/id/$self->{ID}",
3798 $local_wanted)) {
3799 my $note = "";
3800 if ($CPAN::Index::DATE_OF_02) {
3801 $note = "Note: Current database in memory was generated ".
3802 "on $CPAN::Index::DATE_OF_02\n";
3803 }
3804 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
3805 }
d8773709 3806 $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
05454584 3807 $self->{localfile} = $local_file;
d8773709 3808 return if $CPAN::Signal;
05454584 3809
d8773709
JH		 3810 #
3811 # Check integrity
3812 #
5b6aeab6
GA		 3813 if ($CPAN::META->has_inst("Digest::MD5")) {
3814 $self->debug("Digest::MD5 is installed, verifying");
05454584 3815 $self->verifyMD5;
55e314ee 3816 } else {
5b6aeab6 3817 $self->debug("Digest::MD5 is NOT installed");
55e314ee 3818 }
d8773709
JH		 3819 return if $CPAN::Signal;
3820
3821 #
3822 # Create a clean room and go there
3823 #
3824 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
3825 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
3826 $self->safe_chdir($builddir);
55e314ee
A		 3827 $self->debug("Removing tmp") if $CPAN::DEBUG;
3828 File::Path::rmtree("tmp");
3829 mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
d8773709
JH		 3830 if ($CPAN::Signal){
3831 $self->safe_chdir($sub_wd);
3832 return;
3833 }
3834 $self->safe_chdir("tmp");
3835
3836 #
3837 # Unpack the goods
3838 #
3839 if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
5a5fac02 3840 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
55e314ee 3841 $self->untar_me($local_file);
05d2a450 3842 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
55e314ee 3843 $self->unzip_me($local_file);
05d2a450 3844 } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
5a5fac02 3845 $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
55e314ee
A		 3846 $self->pm2dir_me($local_file);
3847 } else {
3848 $self->{archived} = "NO";
d8773709
JH		 3849 $self->safe_chdir($sub_wd);
3850 return;
5f05dabc 3851 }
d8773709
JH		 3852
3853 # we are still in the tmp directory!
3854 # Let's check if the package has its own directory.
3855 my $dh = DirHandle->new(File::Spec->curdir)
3856 or Carp::croak("Couldn't opendir .: $!");
3857 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
3858 $dh->close;
3859 my ($distdir,$packagedir);
3860 if (@readdir == 1 && -d $readdir[0]) {
05d2a450 3861 $distdir = $readdir[0];
5de3f0da 3862 $packagedir = File::Spec->catdir($builddir,$distdir);
d8773709
JH		 3863 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
3864 if $CPAN::DEBUG;
6d29edf5
JH		 3865 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
3866 "$packagedir\n");
05d2a450 3867 File::Path::rmtree($packagedir);
6d29edf5
JH		 3868 rename($distdir,$packagedir) or
3869 Carp::confess("Couldn't rename $distdir to $packagedir: $!");
d8773709
JH		 3870 $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
3871 $distdir,
3872 $packagedir,
3873 -e $packagedir,
3874 -d $packagedir,
3875 )) if $CPAN::DEBUG;
3876 } else {
3877 my $userid = $self->cpan_userid;
3878 unless ($userid) {
3879 CPAN->debug("no userid? self[$self]");
3880 $userid = "anon";
3881 }
3882 my $pragmatic_dir = $userid . '000';
3883 $pragmatic_dir =~ s/\W_//g;
3884 $pragmatic_dir++ while -d "../$pragmatic_dir";
5de3f0da 3885 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
d8773709
JH		 3886 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
3887 File::Path::mkpath($packagedir);
3888 my($f);
3889 for $f (@readdir) { # is already without "." and ".."
5de3f0da 3890 my $to = File::Spec->catdir($packagedir,$f);
d8773709 3891 rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
9d61fa1d 3892 }
d8773709
JH		 3893 }
3894 if ($CPAN::Signal){
3895 $self->safe_chdir($sub_wd);
3896 return;
3897 }
05d2a450 3898
d8773709
JH		 3899 $self->{'build_dir'} = $packagedir;
3900 $self->safe_chdir(File::Spec->updir);
3901 File::Path::rmtree("tmp");
3902
5de3f0da 3903 my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
d8773709
JH		 3904 my($mpl_exists) = -f $mpl;
3905 unless ($mpl_exists) {
c049f953
JH		 3906 # NFS has been reported to have racing problems after the
3907 # renaming of a directory in some environments.
3908 # This trick helps.
3909 sleep 1;
3910 my $mpldh = DirHandle->new($packagedir)
d8773709 3911 or Carp::croak("Couldn't opendir $packagedir: $!");
c049f953
JH		 3912 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
3913 $mpldh->close;
d8773709
JH		 3914 }
3915 unless ($mpl_exists) {
3916 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
3917 $mpl,
3918 CPAN::anycwd(),
3919 )) if $CPAN::DEBUG;
5de3f0da 3920 my($configure) = File::Spec->catfile($packagedir,"Configure");
05d2a450 3921 if (-f $configure) {
d8773709
JH		 3922 # do we have anything to do?
3923 $self->{'configure'} = $configure;
5de3f0da 3924 } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
d8773709 3925 $CPAN::Frontend->myprint(qq{
09d9d230
A		 3926Package comes with a Makefile and without a Makefile.PL.
3927We\'ll try to build it with that Makefile then.
3928});
d8773709
JH		 3929 $self->{writemakefile} = "YES";
3930 sleep 2;
05d2a450 3931 } else {
d8773709
JH		 3932 my $cf = $self->called_for || "unknown";
3933 if ($cf =~ m|/|) {
3934 $cf =~ s|.*/||;
3935 $cf =~ s|\W.*||;
3936 }
3937 $cf =~ s|[/\\:]||g; # risk of filesystem damage
3938 $cf = "unknown" unless length($cf);
3939 $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
3940 (The test -f "$mpl" returned false.)
3941 Writing one on our own (setting NAME to $cf)\a\n});
3942 $self->{had_no_makefile_pl}++;
3943 sleep 3;
3944
3945 # Writing our own Makefile.PL
3946
3947 my $fh = FileHandle->new;
3948 $fh->open(">$mpl")
3949 or Carp::croak("Could not open >$mpl: $!");
3950 $fh->print(
55e314ee
A		 3951qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
3952# because there was no Makefile.PL supplied.
05454584 3953# Autogenerated on: }.scalar localtime().qq{
55e314ee 3954
09d9d230
A		 3955use ExtUtils::MakeMaker;
3956WriteMakefile(NAME => q[$cf]);
55e314ee 3957
05454584 3958});
d8773709 3959 $fh->close;
05d2a450 3960 }
5f05dabc 3961 }
d8773709 3962
05454584 3963 return $self;
5f05dabc 3964}
3965
6d29edf5 3966# CPAN::Distribution::untar_me ;
55e314ee
A		 3967sub untar_me {
3968 my($self,$local_file) = @_;
3969 $self->{archived} = "tar";
09d9d230 3970 if (CPAN::Tarzip->untar($local_file)) {
55e314ee
A		 3971 $self->{unwrapped} = "YES";
3972 } else {
3973 $self->{unwrapped} = "NO";
3974 }
3975}
3976
6d29edf5 3977# CPAN::Distribution::unzip_me ;
55e314ee
A		 3978sub unzip_me {
3979 my($self,$local_file) = @_;
05d2a450 3980 $self->{archived} = "zip";
c4d24d4c 3981 if (CPAN::Tarzip->unzip($local_file)) {
55e314ee
A		 3982 $self->{unwrapped} = "YES";
3983 } else {
3984 $self->{unwrapped} = "NO";
3985 }
c4d24d4c 3986 return;
55e314ee
A		 3987}
3988
3989sub pm2dir_me {
3990 my($self,$local_file) = @_;
3991 $self->{archived} = "pm";
3992 my $to = File::Basename::basename($local_file);
05d2a450 3993 $to =~ s/\.(gz|Z)(?!\n)\Z//;
09d9d230 3994 if (CPAN::Tarzip->gunzip($local_file,$to)) {
55e314ee
A		 3995 $self->{unwrapped} = "YES";
3996 } else {
3997 $self->{unwrapped} = "NO";
3998 }
3999}
4000
05454584
A		 4001#-> sub CPAN::Distribution::new ;
4002sub new {
4003 my($class,%att) = @_;
5f05dabc 4004
5e05dca5 4005 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5f05dabc 4006
05454584
A		 4007 my $this = { %att };
4008 return bless $this, $class;
5f05dabc 4009}
4010
05454584
A		 4011#-> sub CPAN::Distribution::look ;
4012sub look {
5f05dabc 4013 my($self) = @_;
36263cb3
GS		 4014
4015 if ($^O eq 'MacOS') {
be708cc0 4016 $self->Mac::BuildTools::look;
36263cb3
GS		 4017 return;
4018 }
4019
05454584 4020 if ( $CPAN::Config->{'shell'} ) {
c356248b 4021 $CPAN::Frontend->myprint(qq{
05454584 4022Trying to open a subshell in the build directory...
c356248b 4023});
05454584 4024 } else {
c356248b 4025 $CPAN::Frontend->myprint(qq{
05454584
A		 4026Your configuration does not define a value for subshells.
4027Please define it with "o conf shell <your shell>"
c356248b 4028});
05454584 4029 return;
5f05dabc 4030 }
05454584 4031 my $dist = $self->id;
c049f953
JH		 4032 my $dir;
4033 unless ($dir = $self->dir) {
4034 $self->get;
4035 }
4036 unless ($dir ||= $self->dir) {
4037 $CPAN::Frontend->mywarn(qq{
4038Could not determine which directory to use for looking at $dist.
4039});
4040 return;
4041 }
9d61fa1d 4042 my $pwd = CPAN::anycwd();
c049f953 4043 $self->safe_chdir($dir);
c356248b
A		 4044 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4045 system($CPAN::Config->{'shell'}) == 0
4046 or $CPAN::Frontend->mydie("Subprocess shell error");
c049f953 4047 $self->safe_chdir($pwd);
5f05dabc 4048}
4049
6d29edf5 4050# CPAN::Distribution::cvs_import ;
911a92db
GS		 4051sub cvs_import {
4052 my($self) = @_;
4053 $self->get;
4054 my $dir = $self->dir;
4055
4056 my $package = $self->called_for;
4057 my $module = $CPAN::META->instance('CPAN::Module', $package);
6d29edf5 4058 my $version = $module->cpan_version;
911a92db 4059
6d29edf5 4060 my $userid = $self->cpan_userid;
911a92db
GS		 4061
4062 my $cvs_dir = (split '/', $dir)[-1];
05d2a450 4063 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
911a92db
GS		 4064 my $cvs_root =
4065 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
4066 my $cvs_site_perl =
4067 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
4068 if ($cvs_site_perl) {
4069 $cvs_dir = "$cvs_site_perl/$cvs_dir";
4070 }
4071 my $cvs_log = qq{"imported $package $version sources"};
4072 $version =~ s/\./_/g;
4073 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
4074 "$cvs_dir", $userid, "v$version");
4075
9d61fa1d 4076 my $pwd = CPAN::anycwd();
05d2a450 4077 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
911a92db
GS		 4078
4079 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
4080
4081 $CPAN::Frontend->myprint(qq{@cmd\n});
de34a54b 4082 system(@cmd) == 0 or
911a92db 4083 $CPAN::Frontend->mydie("cvs import failed");
05d2a450 4084 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
911a92db
GS		 4085}
4086
05454584
A		 4087#-> sub CPAN::Distribution::readme ;
4088sub readme {
5f05dabc 4089 my($self) = @_;
05454584
A		 4090 my($dist) = $self->id;
4091 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
4092 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
4093 my($local_file);
4094 my($local_wanted) =
5de3f0da
DR		 4095 File::Spec->catfile(
4096 $CPAN::Config->{keep_source_where},
4097 "authors",
4098 "id",
4099 split("/","$sans.readme"),
4100 );
05454584 4101 $self->debug("Doing localize") if $CPAN::DEBUG;
c356248b
A		 4102 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
4103 $local_wanted)
4104 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
f14b5cec
JH		 4105
4106 if ($^O eq 'MacOS') {
be708cc0 4107 Mac::BuildTools::launch_file($local_file);
f14b5cec
JH		 4108 return;
4109 }
4110
05454584 4111 my $fh_pager = FileHandle->new;
c356248b 4112 local($SIG{PIPE}) = "IGNORE";
05454584
A		 4113 $fh_pager->open("|$CPAN::Config->{'pager'}")
4114 or die "Could not open pager $CPAN::Config->{'pager'}: $!";
4115 my $fh_readme = FileHandle->new;
c356248b
A		 4116 $fh_readme->open($local_file)
4117 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
4118 $CPAN::Frontend->myprint(qq{
4119Displaying file
4120 $local_file
4121with pager "$CPAN::Config->{'pager'}"
4122});
4123 sleep 2;
05454584 4124 $fh_pager->print(<$fh_readme>);
5f05dabc 4125}
4126
05454584
A		 4127#-> sub CPAN::Distribution::verifyMD5 ;
4128sub verifyMD5 {
5f05dabc 4129 my($self) = @_;
05454584
A		 4130 EXCUSE: {
4131 my @e;
4132 $self->{MD5_STATUS} ||= "";
4133 $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
c356248b 4134 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 4135 }
55e314ee 4136 my($lc_want,$lc_file,@local,$basename);
8d97e4a1 4137 @local = split("/",$self->id);
55e314ee 4138 pop @local;
05454584 4139 push @local, "CHECKSUMS";
55e314ee 4140 $lc_want =
5de3f0da
DR		 4141 File::Spec->catfile($CPAN::Config->{keep_source_where},
4142 "authors", "id", @local);
05454584
A		 4143 local($") = "/";
4144 if (
c356248b 4145 -s $lc_want
05454584 4146 &&
55e314ee 4147 $self->MD5_check_file($lc_want)
05454584
A		 4148 ) {
4149 return $self->{MD5_STATUS} = "OK";
4150 }
55e314ee 4151 $lc_file = CPAN::FTP->localize("authors/id/@local",
c356248b 4152 $lc_want,1);
55e314ee 4153 unless ($lc_file) {
8d97e4a1 4154 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
05454584 4155 $local[-1] .= ".gz";
55e314ee 4156 $lc_file = CPAN::FTP->localize("authors/id/@local",
c356248b
A		 4157 "$lc_want.gz",1);
4158 if ($lc_file) {
05d2a450 4159 $lc_file =~ s/\.gz(?!\n)\Z//;
09d9d230 4160 CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
c356248b
A		 4161 } else {
4162 return;
4163 }
05454584 4164 }
55e314ee 4165 $self->MD5_check_file($lc_file);
5f05dabc 4166}
4167
05454584
A		 4168#-> sub CPAN::Distribution::MD5_check_file ;
4169sub MD5_check_file {
55e314ee
A		 4170 my($self,$chk_file) = @_;
4171 my($cksum,$file,$basename);
c356248b 4172 $file = $self->{localfile};
55e314ee
A		 4173 $basename = File::Basename::basename($file);
4174 my $fh = FileHandle->new;
55e314ee 4175 if (open $fh, $chk_file){
c356248b 4176 local($/);
05454584 4177 my $eval = <$fh>;
f14b5cec 4178 $eval =~ s/\015?\012/\n/g;
05454584
A		 4179 close $fh;
4180 my($comp) = Safe->new();
4181 $cksum = $comp->reval($eval);
55e314ee
A		 4182 if ($@) {
4183 rename $chk_file, "$chk_file.bad";
4184 Carp::confess($@) if $@;
4185 }
4186 } else {
4187 Carp::carp "Could not open $chk_file for reading";
4188 }
09d9d230
A		 4189
4190 if (exists $cksum->{$basename}{md5}) {
55e314ee 4191 $self->debug("Found checksum for $basename:" .
09d9d230
A		 4192 "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
4193
4194 open($fh, $file);
4195 binmode $fh;
4196 my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
4197 $fh->close;
4198 $fh = CPAN::Tarzip->TIEHANDLE($file);
4199
4200 unless ($eq) {
4201 # had to inline it, when I tied it, the tiedness got lost on
4202 # the call to eq_MD5. (Jan 1998)
5b6aeab6 4203 my $md5 = Digest::MD5->new;
09d9d230
A		 4204 my($data,$ref);
4205 $ref = \$data;
36263cb3 4206 while ($fh->READ($ref, 4096) > 0){
09d9d230
A		 4207 $md5->add($data);
4208 }
4209 my $hexdigest = $md5->hexdigest;
4210 $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
4211 }
4212
4213 if ($eq) {
4214 $CPAN::Frontend->myprint("Checksum for $file ok\n");
4215 return $self->{MD5_STATUS} = "OK";
05454584 4216 } else {
de34a54b 4217 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
c356248b
A		 4218 qq{distribution file. }.
4219 qq{Please investigate.\n\n}.
4220 $self->as_string,
4221 $CPAN::META->instance(
4222 'CPAN::Author',
6d29edf5 4223 $self->cpan_userid
c356248b 4224 )->as_string);
de34a54b
JH		 4225
4226 my $wrap = qq{I\'d recommend removing $file. Its MD5
c4d24d4c
A		 4227checksum is incorrect. Maybe you have configured your 'urllist' with
4228a bad URL. Please check this array with 'o conf urllist', and
55e314ee 4229retry.};
de34a54b 4230
c4d24d4c
A		 4231 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
4232
4233 # former versions just returned here but this seems a
4234 # serious threat that deserves a die
4235
4236 # $CPAN::Frontend->myprint("\n\n");
4237 # sleep 3;
4238 # return;
5f05dabc 4239 }
09d9d230 4240 # close $fh if fileno($fh);
5f05dabc 4241 } else {
55e314ee
A		 4242 $self->{MD5_STATUS} ||= "";
4243 if ($self->{MD5_STATUS} eq "NIL") {
5a5fac02
JH		 4244 $CPAN::Frontend->mywarn(qq{
4245Warning: No md5 checksum for $basename in $chk_file.
4246
4247The cause for this may be that the file is very new and the checksum
4248has not yet been calculated, but it may also be that something is
4249going awry right now.
c356248b 4250});
5a5fac02
JH		 4251 my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
4252 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
55e314ee
A		 4253 }
4254 $self->{MD5_STATUS} = "NIL";
4255 return;
5f05dabc 4256 }
4257}
4258
05454584
A		 4259#-> sub CPAN::Distribution::eq_MD5 ;
4260sub eq_MD5 {
4261 my($self,$fh,$expectMD5) = @_;
5b6aeab6 4262 my $md5 = Digest::MD5->new;
09d9d230
A		 4263 my($data);
4264 while (read($fh, $data, 4096)){
4265 $md5->add($data);
4266 }
4267 # $md5->addfile($fh);
05454584 4268 my $hexdigest = $md5->hexdigest;
09d9d230 4269 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
05454584
A		 4270 $hexdigest eq $expectMD5;
4271}
5f05dabc 4272
05454584 4273#-> sub CPAN::Distribution::force ;
c4d24d4c
A		 4274
4275# Both modules and distributions know if "force" is in effect by
4276# autoinspection, not by inspecting a global variable. One of the
4277# reason why this was chosen to work that way was the treatment of
4278# dependencies. They should not autpomatically inherit the force
4279# status. But this has the downside that ^C and die() will return to
4280# the prompt but will not be able to reset the force_update
4281# attributes. We try to correct for it currently in the read_metadata
4282# routine, and immediately before we check for a Signal. I hope this
4283# works out in one of v1.57_53ff
4284
5f05dabc 4285sub force {
c4d24d4c 4286 my($self, $method) = @_;
f610777f
A		 4287 for my $att (qw(
4288 MD5_STATUS archived build_dir localfile make install unwrapped
36263cb3 4289 writemakefile
f610777f
A		 4290 )) {
4291 delete $self->{$att};
4292 }
c4d24d4c
A		 4293 if ($method && $method eq "install") {
4294 $self->{"force_update"}++; # name should probably have been force_install
4295 }
4296}
4297
4298#-> sub CPAN::Distribution::unforce ;
4299sub unforce {
4300 my($self) = @_;
4301 delete $self->{'force_update'};
5f05dabc 4302}
4303
de34a54b 4304#-> sub CPAN::Distribution::isa_perl ;
09d9d230
A		 4305sub isa_perl {
4306 my($self) = @_;
4307 my $file = File::Basename::basename($self->id);
05d2a450
A		 4308 if ($file =~ m{ ^ perl
4309 -?
4310 (5)
4311 ([._-])
4312 (
4313 \d{3}(_[0-4][0-9])?
4314 |
4315 \d*[24680]\.\d+
4316 )
4317 \.tar[._-]gz
4318 (?!\n)\Z
4319 }xs){
4320 return "$1.$3";
6d29edf5
JH		 4321 } elsif ($self->cpan_comment
4322 &&
4323 $self->cpan_comment =~ /isa_perl\(.+?\)/){
05d2a450
A		 4324 return $1;
4325 }
09d9d230
A		 4326}
4327
d4fd5c69
A		 4328#-> sub CPAN::Distribution::perl ;
4329sub perl {
4330 my($self) = @_;
5de3f0da 4331 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
9d61fa1d 4332 my $pwd = CPAN::anycwd();
5de3f0da 4333 my $candidate = File::Spec->catfile($pwd,$^X);
e50380aa 4334 $perl ||= $candidate if MM->maybe_command($candidate);
d4fd5c69
A		 4335 unless ($perl) {
4336 my ($component,$perl_name);
911a92db 4337 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
5de3f0da 4338 PATH_COMPONENT: foreach $component (File::Spec->path(),
c356248b 4339 $Config::Config{'binexp'}) {
d4fd5c69 4340 next unless defined($component) && $component;
5de3f0da 4341 my($abs) = File::Spec->catfile($component,$perl_name);
d4fd5c69
A		 4342 if (MM->maybe_command($abs)) {
4343 $perl = $abs;
4344 last DIST_PERLNAME;
4345 }
4346 }
4347 }
4348 }
4349 $perl;
4350}
4351
05454584
A		 4352#-> sub CPAN::Distribution::make ;
4353sub make {
4354 my($self) = @_;
c356248b 4355 $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
09d9d230
A		 4356 # Emergency brake if they said install Pippi and get newest perl
4357 if ($self->isa_perl) {
4358 if (
c4d24d4c
A		 4359 $self->called_for ne $self->id &&
4360 ! $self->{force_update}
09d9d230 4361 ) {
de34a54b
JH		 4362 # if we die here, we break bundles
4363 $CPAN::Frontend->mywarn(sprintf qq{
09d9d230
A		 4364The most recent version "%s" of the module "%s"
4365comes with the current version of perl (%s).
4366I\'ll build that only if you ask for something like
4367 force install %s
4368or
4369 install %s
4370},
4371 $CPAN::META->instance(
4372 'CPAN::Module',
4373 $self->called_for
6d29edf5 4374 )->cpan_version,
09d9d230
A		 4375 $self->called_for,
4376 $self->isa_perl,
4377 $self->called_for,
4378 $self->id);
de34a54b 4379 sleep 5; return;
09d9d230
A		 4380 }
4381 }
05454584
A		 4382 $self->get;
4383 EXCUSE: {
4384 my @e;
4385 $self->{archived} eq "NO" and push @e,
4386 "Is neither a tar nor a zip archive.";
5f05dabc 4387
d4fd5c69 4388 $self->{unwrapped} eq "NO" and push @e,
05454584
A		 4389 "had problems unarchiving. Please build manually";
4390
4391 exists $self->{writemakefile} &&
36263cb3
GS		 4392 $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
4393 $1 || "Had some problem writing Makefile";
05454584
A		 4394
4395 defined $self->{'make'} and push @e,
6d29edf5
JH		 4396 "Has already been processed within this session";
4397
4398 exists $self->{later} and length($self->{later}) and
4399 push @e, $self->{later};
05454584 4400
c356248b 4401 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
5f05dabc 4402 }
c356248b 4403 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
05454584
A		 4404 my $builddir = $self->dir;
4405 chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
4406 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
4407
f14b5cec 4408 if ($^O eq 'MacOS') {
be708cc0 4409 Mac::BuildTools::make($self);
f14b5cec
JH		 4410 return;
4411 }
4412
05454584
A		 4413 my $system;
4414 if ($self->{'configure'}) {
09d9d230 4415 $system = $self->{'configure'};
5f05dabc 4416 } else {
d4fd5c69
A		 4417 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
4418 my $switch = "";
4419# This needs a handler that can be turned on or off:
4420# $switch = "-MExtUtils::MakeMaker ".
4421# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
4422# if $] > 5.00310;
4423 $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
4424 }
09d9d230 4425 unless (exists $self->{writemakefile}) {
e50380aa
A		 4426 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
4427 my($ret,$pid);
4428 $@ = "";
4429 if ($CPAN::Config->{inactivity_timeout}) {
4430 eval {
4431 alarm $CPAN::Config->{inactivity_timeout};
f14b5cec 4432 local $SIG{CHLD}; # = sub { wait };
e50380aa
A		 4433 if (defined($pid = fork)) {
4434 if ($pid) { #parent
f14b5cec
JH		 4435 # wait;
4436 waitpid $pid, 0;
e50380aa 4437 } else { #child
09d9d230
A		 4438 # note, this exec isn't necessary if
4439 # inactivity_timeout is 0. On the Mac I'd
4440 # suggest, we set it always to 0.
4441 exec $system;
e50380aa
A		 4442 }
4443 } else {
c356248b 4444 $CPAN::Frontend->myprint("Cannot fork: $!");
e50380aa 4445 return;
05454584 4446 }
e50380aa
A		 4447 };
4448 alarm 0;
4449 if ($@){
4450 kill 9, $pid;
4451 waitpid $pid, 0;
c356248b 4452 $CPAN::Frontend->myprint($@);
36263cb3 4453 $self->{writemakefile} = "NO $@";
e50380aa 4454 $@ = "";
05454584
A		 4455 return;
4456 }
e50380aa 4457 } else {
2e2b7522
GS		 4458 $ret = system($system);
4459 if ($ret != 0) {
36263cb3 4460 $self->{writemakefile} = "NO Makefile.PL returned status $ret";
2e2b7522 4461 return;
09d9d230 4462 }
e50380aa 4463 }
36263cb3
GS		 4464 if (-f "Makefile") {
4465 $self->{writemakefile} = "YES";
c4d24d4c 4466 delete $self->{make_clean}; # if cleaned before, enable next
36263cb3
GS		 4467 } else {
4468 $self->{writemakefile} =
4469 qq{NO Makefile.PL refused to write a Makefile.};
29ca949e 4470 # It's probably worth it to record the reason, so let's retry
36263cb3
GS		 4471 # local $/;
4472 # my $fh = IO::File->new("$system |"); # STDERR? STDIN?
4473 # $self->{writemakefile} .= <$fh>;
4474 }
05454584 4475 }
c4d24d4c
A		 4476 if ($CPAN::Signal){
4477 delete $self->{force_update};
4478 return;
4479 }
6d29edf5
JH		 4480 if (my @prereq = $self->unsat_prereq){
4481 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4482 }
4483 $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
4484 if (system($system) == 0) {
4485 $CPAN::Frontend->myprint(" $system -- OK\n");
4486 $self->{'make'} = "YES";
4487 } else {
4488 $self->{writemakefile} ||= "YES";
4489 $self->{'make'} = "NO";
4490 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
4491 }
4492}
f610777f 4493
6d29edf5
JH		 4494sub follow_prereqs {
4495 my($self) = shift;
4496 my(@prereq) = @_;
4497 my $id = $self->id;
4498 $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
4499 "during [$id] -----\n");
4500
4501 for my $p (@prereq) {
f610777f 4502 $CPAN::Frontend->myprint(" $p\n");
6d29edf5
JH		 4503 }
4504 my $follow = 0;
4505 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
f610777f 4506 $follow = 1;
6d29edf5 4507 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
f610777f
A		 4508 require ExtUtils::MakeMaker;
4509 my $answer = ExtUtils::MakeMaker::prompt(
4510"Shall I follow them and prepend them to the queue
4511of modules we are processing right now?", "yes");
4512 $follow = $answer =~ /^\s*y/i;
6d29edf5 4513 } else {
f14b5cec 4514 local($") = ", ";
de34a54b
JH		 4515 $CPAN::Frontend->
4516 myprint(" Ignoring dependencies on modules @prereq\n");
f610777f 4517 }
6d29edf5
JH		 4518 if ($follow) {
4519 # color them as dirty
4520 for my $p (@prereq) {
4521 CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
4522 }
4523 CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
4524 $self->{later} = "Delayed until after prerequisites";
4525 return 1; # signal success to the queuerunner
4526 }
4527}
4528
4529#-> sub CPAN::Distribution::unsat_prereq ;
4530sub unsat_prereq {
4531 my($self) = @_;
4532 my $prereq_pm = $self->prereq_pm or return;
4533 my(@need);
4534 NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
4535 my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
4536 # we were too demanding:
4537 next if $nmo->uptodate;
4538
4539 # if they have not specified a version, we accept any installed one
4540 if (not defined $need_version or
4541 $need_version == 0 or
4542 $need_version eq "undef") {
4543 next if defined $nmo->inst_file;
4544 }
4545
4546 # We only want to install prereqs if either they're not installed
4547 # or if the installed version is too old. We cannot omit this
4548 # check, because if 'force' is in effect, nobody else will check.
4549 {
4550 local($^W) = 0;
4551 if (
4552 defined $nmo->inst_file &&
4553 ! CPAN::Version->vgt($need_version, $nmo->inst_version)
4554 ){
4555 CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
4556 $nmo->id,
4557 $nmo->inst_file,
4558 $nmo->inst_version,
4559 CPAN::Version->readable($need_version)
4560 );
4561 next NEED;
4562 }
4563 }
4564
4565 if ($self->{sponsored_mods}{$need_module}++){
4566 # We have already sponsored it and for some reason it's still
4567 # not available. So we do nothing. Or what should we do?
4568 # if we push it again, we have a potential infinite loop
4569 next;
4570 }
4571 push @need, $need_module;
5f05dabc 4572 }
6d29edf5 4573 @need;
5f05dabc 4574}
4575
6d29edf5
JH		 4576#-> sub CPAN::Distribution::prereq_pm ;
4577sub prereq_pm {
f610777f 4578 my($self) = @_;
6d29edf5
JH		 4579 return $self->{prereq_pm} if
4580 exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
4581 return unless $self->{writemakefile}; # no need to have succeeded
4582 # but we must have run it
4583 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
4584 my $makefile = File::Spec->catfile($build_dir,"Makefile");
4585 my(%p) = ();
4586 my $fh;
4587 if (-f $makefile
4588 and
4589 $fh = FileHandle->new("<$makefile\0")) {
4590
4591 local($/) = "\n";
4592
4593 # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
4594 while (<$fh>) {
4595 last if /MakeMaker post_initialize section/;
4596 my($p) = m{^[\#]
f610777f
A		 4597 \s+PREREQ_PM\s+=>\s+(.+)
4598 }x;
6d29edf5
JH		 4599 next unless $p;
4600 # warn "Found prereq expr[$p]";
4601
4602 # Regexp modified by A.Speer to remember actual version of file
4603 # PREREQ_PM hash key wants, then add to
4604 while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
4605 # In case a prereq is mentioned twice, complain.
4606 if ( defined $p{$1} ) {
4607 warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
4608 }
4609 $p{$1} = $2;
4610 }
4611 last;
de34a54b 4612 }
f610777f 4613 }
6d29edf5
JH		 4614 $self->{prereq_pm_detected}++;
4615 return $self->{prereq_pm} = \%p;
f610777f
A		 4616}
4617
05454584
A		 4618#-> sub CPAN::Distribution::test ;
4619sub test {
5f05dabc 4620 my($self) = @_;
05454584 4621 $self->make;
c4d24d4c
A		 4622 if ($CPAN::Signal){
4623 delete $self->{force_update};
4624 return;
4625 }
c356248b 4626 $CPAN::Frontend->myprint("Running make test\n");
6d29edf5
JH		 4627 if (my @prereq = $self->unsat_prereq){
4628 return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
4629 }
05454584
A		 4630 EXCUSE: {
4631 my @e;
6d29edf5 4632 exists $self->{make} or exists $self->{later} or push @e,
05454584
A		 4633 "Make had some problems, maybe interrupted? Won't test";
4634
4635 exists $self->{'make'} and
4636 $self->{'make'} eq 'NO' and
c4d24d4c 4637 push @e, "Can't test without successful make";
05454584 4638
6d29edf5
JH		 4639 exists $self->{build_dir} or push @e, "Has no own directory";
4640 $self->{badtestcnt} ||= 0;
4641 $self->{badtestcnt} > 0 and
4642 push @e, "Won't repeat unsuccessful test during this command";
4643
4644 exists $self->{later} and length($self->{later}) and
4645 push @e, $self->{later};
4646
c356248b 4647 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 4648 }
c356248b
A		 4649 chdir $self->{'build_dir'} or
4650 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4651 $self->debug("Changed directory to $self->{'build_dir'}")
4652 if $CPAN::DEBUG;
f14b5cec
JH		 4653
4654 if ($^O eq 'MacOS') {
be708cc0 4655 Mac::BuildTools::make_test($self);
f14b5cec
JH		 4656 return;
4657 }
4658
0362b508 4659 local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
4c070e31 4660 $CPAN::META->set_perl5lib;
05454584 4661 my $system = join " ", $CPAN::Config->{'make'}, "test";
e50380aa 4662 if (system($system) == 0) {
c356248b 4663 $CPAN::Frontend->myprint(" $system -- OK\n");
4c070e31 4664 $CPAN::META->is_tested($self->{'build_dir'});
6d29edf5 4665 $self->{make_test} = "YES";
05454584 4666 } else {
6d29edf5
JH		 4667 $self->{make_test} = "NO";
4668 $self->{badtestcnt}++;
c356248b 4669 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
5f05dabc 4670 }
4671}
4672
05454584
A		 4673#-> sub CPAN::Distribution::clean ;
4674sub clean {
5f05dabc 4675 my($self) = @_;
c356248b 4676 $CPAN::Frontend->myprint("Running make clean\n");
05454584
A		 4677 EXCUSE: {
4678 my @e;
c4d24d4c
A		 4679 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
4680 push @e, "make clean already called once";
4681 exists $self->{build_dir} or push @e, "Has no own directory";
c356248b 4682 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 4683 }
c356248b
A		 4684 chdir $self->{'build_dir'} or
4685 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
05454584 4686 $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
f14b5cec
JH		 4687
4688 if ($^O eq 'MacOS') {
be708cc0 4689 Mac::BuildTools::make_clean($self);
f14b5cec
JH		 4690 return;
4691 }
4692
05454584 4693 my $system = join " ", $CPAN::Config->{'make'}, "clean";
e50380aa 4694 if (system($system) == 0) {
c4d24d4c
A		 4695 $CPAN::Frontend->myprint(" $system -- OK\n");
4696
4697 # $self->force;
4698
4699 # Jost Krieger pointed out that this "force" was wrong because
4700 # it has the effect that the next "install" on this distribution
4701 # will untar everything again. Instead we should bring the
4702 # object's state back to where it is after untarring.
4703
4704 delete $self->{force_update};
4705 delete $self->{install};
4706 delete $self->{writemakefile};
4707 delete $self->{make};
4708 delete $self->{make_test}; # no matter if yes or no, tests must be redone
4709 $self->{make_clean} = "YES";
4710
05454584 4711 } else {
c4d24d4c
A		 4712 # Hmmm, what to do if make clean failed?
4713
4714 $CPAN::Frontend->myprint(qq{ $system -- NOT OK
4715
4716make clean did not succeed, marking directory as unusable for further work.
4717});
4718 $self->force("make"); # so that this directory won't be used again
4719
5f05dabc 4720 }
4721}
4722
05454584
A		 4723#-> sub CPAN::Distribution::install ;
4724sub install {
5f05dabc 4725 my($self) = @_;
05454584 4726 $self->test;
c4d24d4c
A		 4727 if ($CPAN::Signal){
4728 delete $self->{force_update};
4729 return;
4730 }
c356248b 4731 $CPAN::Frontend->myprint("Running make install\n");
05454584
A		 4732 EXCUSE: {
4733 my @e;
6d29edf5 4734 exists $self->{build_dir} or push @e, "Has no own directory";
5f05dabc 4735
6d29edf5 4736 exists $self->{make} or exists $self->{later} or push @e,
05454584 4737 "Make had some problems, maybe interrupted? Won't install";
5f05dabc 4738
05454584
A		 4739 exists $self->{'make'} and
4740 $self->{'make'} eq 'NO' and
6d29edf5 4741 push @e, "make had returned bad status, install seems impossible";
05454584 4742
c356248b
A		 4743 push @e, "make test had returned bad status, ".
4744 "won't install without force"
d4fd5c69
A		 4745 if exists $self->{'make_test'} and
4746 $self->{'make_test'} eq 'NO' and
4747 ! $self->{'force_update'};
4748
05454584
A		 4749 exists $self->{'install'} and push @e,
4750 $self->{'install'} eq "YES" ?
4751 "Already done" : "Already tried without success";
4752
6d29edf5
JH		 4753 exists $self->{later} and length($self->{later}) and
4754 push @e, $self->{later};
4755
c356248b 4756 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 4757 }
c356248b
A		 4758 chdir $self->{'build_dir'} or
4759 Carp::croak("Couldn't chdir to $self->{'build_dir'}");
4760 $self->debug("Changed directory to $self->{'build_dir'}")
4761 if $CPAN::DEBUG;
f14b5cec
JH		 4762
4763 if ($^O eq 'MacOS') {
be708cc0 4764 Mac::BuildTools::make_install($self);
f14b5cec
JH		 4765 return;
4766 }
4767
c356248b
A		 4768 my $system = join(" ", $CPAN::Config->{'make'},
4769 "install", $CPAN::Config->{make_install_arg});
f610777f
A		 4770 my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
4771 my($pipe) = FileHandle->new("$system $stderr |");
05454584
A		 4772 my($makeout) = "";
4773 while (<$pipe>){
c356248b 4774 $CPAN::Frontend->myprint($_);
05454584
A		 4775 $makeout .= $_;
4776 }
4777 $pipe->close;
4778 if ($?==0) {
c356248b 4779 $CPAN::Frontend->myprint(" $system -- OK\n");
4c070e31 4780 $CPAN::META->is_installed($self->{'build_dir'});
f610777f 4781 return $self->{'install'} = "YES";
5f05dabc 4782 } else {
05454584 4783 $self->{'install'} = "NO";
c356248b 4784 $CPAN::Frontend->myprint(" $system -- NOT OK\n");
05454584 4785 if ($makeout =~ /permission/s && $> > 0) {
c356248b
A		 4786 $CPAN::Frontend->myprint(qq{ You may have to su }.
4787 qq{to root to install the package\n});
05454584 4788 }
5f05dabc 4789 }
c4d24d4c 4790 delete $self->{force_update};
5f05dabc 4791}
4792
05454584
A		 4793#-> sub CPAN::Distribution::dir ;
4794sub dir {
4795 shift->{'build_dir'};
5f05dabc 4796}
4797
05454584 4798package CPAN::Bundle;
5f05dabc 4799
e662ec5f
A		 4800sub look {
4801 my $self = shift;
4802 $CPAN::Frontend->myprint(
4803 qq{ look() commmand on bundles not}.
4804 qq{ implemented (What should it do?)}
4805 );
4806}
4807
6d29edf5
JH		 4808sub undelay {
4809 my $self = shift;
4810 delete $self->{later};
4811 for my $c ( $self->contains ) {
4812 my $obj = CPAN::Shell->expandany($c) or next;
4813 $obj->undelay;
4814 }
4815}
4816
4817#-> sub CPAN::Bundle::color_cmd_tmps ;
4818sub color_cmd_tmps {
4819 my($self) = shift;
4820 my($depth) = shift || 0;
4821 my($color) = shift || 0;
4822 # a module needs to recurse to its cpan_file, a distribution needs
4823 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
4824
4825 return if exists $self->{incommandcolor}
4826 && $self->{incommandcolor}==$color;
4827 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
4828 "color_cmd_tmps depth[%s] self[%s] id[%s]",
4829 $depth,
4830 $self,
4831 $self->id
4832 )) if $depth>=100;
4833 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
4834
4835 for my $c ( $self->contains ) {
4836 my $obj = CPAN::Shell->expandany($c) or next;
4837 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
4838 $obj->color_cmd_tmps($depth+1,$color);
4839 }
4840 if ($color==0) {
4841 delete $self->{badtestcnt};
4842 }
4843 $self->{incommandcolor} = $color;
4844}
4845
05454584
A		 4846#-> sub CPAN::Bundle::as_string ;
4847sub as_string {
4848 my($self) = @_;
4849 $self->contains;
5e05dca5 4850 # following line must be "=", not "||=" because we have a moving target
6d29edf5 4851 $self->{INST_VERSION} = $self->inst_version;
05454584
A		 4852 return $self->SUPER::as_string;
4853}
4854
4855#-> sub CPAN::Bundle::contains ;
4856sub contains {
c049f953
JH		 4857 my($self) = @_;
4858 my($inst_file) = $self->inst_file || "";
4859 my($id) = $self->id;
4860 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
4861 unless ($inst_file) {
4862 # Try to get at it in the cpan directory
4863 $self->debug("no inst_file") if $CPAN::DEBUG;
4864 my $cpan_file;
4865 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
4866 $cpan_file = $self->cpan_file;
4867 if ($cpan_file eq "N/A") {
4868 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
4869 Maybe stale symlink? Maybe removed during session? Giving up.\n");
4870 }
4871 my $dist = $CPAN::META->instance('CPAN::Distribution',
4872 $self->cpan_file);
4873 $dist->get;
4874 $self->debug($dist->as_string) if $CPAN::DEBUG;
4875 my($todir) = $CPAN::Config->{'cpan_home'};
4876 my(@me,$from,$to,$me);
4877 @me = split /::/, $self->id;
4878 $me[-1] .= ".pm";
5de3f0da 4879 $me = File::Spec->catfile(@me);
c049f953 4880 $from = $self->find_bundle_file($dist->{'build_dir'},$me);
5de3f0da 4881 $to = File::Spec->catfile($todir,$me);
c049f953
JH		 4882 File::Path::mkpath(File::Basename::dirname($to));
4883 File::Copy::copy($from, $to)
4884 or Carp::confess("Couldn't copy $from to $to: $!");
4885 $inst_file = $to;
4886 }
4887 my @result;
4888 my $fh = FileHandle->new;
4889 local $/ = "\n";
4890 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
4891 my $in_cont = 0;
4892 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
4893 while (<$fh>) {
4894 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
4895 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
4896 next unless $in_cont;
4897 next if /^=/;
4898 s/\#.*//;
4899 next if /^\s+$/;
4900 chomp;
4901 push @result, (split " ", $_, 2)[0];
4902 }
4903 close $fh;
4904 delete $self->{STATUS};
4905 $self->{CONTAINS} = \@result;
4906 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
4907 unless (@result) {
4908 $CPAN::Frontend->mywarn(qq{
4909The bundle file "$inst_file" may be a broken
2e2b7522
GS		 4910bundlefile. It seems not to contain any bundle definition.
4911Please check the file and if it is bogus, please delete it.
4912Sorry for the inconvenience.
4913});
c049f953
JH		 4914 }
4915 @result;
5f05dabc 4916}
4917
e50380aa
A		 4918#-> sub CPAN::Bundle::find_bundle_file
4919sub find_bundle_file {
4920 my($self,$where,$what) = @_;
c356248b 4921 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
2e2b7522 4922### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5de3f0da 4923### my $bu = File::Spec->catfile($where,$what);
2e2b7522 4924### return $bu if -f $bu;
5de3f0da 4925 my $manifest = File::Spec->catfile($where,"MANIFEST");
e50380aa
A		 4926 unless (-f $manifest) {
4927 require ExtUtils::Manifest;
9d61fa1d 4928 my $cwd = CPAN::anycwd();
05d2a450 4929 chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
e50380aa 4930 ExtUtils::Manifest::mkmanifest();
05d2a450 4931 chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
e50380aa 4932 }
c356248b
A		 4933 my $fh = FileHandle->new($manifest)
4934 or Carp::croak("Couldn't open $manifest: $!");
e50380aa 4935 local($/) = "\n";
f610777f 4936 my $what2 = $what;
f14b5cec
JH		 4937 if ($^O eq 'MacOS') {
4938 $what =~ s/^://;
be708cc0 4939 $what =~ tr|:|/|;
f14b5cec
JH		 4940 $what2 =~ s/:Bundle://;
4941 $what2 =~ tr|:|/|;
4942 } else {
911a92db 4943 $what2 =~ s|Bundle[/\\]||;
f14b5cec 4944 }
f610777f 4945 my $bu;
e50380aa
A		 4946 while (<$fh>) {
4947 next if /^\s*\#/;
4948 my($file) = /(\S+)/;
c356248b 4949 if ($file =~ m|\Q$what\E$|) {
e50380aa 4950 $bu = $file;
5de3f0da 4951 # return File::Spec->catfile($where,$bu); # bad
f610777f 4952 last;
e50380aa 4953 }
f610777f
A		 4954 # retry if she managed to
4955 # have no Bundle directory
4956 $bu = $file if $file =~ m|\Q$what2\E$|;
e50380aa 4957 }
f14b5cec 4958 $bu =~ tr|/|:| if $^O eq 'MacOS';
5de3f0da 4959 return File::Spec->catfile($where, $bu) if $bu;
c356248b 4960 Carp::croak("Couldn't find a Bundle file in $where");
e50380aa
A		 4961}
4962
d8773709
JH		 4963# needs to work quite differently from Module::inst_file because of
4964# cpan_home/Bundle/ directory and the possibility that we have
4965# shadowing effect. As it makes no sense to take the first in @INC for
4966# Bundles, we parse them all for $VERSION and take the newest.
6d29edf5 4967
05454584
A		 4968#-> sub CPAN::Bundle::inst_file ;
4969sub inst_file {
4970 my($self) = @_;
6d29edf5
JH		 4971 my($inst_file);
4972 my(@me);
4973 @me = split /::/, $self->id;
4974 $me[-1] .= ".pm";
d8773709
JH		 4975 my($incdir,$bestv);
4976 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5de3f0da 4977 my $bfile = File::Spec->catfile($incdir, @me);
d8773709
JH		 4978 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
4979 next unless -f $bfile;
4980 my $foundv = MM->parse_version($bfile);
4981 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
4982 $self->{INST_FILE} = $bfile;
4983 $self->{INST_VERSION} = $bestv = $foundv;
4984 }
4985 }
4986 $self->{INST_FILE};
4987}
4988
4989#-> sub CPAN::Bundle::inst_version ;
4990sub inst_version {
4991 my($self) = @_;
4992 $self->inst_file; # finds INST_VERSION as side effect
4993 $self->{INST_VERSION};
5f05dabc 4994}
4995
05454584
A		 4996#-> sub CPAN::Bundle::rematein ;
4997sub rematein {
4998 my($self,$meth) = @_;
4999 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
c356248b
A		 5000 my($id) = $self->id;
5001 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
6d29edf5 5002 unless $self->inst_file || $self->cpan_file;
f610777f 5003 my($s,%fail);
05454584
A		 5004 for $s ($self->contains) {
5005 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
5006 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
5007 if ($type eq 'CPAN::Distribution') {
c356248b 5008 $CPAN::Frontend->mywarn(qq{
05454584
A		 5009The Bundle }.$self->id.qq{ contains
5010explicitly a file $s.
c356248b 5011});
05454584 5012 sleep 3;
5f05dabc 5013 }
f610777f 5014 # possibly noisy action:
de34a54b 5015 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
f610777f
A		 5016 my $obj = $CPAN::META->instance($type,$s);
5017 $obj->$meth();
de34a54b
JH		 5018 if ($obj->isa(CPAN::Bundle)
5019 &&
5020 exists $obj->{install_failed}
5021 &&
5022 ref($obj->{install_failed}) eq "HASH"
5023 ) {
5024 for (keys %{$obj->{install_failed}}) {
5025 $self->{install_failed}{$_} = undef; # propagate faiure up
5026 # to me in a
5027 # recursive call
5028 $fail{$s} = 1; # the bundle itself may have succeeded but
5029 # not all children
5030 }
5031 } else {
5032 my $success;
5033 $success = $obj->can("uptodate") ? $obj->uptodate : 0;
5034 $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
5035 if ($success) {
5036 delete $self->{install_failed}{$s};
5037 } else {
5038 $fail{$s} = 1;
5039 }
5040 }
f610777f 5041 }
de34a54b 5042
f610777f 5043 # recap with less noise
de34a54b 5044 if ( $meth eq "install" ) {
f610777f 5045 if (%fail) {
911a92db
GS		 5046 require Text::Wrap;
5047 my $raw = sprintf(qq{Bundle summary:
5048The following items in bundle %s had installation problems:},
5049 $self->id
5050 );
5051 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
5052 $CPAN::Frontend->myprint("\n");
5053 my $paragraph = "";
de34a54b 5054 my %reported;
f610777f 5055 for $s ($self->contains) {
de34a54b
JH		 5056 if ($fail{$s}){
5057 $paragraph .= "$s ";
5058 $self->{install_failed}{$s} = undef;
5059 $reported{$s} = undef;
5060 }
f610777f 5061 }
de34a54b
JH		 5062 my $report_propagated;
5063 for $s (sort keys %{$self->{install_failed}}) {
5064 next if exists $reported{$s};
5065 $paragraph .= "and the following items had problems
5066during recursive bundle calls: " unless $report_propagated++;
5067 $paragraph .= "$s ";
5068 }
911a92db
GS		 5069 $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
5070 $CPAN::Frontend->myprint("\n");
f610777f
A		 5071 } else {
5072 $self->{'install'} = 'YES';
5073 }
5f05dabc 5074 }
5f05dabc 5075}
5076
e50380aa
A		 5077#sub CPAN::Bundle::xs_file
5078sub xs_file {
5079 # If a bundle contains another that contains an xs_file we have
5080 # here, we just don't bother I suppose
5081 return 0;
5082}
5083
05454584
A		 5084#-> sub CPAN::Bundle::force ;
5085sub force { shift->rematein('force',@_); }
5086#-> sub CPAN::Bundle::get ;
5087sub get { shift->rematein('get',@_); }
5088#-> sub CPAN::Bundle::make ;
5089sub make { shift->rematein('make',@_); }
5090#-> sub CPAN::Bundle::test ;
6d29edf5
JH		 5091sub test {
5092 my $self = shift;
5093 $self->{badtestcnt} ||= 0;
5094 $self->rematein('test',@_);
5095}
05454584 5096#-> sub CPAN::Bundle::install ;
09d9d230
A		 5097sub install {
5098 my $self = shift;
5099 $self->rematein('install',@_);
09d9d230 5100}
05454584
A		 5101#-> sub CPAN::Bundle::clean ;
5102sub clean { shift->rematein('clean',@_); }
5f05dabc 5103
d8773709
JH		 5104#-> sub CPAN::Bundle::uptodate ;
5105sub uptodate {
5106 my($self) = @_;
5107 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
5108 my $c;
5109 foreach $c ($self->contains) {
5110 my $obj = CPAN::Shell->expandany($c);
5111 return 0 unless $obj->uptodate;
5112 }
5113 return 1;
5114}
5115
05454584
A		 5116#-> sub CPAN::Bundle::readme ;
5117sub readme {
5118 my($self) = @_;
c356248b
A		 5119 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
5120No File found for bundle } . $self->id . qq{\n}), return;
05454584
A		 5121 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
5122 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5f05dabc 5123}
5124
05454584 5125package CPAN::Module;
5f05dabc 5126
6d29edf5
JH		 5127# Accessors
5128# sub cpan_userid { shift->{RO}{CPAN_USERID} }
5129sub userid {
5130 my $self = shift;
8d97e4a1
JH		 5131 return unless exists $self->{RO}; # should never happen
5132 return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
6d29edf5
JH		 5133}
5134sub description { shift->{RO}{description} }
5135
5136sub undelay {
5137 my $self = shift;
5138 delete $self->{later};
5139 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5140 $dist->undelay;
5141 }
5142}
5143
5144#-> sub CPAN::Module::color_cmd_tmps ;
5145sub color_cmd_tmps {
5146 my($self) = shift;
5147 my($depth) = shift || 0;
5148 my($color) = shift || 0;
5149 # a module needs to recurse to its cpan_file
5150
5151 return if exists $self->{incommandcolor}
5152 && $self->{incommandcolor}==$color;
5153 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
5154 "color_cmd_tmps depth[%s] self[%s] id[%s]",
5155 $depth,
5156 $self,
5157 $self->id
5158 )) if $depth>=100;
5159 ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5160
5161 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
5162 $dist->color_cmd_tmps($depth+1,$color);
5163 }
5164 if ($color==0) {
5165 delete $self->{badtestcnt};
5166 }
5167 $self->{incommandcolor} = $color;
5168}
5169
05454584
A		 5170#-> sub CPAN::Module::as_glimpse ;
5171sub as_glimpse {
5172 my($self) = @_;
5173 my(@m);
5174 my $class = ref($self);
5175 $class =~ s/^CPAN:://;
9d61fa1d
A		 5176 my $color_on = "";
5177 my $color_off = "";
5178 if (
5179 $CPAN::Shell::COLOR_REGISTERED
5180 &&
5181 $CPAN::META->has_inst("Term::ANSIColor")
5182 &&
5183 $self->{RO}{description}
5184 ) {
5185 $color_on = Term::ANSIColor::color("green");
5186 $color_off = Term::ANSIColor::color("reset");
5187 }
5188 push @m, sprintf("%-15s %s%-15s%s (%s)\n",
5189 $class,
5190 $color_on,
5191 $self->id,
5192 $color_off,
c356248b 5193 $self->cpan_file);
05454584
A		 5194 join "", @m;
5195}
5f05dabc 5196
05454584
A		 5197#-> sub CPAN::Module::as_string ;
5198sub as_string {
5199 my($self) = @_;
5200 my(@m);
5201 CPAN->debug($self) if $CPAN::DEBUG;
5202 my $class = ref($self);
5203 $class =~ s/^CPAN:://;
5204 local($^W) = 0;
5205 push @m, $class, " id = $self->{ID}\n";
5206 my $sprintf = " %-12s %s\n";
6d29edf5
JH		 5207 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
5208 if $self->description;
05454584
A		 5209 my $sprintf2 = " %-12s %s (%s)\n";
5210 my($userid);
6d29edf5 5211 if ($userid = $self->cpan_userid || $self->userid){
c356248b
A		 5212 my $author;
5213 if ($author = CPAN::Shell->expand('Author',$userid)) {
09d9d230
A		 5214 my $email = "";
5215 my $m; # old perls
5216 if ($m = $author->email) {
5217 $email = " <$m>";
5218 }
5219 push @m, sprintf(
5220 $sprintf2,
5221 'CPAN_USERID',
5222 $userid,
5223 $author->fullname . $email
5224 );
c356248b
A		 5225 }
5226 }
6d29edf5
JH		 5227 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
5228 if $self->cpan_version;
5229 push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
5230 if $self->cpan_file;
05454584
A		 5231 my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
5232 my(%statd,%stats,%statl,%stati);
c356248b
A		 5233 @statd{qw,? i c a b R M S,} = qw,unknown idea
5234 pre-alpha alpha beta released mature standard,;
5235 @stats{qw,? m d u n,} = qw,unknown mailing-list
5236 developer comp.lang.perl.* none,;
2e2b7522
GS		 5237 @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
5238 @stati{qw,? f r O h,} = qw,unknown functions
5239 references+ties object-oriented hybrid,;
05454584
A		 5240 $statd{' '} = 'unknown';
5241 $stats{' '} = 'unknown';
5242 $statl{' '} = 'unknown';
5243 $stati{' '} = 'unknown';
5244 push @m, sprintf(
5245 $sprintf3,
5246 'DSLI_STATUS',
6d29edf5
JH		 5247 $self->{RO}{statd},
5248 $self->{RO}{stats},
5249 $self->{RO}{statl},
5250 $self->{RO}{stati},
5251 $statd{$self->{RO}{statd}},
5252 $stats{$self->{RO}{stats}},
5253 $statl{$self->{RO}{statl}},
5254 $stati{$self->{RO}{stati}}
5255 ) if $self->{RO}{statd};
05454584 5256 my $local_file = $self->inst_file;
9d61fa1d
A		 5257 unless ($self->{MANPAGE}) {
5258 if ($local_file) {
5259 $self->{MANPAGE} = $self->manpage_headline($local_file);
5260 } else {
5261 # If we have already untarred it, we should look there
5262 my $dist = $CPAN::META->instance('CPAN::Distribution',
5263 $self->cpan_file);
5264 # warn "dist[$dist]";
5265 # mff=manifest file; mfh=manifest handle
5266 my($mff,$mfh);
c049f953
JH		 5267 if (
5268 $dist->{build_dir}
5269 and
5de3f0da 5270 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
c049f953 5271 and
9d61fa1d
A		 5272 $mfh = FileHandle->new($mff)
5273 ) {
8d97e4a1 5274 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9d61fa1d
A		 5275 my $lfre = $self->id; # local file RE
5276 $lfre =~ s/::/./g;
5277 $lfre .= "\\.pm\$";
5278 my($lfl); # local file file
5279 local $/ = "\n";
5280 my(@mflines) = <$mfh>;
8d97e4a1
JH		 5281 for (@mflines) {
5282 s/^\s+//;
5283 s/\s.*//s;
5284 }
9d61fa1d
A		 5285 while (length($lfre)>5 and !$lfl) {
5286 ($lfl) = grep /$lfre/, @mflines;
8d97e4a1 5287 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9d61fa1d 5288 $lfre =~ s/.+?\.//;
9d61fa1d
A		 5289 }
5290 $lfl =~ s/\s.*//; # remove comments
5291 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5de3f0da 5292 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9d61fa1d
A		 5293 # warn "lfl_abs[$lfl_abs]";
5294 if (-f $lfl_abs) {
5295 $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
5296 }
5297 }
5298 }
5f05dabc 5299 }
d4fd5c69 5300 my($item);
6d29edf5 5301 for $item (qw/MANPAGE/) {
c356248b
A		 5302 push @m, sprintf($sprintf, $item, $self->{$item})
5303 if exists $self->{$item};
d4fd5c69 5304 }
6d29edf5
JH		 5305 for $item (qw/CONTAINS/) {
5306 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
5307 if exists $self->{$item} && @{$self->{$item}};
5308 }
c356248b
A		 5309 push @m, sprintf($sprintf, 'INST_FILE',
5310 $local_file || "(not installed)");
5311 push @m, sprintf($sprintf, 'INST_VERSION',
6d29edf5 5312 $self->inst_version) if $local_file;
05454584 5313 join "", @m, "\n";
5f05dabc 5314}
5315
09d9d230
A		 5316sub manpage_headline {
5317 my($self,$local_file) = @_;
5318 my(@local_file) = $local_file;
05d2a450 5319 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
09d9d230
A		 5320 push @local_file, $local_file;
5321 my(@result,$locf);
5322 for $locf (@local_file) {
5323 next unless -f $locf;
5324 my $fh = FileHandle->new($locf)
5325 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
5326 my $inpod = 0;
5327 local $/ = "\n";
5328 while (<$fh>) {
e662ec5f
A		 5329 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
5330 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
09d9d230
A		 5331 next unless $inpod;
5332 next if /^=/;
5333 next if /^\s+$/;
5334 chomp;
5335 push @result, $_;
5336 }
5337 close $fh;
5338 last if @result;
5339 }
5340 join " ", @result;
5341}
5342
05454584 5343#-> sub CPAN::Module::cpan_file ;
c049f953
JH		 5344# Note: also inherited by CPAN::Bundle
5345sub cpan_file {
05454584 5346 my $self = shift;
6d29edf5
JH		 5347 CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
5348 unless (defined $self->{RO}{CPAN_FILE}) {
05454584
A		 5349 CPAN::Index->reload;
5350 }
6d29edf5
JH		 5351 if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
5352 return $self->{RO}{CPAN_FILE};
10b2abe6 5353 } else {
8d97e4a1
JH		 5354 my $userid = $self->userid;
5355 if ( $userid ) {
5356 if ($CPAN::META->exists("CPAN::Author",$userid)) {
5357 my $author = $CPAN::META->instance("CPAN::Author",
5358 $userid);
5359 my $fullname = $author->fullname;
5360 my $email = $author->email;
5361 unless (defined $fullname && defined $email) {
5362 return sprintf("Contact Author %s",
5363 $userid,
5364 );
5365 }
5366 return "Contact Author $fullname <$email>";
5367 } else {
5368 return "UserID $userid";
5369 }
5370 } else {
5371 return "N/A";
5372 }
5f05dabc 5373 }
5374}
5375
05454584 5376#-> sub CPAN::Module::cpan_version ;
c356248b
A		 5377sub cpan_version {
5378 my $self = shift;
6d29edf5
JH		 5379
5380 $self->{RO}{CPAN_VERSION} = 'undef'
5381 unless defined $self->{RO}{CPAN_VERSION};
5382 # I believe this is always a bug in the index and should be reported
5383 # as such, but usually I find out such an error and do not want to
5384 # provoke too many bugreports
5385
5386 $self->{RO}{CPAN_VERSION};
c356248b 5387}
5f05dabc 5388
05454584
A		 5389#-> sub CPAN::Module::force ;
5390sub force {
5391 my($self) = @_;
5392 $self->{'force_update'}++;
5f05dabc 5393}
5394
05454584
A		 5395#-> sub CPAN::Module::rematein ;
5396sub rematein {
5397 my($self,$meth) = @_;
6d29edf5
JH		 5398 $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
5399 $meth,
5400 $self->id));
05454584 5401 my $cpan_file = $self->cpan_file;
09d9d230
A		 5402 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
5403 $CPAN::Frontend->mywarn(sprintf qq{
5404 The module %s isn\'t available on CPAN.
5405
5406 Either the module has not yet been uploaded to CPAN, or it is
5407 temporary unavailable. Please contact the author to find out
c4d24d4c 5408 more about the status. Try 'i %s'.
09d9d230
A		 5409},
5410 $self->id,
5411 $self->id,
5412 );
5413 return;
5414 }
05454584
A		 5415 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
5416 $pack->called_for($self->id);
c4d24d4c 5417 $pack->force($meth) if exists $self->{'force_update'};
05454584 5418 $pack->$meth();
c4d24d4c 5419 $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
05454584 5420 delete $self->{'force_update'};
5f05dabc 5421}
5422
05454584
A		 5423#-> sub CPAN::Module::readme ;
5424sub readme { shift->rematein('readme') }
5425#-> sub CPAN::Module::look ;
5426sub look { shift->rematein('look') }
911a92db
GS		 5427#-> sub CPAN::Module::cvs_import ;
5428sub cvs_import { shift->rematein('cvs_import') }
05454584
A		 5429#-> sub CPAN::Module::get ;
5430sub get { shift->rematein('get',@_); }
5431#-> sub CPAN::Module::make ;
6d29edf5
JH		 5432sub make {
5433 my $self = shift;
5434 $self->rematein('make');
5435}
05454584 5436#-> sub CPAN::Module::test ;
6d29edf5
JH		 5437sub test {
5438 my $self = shift;
5439 $self->{badtestcnt} ||= 0;
5440 $self->rematein('test',@_);
5441}
f610777f
A		 5442#-> sub CPAN::Module::uptodate ;
5443sub uptodate {
5f05dabc 5444 my($self) = @_;
6d29edf5 5445 my($latest) = $self->cpan_version;
05454584
A		 5446 $latest ||= 0;
5447 my($inst_file) = $self->inst_file;
5448 my($have) = 0;
5449 if (defined $inst_file) {
6d29edf5 5450 $have = $self->inst_version;
05454584 5451 }
f14b5cec
JH		 5452 local($^W)=0;
5453 if ($inst_file
5454 &&
5e05dca5 5455 ! CPAN::Version->vgt($latest, $have)
f14b5cec 5456 ) {
6d29edf5
JH		 5457 CPAN->debug("returning uptodate. inst_file[$inst_file] ".
5458 "latest[$latest] have[$have]") if $CPAN::DEBUG;
5459 return 1;
5f05dabc 5460 }
f610777f
A		 5461 return;
5462}
5463#-> sub CPAN::Module::install ;
5464sub install {
5465 my($self) = @_;
5466 my($doit) = 0;
5467 if ($self->uptodate
5468 &&
5469 not exists $self->{'force_update'}
5470 ) {
5471 $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
5472 } else {
5473 $doit = 1;
5474 }
05454584 5475 $self->rematein('install') if $doit;
5f05dabc 5476}
05454584
A		 5477#-> sub CPAN::Module::clean ;
5478sub clean { shift->rematein('clean') }
5f05dabc 5479
05454584
A		 5480#-> sub CPAN::Module::inst_file ;
5481sub inst_file {
5482 my($self) = @_;
5483 my($dir,@packpath);
5484 @packpath = split /::/, $self->{ID};
5485 $packpath[-1] .= ".pm";
5486 foreach $dir (@INC) {
5de3f0da 5487 my $pmfile = File::Spec->catfile($dir,@packpath);
05454584
A		 5488 if (-f $pmfile){
5489 return $pmfile;
da199366 5490 }
5f05dabc 5491 }
d4fd5c69 5492 return;
5f05dabc 5493}
5494
05454584
A		 5495#-> sub CPAN::Module::xs_file ;
5496sub xs_file {
5497 my($self) = @_;
5498 my($dir,@packpath);
5499 @packpath = split /::/, $self->{ID};
5500 push @packpath, $packpath[-1];
5501 $packpath[-1] .= "." . $Config::Config{'dlext'};
5502 foreach $dir (@INC) {
5de3f0da 5503 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
05454584
A		 5504 if (-f $xsfile){
5505 return $xsfile;
5506 }
5507 }
d4fd5c69 5508 return;
5f05dabc 5509}
5510
05454584
A		 5511#-> sub CPAN::Module::inst_version ;
5512sub inst_version {
5513 my($self) = @_;
c356248b 5514 my $parsefile = $self->inst_file or return;
05454584 5515 local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
de34a54b 5516 my $have;
de34a54b
JH		 5517
5518 # there was a bug in 5.6.0 that let lots of unini warnings out of
5519 # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
c4d24d4c 5520 # the following workaround after 5.6.1 is out.
de34a54b
JH		 5521 local($SIG{__WARN__}) = sub { my $w = shift;
5522 return if $w =~ /uninitialized/i;
5523 warn $w;
5524 };
c4d24d4c 5525
de34a54b 5526 $have = MM->parse_version($parsefile) || "undef";
05d2a450
A		 5527 $have =~ s/^ //; # since the %vd hack these two lines here are needed
5528 $have =~ s/ $//; # trailing whitespace happens all the time
5529
c4d24d4c 5530 # My thoughts about why %vd processing should happen here
5e05dca5 5531
c4d24d4c 5532 # Alt1 maintain it as string with leading v:
5e05dca5
A		 5533 # read index files do nothing
5534 # compare it use utility for compare
5535 # print it do nothing
5536
d1be9408 5537 # Alt2 maintain it as what it is
5e05dca5
A		 5538 # read index files convert
5539 # compare it use utility because there's still a ">" vs "gt" issue
5540 # print it use CPAN::Version for print
5541
5542 # Seems cleaner to hold it in memory as a string starting with a "v"
5543
c4d24d4c
A		 5544 # If the author of this module made a mistake and wrote a quoted
5545 # "v1.13" instead of v1.13, we simply leave it at that with the
5546 # effect that *we* will treat it like a v-tring while the rest of
5547 # perl won't. Seems sensible when we consider that any action we
5548 # could take now would just add complexity.
5549
5e05dca5 5550 $have = CPAN::Version->readable($have);
c4d24d4c 5551
911a92db 5552 $have =~ s/\s*//g; # stringify to float around floating point issues
de34a54b 5553 $have; # no stringify needed, \s* above matches always
5f05dabc 5554}
5555
09d9d230
A		 5556package CPAN::Tarzip;
5557
de34a54b 5558# CPAN::Tarzip::gzip
09d9d230
A		 5559sub gzip {
5560 my($class,$read,$write) = @_;
5561 if ($CPAN::META->has_inst("Compress::Zlib")) {
5562 my($buffer,$fhw);
5563 $fhw = FileHandle->new($read)
5564 or $CPAN::Frontend->mydie("Could not open $read: $!");
5565 my $gz = Compress::Zlib::gzopen($write, "wb")
5566 or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
5567 $gz->gzwrite($buffer)
5568 while read($fhw,$buffer,4096) > 0 ;
5569 $gz->gzclose() ;
5570 $fhw->close;
5571 return 1;
5572 } else {
5a5fac02 5573 system("$CPAN::Config->{gzip} -c $read > $write")==0;
09d9d230
A		 5574 }
5575}
5576
de34a54b
JH		 5577
5578# CPAN::Tarzip::gunzip
09d9d230
A		 5579sub gunzip {
5580 my($class,$read,$write) = @_;
5581 if ($CPAN::META->has_inst("Compress::Zlib")) {
5582 my($buffer,$fhw);
5583 $fhw = FileHandle->new(">$write")
5584 or $CPAN::Frontend->mydie("Could not open >$write: $!");
5585 my $gz = Compress::Zlib::gzopen($read, "rb")
5586 or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
5587 $fhw->print($buffer)
5588 while $gz->gzread($buffer) > 0 ;
5589 $CPAN::Frontend->mydie("Error reading from $read: $!\n")
5590 if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
5591 $gz->gzclose() ;
5592 $fhw->close;
5593 return 1;
5594 } else {
5a5fac02 5595 system("$CPAN::Config->{gzip} -dc $read > $write")==0;
09d9d230
A		 5596 }
5597}
5598
de34a54b
JH		 5599
5600# CPAN::Tarzip::gtest
09d9d230
A		 5601sub gtest {
5602 my($class,$read) = @_;
5a5fac02
JH		 5603 # After I had reread the documentation in zlib.h, I discovered that
5604 # uncompressed files do not lead to an gzerror (anymore?).
5605 if ( $CPAN::META->has_inst("Compress::Zlib") ) {
5606 my($buffer,$len);
5607 $len = 0;
09d9d230 5608 my $gz = Compress::Zlib::gzopen($read, "rb")
5a5fac02
JH		 5609 or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
5610 $read,
5611 $Compress::Zlib::gzerrno));
5612 while ($gz->gzread($buffer) > 0 ){
5613 $len += length($buffer);
5614 $buffer = "";
5615 }
de34a54b
JH		 5616 my $err = $gz->gzerror;
5617 my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
5a5fac02
JH		 5618 if ($len == -s $read){
5619 $success = 0;
5620 CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
5621 }
de34a54b 5622 $gz->gzclose();
5a5fac02 5623 CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
de34a54b 5624 return $success;
09d9d230 5625 } else {
5a5fac02 5626 return system("$CPAN::Config->{gzip} -dt $read")==0;
09d9d230
A		 5627 }
5628}
5629
de34a54b
JH		 5630
5631# CPAN::Tarzip::TIEHANDLE
09d9d230
A		 5632sub TIEHANDLE {
5633 my($class,$file) = @_;
5634 my $ret;
5635 $class->debug("file[$file]");
5636 if ($CPAN::META->has_inst("Compress::Zlib")) {
5637 my $gz = Compress::Zlib::gzopen($file,"rb") or
5638 die "Could not gzopen $file";
5639 $ret = bless {GZ => $gz}, $class;
5640 } else {
5a5fac02 5641 my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
e8427fc1 5642 my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
09d9d230
A		 5643 binmode $fh;
5644 $ret = bless {FH => $fh}, $class;
5645 }
5646 $ret;
5647}
5648
de34a54b
JH		 5649
5650# CPAN::Tarzip::READLINE
09d9d230
A		 5651sub READLINE {
5652 my($self) = @_;
5653 if (exists $self->{GZ}) {
5654 my $gz = $self->{GZ};
5655 my($line,$bytesread);
5656 $bytesread = $gz->gzreadline($line);
36263cb3 5657 return undef if $bytesread <= 0;
09d9d230
A		 5658 return $line;
5659 } else {
5660 my $fh = $self->{FH};
5661 return scalar <$fh>;
5662 }
5663}
5664
de34a54b
JH		 5665
5666# CPAN::Tarzip::READ
09d9d230
A		 5667sub READ {
5668 my($self,$ref,$length,$offset) = @_;
5669 die "read with offset not implemented" if defined $offset;
5670 if (exists $self->{GZ}) {
5671 my $gz = $self->{GZ};
5672 my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
5673 return $byteread;
5674 } else {
5675 my $fh = $self->{FH};
5676 return read($fh,$$ref,$length);
5677 }
5678}
5679
de34a54b
JH		 5680
5681# CPAN::Tarzip::DESTROY
09d9d230 5682sub DESTROY {
5a5fac02
JH		 5683 my($self) = @_;
5684 if (exists $self->{GZ}) {
5685 my $gz = $self->{GZ};
5686 $gz->gzclose() if defined $gz; # hard to say if it is allowed
5687 # to be undef ever. AK, 2000-09
5688 } else {
5689 my $fh = $self->{FH};
5690 $fh->close if defined $fh;
5691 }
5692 undef $self;
09d9d230
A		 5693}
5694
de34a54b
JH		 5695
5696# CPAN::Tarzip::untar
09d9d230
A		 5697sub untar {
5698 my($class,$file) = @_;
8d97e4a1
JH		 5699 my($prefer) = 0;
5700
c4d24d4c 5701 if (0) { # makes changing order easier
8d97e4a1
JH		 5702 } elsif ($BUGHUNTING){
5703 $prefer=2;
5a5fac02 5704 } elsif (MM->maybe_command($CPAN::Config->{gzip})
8d97e4a1
JH		 5705 &&
5706 MM->maybe_command($CPAN::Config->{'tar'})) {
5707 # should be default until Archive::Tar is fixed
5708 $prefer = 1;
5709 } elsif (
5710 $CPAN::META->has_inst("Archive::Tar")
5711 &&
5712 $CPAN::META->has_inst("Compress::Zlib") ) {
5713 $prefer = 2;
5714 } else {
5715 $CPAN::Frontend->mydie(qq{
5716CPAN.pm needs either both external programs tar and gzip installed or
5717both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
5718is available. Can\'t continue.
5719});
5720 }
5721 if ($prefer==1) { # 1 => external gzip+tar
5a5fac02
JH		 5722 my($system);
5723 my $is_compressed = $class->gtest($file);
5724 if ($is_compressed) {
5725 $system = "$CPAN::Config->{gzip} --decompress --stdout " .
5726 "< $file | $CPAN::Config->{tar} xvf -";
5727 } else {
5728 $system = "$CPAN::Config->{tar} xvf $file";
5729 }
911a92db 5730 if (system($system) != 0) {
5a5fac02
JH		 5731 # people find the most curious tar binaries that cannot handle
5732 # pipes
5733 if ($is_compressed) {
5734 (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
5735 if (CPAN::Tarzip->gunzip($file, $ungzf)) {
5736 $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
5737 } else {
5738 $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
5739 }
5740 $file = $ungzf;
5741 }
5742 $system = "$CPAN::Config->{tar} xvf $file";
5743 $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
5744 if (system($system)==0) {
5745 $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
5746 } else {
5747 $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
5748 }
5749 return 1;
f610777f 5750 } else {
5a5fac02 5751 return 1;
f610777f 5752 }
8d97e4a1 5753 } elsif ($prefer==2) { # 2 => modules
6d29edf5
JH		 5754 my $tar = Archive::Tar->new($file,1);
5755 my $af; # archive file
5a5fac02 5756 my @af;
8d97e4a1
JH		 5757 if ($BUGHUNTING) {
5758 # RCS 1.337 had this code, it turned out unacceptable slow but
5759 # it revealed a bug in Archive::Tar. Code is only here to hunt
5760 # the bug again. It should never be enabled in published code.
5761 # GDGraph3d-0.53 was an interesting case according to Larry
5762 # Virden.
5763 warn(">>>Bughunting code enabled<<< " x 20);
5764 for $af ($tar->list_files) {
5765 if ($af =~ m!^(/|\.\./)!) {
5766 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5767 "illegal member [$af]");
5768 }
5769 $CPAN::Frontend->myprint("$af\n");
5770 $tar->extract($af); # slow but effective for finding the bug
5771 return if $CPAN::Signal;
6d29edf5 5772 }
8d97e4a1
JH		 5773 } else {
5774 for $af ($tar->list_files) {
5775 if ($af =~ m!^(/|\.\./)!) {
5776 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5777 "illegal member [$af]");
5778 }
5779 $CPAN::Frontend->myprint("$af\n");
5780 push @af, $af;
5781 return if $CPAN::Signal;
5782 }
5783 $tar->extract(@af);
6d29edf5
JH		 5784 }
5785
be708cc0 5786 Mac::BuildTools::convert_files([$tar->list_files], 1)
6d29edf5
JH		 5787 if ($^O eq 'MacOS');
5788
5789 return 1;
09d9d230
A		 5790 }
5791}
5792
05d2a450 5793sub unzip {
c4d24d4c
A		 5794 my($class,$file) = @_;
5795 if ($CPAN::META->has_inst("Archive::Zip")) {
5796 # blueprint of the code from Archive::Zip::Tree::extractTree();
5797 my $zip = Archive::Zip->new();
5798 my $status;
5799 $status = $zip->read($file);
5800 die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
5801 $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
5802 my @members = $zip->members();
5803 for my $member ( @members ) {
5804 my $af = $member->fileName();
5805 if ($af =~ m!^(/|\.\./)!) {
6d29edf5
JH		 5806 $CPAN::Frontend->mydie("ALERT: Archive contains ".
5807 "illegal member [$af]");
c4d24d4c
A		 5808 }
5809 my $status = $member->extractToFileNamed( $af );
5810 $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
5811 die "Extracting of file[$af] from zipfile[$file] failed\n" if
5812 $status != Archive::Zip::AZ_OK();
5813 return if $CPAN::Signal;
5814 }
5815 return 1;
5816 } else {
5817 my $unzip = $CPAN::Config->{unzip} or
5818 $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
5819 my @system = ($unzip, $file);
5820 return system(@system) == 0;
5821 }
05d2a450
A		 5822}
5823
5e05dca5 5824
c4d24d4c
A		 5825package CPAN::Version;
5826# CPAN::Version::vcmp courtesy Jost Krieger
5827sub vcmp {
5e05dca5
A		 5828 my($self,$l,$r) = @_;
5829 local($^W) = 0;
5830 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
c4d24d4c
A		 5831
5832 return 0 if $l eq $r; # short circuit for quicker success
5833
5834 if ($l=~/^v/ <=> $r=~/^v/) {
5835 for ($l,$r) {
5836 next if /^v/;
5837 $_ = $self->float2vv($_);
5838 }
5839 }
5840
5841 return
5842 ($l ne "undef") <=> ($r ne "undef") ||
5843 ($] >= 5.006 &&
5844 $l =~ /^v/ &&
5845 $r =~ /^v/ &&
5846 $self->vstring($l) cmp $self->vstring($r)) ||
5847 $l <=> $r ||
5848 $l cmp $r;
5849}
5850
5851sub vgt {
5852 my($self,$l,$r) = @_;
5853 $self->vcmp($l,$r) > 0;
5e05dca5
A		 5854}
5855
5856sub vstring {
5857 my($self,$n) = @_;
6d29edf5 5858 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
5e05dca5
A		 5859 pack "U*", split /\./, $n;
5860}
5861
c4d24d4c
A		 5862# vv => visible vstring
5863sub float2vv {
5864 my($self,$n) = @_;
5865 my($rev) = int($n);
5866 $rev ||= 0;
8d97e4a1
JH		 5867 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
5868 # architecture influence
c4d24d4c
A		 5869 $mantissa ||= 0;
5870 $mantissa .= "0" while length($mantissa)%3;
5871 my $ret = "v" . $rev;
5872 while ($mantissa) {
5873 $mantissa =~ s/(\d{1,3})// or
5874 die "Panic: length>0 but not a digit? mantissa[$mantissa]";
5875 $ret .= ".".int($1);
5876 }
5877 # warn "n[$n]ret[$ret]";
5878 $ret;
5879}
5880
5e05dca5
A		 5881sub readable {
5882 my($self,$n) = @_;
99c3d640 5883 $n =~ /^([\w\-\+\.]+)/;
c4d24d4c
A		 5884
5885 return $1 if defined $1 && length($1)>0;
5886 # if the first user reaches version v43, he will be treated as "+".
5887 # We'll have to decide about a new rule here then, depending on what
5888 # will be the prevailing versioning behavior then.
5889
5e05dca5
A		 5890 if ($] < 5.006) { # or whenever v-strings were introduced
5891 # we get them wrong anyway, whatever we do, because 5.005 will
5892 # have already interpreted 0.2.4 to be "0.24". So even if he
5893 # indexer sends us something like "v0.2.4" we compare wrongly.
5894
5895 # And if they say v1.2, then the old perl takes it as "v12"
5896
5897 $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
5898 return $n;
5899 }
5900 my $better = sprintf "v%vd", $n;
5901 CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
5902 return $better;
5903}
5904
55e314ee 5905package CPAN;
d4fd5c69 5906
5f05dabc 59071;
55e314ee 5908
e50380aa 5909__END__
5f05dabc 5910
5911=head1 NAME
5912
5913CPAN - query, download and build perl modules from CPAN sites
5914
5915=head1 SYNOPSIS
5916
5917Interactive mode:
5918
5919 perl -MCPAN -e shell;
5920
5921Batch mode:
5922
5923 use CPAN;
5924
10b2abe6 5925 autobundle, clean, install, make, recompile, test
5f05dabc 5926
5927=head1 DESCRIPTION
5928
10b2abe6 5929The CPAN module is designed to automate the make and install of perl
42d3b621
A		 5930modules and extensions. It includes some searching capabilities and
5931knows how to use Net::FTP or LWP (or lynx or an external ftp client)
5932to fetch the raw data from the net.
5f05dabc 5933
5934Modules are fetched from one or more of the mirrored CPAN
5935(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
5936directory.
5937
5938The CPAN module also supports the concept of named and versioned
911a92db
GS		 5939I<bundles> of modules. Bundles simplify the handling of sets of
5940related modules. See Bundles below.
5f05dabc 5941
5942The package contains a session manager and a cache manager. There is
5943no status retained between sessions. The session manager keeps track
5944of what has been fetched, built and installed in the current
5945session. The cache manager keeps track of the disk space occupied by
42d3b621
A		 5946the make processes and deletes excess space according to a simple FIFO
5947mechanism.
5f05dabc 5948
2e2b7522 5949For extended searching capabilities there's a plugin for CPAN available,
8b3ad137
JL		 5950L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
5951that indexes all documents available in CPAN authors directories. If
d8773709
JH		 5952C<CPAN::WAIT> is installed on your system, the interactive shell of
5953CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
5954which send queries to the WAIT server that has been configured for your
5955installation.
2e2b7522
GS		 5956
5957All other methods provided are accessible in a programmer style and in an
10b2abe6
CS		 5958interactive shell style.
5959
5f05dabc 5960=head2 Interactive Mode
5961
5962The interactive mode is entered by running
5963
5964 perl -MCPAN -e shell
5965
09d9d230 5966which puts you into a readline interface. You will have the most fun if
5f05dabc 5967you install Term::ReadKey and Term::ReadLine to enjoy both history and
09d9d230 5968command completion.
5f05dabc 5969
5970Once you are on the command line, type 'h' and the rest should be
5971self-explanatory.
5972
9d61fa1d
A		 5973The function call C<shell> takes two optional arguments, one is the
5974prompt, the second is the default initial command line (the latter
5975only works if a real ReadLine interface module is installed).
5976
10b2abe6
CS		 5977The most common uses of the interactive modes are
5978
5979=over 2
5980
5981=item Searching for authors, bundles, distribution files and modules
5982
5983There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
42d3b621
A		 5984for each of the four categories and another, C<i> for any of the
5985mentioned four. Each of the four entities is implemented as a class
5986with slightly differing methods for displaying an object.
10b2abe6 5987
09d9d230 5988Arguments you pass to these commands are either strings exactly matching
10b2abe6
CS		 5989the identification string of an object or regular expressions that are
5990then matched case-insensitively against various attributes of the
09d9d230 5991objects. The parser recognizes a regular expression only if you
10b2abe6
CS		 5992enclose it between two slashes.
5993
5994The principle is that the number of found objects influences how an
911a92db
GS		 5995item is displayed. If the search finds one item, the result is
5996displayed with the rather verbose method C<as_string>, but if we find
5997more than one, we display each object with the terse method
5998<as_glimpse>.
10b2abe6 5999
da199366 6000=item make, test, install, clean modules or distributions
10b2abe6 6001
911a92db 6002These commands take any number of arguments and investigate what is
09d9d230 6003necessary to perform the action. If the argument is a distribution
f14b5cec
JH		 6004file name (recognized by embedded slashes), it is processed. If it is
6005a module, CPAN determines the distribution file in which this module
6006is included and processes that, following any dependencies named in
6007the module's Makefile.PL (this behavior is controlled by
6008I<prerequisites_policy>.)
10b2abe6 6009
09d9d230 6010Any C<make> or C<test> are run unconditionally. An
42d3b621 6011
05454584 6012 install <distribution_file>
42d3b621 6013
09d9d230 6014also is run unconditionally. But for
42d3b621 6015
05454584 6016 install <module>
42d3b621
A		 6017
6018CPAN checks if an install is actually needed for it and prints
09d9d230 6019I<module up to date> in the case that the distribution file containing
de34a54b 6020the module doesn't need to be updated.
10b2abe6
CS		 6021
6022CPAN also keeps track of what it has done within the current session
de34a54b 6023and doesn't try to build a package a second time regardless if it
09d9d230
A		 6024succeeded or not. The C<force> command takes as a first argument the
6025method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
10b2abe6
CS		 6026command from scratch.
6027
6028Example:
6029
6030 cpan> install OpenGL
6031 OpenGL is up to date.
6032 cpan> force install OpenGL
6033 Running make
6034 OpenGL-0.4/
6035 OpenGL-0.4/COPYRIGHT
6036 [...]
6037
f610777f 6038A C<clean> command results in a
09d9d230
A		 6039
6040 make clean
6041
6042being executed within the distribution file's working directory.
6043
911a92db 6044=item get, readme, look module or distribution
da199366 6045
911a92db
GS		 6046C<get> downloads a distribution file without further action. C<readme>
6047displays the README file of the associated distribution. C<Look> gets
6048and untars (if not yet done) the distribution file, changes to the
09d9d230
A		 6049appropriate directory and opens a subshell process in that directory.
6050
c049f953
JH		 6051=item ls author
6052
6053C<ls> lists all distribution files in and below an author's CPAN
6054directory. Only those files that contain modules are listed and if
6055there is more than one for any given module, only the most recent one
6056is listed.
6057
09d9d230
A		 6058=item Signals
6059
6060CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
6061in the cpan-shell it is intended that you can press C<^C> anytime and
6062return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
6063to clean up and leave the shell loop. You can emulate the effect of a
6064SIGTERM by sending two consecutive SIGINTs, which usually means by
6065pressing C<^C> twice.
6066
6067CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
6068SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
da199366 6069
10b2abe6
CS		 6070=back
6071
5f05dabc 6072=head2 CPAN::Shell
6073
6074The commands that are available in the shell interface are methods in
6075the package CPAN::Shell. If you enter the shell command, all your
10b2abe6
CS		 6076input is split by the Text::ParseWords::shellwords() routine which
6077acts like most shells do. The first word is being interpreted as the
6078method to be called and the rest of the words are treated as arguments
c356248b
A		 6079to this method. Continuation lines are supported if a line ends with a
6080literal backslash.
10b2abe6 6081
da199366
A		 6082=head2 autobundle
6083
6084C<autobundle> writes a bundle file into the
6085C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
6086a list of all modules that are both available from CPAN and currently
6087installed within @INC. The name of the bundle file is based on the
6088current date and a counter.
6089
6090=head2 recompile
6091
6092recompile() is a very special command in that it takes no argument and
6093runs the make/test/install cycle with brute force over all installed
6094dynamically loadable extensions (aka XS modules) with 'force' in
09d9d230 6095effect. The primary purpose of this command is to finish a network
da199366
A		 6096installation. Imagine, you have a common source tree for two different
6097architectures. You decide to do a completely independent fresh
6098installation. You start on one architecture with the help of a Bundle
6099file produced earlier. CPAN installs the whole Bundle for you, but
6100when you try to repeat the job on the second architecture, CPAN
6101responds with a C<"Foo up to date"> message for all modules. So you
de34a54b 6102invoke CPAN's recompile on the second architecture and you're done.
da199366
A		 6103
6104Another popular use for C<recompile> is to act as a rescue in case your
6105perl breaks binary compatibility. If one of the modules that CPAN uses
6106is in turn depending on binary compatibility (so you cannot run CPAN
6107commands), then you should try the CPAN::Nox module for recovery.
6108
c356248b 6109=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
e50380aa 6110
09d9d230
A		 6111Although it may be considered internal, the class hierarchy does matter
6112for both users and programmer. CPAN.pm deals with above mentioned four
6113classes, and all those classes share a set of methods. A classical
6114single polymorphism is in effect. A metaclass object registers all
6115objects of all kinds and indexes them with a string. The strings
6116referencing objects have a separated namespace (well, not completely
6117separated):
e50380aa
A		 6118
6119 Namespace Class
6120
6121 words containing a "/" (slash) Distribution
6122 words starting with Bundle:: Bundle
6123 everything else Module or Author
6124
6125Modules know their associated Distribution objects. They always refer
09d9d230
A		 6126to the most recent official release. Developers may mark their releases
6127as unstable development versions (by inserting an underbar into the
16703a00
EHA		 6128module version number which will also be reflected in the distribution
6129name when you run 'make dist'), so the really hottest and newest
6130distribution is not always the default. If a module Foo circulates
6131on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
6132way to install version 1.23 by saying
e50380aa
A		 6133
6134 install Foo
6135
6136This would install the complete distribution file (say
09d9d230
A		 6137BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
6138like to install version 1.23_90, you need to know where the
e50380aa 6139distribution file resides on CPAN relative to the authors/id/
09d9d230 6140directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
c356248b 6141so you would have to say
e50380aa
A		 6142
6143 install BAR/Foo-1.23_90.tar.gz
6144
6145The first example will be driven by an object of the class
c356248b 6146CPAN::Module, the second by an object of class CPAN::Distribution.
e50380aa 6147
de34a54b 6148=head2 Programmer's interface
5f05dabc 6149
10b2abe6
CS		 6150If you do not enter the shell, the available shell commands are both
6151available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
e50380aa
A		 6152functions in the calling package (C<install(...)>).
6153
09d9d230 6154There's currently only one class that has a stable interface -
e50380aa 6155CPAN::Shell. All commands that are available in the CPAN shell are
55e314ee 6156methods of the class CPAN::Shell. Each of the commands that produce
36263cb3
GS		 6157listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
6158the IDs of all modules within the list.
e50380aa
A		 6159
6160=over 2
6161
6162=item expand($type,@things)
6163
6164The IDs of all objects available within a program are strings that can
6165be expanded to the corresponding real objects with the
55e314ee
A		 6166C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
6167list of CPAN::Module objects according to the C<@things> arguments
6168given. In scalar context it only returns the first element of the
6169list.
e50380aa 6170
d8773709
JH		 6171=item expandany(@things)
6172
6173Like expand, but returns objects of the appropriate type, i.e.
6174CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
6175CPAN::Distribution objects fro distributions.
6176
e50380aa
A		 6177=item Programming Examples
6178
55e314ee
A		 6179This enables the programmer to do operations that combine
6180functionalities that are available in the shell.
e50380aa
A		 6181
6182 # install everything that is outdated on my disk:
6183 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
6184
6185 # install my favorite programs if necessary:
5b6aeab6 6186 for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
e50380aa
A		 6187 my $obj = CPAN::Shell->expand('Module',$mod);
6188 $obj->install;
6189 }
6190
55e314ee
A		 6191 # list all modules on my disk that have no VERSION number
6192 for $mod (CPAN::Shell->expand("Module","/./")){
6193 next unless $mod->inst_file;
c356248b
A		 6194 # MakeMaker convention for undefined $VERSION:
6195 next unless $mod->inst_version eq "undef";
55e314ee
A		 6196 print "No VERSION in ", $mod->id, "\n";
6197 }
6198
de34a54b
JH		 6199 # find out which distribution on CPAN contains a module:
6200 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
6201
36263cb3 6202Or if you want to write a cronjob to watch The CPAN, you could list
de34a54b 6203all modules that need updating. First a quick and dirty way:
36263cb3
GS		 6204
6205 perl -e 'use CPAN; CPAN::Shell->r;'
6206
9d61fa1d
A		 6207If you don't want to get any output in the case that all modules are
6208up to date, you can parse the output of above command for the regular
6209expression //modules are up to date// and decide to mail the output
6210only if it doesn't match. Ick?
36263cb3
GS		 6211
6212If you prefer to do it more in a programmer style in one single
8b3ad137 6213process, maybe something like this suits you better:
36263cb3
GS		 6214
6215 # list all modules on my disk that have newer versions on CPAN
6216 for $mod (CPAN::Shell->expand("Module","/./")){
6217 next unless $mod->inst_file;
6218 next if $mod->uptodate;
6219 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
6220 $mod->id, $mod->inst_version, $mod->cpan_version;
6221 }
6222
6223If that gives you too much output every day, you maybe only want to
6224watch for three modules. You can write
6225
6226 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
6227
6228as the first line instead. Or you can combine some of the above
6229tricks:
6230
6231 # watch only for a new mod_perl module
6232 $mod = CPAN::Shell->expand("Module","mod_perl");
6233 exit if $mod->uptodate;
6234 # new mod_perl arrived, let me know all update recommendations
6235 CPAN::Shell->r;
6236
e50380aa 6237=back
5f05dabc 6238
d8773709
JH		 6239=head2 Methods in the other Classes
6240
6241The programming interface for the classes CPAN::Module,
6242CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
6243beta and partially even alpha. In the following paragraphs only those
6244methods are documented that have proven useful over a longer time and
6245thus are unlikely to change.
6246
bbc7dcd2 6247=over 4
d8773709
JH		 6248
6249=item CPAN::Author::as_glimpse()
6250
6251Returns a one-line description of the author
6252
6253=item CPAN::Author::as_string()
6254
6255Returns a multi-line description of the author
6256
6257=item CPAN::Author::email()
6258
6259Returns the author's email address
6260
6261=item CPAN::Author::fullname()
6262
6263Returns the author's name
6264
6265=item CPAN::Author::name()
6266
6267An alias for fullname
6268
6269=item CPAN::Bundle::as_glimpse()
6270
6271Returns a one-line description of the bundle
6272
6273=item CPAN::Bundle::as_string()
6274
6275Returns a multi-line description of the bundle
6276
6277=item CPAN::Bundle::clean()
6278
6279Recursively runs the C<clean> method on all items contained in the bundle.
6280
6281=item CPAN::Bundle::contains()
6282
6283Returns a list of objects' IDs contained in a bundle. The associated
6284objects may be bundles, modules or distributions.
6285
6286=item CPAN::Bundle::force($method,@args)
6287
6288Forces CPAN to perform a task that normally would have failed. Force
6289takes as arguments a method name to be called and any number of
6290additional arguments that should be passed to the called method. The
6291internals of the object get the needed changes so that CPAN.pm does
6292not refuse to take the action. The C<force> is passed recursively to
6293all contained objects.
6294
6295=item CPAN::Bundle::get()
6296
6297Recursively runs the C<get> method on all items contained in the bundle
6298
6299=item CPAN::Bundle::inst_file()
6300
6301Returns the highest installed version of the bundle in either @INC or
6302C<$CPAN::Config->{cpan_home}>. Note that this is different from
6303CPAN::Module::inst_file.
6304
6305=item CPAN::Bundle::inst_version()
6306
6307Like CPAN::Bundle::inst_file, but returns the $VERSION
6308
6309=item CPAN::Bundle::uptodate()
6310
6311Returns 1 if the bundle itself and all its members are uptodate.
6312
6313=item CPAN::Bundle::install()
6314
6315Recursively runs the C<install> method on all items contained in the bundle
6316
6317=item CPAN::Bundle::make()
6318
6319Recursively runs the C<make> method on all items contained in the bundle
6320
6321=item CPAN::Bundle::readme()
6322
6323Recursively runs the C<readme> method on all items contained in the bundle
6324
6325=item CPAN::Bundle::test()
6326
6327Recursively runs the C<test> method on all items contained in the bundle
6328
6329=item CPAN::Distribution::as_glimpse()
6330
6331Returns a one-line description of the distribution
6332
6333=item CPAN::Distribution::as_string()
6334
6335Returns a multi-line description of the distribution
6336
6337=item CPAN::Distribution::clean()
6338
6339Changes to the directory where the distribution has been unpacked and
6340runs C<make clean> there.
6341
6342=item CPAN::Distribution::containsmods()
6343
6344Returns a list of IDs of modules contained in a distribution file.
6345Only works for distributions listed in the 02packages.details.txt.gz
6346file. This typically means that only the most recent version of a
6347distribution is covered.
6348
6349=item CPAN::Distribution::cvs_import()
6350
6351Changes to the directory where the distribution has been unpacked and
6352runs something like
6353
6354 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
6355
6356there.
6357
6358=item CPAN::Distribution::dir()
6359
6360Returns the directory into which this distribution has been unpacked.
6361
6362=item CPAN::Distribution::force($method,@args)
6363
6364Forces CPAN to perform a task that normally would have failed. Force
6365takes as arguments a method name to be called and any number of
6366additional arguments that should be passed to the called method. The
6367internals of the object get the needed changes so that CPAN.pm does
6368not refuse to take the action.
6369
6370=item CPAN::Distribution::get()
6371
6372Downloads the distribution from CPAN and unpacks it. Does nothing if
6373the distribution has already been downloaded and unpacked within the
6374current session.
6375
6376=item CPAN::Distribution::install()
6377
6378Changes to the directory where the distribution has been unpacked and
6379runs the external command C<make install> there. If C<make> has not
6380yet been run, it will be run first. A C<make test> will be issued in
d1be9408 6381any case and if this fails, the install will be canceled. The
d8773709
JH		 6382cancellation can be avoided by letting C<force> run the C<install> for
6383you.
6384
6385=item CPAN::Distribution::isa_perl()
6386
6387Returns 1 if this distribution file seems to be a perl distribution.
6388Normally this is derived from the file name only, but the index from
6389CPAN can contain a hint to achieve a return value of true for other
6390filenames too.
6391
6392=item CPAN::Distribution::look()
6393
6394Changes to the directory where the distribution has been unpacked and
6395opens a subshell there. Exiting the subshell returns.
6396
6397=item CPAN::Distribution::make()
6398
6399First runs the C<get> method to make sure the distribution is
6400downloaded and unpacked. Changes to the directory where the
6401distribution has been unpacked and runs the external commands C<perl
6402Makefile.PL> and C<make> there.
6403
6404=item CPAN::Distribution::prereq_pm()
6405
6406Returns the hash reference that has been announced by a distribution
6407as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
6408attempt has been made to C<make> the distribution. Returns undef
6409otherwise.
6410
6411=item CPAN::Distribution::readme()
6412
6413Downloads the README file associated with a distribution and runs it
6414through the pager specified in C<$CPAN::Config->{pager}>.
6415
6416=item CPAN::Distribution::test()
6417
6418Changes to the directory where the distribution has been unpacked and
6419runs C<make test> there.
6420
6421=item CPAN::Distribution::uptodate()
6422
6423Returns 1 if all the modules contained in the distribution are
6424uptodate. Relies on containsmods.
6425
6426=item CPAN::Index::force_reload()
6427
6428Forces a reload of all indices.
6429
6430=item CPAN::Index::reload()
6431
6432Reloads all indices if they have been read more than
6433C<$CPAN::Config->{index_expire}> days.
6434
6435=item CPAN::InfoObj::dump()
6436
6437CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
6438inherit this method. It prints the data structure associated with an
6439object. Useful for debugging. Note: the data structure is considered
6440internal and thus subject to change without notice.
6441
6442=item CPAN::Module::as_glimpse()
6443
6444Returns a one-line description of the module
6445
6446=item CPAN::Module::as_string()
6447
6448Returns a multi-line description of the module
6449
6450=item CPAN::Module::clean()
6451
6452Runs a clean on the distribution associated with this module.
6453
6454=item CPAN::Module::cpan_file()
6455
6456Returns the filename on CPAN that is associated with the module.
6457
6458=item CPAN::Module::cpan_version()
6459
6460Returns the latest version of this module available on CPAN.
6461
6462=item CPAN::Module::cvs_import()
6463
6464Runs a cvs_import on the distribution associated with this module.
6465
6466=item CPAN::Module::description()
6467
d1be9408 6468Returns a 44 character description of this module. Only available for
d8773709
JH		 6469modules listed in The Module List (CPAN/modules/00modlist.long.html
6470or 00modlist.long.txt.gz)
6471
6472=item CPAN::Module::force($method,@args)
6473
6474Forces CPAN to perform a task that normally would have failed. Force
6475takes as arguments a method name to be called and any number of
6476additional arguments that should be passed to the called method. The
6477internals of the object get the needed changes so that CPAN.pm does
6478not refuse to take the action.
6479
6480=item CPAN::Module::get()
6481
6482Runs a get on the distribution associated with this module.
6483
6484=item CPAN::Module::inst_file()
6485
6486Returns the filename of the module found in @INC. The first file found
6487is reported just like perl itself stops searching @INC when it finds a
6488module.
6489
6490=item CPAN::Module::inst_version()
6491
6492Returns the version number of the module in readable format.
6493
6494=item CPAN::Module::install()
6495
6496Runs an C<install> on the distribution associated with this module.
6497
6498=item CPAN::Module::look()
6499
d1be9408 6500Changes to the directory where the distribution associated with this
d8773709
JH		 6501module has been unpacked and opens a subshell there. Exiting the
6502subshell returns.
6503
6504=item CPAN::Module::make()
6505
6506Runs a C<make> on the distribution associated with this module.
6507
6508=item CPAN::Module::manpage_headline()
6509
6510If module is installed, peeks into the module's manpage, reads the
6511headline and returns it. Moreover, if the module has been downloaded
6512within this session, does the equivalent on the downloaded module even
6513if it is not installed.
6514
6515=item CPAN::Module::readme()
6516
6517Runs a C<readme> on the distribution associated with this module.
6518
6519=item CPAN::Module::test()
6520
6521Runs a C<test> on the distribution associated with this module.
6522
6523=item CPAN::Module::uptodate()
6524
6525Returns 1 if the module is installed and up-to-date.
6526
6527=item CPAN::Module::userid()
6528
6529Returns the author's ID of the module.
6530
d8773709 6531=back
55e314ee 6532
5f05dabc 6533=head2 Cache Manager
6534
6535Currently the cache manager only keeps track of the build directory
6536($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
42d3b621 6537deletes complete directories below C<build_dir> as soon as the size of
5f05dabc 6538all directories there gets bigger than $CPAN::Config->{build_cache}
6539(in MB). The contents of this cache may be used for later
6540re-installations that you intend to do manually, but will never be
10b2abe6
CS		 6541trusted by CPAN itself. This is due to the fact that the user might
6542use these directories for building modules on different architectures.
5f05dabc 6543
6544There is another directory ($CPAN::Config->{keep_source_where}) where
6545the original distribution files are kept. This directory is not
6546covered by the cache manager and must be controlled by the user. If
6547you choose to have the same directory as build_dir and as
6548keep_source_where directory, then your sources will be deleted with
6549the same fifo mechanism.
6550
6551=head2 Bundles
6552
6553A bundle is just a perl module in the namespace Bundle:: that does not
6554define any functions or methods. It usually only contains documentation.
6555
6556It starts like a perl module with a package declaration and a $VERSION
6557variable. After that the pod section looks like any other pod with the
09d9d230 6558only difference being that I<one special pod section> exists starting with
10b2abe6 6559(verbatim):
5f05dabc 6560
6561 =head1 CONTENTS
6562
6563In this pod section each line obeys the format
6564
6565 Module_Name [Version_String] [- optional text]
6566
6567The only required part is the first field, the name of a module
09d9d230 6568(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
5f05dabc 6569of the line is optional. The comment part is delimited by a dash just
6570as in the man page header.
6571
6572The distribution of a bundle should follow the same convention as
42d3b621 6573other distributions.
5f05dabc 6574
6575Bundles are treated specially in the CPAN package. If you say 'install
6576Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
09d9d230 6577the modules in the CONTENTS section of the pod. You can install your
5f05dabc 6578own Bundles locally by placing a conformant Bundle file somewhere into
6579your @INC path. The autobundle() command which is available in the
6580shell interface does that for you by including all currently installed
6581modules in a snapshot bundle file.
6582
da199366 6583=head2 Prerequisites
5f05dabc 6584
da199366
A		 6585If you have a local mirror of CPAN and can access all files with
6586"file:" URLs, then you only need a perl better than perl5.003 to run
6587this module. Otherwise Net::FTP is strongly recommended. LWP may be
6588required for non-UNIX systems or if your nearest CPAN site is
d1be9408 6589associated with a URL that is not C<ftp:>.
5f05dabc 6590
da199366
A		 6591If you have neither Net::FTP nor LWP, there is a fallback mechanism
6592implemented for an external ftp command or for an external lynx
6593command.
5f05dabc 6594
09d9d230
A		 6595=head2 Finding packages and VERSION
6596
da199366 6597This module presumes that all packages on CPAN
5f05dabc 6598
da199366
A		 6599=over 2
6600
6601=item *
6602
6603declare their $VERSION variable in an easy to parse manner. This
09d9d230 6604prerequisite can hardly be relaxed because it consumes far too much
da199366 6605memory to load all packages into the running program just to determine
09d9d230 6606the $VERSION variable. Currently all programs that are dealing with
da199366
A		 6607version use something like this
6608
6609 perl -MExtUtils::MakeMaker -le \
2e2b7522 6610 'print MM->parse_version(shift)' filename
da199366
A		 6611
6612If you are author of a package and wonder if your $VERSION can be
6613parsed, please try the above method.
6614
6615=item *
6616
6617come as compressed or gzipped tarfiles or as zip files and contain a
09d9d230 6618Makefile.PL (well, we try to handle a bit more, but without much
da199366
A		 6619enthusiasm).
6620
6621=back
6622
6623=head2 Debugging
6624
6d29edf5 6625The debugging of this module is a bit complex, because we have
da199366
A		 6626interferences of the software producing the indices on CPAN, of the
6627mirroring process on CPAN, of packaging, of configuration, of
6628synchronicity, and of bugs within CPAN.pm.
6629
6d29edf5
JH		 6630For code debugging in interactive mode you can try "o debug" which
6631will list options for debugging the various parts of the code. You
6632should know that "o debug" has built-in completion support.
6633
6634For data debugging there is the C<dump> command which takes the same
6635arguments as make/test/install and outputs the object's Data::Dumper
6636dump.
da199366 6637
f610777f 6638=head2 Floppy, Zip, Offline Mode
da199366
A		 6639
6640CPAN.pm works nicely without network too. If you maintain machines
6641that are not networked at all, you should consider working with file:
6642URLs. Of course, you have to collect your modules somewhere first. So
6643you might use CPAN.pm to put together all you need on a networked
6644machine. Then copy the $CPAN::Config->{keep_source_where} (but not
6645$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
6646of a personal CPAN. CPAN.pm on the non-networked machines works nicely
36263cb3 6647with this floppy. See also below the paragraph about CD-ROM support.
10b2abe6 6648
5f05dabc 6649=head1 CONFIGURATION
6650
09d9d230 6651When the CPAN module is installed, a site wide configuration file is
5f05dabc 6652created as CPAN/Config.pm. The default values defined there can be
6653overridden in another configuration file: CPAN/MyConfig.pm. You can
6654store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
6655$HOME/.cpan is added to the search path of the CPAN module before the
6656use() or require() statements.
6657
6658Currently the following keys in the hash reference $CPAN::Config are
6659defined:
6660
42d3b621
A		 6661 build_cache size of cache for directories to build modules
6662 build_dir locally accessible directory to build modules
09d9d230 6663 index_expire after this many days refetch index files
5e05dca5 6664 cache_metadata use serializer to cache metadata
42d3b621 6665 cpan_home local directory reserved for this package
de34a54b
JH		 6666 dontload_hash anonymous hash: modules in the keys will not be
6667 loaded by the CPAN::has_inst() routine
42d3b621 6668 gzip location of external program gzip
09d9d230 6669 inactivity_timeout breaks interactive Makefile.PLs after this
42d3b621 6670 many seconds inactivity. Set to 0 to never break.
5f05dabc 6671 inhibit_startup_message
42d3b621 6672 if true, does not print the startup message
09d9d230
A		 6673 keep_source_where directory in which to keep the source (if we do)
6674 make location of external make program
42d3b621
A		 6675 make_arg arguments that should always be passed to 'make'
6676 make_install_arg same as make_arg for 'make install'
6677 makepl_arg arguments passed to 'perl Makefile.PL'
6678 pager location of external program more (or any pager)
f14b5cec
JH		 6679 prerequisites_policy
6680 what to do if you are missing module prerequisites
6681 ('follow' automatically, 'ask' me, or 'ignore')
c049f953
JH		 6682 proxy_user username for accessing an authenticating proxy
6683 proxy_pass password for accessing an authenticating proxy
f610777f 6684 scan_cache controls scanning of cache ('atstart' or 'never')
42d3b621 6685 tar location of external program tar
9d61fa1d
A		 6686 term_is_latin if true internal UTF-8 is translated to ISO-8859-1
6687 (and nonsense for characters outside latin range)
42d3b621
A		 6688 unzip location of external program unzip
6689 urllist arrayref to nearby CPAN sites (or equivalent locations)
09d9d230 6690 wait_list arrayref to a wait server to try (See CPAN::WAIT)
f610777f
A		 6691 ftp_proxy, } the three usual variables for configuring
6692 http_proxy, } proxy requests. Both as CPAN::Config variables
6693 no_proxy } and as environment variables configurable.
5f05dabc 6694
6695You can set and query each of these options interactively in the cpan
6696shell with the command set defined within the C<o conf> command:
6697
6698=over 2
6699
911a92db 6700=item C<o conf E<lt>scalar optionE<gt>>
5f05dabc 6701
6702prints the current value of the I<scalar option>
6703
911a92db 6704=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
5f05dabc 6705
6706Sets the value of the I<scalar option> to I<value>
6707
911a92db 6708=item C<o conf E<lt>list optionE<gt>>
5f05dabc 6709
6710prints the current value of the I<list option> in MakeMaker's
6711neatvalue format.
6712
911a92db 6713=item C<o conf E<lt>list optionE<gt> [shift|pop]>
5f05dabc 6714
6715shifts or pops the array in the I<list option> variable
6716
911a92db 6717=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
5f05dabc 6718
42d3b621 6719works like the corresponding perl commands.
5f05dabc 6720
6721=back
6722
36263cb3
GS		 6723=head2 Note on urllist parameter's format
6724
6725urllist parameters are URLs according to RFC 1738. We do a little
05d2a450
A		 6726guessing if your URL is not compliant, but if you have problems with
6727file URLs, please try the correct format. Either:
36263cb3
GS		 6728
6729 file://localhost/whatever/ftp/pub/CPAN/
6730
6731or
6732
6733 file:///home/ftp/pub/CPAN/
6734
2e2b7522 6735=head2 urllist parameter has CD-ROM support
c356248b
A		 6736
6737The C<urllist> parameter of the configuration table contains a list of
6738URLs that are to be used for downloading. If the list contains any
6739C<file> URLs, CPAN always tries to get files from there first. This
6740feature is disabled for index files. So the recommendation for the
6741owner of a CD-ROM with CPAN contents is: include your local, possibly
6742outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
6743
6744 o conf urllist push file://localhost/CDROM/CPAN
6745
6746CPAN.pm will then fetch the index files from one of the CPAN sites
6747that come at the beginning of urllist. It will later check for each
6748module if there is a local copy of the most recent version.
6749
2e2b7522
GS		 6750Another peculiarity of urllist is that the site that we could
6751successfully fetch the last file from automatically gets a preference
6752token and is tried as the first site for the next request. So if you
6753add a new site at runtime it may happen that the previously preferred
6754site will be tried another time. This means that if you want to disallow
6755a site for the next transfer, it must be explicitly removed from
6756urllist.
6757
5f05dabc 6758=head1 SECURITY
6759
6760There's no strong security layer in CPAN.pm. CPAN.pm helps you to
6761install foreign, unmasked, unsigned code on your machine. We compare
6762to a checksum that comes from the net just as the distribution file
6763itself. If somebody has managed to tamper with the distribution file,
6764they may have as well tampered with the CHECKSUMS file. Future
f14b5cec 6765development will go towards strong authentication.
5f05dabc 6766
6767=head1 EXPORT
6768
6769Most functions in package CPAN are exported per default. The reason
6770for this is that the primary use is intended for the cpan shell or for
d1be9408 6771one-liners.
5f05dabc 6772
f610777f
A		 6773=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
6774
d8773709 6775Populating a freshly installed perl with my favorite modules is pretty
8b3ad137 6776easy if you maintain a private bundle definition file. To get a useful
f610777f
A		 6777blueprint of a bundle definition file, the command autobundle can be used
6778on the CPAN shell command line. This command writes a bundle definition
36263cb3 6779file for all modules that are installed for the currently running perl
f610777f
A		 6780interpreter. It's recommended to run this command only once and from then
6781on maintain the file manually under a private name, say
6782Bundle/my_bundle.pm. With a clever bundle file you can then simply say
6783
6784 cpan> install Bundle::my_bundle
6785
36263cb3 6786then answer a few questions and then go out for a coffee.
f610777f 6787
8b3ad137 6788Maintaining a bundle definition file means keeping track of two
36263cb3
GS		 6789things: dependencies and interactivity. CPAN.pm sometimes fails on
6790calculating dependencies because not all modules define all MakeMaker
6791attributes correctly, so a bundle definition file should specify
6792prerequisites as early as possible. On the other hand, it's a bit
6793annoying that many distributions need some interactive configuring. So
6794what I try to accomplish in my private bundle file is to have the
6795packages that need to be configured early in the file and the gentle
6796ones later, so I can go out after a few minutes and leave CPAN.pm
8b3ad137 6797untended.
f610777f
A		 6798
6799=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
6800
36263cb3 6801Thanks to Graham Barr for contributing the following paragraphs about
de34a54b
JH		 6802the interaction between perl, and various firewall configurations. For
6803further informations on firewalls, it is recommended to consult the
6804documentation that comes with the ncftp program. If you are unable to
6805go through the firewall with a simple Perl setup, it is very likely
6806that you can configure ncftp so that it works for your firewall.
6807
6808=head2 Three basic types of firewalls
f610777f
A		 6809
6810Firewalls can be categorized into three basic types.
6811
bbc7dcd2 6812=over 4
f610777f
A		 6813
6814=item http firewall
6815
6816This is where the firewall machine runs a web server and to access the
6817outside world you must do it via the web server. If you set environment
6818variables like http_proxy or ftp_proxy to a values beginning with http://
6819or in your web browser you have to set proxy information then you know
d1be9408 6820you are running an http firewall.
f610777f
A		 6821
6822To access servers outside these types of firewalls with perl (even for
6823ftp) you will need to use LWP.
6824
6825=item ftp firewall
6826
d1be9408 6827This where the firewall machine runs an ftp server. This kind of
911a92db
GS		 6828firewall will only let you access ftp servers outside the firewall.
6829This is usually done by connecting to the firewall with ftp, then
6830entering a username like "user@outside.host.com"
f610777f
A		 6831
6832To access servers outside these type of firewalls with perl you
6833will need to use Net::FTP.
6834
6835=item One way visibility
6836
d1be9408 6837I say one way visibility as these firewalls try to make themselves look
f610777f
A		 6838invisible to the users inside the firewall. An FTP data connection is
6839normally created by sending the remote server your IP address and then
6840listening for the connection. But the remote server will not be able to
6841connect to you because of the firewall. So for these types of firewall
6842FTP connections need to be done in a passive mode.
6843
6844There are two that I can think off.
6845
bbc7dcd2 6846=over 4
f610777f
A		 6847
6848=item SOCKS
6849
6850If you are using a SOCKS firewall you will need to compile perl and link
c4d24d4c 6851it with the SOCKS library, this is what is normally called a 'socksified'
f610777f
A		 6852perl. With this executable you will be able to connect to servers outside
6853the firewall as if it is not there.
6854
6855=item IP Masquerade
6856
6857This is the firewall implemented in the Linux kernel, it allows you to
6858hide a complete network behind one IP address. With this firewall no
d8773709 6859special compiling is needed as you can access hosts directly.
f610777f
A		 6860
6861=back
6862
6863=back
6864
c4d24d4c 6865=head2 Configuring lynx or ncftp for going through a firewall
de34a54b
JH		 6866
6867If you can go through your firewall with e.g. lynx, presumably with a
6868command such as
6869
6870 /usr/local/bin/lynx -pscott:tiger
6871
6872then you would configure CPAN.pm with the command
6873
6874 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
6875
6876That's all. Similarly for ncftp or ftp, you would configure something
6877like
6878
6879 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
6880
d1be9408 6881Your mileage may vary...
de34a54b
JH		 6882
6883=head1 FAQ
6884
bbc7dcd2 6885=over 4
de34a54b 6886
551e1d92
RB		 6887=item 1)
6888
6889I installed a new version of module X but CPAN keeps saying,
6890I have the old version installed
de34a54b
JH		 6891
6892Most probably you B<do> have the old version installed. This can
6893happen if a module installs itself into a different directory in the
6894@INC path than it was previously installed. This is not really a
6895CPAN.pm problem, you would have the same problem when installing the
6896module manually. The easiest way to prevent this behaviour is to add
6897the argument C<UNINST=1> to the C<make install> call, and that is why
6898many people add this argument permanently by configuring
6899
6900 o conf make_install_arg UNINST=1
6901
551e1d92
RB		 6902=item 2)
6903
6904So why is UNINST=1 not the default?
de34a54b
JH		 6905
6906Because there are people who have their precise expectations about who
6907may install where in the @INC path and who uses which @INC array. In
6908fine tuned environments C<UNINST=1> can cause damage.
6909
551e1d92
RB		 6910=item 3)
6911
6912I want to clean up my mess, and install a new perl along with
6913all modules I have. How do I go about it?
9d61fa1d
A		 6914
6915Run the autobundle command for your old perl and optionally rename the
6916resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
6917with the Configure option prefix, e.g.
6918
6919 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
6920
6921Install the bundle file you produced in the first step with something like
6922
6923 cpan> install Bundle::mybundle
6924
6925and you're done.
6926
551e1d92
RB		 6927=item 4)
6928
6929When I install bundles or multiple modules with one command
6930there is too much output to keep track of.
de34a54b
JH		 6931
6932You may want to configure something like
6933
6934 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
6935 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
6936
6937so that STDOUT is captured in a file for later inspection.
6938
c4d24d4c 6939
551e1d92
RB		 6940=item 5)
6941
6942I am not root, how can I install a module in a personal directory?
c4d24d4c
A		 6943
6944You will most probably like something like this:
6945
6946 o conf makepl_arg "LIB=~/myperl/lib \
6947 INSTALLMAN1DIR=~/myperl/man/man1 \
6948 INSTALLMAN3DIR=~/myperl/man/man3"
6949 install Sybase::Sybperl
6950
6951You can make this setting permanent like all C<o conf> settings with
6952C<o conf commit>.
6953
6954You will have to add ~/myperl/man to the MANPATH environment variable
6955and also tell your perl programs to look into ~/myperl/lib, e.g. by
6956including
6957
6958 use lib "$ENV{HOME}/myperl/lib";
6959
6960or setting the PERL5LIB environment variable.
6961
6962Another thing you should bear in mind is that the UNINST parameter
6963should never be set if you are not root.
6964
551e1d92
RB		 6965=item 6)
6966
6967How to get a package, unwrap it, and make a change before building it?
c4d24d4c
A		 6968
6969 look Sybase::Sybperl
6970
551e1d92
RB		 6971=item 7)
6972
6973I installed a Bundle and had a couple of fails. When I
6974retried, everything resolved nicely. Can this be fixed to work
6975on first try?
c4d24d4c
A		 6976
6977The reason for this is that CPAN does not know the dependencies of all
6978modules when it starts out. To decide about the additional items to
6979install, it just uses data found in the generated Makefile. An
6980undetected missing piece breaks the process. But it may well be that
6981your Bundle installs some prerequisite later than some depending item
6982and thus your second try is able to resolve everything. Please note,
6983CPAN.pm does not know the dependency tree in advance and cannot sort
5a5fac02
JH		 6984the queue of things to install in a topologically correct order. It
6985resolves perfectly well IFF all modules declare the prerequisites
6986correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
6987fail and you need to install often, it is recommended sort the Bundle
6988definition file manually. It is planned to improve the metadata
6989situation for dependencies on CPAN in general, but this will still
6990take some time.
6991
551e1d92
RB		 6992=item 8)
6993
6994In our intranet we have many modules for internal use. How
6995can I integrate these modules with CPAN.pm but without uploading
6996the modules to CPAN?
5a5fac02
JH		 6997
6998Have a look at the CPAN::Site module.
c4d24d4c 6999
551e1d92
RB		 7000=item 9)
7001
7002When I run CPAN's shell, I get error msg about line 1 to 4,
7003setting meta input/output via the /etc/inputrc file.
9d61fa1d 7004
8d97e4a1
JH		 7005Some versions of readline are picky about capitalization in the
7006/etc/inputrc file and specifically RedHat 6.2 comes with a
7007/etc/inputrc that contains the word C<on> in lowercase. Change the
7008occurrences of C<on> to C<On> and the bug should disappear.
7009
551e1d92
RB		 7010=item 10)
7011
7012Some authors have strange characters in their names.
8d97e4a1
JH		 7013
7014Internally CPAN.pm uses the UTF-8 charset. If your terminal is
7015expecting ISO-8859-1 charset, a converter can be activated by setting
7016term_is_latin to a true value in your config file. One way of doing so
7017would be
7018
7019 cpan> ! $CPAN::Config->{term_is_latin}=1
7020
7021Extended support for converters will be made available as soon as perl
7022becomes stable with regard to charset issues.
9d61fa1d 7023
de34a54b
JH		 7024=back
7025
da199366 7026=head1 BUGS
5f05dabc 7027
36263cb3 7028We should give coverage for B<all> of the CPAN and not just the PAUSE
09d9d230 7029part, right? In this discussion CPAN and PAUSE have become equal --
c049f953 7030but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
c4d24d4c 7031PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
5f05dabc 7032
c356248b 7033Future development should be directed towards a better integration of
da199366 7034the other parts.
5f05dabc 7035
09d9d230
A		 7036If a Makefile.PL requires special customization of libraries, prompts
7037the user for special input, etc. then you may find CPAN is not able to
7038build the distribution. In that case, you should attempt the
7039traditional method of building a Perl module package from a shell.
7040
5f05dabc 7041=head1 AUTHOR
7042
911a92db 7043Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
5f05dabc 7044
c049f953
JH		 7045=head1 TRANSLATIONS
7046
7047Kawai,Takanori provides a Japanese translation of this manpage at
7048http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
7049
5f05dabc 7050=head1 SEE ALSO
7051
7052perl(1), CPAN::Nox(3)
7053
7054=cut
7055
Unnamed repository; edit this file 'description' to name the repository.