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
Refactoring the /Can't return (?:array|hash) to scalar context/ croak
[perl5.git] / lib / CPAN.pm
CommitLineData
44d21104 1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
e82b9348 2use strict;
8962fc49 3package CPAN;
ecc7fca0 4$CPAN::VERSION = '1.9205';
23a216b4 5$CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/;
5f05dabc 6
e82b9348 7use CPAN::HandleConfig;
554a9ef5 8use CPAN::Version;
e82b9348 9use CPAN::Debug;
135a59c2 10use CPAN::Queue;
e82b9348 11use CPAN::Tarzip;
f04ea8d1 12use CPAN::DeferedCode;
5f05dabc 13use Carp ();
14use Config ();
15use Cwd ();
0cf35e6a 16use DirHandle ();
5f05dabc 17use Exporter ();
b96578bb
SP		 18use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
19 # 5.005_04 does not work without
20 # this
5f05dabc 21use File::Basename ();
10b2abe6 22use File::Copy ();
5f05dabc 23use File::Find;
24use File::Path ();
0cf35e6a 25use File::Spec ();
da199366 26use FileHandle ();
05bab18e 27use Fcntl qw(:flock);
5f05dabc 28use Safe ();
0cf35e6a 29use Sys::Hostname qw(hostname);
10b2abe6 30use Text::ParseWords ();
0cf35e6a 31use Text::Wrap ();
8962fc49 32
b03f445c
RGS		 33sub find_perl ();
34
8962fc49
SP		 35# we need to run chdir all over and we would get at wrong libraries
36# there
37BEGIN {
38 if (File::Spec->can("rel2abs")) {
39 for my $inc (@INC) {
2b3bde2a 40 $inc = File::Spec->rel2abs($inc) unless ref $inc;
8962fc49
SP		 41 }
42 }
43}
44no lib ".";
5f05dabc 45
be708cc0 46require Mac::BuildTools if $^O eq 'MacOS';
f04ea8d1
SP		 47$ENV{PERL5_CPAN_IS_RUNNING}=$$;
48$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
be708cc0 49
e82b9348
SP		 50END { $CPAN::End++; &cleanup; }
51
da199366 52$CPAN::Signal ||= 0;
c356248b 53$CPAN::Frontend ||= "CPAN::Shell";
f04ea8d1 54unless (@CPAN::Defaultsites) {
7fefbd44
RGS		 55 @CPAN::Defaultsites = map {
56 CPAN::URL->new(TEXT => $_, FROM => "DEF")
57 }
58 "http://www.perl.org/CPAN/",
59 "ftp://ftp.perl.org/pub/CPAN/";
60}
0cf35e6a 61# $CPAN::iCwd (i for initial) is going to be initialized during find_perl
607a774b 62$CPAN::Perl ||= CPAN::find_perl();
554a9ef5 63$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
f04ea8d1
SP		 64$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
65$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
607a774b 66
05bab18e 67# our globals are getting a mess
6658a91b
SP		 68use vars qw(
69 $AUTOLOAD
135a59c2 70 $Be_Silent
6658a91b 71 $CONFIG_DIRTY
6658a91b 72 $Defaultdocs
2b3bde2a 73 $Echo_readline
6658a91b
SP		 74 $Frontend
75 $GOTOSHELL
76 $HAS_USABLE
77 $Have_warned
f20de9f0 78 $MAX_RECURSION
6658a91b 79 $META
05bab18e 80 $RUN_DEGRADED
6658a91b 81 $Signal
be34b10d 82 $SQLite
6658a91b
SP		 83 $Suppress_readline
84 $VERSION
135a59c2 85 $autoload_recursion
6658a91b
SP		 86 $term
87 @Defaultsites
88 @EXPORT
135a59c2 89 );
6d29edf5 90
f20de9f0
SP		 91$MAX_RECURSION = 32;
92
2e2b7522 93@CPAN::ISA = qw(CPAN::Debug Exporter);
5f05dabc 94
44d21104
A		 95# note that these functions live in CPAN::Shell and get executed via
96# AUTOLOAD when called directly
55e314ee 97@EXPORT = qw(
44d21104
A		 98 autobundle
99 bundle
100 clean
101 cvs_import
102 expand
103 force
b72dd56f 104 fforce
44d21104
A		 105 get
106 install
05bab18e 107 install_tested
f20de9f0 108 is_tested
44d21104
A		 109 make
110 mkmyconfig
111 notest
112 perldoc
113 readme
114 recent
115 recompile
8fc516fe 116 report
44d21104 117 shell
f04ea8d1 118 smoke
44d21104 119 test
ed84aac9 120 upgrade
f04ea8d1 121 );
5f05dabc 122
0cf35e6a
SP		 123sub soft_chdir_with_alternatives ($);
124
135a59c2
A		 125{
126 $autoload_recursion ||= 0;
127
128 #-> sub CPAN::AUTOLOAD ;
129 sub AUTOLOAD {
130 $autoload_recursion++;
131 my($l) = $AUTOLOAD;
132 $l =~ s/.*:://;
133 if ($CPAN::Signal) {
134 warn "Refusing to autoload '$l' while signal pending";
135 $autoload_recursion--;
136 return;
137 }
138 if ($autoload_recursion > 1) {
139 my $fullcommand = join " ", map { "'$_'" } $l, @_;
140 warn "Refusing to autoload $fullcommand in recursion\n";
141 $autoload_recursion--;
142 return;
143 }
144 my(%export);
145 @export{@EXPORT} = '';
146 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
f04ea8d1 147 if (exists $export{$l}) {
135a59c2
A		 148 CPAN::Shell->$l(@_);
149 } else {
150 die(qq{Unknown CPAN command "$AUTOLOAD". }.
151 qq{Type ? for help.\n});
152 }
153 $autoload_recursion--;
55e314ee
A		 154 }
155}
156
157#-> sub CPAN::shell ;
158sub shell {
36263cb3 159 my($self) = @_;
911a92db 160 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
e82b9348 161 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
55e314ee 162
9ddc4ed0 163 my $oprompt = shift || CPAN::Prompt->new;
9d61fa1d
A		 164 my $prompt = $oprompt;
165 my $commandline = shift || "";
9ddc4ed0 166 $CPAN::CurrentCommandId ||= 1;
5e05dca5 167
55e314ee
A		 168 local($^W) = 1;
169 unless ($Suppress_readline) {
f04ea8d1 170 require Term::ReadLine;
9d61fa1d
A		 171 if (! $term
172 or
173 $term->ReadLine eq "Term::ReadLine::Stub"
174 ) {
175 $term = Term::ReadLine->new('CPAN Monitor');
176 }
f04ea8d1
SP		 177 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
178 my $attribs = $term->Attribs;
179 $attribs->{attempted_completion_function} = sub {
180 &CPAN::Complete::gnu_cpl;
181 }
182 } else {
183 $readline::rl_completion_function =
184 $readline::rl_completion_function = 'CPAN::Complete::cpl';
185 }
5fc0f0f6
JH		 186 if (my $histfile = $CPAN::Config->{'histfile'}) {{
187 unless ($term->can("AddHistory")) {
188 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
189 last;
190 }
f20de9f0 191 $META->readhist($term,$histfile);
5fc0f0f6 192 }}
8962fc49
SP		 193 for ($CPAN::Config->{term_ornaments}) { # alias
194 local $Term::ReadLine::termcap_nowarn = 1;
ed84aac9
A		 195 $term->ornaments($_) if defined;
196 }
f04ea8d1
SP		 197 # $term->OUT is autoflushed anyway
198 my $odef = select STDERR;
199 $| = 1;
200 select STDOUT;
201 $| = 1;
202 select $odef;
55e314ee
A		 203 }
204
55e314ee 205 $META->checklock();
135a59c2
A		 206 my @cwd = grep { defined $_ and length $_ }
207 CPAN::anycwd(),
208 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
209 File::Spec->rootdir();
911a92db
GS		 210 my $try_detect_readline;
211 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
f04ea8d1
SP		 212 unless ($CPAN::Config->{inhibit_startup_message}) {
213 my $rl_avail = $Suppress_readline ? "suppressed" :
214 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
215 "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
8962fc49
SP		 216 $CPAN::Frontend->myprint(
217 sprintf qq{
554a9ef5 218cpan shell -- CPAN exploration and modules installation (v%s)
6d29edf5 219ReadLine support %s
55e314ee 220
6d29edf5 221},
8962fc49
SP		 222 $CPAN::VERSION,
223 $rl_avail
224 )
225 }
c356248b 226 my($continuation) = "";
8962fc49 227 my $last_term_ornaments;
8d97e4a1 228 SHELLCOMMAND: while () {
f04ea8d1 229 if ($Suppress_readline) {
2b3bde2a
SP		 230 if ($Echo_readline) {
231 $|=1;
232 }
f04ea8d1
SP		 233 print $prompt;
234 last SHELLCOMMAND unless defined ($_ = <> );
2b3bde2a
SP		 235 if ($Echo_readline) {
236 # backdoor: I could not find a way to record sessions
237 print $_;
238 }
f04ea8d1
SP		 239 chomp;
240 } else {
241 last SHELLCOMMAND unless
8d97e4a1 242 defined ($_ = $term->readline($prompt, $commandline));
f04ea8d1
SP		 243 }
244 $_ = "$continuation$_" if $continuation;
245 s/^\s+//;
246 next SHELLCOMMAND if /^$/;
247 s/^\s*\?\s*/help /;
248 if (/^(?:q(?:uit)?|bye|exit)$/i) {
249 last SHELLCOMMAND;
250 } elsif (s/\\$//s) {
251 chomp;
252 $continuation = $_;
253 $prompt = " > ";
254 } elsif (/^\!/) {
255 s/^\!//;
256 my($eval) = $_;
257 package CPAN::Eval;
e82b9348 258 use strict;
f04ea8d1
SP		 259 use vars qw($import_done);
260 CPAN->import(':DEFAULT') unless $import_done++;
261 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
262 eval($eval);
263 warn $@ if $@;
264 $continuation = "";
265 $prompt = $oprompt;
266 } elsif (/./) {
267 my(@line);
6a935156
SP		 268 eval { @line = Text::ParseWords::shellwords($_) };
269 warn($@), next SHELLCOMMAND if $@;
270 warn("Text::Parsewords could not parse the line [$_]"),
271 next SHELLCOMMAND unless @line;
f04ea8d1
SP		 272 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
273 my $command = shift @line;
274 eval { CPAN::Shell->$command(@line) };
275 if ($@) {
276 my $err = "$@";
277 if ($err =~ /\S/) {
278 require Carp;
279 require Dumpvalue;
280 my $dv = Dumpvalue->new();
281 Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
282 }
283 }
284 if ($command =~ /^(
285 # classic commands
286 make
287 |test
288 |install
289 |clean
290
291 # pragmas for classic commands
292 |ff?orce
293 |notest
294
295 # compounds
296 |report
297 |smoke
298 |upgrade
299 )$/x) {
300 # only commands that tell us something about failed distros
9ddc4ed0
A		 301 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
302 }
0cf35e6a 303 soft_chdir_with_alternatives(\@cwd);
f04ea8d1
SP		 304 $CPAN::Frontend->myprint("\n");
305 $continuation = "";
9ddc4ed0 306 $CPAN::CurrentCommandId++;
f04ea8d1
SP		 307 $prompt = $oprompt;
308 }
55e314ee 309 } continue {
f04ea8d1
SP		 310 $commandline = ""; # I do want to be able to pass a default to
311 # shell, but on the second command I see no
312 # use in that
313 $Signal=0;
314 CPAN::Queue->nullify_queue;
315 if ($try_detect_readline) {
316 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
317 ||
318 $CPAN::META->has_inst("Term::ReadLine::Perl")
319 ) {
320 delete $INC{"Term/ReadLine.pm"};
321 my $redef = 0;
322 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
323 require Term::ReadLine;
324 $CPAN::Frontend->myprint("\n$redef subroutines in ".
325 "Term::ReadLine redefined\n");
326 $GOTOSHELL = 1;
327 }
328 }
329 if ($term and $term->can("ornaments")) {
330 for ($CPAN::Config->{term_ornaments}) { # alias
331 if (defined $_) {
332 if (not defined $last_term_ornaments
333 or $_ != $last_term_ornaments
334 ) {
335 local $Term::ReadLine::termcap_nowarn = 1;
336 $term->ornaments($_);
337 $last_term_ornaments = $_;
338 }
339 } else {
340 undef $last_term_ornaments;
341 }
342 }
343 }
344 for my $class (qw(Module Distribution)) {
345 # again unsafe meta access?
346 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
347 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
348 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
349 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
350 }
351 }
352 if ($GOTOSHELL) {
353 $GOTOSHELL = 0; # not too often
354 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
355 @_ = ($oprompt,"");
356 goto &shell;
357 }
55e314ee 358 }
0cf35e6a 359 soft_chdir_with_alternatives(\@cwd);
55e314ee
A		 360}
361
ecc7fca0 362#-> CPAN::soft_chdir_with_alternatives ;
0cf35e6a
SP		 363sub soft_chdir_with_alternatives ($) {
364 my($cwd) = @_;
135a59c2
A		 365 unless (@$cwd) {
366 my $root = File::Spec->rootdir();
367 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
368Trying '$root' as temporary haven.
0cf35e6a 369});
135a59c2
A		 370 push @$cwd, $root;
371 }
372 while () {
373 if (chdir $cwd->[0]) {
374 return;
0cf35e6a 375 } else {
135a59c2
A		 376 if (@$cwd>1) {
377 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
378Trying to chdir to "$cwd->[1]" instead.
379});
380 shift @$cwd;
381 } else {
382 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
383 }
0cf35e6a
SP		 384 }
385 }
386}
44d21104 387
f04ea8d1
SP		 388sub _flock {
389 my($fh,$mode) = @_;
390 if ($Config::Config{d_flock}) {
391 return flock $fh, $mode;
392 } elsif (!$Have_warned->{"d_flock"}++) {
393 $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n");
394 $CPAN::Frontend->mysleep(5);
395 return 1;
396 } else {
397 return 1;
398 }
399}
400
b72dd56f 401sub _yaml_module () {
05bab18e
SP		 402 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
403 if (
404 $yaml_module ne "YAML"
405 &&
406 !$CPAN::META->has_inst($yaml_module)
407 ) {
408 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
409 $yaml_module = "YAML";
410 }
ade94d80
SP		 411 if ($yaml_module eq "YAML"
412 &&
413 $CPAN::META->has_inst($yaml_module)
414 &&
415 $YAML::VERSION < 0.60
416 &&
417 !$Have_warned->{"YAML"}++
418 ) {
419 $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
420 "I'll continue but problems are *very* likely to happen.\n"
421 );
422 $CPAN::Frontend->mysleep(5);
423 }
05bab18e
SP		 424 return $yaml_module;
425}
426
1e8f9a0a
SP		 427# CPAN::_yaml_loadfile
428sub _yaml_loadfile {
429 my($self,$local_file) = @_;
05bab18e 430 return +[] unless -s $local_file;
b72dd56f 431 my $yaml_module = _yaml_module;
1e8f9a0a 432 if ($CPAN::META->has_inst($yaml_module)) {
f04ea8d1
SP		 433 # temporarly enable yaml code deserialisation
434 no strict 'refs';
435 # 5.6.2 could not do the local() with the reference
436 local $YAML::LoadCode;
437 local $YAML::Syck::LoadCode;
438 ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
439
f20de9f0
SP		 440 my $code;
441 if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
442 my @yaml;
443 eval { @yaml = $code->($local_file); };
444 if ($@) {
445 # this shall not be done by the frontend
446 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
447 }
448 return \@yaml;
449 } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
450 local *FH;
451 open FH, $local_file or die "Could not open '$local_file': $!";
452 local $/;
453 my $ystream = <FH>;
454 my @yaml;
455 eval { @yaml = $code->($ystream); };
456 if ($@) {
457 # this shall not be done by the frontend
458 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
459 }
460 return \@yaml;
1e8f9a0a 461 }
1e8f9a0a 462 } else {
b72dd56f
SP		 463 # this shall not be done by the frontend
464 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
1e8f9a0a 465 }
6658a91b 466 return +[];
1e8f9a0a
SP		 467}
468
05bab18e
SP		 469# CPAN::_yaml_dumpfile
470sub _yaml_dumpfile {
b72dd56f
SP		 471 my($self,$local_file,@what) = @_;
472 my $yaml_module = _yaml_module;
05bab18e 473 if ($CPAN::META->has_inst($yaml_module)) {
f20de9f0 474 my $code;
b72dd56f 475 if (UNIVERSAL::isa($local_file, "FileHandle")) {
f20de9f0 476 $code = UNIVERSAL::can($yaml_module, "Dump");
b72dd56f 477 eval { print $local_file $code->(@what) };
f20de9f0 478 } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
b72dd56f 479 eval { $code->($local_file,@what); };
f20de9f0
SP		 480 } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
481 local *FH;
482 open FH, ">$local_file" or die "Could not open '$local_file': $!";
483 print FH $code->(@what);
05bab18e
SP		 484 }
485 if ($@) {
b72dd56f 486 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
05bab18e
SP		 487 }
488 } else {
b72dd56f 489 if (UNIVERSAL::isa($local_file, "FileHandle")) {
be34b10d
SP		 490 # I think this case does not justify a warning at all
491 } else {
b72dd56f 492 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
be34b10d 493 }
05bab18e
SP		 494 }
495}
496
be34b10d 497sub _init_sqlite () {
810a0276 498 unless ($CPAN::META->has_inst("CPAN::SQLite")) {
b72dd56f 499 $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
810a0276 500 unless $Have_warned->{"CPAN::SQLite"}++;
be34b10d
SP		 501 return;
502 }
810a0276 503 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
be34b10d
SP		 504 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
505}
506
810a0276
SP		 507{
508 my $negative_cache = {};
509 sub _sqlite_running {
510 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
511 # need to cache the result, otherwise too slow
512 return $negative_cache->{fact};
513 } else {
514 $negative_cache = {}; # reset
515 }
516 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
517 return $ret if $ret; # fast anyway
518 $negative_cache->{time} = time;
519 return $negative_cache->{fact} = $ret;
520 }
521}
522
55e314ee 523package CPAN::CacheMgr;
e82b9348 524use strict;
c356248b 525@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
55e314ee
A		 526use File::Find;
527
55e314ee 528package CPAN::FTP;
e82b9348 529use strict;
05bab18e 530use Fcntl qw(:flock);
f04ea8d1 531use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
55e314ee
A		 532@CPAN::FTP::ISA = qw(CPAN::Debug);
533
c049f953 534package CPAN::LWP::UserAgent;
e82b9348 535use strict;
c049f953 536use vars qw(@ISA $USER $PASSWD $SETUPDONE);
3c4b39be 537# we delay requiring LWP::UserAgent and setting up inheritance until we need it
c049f953 538
55e314ee 539package CPAN::Complete;
e82b9348 540use strict;
55e314ee 541@CPAN::Complete::ISA = qw(CPAN::Debug);
05bab18e
SP		 542# Q: where is the "How do I add a new command" HOWTO?
543# A: svn diff -r 1048:1049 where andk added the report command
9d61fa1d 544@CPAN::Complete::COMMANDS = sort qw(
f04ea8d1 545 ? ! a b d h i m o q r u
0cf35e6a 546 autobundle
f04ea8d1 547 bye
0cf35e6a
SP		 548 clean
549 cvs_import
550 dump
f04ea8d1 551 exit
f20de9f0 552 failed
0cf35e6a 553 force
b72dd56f 554 fforce
05bab18e 555 hosts
0cf35e6a 556 install
05bab18e 557 install_tested
f20de9f0 558 is_tested
0cf35e6a
SP		 559 look
560 ls
44d21104
A		 561 make
562 mkmyconfig
0cf35e6a
SP		 563 notest
564 perldoc
f04ea8d1 565 quit
0cf35e6a
SP		 566 readme
567 recent
44d21104 568 recompile
0cf35e6a 569 reload
8fc516fe 570 report
dc053c64 571 reports
ed84aac9 572 scripts
f04ea8d1 573 smoke
44d21104 574 test
ed84aac9 575 upgrade
0cf35e6a 576);
55e314ee
A		 577
578package CPAN::Index;
e82b9348 579use strict;
05bab18e 580use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
55e314ee 581@CPAN::Index::ISA = qw(CPAN::Debug);
c049f953
JH		 582$LAST_TIME ||= 0;
583$DATE_OF_03 ||= 0;
6d29edf5
JH		 584# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
585sub PROTOCOL { 2.0 }
55e314ee
A		 586
587package CPAN::InfoObj;
e82b9348 588use strict;
55e314ee
A		 589@CPAN::InfoObj::ISA = qw(CPAN::Debug);
590
591package CPAN::Author;
e82b9348 592use strict;
55e314ee
A		 593@CPAN::Author::ISA = qw(CPAN::InfoObj);
594
595package CPAN::Distribution;
e82b9348 596use strict;
55e314ee
A		 597@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
598
599package CPAN::Bundle;
e82b9348 600use strict;
55e314ee
A		 601@CPAN::Bundle::ISA = qw(CPAN::Module);
602
603package CPAN::Module;
e82b9348 604use strict;
55e314ee 605@CPAN::Module::ISA = qw(CPAN::InfoObj);
10b2abe6 606
35576f8c 607package CPAN::Exception::RecursiveDependency;
e82b9348 608use strict;
35576f8c
A		 609use overload '""' => "as_string";
610
f20de9f0
SP		 611# a module sees its distribution (no version)
612# a distribution sees its prereqs (which are module names) (usually with versions)
613# a bundle sees its module names and/or its distributions (no version)
614
35576f8c
A		 615sub new {
616 my($class) = shift;
617 my($deps) = shift;
ade94d80
SP		 618 my (@deps,%seen,$loop_starts_with);
619 DCHAIN: for my $dep (@$deps) {
620 push @deps, {name => $dep, display_as => $dep};
f04ea8d1 621 if ($seen{$dep}++) {
ade94d80
SP		 622 $loop_starts_with = $dep;
623 last DCHAIN;
624 }
625 }
626 my $in_loop = 0;
627 for my $i (0..$#deps) {
628 my $x = $deps[$i]{name};
629 $in_loop ||= $x eq $loop_starts_with;
630 my $xo = CPAN::Shell->expandany($x) or next;
631 if ($xo->isa("CPAN::Module")) {
632 my $have = $xo->inst_version || "N/A";
633 my($want,$d,$want_type);
634 if ($i>0 and $d = $deps[$i-1]{name}) {
635 my $do = CPAN::Shell->expandany($d);
636 $want = $do->{prereq_pm}{requires}{$x};
637 if (defined $want) {
638 $want_type = "requires: ";
639 } else {
640 $want = $do->{prereq_pm}{build_requires}{$x};
641 if (defined $want) {
642 $want_type = "build_requires: ";
643 } else {
644 $want_type = "unknown status";
645 $want = "???";
646 }
647 }
648 } else {
649 $want = $xo->cpan_version;
650 $want_type = "want: ";
651 }
652 $deps[$i]{have} = $have;
653 $deps[$i]{want_type} = $want_type;
654 $deps[$i]{want} = $want;
655 $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
656 } elsif ($xo->isa("CPAN::Distribution")) {
657 $deps[$i]{display_as} = $xo->pretty_id;
658 if ($in_loop) {
659 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
660 } else {
661 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
662 }
663 $xo->store_persistent_state; # otherwise I will not reach
664 # all involved parties for
665 # the next session
666 }
35576f8c
A		 667 }
668 bless { deps => \@deps }, $class;
669}
670
671sub as_string {
672 my($self) = shift;
ade94d80
SP		 673 my $ret = "\nRecursive dependency detected:\n ";
674 $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
675 $ret .= ".\nCannot resolve.\n";
676 $ret;
35576f8c
A		 677}
678
b72dd56f
SP		 679package CPAN::Exception::yaml_not_installed;
680use strict;
681use overload '""' => "as_string";
682
683sub new {
684 my($class,$module,$file,$during) = @_;
685 bless { module => $module, file => $file, during => $during }, $class;
686}
687
688sub as_string {
689 my($self) = shift;
690 "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
691}
692
693package CPAN::Exception::yaml_process_error;
694use strict;
695use overload '""' => "as_string";
696
697sub new {
23a216b4 698 my($class,$module,$file,$during,$error) = @_;
b72dd56f
SP		 699 bless { module => $module,
700 file => $file,
701 during => $during,
702 error => $error }, $class;
703}
704
705sub as_string {
706 my($self) = shift;
23a216b4
SP		 707 if ($self->{during}) {
708 if ($self->{file}) {
709 if ($self->{module}) {
710 if ($self->{error}) {
711 return "Alert: While trying to '$self->{during}' YAML file\n".
712 " '$self->{file}'\n".
713 "with '$self->{module}' the following error was encountered:\n".
714 " $self->{error}\n";
715 } else {
716 return "Alert: While trying to '$self->{during}' YAML file\n".
717 " '$self->{file}'\n".
718 "with '$self->{module}' some unknown error was encountered\n";
719 }
720 } else {
721 return "Alert: While trying to '$self->{during}' YAML file\n".
722 " '$self->{file}'\n".
723 "some unknown error was encountered\n";
724 }
725 } else {
726 return "Alert: While trying to '$self->{during}' some YAML file\n".
727 "some unknown error was encountered\n";
728 }
729 } else {
730 return "Alert: unknown error encountered\n";
731 }
b72dd56f
SP		 732}
733
9ddc4ed0 734package CPAN::Prompt; use overload '""' => "as_string";
4d1321a7
A		 735use vars qw($prompt);
736$prompt = "cpan> ";
9ddc4ed0 737$CPAN::CurrentCommandId ||= 0;
9ddc4ed0
A		 738sub new {
739 bless {}, shift;
740}
741sub as_string {
05bab18e
SP		 742 my $word = "cpan";
743 unless ($CPAN::META->{LOCK}) {
744 $word = "nolock_cpan";
745 }
9ddc4ed0 746 if ($CPAN::Config->{commandnumber_in_prompt}) {
05bab18e 747 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
9ddc4ed0 748 } else {
05bab18e 749 "$word> ";
9ddc4ed0
A		 750 }
751}
752
7fefbd44
RGS		 753package CPAN::URL; use overload '""' => "as_string", fallback => 1;
754# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
755# planned are things like age or quality
756sub new {
757 my($class,%args) = @_;
758 bless {
759 %args
760 }, $class;
761}
762sub as_string {
763 my($self) = @_;
764 $self->text;
765}
766sub text {
767 my($self,$set) = @_;
768 if (defined $set) {
769 $self->{TEXT} = $set;
770 }
771 $self->{TEXT};
772}
773
9ddc4ed0
A		 774package CPAN::Distrostatus;
775use overload '""' => "as_string",
776 fallback => 1;
777sub new {
778 my($class,$arg) = @_;
779 bless {
780 TEXT => $arg,
781 FAILED => substr($arg,0,2) eq "NO",
782 COMMANDID => $CPAN::CurrentCommandId,
be34b10d 783 TIME => time,
9ddc4ed0
A		 784 }, $class;
785}
786sub commandid { shift->{COMMANDID} }
787sub failed { shift->{FAILED} }
788sub text {
789 my($self,$set) = @_;
790 if (defined $set) {
791 $self->{TEXT} = $set;
792 }
793 $self->{TEXT};
794}
795sub as_string {
796 my($self) = @_;
4d1321a7 797 $self->text;
9ddc4ed0
A		 798}
799
55e314ee 800package CPAN::Shell;
e82b9348 801use strict;
6a935156
SP		 802use vars qw(
803 $ADVANCED_QUERY
804 $AUTOLOAD
805 $COLOR_REGISTERED
f04ea8d1 806 $Help
135a59c2 807 $autoload_recursion
6a935156
SP		 808 $reload
809 @ISA
135a59c2 810 );
55e314ee 811@CPAN::Shell::ISA = qw(CPAN::Debug);
9d61fa1d 812$COLOR_REGISTERED ||= 0;
f04ea8d1
SP		 813$Help = {
814 '?' => \"help",
815 '!' => "eval the rest of the line as perl",
816 a => "whois author",
817 autobundle => "wtite inventory into a bundle file",
818 b => "info about bundle",
819 bye => \"quit",
820 clean => "clean up a distribution's build directory",
821 # cvs_import
822 d => "info about a distribution",
823 # dump
824 exit => \"quit",
825 failed => "list all failed actions within current session",
826 fforce => "redo a command from scratch",
827 force => "redo a command",
828 h => \"help",
829 help => "overview over commands; 'help ...' explains specific commands",
830 hosts => "statistics about recently used hosts",
831 i => "info about authors/bundles/distributions/modules",
832 install => "install a distribution",
833 install_tested => "install all distributions tested OK",
834 is_tested => "list all distributions tested OK",
835 look => "open a subshell in a distribution's directory",
836 ls => "list distributions according to a glob",
837 m => "info about a module",
838 make => "make/build a distribution",
839 mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
840 notest => "run a (usually install) command but leave out the test phase",
841 o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
842 perldoc => "try to get a manpage for a module",
843 q => \"quit",
844 quit => "leave the cpan shell",
845 r => "review over upgradeable modules",
846 readme => "display the README of a distro woth a pager",
847 recent => "show recent uploads to the CPAN",
848 # recompile
849 reload => "'reload cpan' or 'reload index'",
850 report => "test a distribution and send a test report to cpantesters",
851 reports => "info about reported tests from cpantesters",
852 # scripts
853 # smoke
854 test => "test a distribution",
855 u => "display uninstalled modules",
856 upgrade => "combine 'r' command with immediate installation",
857 };
135a59c2 858{
135a59c2
A		 859 $autoload_recursion ||= 0;
860
861 #-> sub CPAN::Shell::AUTOLOAD ;
862 sub AUTOLOAD {
863 $autoload_recursion++;
864 my($l) = $AUTOLOAD;
865 my $class = shift(@_);
866 # warn "autoload[$l] class[$class]";
867 $l =~ s/.*:://;
868 if ($CPAN::Signal) {
869 warn "Refusing to autoload '$l' while signal pending";
870 $autoload_recursion--;
871 return;
872 }
873 if ($autoload_recursion > 1) {
874 my $fullcommand = join " ", map { "'$_'" } $l, @_;
875 warn "Refusing to autoload $fullcommand in recursion\n";
876 $autoload_recursion--;
877 return;
878 }
879 if ($l =~ /^w/) {
880 # XXX needs to be reconsidered
881 if ($CPAN::META->has_inst('CPAN::WAIT')) {
882 CPAN::WAIT->$l(@_);
883 } else {
884 $CPAN::Frontend->mywarn(qq{
55e314ee
A		 885Commands starting with "w" require CPAN::WAIT to be installed.
886Please consider installing CPAN::WAIT to use the fulltext index.
f610777f 887For this you just need to type
55e314ee 888 install CPAN::WAIT
c356248b 889});
6d29edf5 890 }
135a59c2
A		 891 } else {
892 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
893 qq{Type ? for help.
894});
6d29edf5 895 }
135a59c2 896 $autoload_recursion--;
f610777f 897 }
36263cb3
GS		 898}
899
55e314ee 900package CPAN;
e82b9348 901use strict;
55e314ee 902
2e2b7522 903$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
55e314ee 904
6d29edf5
JH		 905# from here on only subs.
906################################################################################
55e314ee 907
05bab18e
SP		 908sub _perl_fingerprint {
909 my($self,$other_fingerprint) = @_;
910 my $dll = eval {OS2::DLLname()};
911 my $mtime_dll = 0;
912 if (defined $dll) {
913 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
914 }
b03f445c 915 my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
05bab18e 916 my $this_fingerprint = {
b03f445c 917 '$^X' => CPAN::find_perl,
05bab18e 918 sitearchexp => $Config::Config{sitearchexp},
f20de9f0 919 'mtime_$^X' => $mtime_perl,
05bab18e
SP		 920 'mtime_dll' => $mtime_dll,
921 };
922 if ($other_fingerprint) {
923 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
924 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
925 }
926 # mandatory keys since 1.88_57
927 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
928 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
929 }
930 return 1;
931 } else {
932 return $this_fingerprint;
933 }
934}
935
ed84aac9
A		 936sub suggest_myconfig () {
937 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
938 $CPAN::Frontend->myprint("You don't seem to have a user ".
939 "configuration (MyConfig.pm) yet.\n");
8962fc49 940 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
ed84aac9
A		 941 "user configuration now? (Y/n)",
942 "yes");
943 if($new =~ m{^y}i) {
944 CPAN::Shell->mkmyconfig();
945 return &checklock;
946 } else {
947 $CPAN::Frontend->mydie("OK, giving up.");
948 }
949 }
950}
951
6d29edf5 952#-> sub CPAN::all_objects ;
36263cb3 953sub all_objects {
5f05dabc 954 my($mgr,$class) = @_;
e82b9348 955 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
5f05dabc 956 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
957 CPAN::Index->reload;
6d29edf5 958 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
5f05dabc 959}
960
c4d24d4c
A		 961# Called by shell, not in batch mode. In batch mode I see no risk in
962# having many processes updating something as installations are
963# continually checked at runtime. In shell mode I suspect it is
964# unintentional to open more than one shell at a time
965
10b2abe6 966#-> sub CPAN::checklock ;
5f05dabc 967sub checklock {
968 my($self) = @_;
5de3f0da 969 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
5f05dabc 970 if (-f $lockfile && -M _ > 0) {
f04ea8d1 971 my $fh = FileHandle->new($lockfile) or
9ddc4ed0 972 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
f04ea8d1
SP		 973 my $otherpid = <$fh>;
974 my $otherhost = <$fh>;
975 $fh->close;
976 if (defined $otherpid && $otherpid) {
977 chomp $otherpid;
978 }
979 if (defined $otherhost && $otherhost) {
980 chomp $otherhost;
981 }
982 my $thishost = hostname();
983 if (defined $otherhost && defined $thishost &&
984 $otherhost ne '' && $thishost ne '' &&
985 $otherhost ne $thishost) {
9ddc4ed0 986 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
c9869e1c
SP		 987 "reports other host $otherhost and other ".
988 "process $otherpid.\n".
0dfa0441 989 "Cannot proceed.\n"));
f04ea8d1 990 } elsif ($RUN_DEGRADED) {
05bab18e
SP		 991 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
992 } elsif (defined $otherpid && $otherpid) {
f04ea8d1
SP		 993 return if $$ == $otherpid; # should never happen
994 $CPAN::Frontend->mywarn(
995 qq{
0dfa0441 996There seems to be running another CPAN process (pid $otherpid). Contacting...
c356248b 997});
f04ea8d1
SP		 998 if (kill 0, $otherpid) {
999 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
1000 my($ans) =
1001 CPAN::Shell::colorable_makemaker_prompt
1002 (qq{Shall I try to run in degraded }.
1003 qq{mode? (Y/n)},"y");
05bab18e
SP		 1004 if ($ans =~ /^y/i) {
1005 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1006Please report if something unexpected happens\n");
1007 $RUN_DEGRADED = 1;
1008 for ($CPAN::Config) {
be34b10d
SP		 1009 # XXX
1010 # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1011 $_->{commandnumber_in_prompt} = 0; # visibility
1012 $_->{histfile} = ""; # who should win otherwise?
1013 $_->{cache_metadata} = 0; # better would be a lock?
b72dd56f 1014 $_->{use_sqlite} = 0; # better would be a write lock!
05bab18e
SP		 1015 }
1016 } else {
1017 $CPAN::Frontend->mydie("
1018You may want to kill the other job and delete the lockfile. On UNIX try:
0dfa0441 1019 kill $otherpid
c356248b 1020 rm $lockfile
05bab18e
SP		 1021");
1022 }
f04ea8d1
SP		 1023 } elsif (-w $lockfile) {
1024 my($ans) =
1025 CPAN::Shell::colorable_makemaker_prompt
1026 (qq{Other job not responding. Shall I overwrite }.
1027 qq{the lockfile '$lockfile'? (Y/n)},"y");
1028 $CPAN::Frontend->myexit("Ok, bye\n")
1029 unless $ans =~ /^y/i;
1030 } else {
1031 Carp::croak(
1032 qq{Lockfile '$lockfile' not writeable by you. }.
1033 qq{Cannot proceed.\n}.
1034 qq{ On UNIX try:\n}.
1035 qq{ rm '$lockfile'\n}.
1036 qq{ and then rerun us.\n}
1037 );
1038 }
1039 } else {
05bab18e
SP		 1040 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1041 "'$lockfile', please remove. Cannot proceed.\n"));
6d29edf5 1042 }
5f05dabc 1043 }
36263cb3
GS		 1044 my $dotcpan = $CPAN::Config->{cpan_home};
1045 eval { File::Path::mkpath($dotcpan);};
1046 if ($@) {
ed84aac9
A		 1047 # A special case at least for Jarkko.
1048 my $firsterror = $@;
1049 my $seconderror;
1050 my $symlinkcpan;
1051 if (-l $dotcpan) {
1052 $symlinkcpan = readlink $dotcpan;
1053 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1054 eval { File::Path::mkpath($symlinkcpan); };
1055 if ($@) {
1056 $seconderror = $@;
1057 } else {
1058 $CPAN::Frontend->mywarn(qq{
36263cb3
GS		 1059Working directory $symlinkcpan created.
1060});
ed84aac9
A		 1061 }
1062 }
1063 unless (-d $dotcpan) {
1064 my $mess = qq{
36263cb3
GS		 1065Your configuration suggests "$dotcpan" as your
1066CPAN.pm working directory. I could not create this directory due
1067to this error: $firsterror\n};
ed84aac9 1068 $mess .= qq{
36263cb3
GS		 1069As "$dotcpan" is a symlink to "$symlinkcpan",
1070I tried to create that, but I failed with this error: $seconderror
1071} if $seconderror;
ed84aac9 1072 $mess .= qq{
36263cb3
GS		 1073Please make sure the directory exists and is writable.
1074};
f04ea8d1 1075 $CPAN::Frontend->mywarn($mess);
ed84aac9
A		 1076 return suggest_myconfig;
1077 }
44d21104 1078 } # $@ after eval mkpath $dotcpan
05bab18e
SP		 1079 if (0) { # to test what happens when a race condition occurs
1080 for (reverse 1..10) {
1081 print $_, "\n";
1082 sleep 1;
1083 }
1084 }
1085 # locking
1086 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1087 my $fh;
1088 unless ($fh = FileHandle->new("+>>$lockfile")) {
1089 if ($! =~ /Permission/) {
f04ea8d1 1090 $CPAN::Frontend->mywarn(qq{
5f05dabc 1091
1092Your configuration suggests that CPAN.pm should use a working
1093directory of
1094 $CPAN::Config->{cpan_home}
1095Unfortunately we could not create the lock file
1096 $lockfile
1097due to permission problems.
1098
1099Please make sure that the configuration variable
1100 \$CPAN::Config->{cpan_home}
1101points to a directory where you can write a .lock file. You can set
87892b73
RGS		 1102this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1103\@INC path;
c356248b 1104});
05bab18e
SP		 1105 return suggest_myconfig;
1106 }
1107 }
1108 my $sleep = 1;
f04ea8d1 1109 while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
05bab18e
SP		 1110 if ($sleep>10) {
1111 $CPAN::Frontend->mydie("Giving up\n");
1112 }
1113 $CPAN::Frontend->mysleep($sleep++);
1114 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1115 }
1116
1117 seek $fh, 0, 0;
1118 truncate $fh, 0;
b03f445c 1119 $fh->autoflush(1);
05bab18e
SP		 1120 $fh->print($$, "\n");
1121 $fh->print(hostname(), "\n");
1122 $self->{LOCK} = $lockfile;
1123 $self->{LOCKFH} = $fh;
5f05dabc 1124 }
6d29edf5 1125 $SIG{TERM} = sub {
135a59c2
A		 1126 my $sig = shift;
1127 &cleanup;
1128 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
c356248b 1129 };
6d29edf5 1130 $SIG{INT} = sub {
09d9d230 1131 # no blocks!!!
135a59c2
A		 1132 my $sig = shift;
1133 &cleanup if $Signal;
1134 die "Got yet another signal" if $Signal > 1;
1135 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1136 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1137 $Signal++;
da199366 1138 };
911a92db
GS		 1139
1140# From: Larry Wall <larry@wall.org>
1141# Subject: Re: deprecating SIGDIE
1142# To: perl5-porters@perl.org
1143# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1144#
1145# The original intent of __DIE__ was only to allow you to substitute one
1146# kind of death for another on an application-wide basis without respect
1147# to whether you were in an eval or not. As a global backstop, it should
1148# not be used any more lightly (or any more heavily :-) than class
1149# UNIVERSAL. Any attempt to build a general exception model on it should
1150# be politely squashed. Any bug that causes every eval {} to have to be
1151# modified should be not so politely squashed.
1152#
1153# Those are my current opinions. It is also my optinion that polite
1154# arguments degenerate to personal arguments far too frequently, and that
1155# when they do, it's because both people wanted it to, or at least didn't
1156# sufficiently want it not to.
1157#
1158# Larry
1159
6d29edf5
JH		 1160 # global backstop to cleanup if we should really die
1161 $SIG{__DIE__} = \&cleanup;
e50380aa 1162 $self->debug("Signal handler set.") if $CPAN::DEBUG;
5f05dabc 1163}
1164
10b2abe6 1165#-> sub CPAN::DESTROY ;
5f05dabc 1166sub DESTROY {
1167 &cleanup; # need an eval?
1168}
1169
9d61fa1d
A		 1170#-> sub CPAN::anycwd ;
1171sub anycwd () {
1172 my $getcwd;
1173 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1174 CPAN->$getcwd();
1175}
1176
55e314ee
A		 1177#-> sub CPAN::cwd ;
1178sub cwd {Cwd::cwd();}
1179
1180#-> sub CPAN::getcwd ;
1181sub getcwd {Cwd::getcwd();}
1182
ca79d794
SP		 1183#-> sub CPAN::fastcwd ;
1184sub fastcwd {Cwd::fastcwd();}
1185
1186#-> sub CPAN::backtickcwd ;
1187sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1188
607a774b 1189#-> sub CPAN::find_perl ;
b03f445c 1190sub find_perl () {
607a774b 1191 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
0cf35e6a 1192 my $pwd = $CPAN::iCwd = CPAN::anycwd();
607a774b
MS		 1193 my $candidate = File::Spec->catfile($pwd,$^X);
1194 $perl ||= $candidate if MM->maybe_command($candidate);
1195
1196 unless ($perl) {
f04ea8d1 1197 my ($component,$perl_name);
607a774b 1198 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
f04ea8d1
SP		 1199 PATH_COMPONENT: foreach $component (File::Spec->path(),
1200 $Config::Config{'binexp'}) {
1201 next unless defined($component) && $component;
1202 my($abs) = File::Spec->catfile($component,$perl_name);
1203 if (MM->maybe_command($abs)) {
1204 $perl = $abs;
1205 last DIST_PERLNAME;
1206 }
1207 }
1208 }
607a774b
MS		 1209 }
1210
1211 return $perl;
1212}
1213
1214
10b2abe6 1215#-> sub CPAN::exists ;
5f05dabc 1216sub exists {
1217 my($mgr,$class,$id) = @_;
e82b9348 1218 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
5f05dabc 1219 CPAN::Index->reload;
e50380aa 1220 ### Carp::croak "exists called without class argument" unless $class;
5f05dabc 1221 $id ||= "";
e82b9348 1222 $id =~ s/:+/::/g if $class eq "CPAN::Module";
810a0276
SP		 1223 my $exists;
1224 if (CPAN::_sqlite_running) {
1225 $exists = (exists $META->{readonly}{$class}{$id} or
1226 $CPAN::SQLite->set($class, $id));
be34b10d 1227 } else {
810a0276 1228 $exists = exists $META->{readonly}{$class}{$id};
be34b10d 1229 }
810a0276 1230 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
5f05dabc 1231}
1232
09d9d230
A		 1233#-> sub CPAN::delete ;
1234sub delete {
1235 my($mgr,$class,$id) = @_;
6d29edf5
JH		 1236 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1237 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
09d9d230
A		 1238}
1239
de34a54b
JH		 1240#-> sub CPAN::has_usable
1241# has_inst is sometimes too optimistic, we should replace it with this
1242# has_usable whenever a case is given
1243sub has_usable {
1244 my($self,$mod,$message) = @_;
1245 return 1 if $HAS_USABLE->{$mod};
1246 my $has_inst = $self->has_inst($mod,$message);
1247 return unless $has_inst;
6d29edf5
JH		 1248 my $usable;
1249 $usable = {
1250 LWP => [ # we frequently had "Can't locate object
1251 # method "new" via package "LWP::UserAgent" at
1252 # (eval 69) line 2006
1253 sub {require LWP},
1254 sub {require LWP::UserAgent},
1255 sub {require HTTP::Request},
1256 sub {require URI::URL},
1257 ],
ec5fee46 1258 'Net::FTP' => [
6d29edf5
JH		 1259 sub {require Net::FTP},
1260 sub {require Net::Config},
87892b73
RGS		 1261 ],
1262 'File::HomeDir' => [
1263 sub {require File::HomeDir;
b03f445c 1264 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
87892b73 1265 for ("Will not use File::HomeDir, need 0.52\n") {
ed84aac9 1266 $CPAN::Frontend->mywarn($_);
87892b73
RGS		 1267 die $_;
1268 }
1269 }
1270 },
1271 ],
f20de9f0
SP		 1272 'Archive::Tar' => [
1273 sub {require Archive::Tar;
b03f445c 1274 unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
f20de9f0
SP		 1275 for ("Will not use Archive::Tar, need 1.00\n") {
1276 $CPAN::Frontend->mywarn($_);
1277 die $_;
1278 }
1279 }
1280 },
1281 ],
b03f445c
RGS		 1282 'File::Temp' => [
1283 # XXX we should probably delete from
1284 # %INC too so we can load after we
1285 # installed a new enough version --
1286 # I'm not sure.
1287 sub {require File::Temp;
1288 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1289 for ("Will not use File::Temp, need 0.16\n") {
1290 $CPAN::Frontend->mywarn($_);
1291 die $_;
1292 }
1293 }
1294 },
1295 ]
6d29edf5
JH		 1296 };
1297 if ($usable->{$mod}) {
87892b73
RGS		 1298 for my $c (0..$#{$usable->{$mod}}) {
1299 my $code = $usable->{$mod}[$c];
1300 my $ret = eval { &$code() };
1301 $ret = "" unless defined $ret;
1302 if ($@) {
1303 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1304 return;
1305 }
de34a54b 1306 }
de34a54b
JH		 1307 }
1308 return $HAS_USABLE->{$mod} = 1;
1309}
1310
55e314ee
A		 1311#-> sub CPAN::has_inst
1312sub has_inst {
1313 my($self,$mod,$message) = @_;
1314 Carp::croak("CPAN->has_inst() called without an argument")
f04ea8d1 1315 unless defined $mod;
4d1321a7
A		 1316 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1317 keys %{$CPAN::Config->{dontload_hash}||{}},
1318 @{$CPAN::Config->{dontload_list}||[]};
1319 if (defined $message && $message eq "no" # afair only used by Nox
de34a54b 1320 ||
4d1321a7 1321 $dont{$mod}
de34a54b 1322 ) {
6d29edf5 1323 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
de34a54b 1324 return 0;
55e314ee
A		 1325 }
1326 my $file = $mod;
c356248b 1327 my $obj;
55e314ee 1328 $file =~ s|::|/|g;
55e314ee 1329 $file .= ".pm";
c356248b 1330 if ($INC{$file}) {
f04ea8d1
SP		 1331 # checking %INC is wrong, because $INC{LWP} may be true
1332 # although $INC{"URI/URL.pm"} may have failed. But as
1333 # I really want to say "bla loaded OK", I have to somehow
1334 # cache results.
1335 ### warn "$file in %INC"; #debug
1336 return 1;
55e314ee 1337 } elsif (eval { require $file }) {
f04ea8d1
SP		 1338 # eval is good: if we haven't yet read the database it's
1339 # perfect and if we have installed the module in the meantime,
1340 # it tries again. The second require is only a NOOP returning
1341 # 1 if we had success, otherwise it's retrying
1342
1343 my $mtime = (stat $INC{$file})[9];
1344 # privileged files loaded by has_inst; Note: we use $mtime
1345 # as a proxy for a checksum.
1346 $CPAN::Shell::reload->{$file} = $mtime;
6a935156
SP		 1347 my $v = eval "\$$mod\::VERSION";
1348 $v = $v ? " (v$v)" : "";
f04ea8d1
SP		 1349 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1350 if ($mod eq "CPAN::WAIT") {
1351 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1352 }
1353 return 1;
55e314ee 1354 } elsif ($mod eq "Net::FTP") {
f04ea8d1 1355 $CPAN::Frontend->mywarn(qq{
55e314ee
A		 1356 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1357 if you just type
1358 install Bundle::libnet
5f05dabc 1359
5a5fac02 1360}) unless $Have_warned->{"Net::FTP"}++;
f04ea8d1
SP		 1361 $CPAN::Frontend->mysleep(3);
1362 } elsif ($mod eq "Digest::SHA") {
4d1321a7 1363 if ($Have_warned->{"Digest::SHA"}++) {
f04ea8d1 1364 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
4d1321a7
A		 1365 qq{because Digest::SHA not installed.\n});
1366 } else {
8962fc49 1367 $CPAN::Frontend->mywarn(qq{
e82b9348
SP		 1368 CPAN: checksum security checks disabled because Digest::SHA not installed.
1369 Please consider installing the Digest::SHA module.
c356248b
A		 1370
1371});
8962fc49 1372 $CPAN::Frontend->mysleep(2);
4d1321a7 1373 }
f04ea8d1 1374 } elsif ($mod eq "Module::Signature") {
be34b10d
SP		 1375 # NOT prefs_lookup, we are not a distro
1376 my $check_sigs = $CPAN::Config->{check_sigs};
1377 if (not $check_sigs) {
ed84aac9
A		 1378 # they do not want us:-(
1379 } elsif (not $Have_warned->{"Module::Signature"}++) {
f04ea8d1
SP		 1380 # No point in complaining unless the user can
1381 # reasonably install and use it.
1382 if (eval { require Crypt::OpenPGP; 1 } ||
1383 (
ed84aac9
A		 1384 defined $CPAN::Config->{'gpg'}
1385 &&
1386 $CPAN::Config->{'gpg'} =~ /\S/
1387 )
1388 ) {
f04ea8d1 1389 $CPAN::Frontend->mywarn(qq{
554a9ef5
SP		 1390 CPAN: Module::Signature security checks disabled because Module::Signature
1391 not installed. Please consider installing the Module::Signature module.
1392 You may also need to be able to connect over the Internet to the public
1393 keyservers like pgp.mit.edu (port 11371).
1394
1395});
f04ea8d1
SP		 1396 $CPAN::Frontend->mysleep(2);
1397 }
1398 }
f14b5cec 1399 } else {
f04ea8d1 1400 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
05454584 1401 }
55e314ee 1402 return 0;
05454584
A		 1403}
1404
10b2abe6 1405#-> sub CPAN::instance ;
5f05dabc 1406sub instance {
1407 my($mgr,$class,$id) = @_;
1408 CPAN::Index->reload;
5f05dabc 1409 $id ||= "";
6d29edf5
JH		 1410 # unsafe meta access, ok?
1411 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1412 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
5f05dabc 1413}
1414
10b2abe6 1415#-> sub CPAN::new ;
5f05dabc 1416sub new {
1417 bless {}, shift;
1418}
1419
10b2abe6 1420#-> sub CPAN::cleanup ;
5f05dabc 1421sub cleanup {
e82b9348 1422 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
2e2b7522
GS		 1423 local $SIG{__DIE__} = '';
1424 my($message) = @_;
1425 my $i = 0;
1426 my $ineval = 0;
5fc0f0f6
JH		 1427 my($subroutine);
1428 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
2e2b7522 1429 $ineval = 1, last if
f04ea8d1 1430 $subroutine eq '(eval)';
2e2b7522 1431 }
e82b9348 1432 return if $ineval && !$CPAN::End;
5fc0f0f6
JH		 1433 return unless defined $META->{LOCK};
1434 return unless -f $META->{LOCK};
1435 $META->savehist;
b72dd56f 1436 close $META->{LOCKFH};
5fc0f0f6 1437 unlink $META->{LOCK};
2e2b7522
GS		 1438 # require Carp;
1439 # Carp::cluck("DEBUGGING");
6658a91b
SP		 1440 if ( $CPAN::CONFIG_DIRTY ) {
1441 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1442 }
8962fc49 1443 $CPAN::Frontend->myprint("Lockfile removed.\n");
5f05dabc 1444}
1445
f20de9f0
SP		 1446#-> sub CPAN::readhist
1447sub readhist {
1448 my($self,$term,$histfile) = @_;
1449 my($fh) = FileHandle->new;
1450 open $fh, "<$histfile" or last;
1451 local $/ = "\n";
1452 while (<$fh>) {
1453 chomp;
1454 $term->AddHistory($_);
1455 }
1456 close $fh;
1457}
1458
5fc0f0f6
JH		 1459#-> sub CPAN::savehist
1460sub savehist {
1461 my($self) = @_;
1462 my($histfile,$histsize);
f04ea8d1 1463 unless ($histfile = $CPAN::Config->{'histfile'}) {
5fc0f0f6
JH		 1464 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1465 return;
1466 }
1467 $histsize = $CPAN::Config->{'histsize'} || 100;
f04ea8d1 1468 if ($CPAN::term) {
35576f8c
A		 1469 unless ($CPAN::term->can("GetHistory")) {
1470 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1471 return;
1472 }
1473 } else {
5fc0f0f6
JH		 1474 return;
1475 }
1476 my @h = $CPAN::term->GetHistory;
1477 splice @h, 0, @h-$histsize if @h>$histsize;
1478 my($fh) = FileHandle->new;
35576f8c 1479 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
5fc0f0f6
JH		 1480 local $\ = local $, = "\n";
1481 print $fh @h;
1482 close $fh;
1483}
1484
6658a91b 1485#-> sub CPAN::is_tested
4c070e31 1486sub is_tested {
b72dd56f
SP		 1487 my($self,$what,$when) = @_;
1488 unless ($what) {
1489 Carp::cluck("DEBUG: empty what");
1490 return;
1491 }
1492 $self->{is_tested}{$what} = $when;
4c070e31
IZ		 1493}
1494
6658a91b 1495#-> sub CPAN::is_installed
135a59c2
A		 1496# unsets the is_tested flag: as soon as the thing is installed, it is
1497# not needed in set_perl5lib anymore
4c070e31
IZ		 1498sub is_installed {
1499 my($self,$what) = @_;
1500 delete $self->{is_tested}{$what};
1501}
1502
b72dd56f
SP		 1503sub _list_sorted_descending_is_tested {
1504 my($self) = @_;
1505 sort
1506 { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1507 keys %{$self->{is_tested}}
1508}
1509
6658a91b 1510#-> sub CPAN::set_perl5lib
4c070e31 1511sub set_perl5lib {
6658a91b
SP		 1512 my($self,$for) = @_;
1513 unless ($for) {
1514 (undef,undef,undef,$for) = caller(1);
1515 $for =~ s/.*://;
1516 }
0362b508 1517 $self->{is_tested} ||= {};
4c070e31
IZ		 1518 return unless %{$self->{is_tested}};
1519 my $env = $ENV{PERL5LIB};
1520 $env = $ENV{PERLLIB} unless defined $env;
1521 my @env;
1522 push @env, $env if defined $env and length $env;
6658a91b
SP		 1523 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1524 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
b72dd56f
SP		 1525
1526 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1527 if (@dirs < 12) {
1528 $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1529 } elsif (@dirs < 24) {
1530 my @d = map {my $cp = $_;
1531 $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1532 $cp
1533 } @dirs;
1534 $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1535 "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1536 "for '$for'\n"
1537 );
6658a91b 1538 } else {
b72dd56f
SP		 1539 my $cnt = keys %{$self->{is_tested}};
1540 $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1541 "$cnt build dirs to PERL5LIB; ".
1542 "for '$for'\n"
6658a91b
SP		 1543 );
1544 }
1545
4c070e31
IZ		 1546 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1547}
1548
05454584 1549package CPAN::CacheMgr;
e82b9348 1550use strict;
5f05dabc 1551
05454584
A		 1552#-> sub CPAN::CacheMgr::as_string ;
1553sub as_string {
1554 eval { require Data::Dumper };
1555 if ($@) {
f04ea8d1 1556 return shift->SUPER::as_string;
5f05dabc 1557 } else {
f04ea8d1 1558 return Data::Dumper::Dumper(shift);
5f05dabc 1559 }
1560}
1561
05454584
A		 1562#-> sub CPAN::CacheMgr::cachesize ;
1563sub cachesize {
1564 shift->{DU};
5f05dabc 1565}
5f05dabc 1566
c4d24d4c 1567#-> sub CPAN::CacheMgr::tidyup ;
09d9d230
A		 1568sub tidyup {
1569 my($self) = @_;
be34b10d 1570 return unless $CPAN::META->{LOCK};
09d9d230 1571 return unless -d $self->{ID};
dc053c64
SP		 1572 my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1573 for my $current (0..$#toremove) {
1574 my $toremove = $toremove[$current];
1575 $CPAN::Frontend->myprint(sprintf(
1576 "DEL(%d/%d): %s \n",
1577 $current+1,
1578 scalar @toremove,
1579 $toremove,
1580 )
1581 );
09d9d230 1582 return if $CPAN::Signal;
810a0276 1583 $self->_clean_cache($toremove);
09d9d230
A		 1584 return if $CPAN::Signal;
1585 }
1586}
5f05dabc 1587
05454584
A		 1588#-> sub CPAN::CacheMgr::dir ;
1589sub dir {
1590 shift->{ID};
1591}
1592
1593#-> sub CPAN::CacheMgr::entries ;
1594sub entries {
1595 my($self,$dir) = @_;
55e314ee 1596 return unless defined $dir;
e50380aa 1597 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
05454584 1598 $dir ||= $self->{ID};
9d61fa1d 1599 my($cwd) = CPAN::anycwd();
05454584 1600 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
f14b5cec
JH		 1601 my $dh = DirHandle->new(File::Spec->curdir)
1602 or Carp::croak("Couldn't opendir $dir: $!");
05454584
A		 1603 my(@entries);
1604 for ($dh->read) {
f04ea8d1
SP		 1605 next if $_ eq "." || $_ eq "..";
1606 if (-f $_) {
1607 push @entries, File::Spec->catfile($dir,$_);
1608 } elsif (-d _) {
1609 push @entries, File::Spec->catdir($dir,$_);
1610 } else {
1611 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1612 }
5f05dabc 1613 }
05454584 1614 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
dc053c64 1615 sort { -M $a <=> -M $b} @entries;
5f05dabc 1616}
1617
05454584
A		 1618#-> sub CPAN::CacheMgr::disk_usage ;
1619sub disk_usage {
dc053c64 1620 my($self,$dir,$fast) = @_;
09d9d230
A		 1621 return if exists $self->{SIZE}{$dir};
1622 return if $CPAN::Signal;
1623 my($Du) = 0;
c9869e1c 1624 if (-e $dir) {
2b3bde2a
SP		 1625 if (-d $dir) {
1626 unless (-x $dir) {
1627 unless (chmod 0755, $dir) {
1628 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1629 "permission to change the permission; cannot ".
1630 "estimate disk usage of '$dir'\n");
1631 $CPAN::Frontend->mysleep(5);
1632 return;
1633 }
c9869e1c 1634 }
2b3bde2a
SP		 1635 } elsif (-f $dir) {
1636 # nothing to say, no matter what the permissions
c9869e1c
SP		 1637 }
1638 } else {
2b3bde2a 1639 $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
0cf35e6a 1640 return;
0cf35e6a 1641 }
dc053c64
SP		 1642 if ($fast) {
1643 $Du = 0; # placeholder
1644 } else {
1645 find(
1646 sub {
0cf35e6a
SP		 1647 $File::Find::prune++ if $CPAN::Signal;
1648 return if -l $_;
1649 if ($^O eq 'MacOS') {
1650 require Mac::Files;
1651 my $cat = Mac::Files::FSpGetCatInfo($_);
1652 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1653 } else {
1654 if (-d _) {
1655 unless (-x _) {
1656 unless (chmod 0755, $_) {
1657 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1658 "the permission to change the permission; ".
1659 "can only partially estimate disk usage ".
1660 "of '$_'\n");
8962fc49 1661 $CPAN::Frontend->mysleep(5);
0cf35e6a
SP		 1662 return;
1663 }
1664 }
1665 } else {
1666 $Du += (-s _);
1667 }
1668 }
1669 },
1670 $dir
dc053c64
SP		 1671 );
1672 }
09d9d230 1673 return if $CPAN::Signal;
05454584 1674 $self->{SIZE}{$dir} = $Du/1024/1024;
dc053c64 1675 unshift @{$self->{FIFO}}, $dir;
05454584
A		 1676 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1677 $self->{DU} += $Du/1024/1024;
05454584 1678 $self->{DU};
5f05dabc 1679}
1680
810a0276
SP		 1681#-> sub CPAN::CacheMgr::_clean_cache ;
1682sub _clean_cache {
05454584 1683 my($self,$dir) = @_;
09d9d230 1684 return unless -e $dir;
810a0276 1685 unless (File::Spec->canonpath(File::Basename::dirname($dir))
f04ea8d1 1686 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
be34b10d
SP		 1687 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1688 "will not remove\n");
1689 $CPAN::Frontend->mysleep(5);
1690 return;
1691 }
05454584 1692 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
f04ea8d1 1693 if $CPAN::DEBUG;
05454584 1694 File::Path::rmtree($dir);
f20de9f0
SP		 1695 my $id_deleted = 0;
1696 if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1697 my $yaml_module = CPAN::_yaml_module;
1698 if ($CPAN::META->has_inst($yaml_module)) {
23a216b4
SP		 1699 my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1700 if ($@) {
1701 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1702 unlink "$dir.yml" or
1703 $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1704 return;
1705 } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
f20de9f0 1706 $CPAN::META->delete("CPAN::Distribution", $id);
23a216b4
SP		 1707
1708 # XXX we should restore the state NOW, otherise this
1709 # distro does not exist until we read an index. BUG ALERT(?)
1710
f20de9f0
SP		 1711 # $CPAN::Frontend->mywarn (" +++\n");
1712 $id_deleted++;
1713 }
1714 }
1715 unlink "$dir.yml"; # may fail
1716 unless ($id_deleted) {
1717 CPAN->debug("no distro found associated with '$dir'");
1718 }
1719 }
05454584
A		 1720 $self->{DU} -= $self->{SIZE}{$dir};
1721 delete $self->{SIZE}{$dir};
5f05dabc 1722}
1723
05454584
A		 1724#-> sub CPAN::CacheMgr::new ;
1725sub new {
1726 my $class = shift;
e50380aa
A		 1727 my $time = time;
1728 my($debug,$t2);
1729 $debug = "";
05454584 1730 my $self = {
f04ea8d1
SP		 1731 ID => $CPAN::Config->{build_dir},
1732 MAX => $CPAN::Config->{'build_cache'},
1733 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1734 DU => 0
1735 };
05454584
A		 1736 File::Path::mkpath($self->{ID});
1737 my $dh = DirHandle->new($self->{ID});
1738 bless $self, $class;
f610777f
A		 1739 $self->scan_cache;
1740 $t2 = time;
1741 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1742 $time = $t2;
1743 CPAN->debug($debug) if $CPAN::DEBUG;
1744 $self;
1745}
1746
1747#-> sub CPAN::CacheMgr::scan_cache ;
1748sub scan_cache {
1749 my $self = shift;
1750 return if $self->{SCAN} eq 'never';
1751 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
f04ea8d1 1752 unless $self->{SCAN} eq 'atstart';
f20de9f0 1753 return unless $CPAN::META->{LOCK};
09d9d230 1754 $CPAN::Frontend->myprint(
f04ea8d1
SP		 1755 sprintf("Scanning cache %s for sizes\n",
1756 $self->{ID}));
f610777f 1757 my $e;
dc053c64 1758 my @entries = $self->entries($self->{ID});
b72dd56f
SP		 1759 my $i = 0;
1760 my $painted = 0;
1761 for $e (@entries) {
dc053c64
SP		 1762 my $symbol = ".";
1763 if ($self->{DU} > $self->{MAX}) {
1764 $symbol = "-";
1765 $self->disk_usage($e,1);
1766 } else {
1767 $self->disk_usage($e);
1768 }
b72dd56f
SP		 1769 $i++;
1770 while (($painted/76) < ($i/@entries)) {
dc053c64 1771 $CPAN::Frontend->myprint($symbol);
b72dd56f
SP		 1772 $painted++;
1773 }
f04ea8d1 1774 return if $CPAN::Signal;
5f05dabc 1775 }
b72dd56f 1776 $CPAN::Frontend->myprint("DONE\n");
09d9d230 1777 $self->tidyup;
5f05dabc 1778}
1779
05454584 1780package CPAN::Shell;
e82b9348 1781use strict;
5f05dabc 1782
05454584
A		 1783#-> sub CPAN::Shell::h ;
1784sub h {
1785 my($class,$about) = @_;
1786 if (defined $about) {
f04ea8d1
SP		 1787 my $help;
1788 if (exists $Help->{$about}) {
1789 if (ref $Help->{$about}) { # aliases
1790 $about = ${$Help->{$about}};
1791 }
1792 $help = $Help->{$about};
1793 } else {
1794 $help = "No help available";
1795 }
1796 $CPAN::Frontend->myprint("$about\: $help\n");
05454584 1797 } else {
9ddc4ed0 1798 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
f04ea8d1 1799 $CPAN::Frontend->myprint(qq{
9ddc4ed0 1800Display Information $filler (ver $CPAN::VERSION)
c049f953
JH		 1801 command argument description
1802 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
6a94b120 1803 i WORD or /REGEXP/ about any of the above
0cf35e6a 1804 ls AUTHOR or GLOB about files in the author's directory
ec5fee46
A		 1805 (with WORD being a module, bundle or author name or a distribution
1806 name of the form AUTHOR/DISTRIBUTION)
911a92db
GS		 1807
1808Download, Test, Make, Install...
ec5fee46
A		 1809 get download clean make clean
1810 make make (implies get) look open subshell in dist directory
1811 test make test (implies make) readme display these README files
1812 install make install (implies test) perldoc display POD documentation
1813
135a59c2
A		 1814Upgrade
1815 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1816 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1817
ec5fee46 1818Pragmas
b72dd56f 1819 force CMD try hard to do command fforce CMD try harder
810a0276 1820 notest CMD skip testing
911a92db
GS		 1821
1822Other
1823 h,? display this menu ! perl-code eval a perl command
1824 o conf [opt] set and query options q quit the cpan shell
1825 reload cpan load CPAN.pm again reload index load newer indices
ec5fee46 1826 autobundle Snapshot recent latest CPAN uploads});
135a59c2 1827}
05454584 1828}
da199366 1829
09d9d230
A		 1830*help = \&h;
1831
05454584 1832#-> sub CPAN::Shell::a ;
de34a54b
JH		 1833sub a {
1834 my($self,@arg) = @_;
1835 # authors are always UPPERCASE
1836 for (@arg) {
c049f953 1837 $_ = uc $_ unless /=/;
de34a54b
JH		 1838 }
1839 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1840}
6d29edf5 1841
ca79d794
SP		 1842#-> sub CPAN::Shell::globls ;
1843sub globls {
1844 my($self,$s,$pragmas) = @_;
0cf35e6a
SP		 1845 # ls is really very different, but we had it once as an ordinary
1846 # command in the Shell (upto rev. 321) and we could not handle
1847 # force well then
e82b9348 1848 my(@accept,@preexpand);
0cf35e6a
SP		 1849 if ($s =~ /[\*\?\/]/) {
1850 if ($CPAN::META->has_inst("Text::Glob")) {
1851 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1852 my $rau = Text::Glob::glob_to_regex(uc $au);
1853 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1854 if $CPAN::DEBUG;
1855 push @preexpand, map { $_->id . "/" . $pathglob }
1856 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
e82b9348 1857 } else {
0cf35e6a
SP		 1858 my $rau = Text::Glob::glob_to_regex(uc $s);
1859 push @preexpand, map { $_->id }
1860 CPAN::Shell->expand_by_method('CPAN::Author',
1861 ['id'],
1862 "/$rau/");
e82b9348
SP		 1863 }
1864 } else {
0cf35e6a 1865 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
e82b9348 1866 }
0cf35e6a
SP		 1867 } else {
1868 push @preexpand, uc $s;
554a9ef5 1869 }
e82b9348
SP		 1870 for (@preexpand) {
1871 unless (/^[A-Z0-9\-]+(\/|$)/i) {
5fc0f0f6 1872 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
c049f953
JH		 1873 next;
1874 }
e82b9348 1875 push @accept, $_;
8d97e4a1 1876 }
554a9ef5
SP		 1877 my $silent = @accept>1;
1878 my $last_alpha = "";
ca79d794 1879 my @results;
f04ea8d1 1880 for my $a (@accept) {
e82b9348
SP		 1881 my($author,$pathglob);
1882 if ($a =~ m|(.*?)/(.*)|) {
1883 my $a2 = $1;
1884 $pathglob = $2;
0cf35e6a
SP		 1885 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1886 ['id'],
b72dd56f
SP		 1887 $a2)
1888 or $CPAN::Frontend->mydie("No author found for $a2\n");
e82b9348 1889 } else {
0cf35e6a
SP		 1890 $author = CPAN::Shell->expand_by_method('CPAN::Author',
1891 ['id'],
b72dd56f
SP		 1892 $a)
1893 or $CPAN::Frontend->mydie("No author found for $a\n");
e82b9348 1894 }
554a9ef5 1895 if ($silent) {
e82b9348 1896 my $alpha = substr $author->id, 0, 1;
554a9ef5 1897 my $ad;
e82b9348
SP		 1898 if ($alpha eq $last_alpha) {
1899 $ad = "";
554a9ef5 1900 } else {
e82b9348
SP		 1901 $ad = "[$alpha]";
1902 $last_alpha = $alpha;
554a9ef5
SP		 1903 }
1904 $CPAN::Frontend->myprint($ad);
1905 }
9ddc4ed0
A		 1906 for my $pragma (@$pragmas) {
1907 if ($author->can($pragma)) {
1908 $author->$pragma();
1909 }
1910 }
ca79d794
SP		 1911 push @results, $author->ls($pathglob,$silent); # silent if
1912 # more than one
1913 # author
9ddc4ed0 1914 for my $pragma (@$pragmas) {
05bab18e
SP		 1915 my $unpragma = "un$pragma";
1916 if ($author->can($unpragma)) {
1917 $author->$unpragma();
9ddc4ed0
A		 1918 }
1919 }
8d97e4a1 1920 }
ca79d794 1921 @results;
8d97e4a1 1922}
6d29edf5 1923
8d97e4a1 1924#-> sub CPAN::Shell::local_bundles ;
6d29edf5 1925sub local_bundles {
05454584 1926 my($self,@which) = @_;
55e314ee 1927 my($incdir,$bdir,$dh);
05454584 1928 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8d97e4a1
JH		 1929 my @bbase = "Bundle";
1930 while (my $bbase = shift @bbase) {
5de3f0da 1931 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
8d97e4a1
JH		 1932 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1933 if ($dh = DirHandle->new($bdir)) { # may fail
1934 my($entry);
1935 for $entry ($dh->read) {
c049f953 1936 next if $entry =~ /^\./;
b96578bb 1937 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
f04ea8d1 1938 if (-d File::Spec->catdir($bdir,$entry)) {
8d97e4a1
JH		 1939 push @bbase, "$bbase\::$entry";
1940 } else {
1941 next unless $entry =~ s/\.pm(?!\n)\Z//;
1942 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1943 }
1944 }
1945 }
1946 }
05454584 1947 }
6d29edf5
JH		 1948}
1949
1950#-> sub CPAN::Shell::b ;
1951sub b {
1952 my($self,@which) = @_;
1953 CPAN->debug("which[@which]") if $CPAN::DEBUG;
1954 $self->local_bundles;
c356248b 1955 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
05454584 1956}
6d29edf5 1957
05454584 1958#-> sub CPAN::Shell::d ;
c356248b 1959sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
6d29edf5 1960
05454584 1961#-> sub CPAN::Shell::m ;
f610777f 1962sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
35576f8c
A		 1963 my $self = shift;
1964 $CPAN::Frontend->myprint($self->format_result('Module',@_));
f610777f 1965}
da199366 1966
05454584
A		 1967#-> sub CPAN::Shell::i ;
1968sub i {
1969 my($self) = shift;
1970 my(@args) = @_;
05454584
A		 1971 @args = '/./' unless @args;
1972 my(@result);
190aa835 1973 for my $type (qw/Bundle Distribution Module/) {
f04ea8d1 1974 push @result, $self->expand($type,@args);
05454584 1975 }
190aa835
MS		 1976 # Authors are always uppercase.
1977 push @result, $self->expand("Author", map { uc $_ } @args);
1978
8d97e4a1 1979 my $result = @result == 1 ?
f04ea8d1 1980 $result[0]->as_string :
8d97e4a1
JH		 1981 @result == 0 ?
1982 "No objects found of any type for argument @args\n" :
1983 join("",
1984 (map {$_->as_glimpse} @result),
1985 scalar @result, " items found\n",
1986 );
c356248b 1987 $CPAN::Frontend->myprint($result);
da199366 1988}
da199366 1989
05454584 1990#-> sub CPAN::Shell::o ;
5e05dca5 1991
8962fc49
SP		 1992# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1993# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
135a59c2
A		 1994# probably have been called 'set' and 'o debug' maybe 'set debug' or
1995# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
05454584
A		 1996sub o {
1997 my($self,$o_type,@o_what) = @_;
1998 $o_type ||= "";
1999 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
2000 if ($o_type eq 'conf') {
ecc7fca0
A		 2001 my($cfilter);
2002 ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
f04ea8d1
SP		 2003 if (!@o_what or $cfilter) { # print all things, "o conf"
2004 $cfilter ||= "";
2005 my $qrfilter = eval 'qr/$cfilter/';
2006 my($k,$v);
2007 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
ed84aac9 2008 my @from;
f04ea8d1 2009 if (exists $INC{'CPAN/Config.pm'}) {
ed84aac9 2010 push @from, $INC{'CPAN/Config.pm'};
f04ea8d1
SP		 2011 }
2012 if (exists $INC{'CPAN/MyConfig.pm'}) {
ed84aac9 2013 push @from, $INC{'CPAN/MyConfig.pm'};
f04ea8d1 2014 }
ed84aac9 2015 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
f04ea8d1
SP		 2016 $CPAN::Frontend->myprint(":\n");
2017 for $k (sort keys %CPAN::HandleConfig::can) {
2018 next unless $k =~ /$qrfilter/;
2019 $v = $CPAN::HandleConfig::can{$k};
2020 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
2021 }
2022 $CPAN::Frontend->myprint("\n");
2023 for $k (sort keys %CPAN::HandleConfig::keys) {
2024 next unless $k =~ /$qrfilter/;
e82b9348 2025 CPAN::HandleConfig->prettyprint($k);
f04ea8d1
SP		 2026 }
2027 $CPAN::Frontend->myprint("\n");
f20de9f0 2028 } else {
05bab18e 2029 if (CPAN::HandleConfig->edit(@o_what)) {
05bab18e
SP		 2030 } else {
2031 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2032 qq{items\n\n});
2033 }
f04ea8d1 2034 }
05454584 2035 } elsif ($o_type eq 'debug') {
f04ea8d1
SP		 2036 my(%valid);
2037 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2038 if (@o_what) {
2039 while (@o_what) {
2040 my($what) = shift @o_what;
8d97e4a1
JH		 2041 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2042 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2043 next;
2044 }
f04ea8d1
SP		 2045 if ( exists $CPAN::DEBUG{$what} ) {
2046 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2047 } elsif ($what =~ /^\d/) {
2048 $CPAN::DEBUG = $what;
2049 } elsif (lc $what eq 'all') {
2050 my($max) = 0;
2051 for (values %CPAN::DEBUG) {
2052 $max += $_;
2053 }
2054 $CPAN::DEBUG = $max;
2055 } else {
2056 my($known) = 0;
2057 for (keys %CPAN::DEBUG) {
2058 next unless lc($_) eq lc($what);
2059 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2060 $known = 1;
2061 }
2062 $CPAN::Frontend->myprint("unknown argument [$what]\n")
2063 unless $known;
2064 }
2065 }
2066 } else {
2067 my $raw = "Valid options for debug are ".
2068 join(", ",sort(keys %CPAN::DEBUG), 'all').
2069 qq{ or a number. Completion works on the options. }.
2070 qq{Case is ignored.};
2071 require Text::Wrap;
2072 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2073 $CPAN::Frontend->myprint("\n\n");
2074 }
2075 if ($CPAN::DEBUG) {
2076 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2077 my($k,$v);
2078 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2079 $v = $CPAN::DEBUG{$k};
2080 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
05d2a450 2081 if $v & $CPAN::DEBUG;
f04ea8d1
SP		 2082 }
2083 } else {
2084 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2085 }
05454584 2086 } else {
f04ea8d1 2087 $CPAN::Frontend->myprint(qq{
05454584
A		 2088Known options:
2089 conf set or get configuration variables
2090 debug set or get debugging options
c356248b 2091});
5f05dabc 2092 }
5f05dabc 2093}
2094
6a935156 2095# CPAN::Shell::paintdots_onreload
6d29edf5 2096sub paintdots_onreload {
36263cb3
GS		 2097 my($ref) = shift;
2098 sub {
f04ea8d1
SP		 2099 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2100 my($subr) = $1;
2101 ++$$ref;
2102 local($|) = 1;
2103 # $CPAN::Frontend->myprint(".($subr)");
2104 $CPAN::Frontend->myprint(".");
6a935156
SP		 2105 if ($subr =~ /\bshell\b/i) {
2106 # warn "debug[$_[0]]";
2107
2108 # It would be nice if we could detect that a
2109 # subroutine has actually changed, but for now we
2110 # practically always set the GOTOSHELL global
2111
2112 $CPAN::GOTOSHELL=1;
2113 }
f04ea8d1
SP		 2114 return;
2115 }
2116 warn @_;
36263cb3
GS		 2117 };
2118}
2119
05bab18e
SP		 2120#-> sub CPAN::Shell::hosts ;
2121sub hosts {
2122 my($self) = @_;
2123 my $fullstats = CPAN::FTP->_ftp_statistics();
2124 my $history = $fullstats->{history} || [];
2125 my %S; # statistics
2126 while (my $last = pop @$history) {
2127 my $attempts = $last->{attempts} or next;
2128 my $start;
2129 if (@$attempts) {
2130 $start = $attempts->[-1]{start};
2131 if ($#$attempts > 0) {
2132 for my $i (0..$#$attempts-1) {
2133 my $url = $attempts->[$i]{url} or next;
2134 $S{no}{$url}++;
2135 }
2136 }
2137 } else {
2138 $start = $last->{start};
2139 }
2140 next unless $last->{thesiteurl}; # C-C? bad filenames?
2141 $S{start} = $start;
2142 $S{end} ||= $last->{end};
2143 my $dltime = $last->{end} - $start;
2144 my $dlsize = $last->{filesize} || 0;
f20de9f0 2145 my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
05bab18e
SP		 2146 my $s = $S{ok}{$url} ||= {};
2147 $s->{n}++;
2148 $s->{dlsize} ||= 0;
2149 $s->{dlsize} += $dlsize/1024;
2150 $s->{dltime} ||= 0;
2151 $s->{dltime} += $dltime;
2152 }
2153 my $res;
2154 for my $url (keys %{$S{ok}}) {
2155 next if $S{ok}{$url}{dltime} == 0; # div by zero
2156 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2157 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2158 $url,
2159 ];
2160 }
2161 for my $url (keys %{$S{no}}) {
2162 push @{$res->{no}}, [$S{no}{$url},
2163 $url,
2164 ];
2165 }
2166 my $R = ""; # report
b72dd56f
SP		 2167 if ($S{start} && $S{end}) {
2168 $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2169 $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
2170 }
05bab18e
SP		 2171 if ($res->{ok} && @{$res->{ok}}) {
2172 $R .= sprintf "\nSuccessful downloads:
2173 N kB secs kB/s url\n";
be34b10d 2174 my $i = 20;
05bab18e
SP		 2175 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2176 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
be34b10d 2177 last if --$i<=0;
05bab18e
SP		 2178 }
2179 }
2180 if ($res->{no} && @{$res->{no}}) {
2181 $R .= sprintf "\nUnsuccessful downloads:\n";
be34b10d 2182 my $i = 20;
05bab18e
SP		 2183 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2184 $R .= sprintf "%4d %s\n", @$_;
be34b10d 2185 last if --$i<=0;
05bab18e
SP		 2186 }
2187 }
2188 $CPAN::Frontend->myprint($R);
2189}
2190
05454584
A		 2191#-> sub CPAN::Shell::reload ;
2192sub reload {
d4fd5c69
A		 2193 my($self,$command,@arg) = @_;
2194 $command ||= "";
2195 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
135a59c2 2196 if ($command =~ /^cpan$/i) {
e82b9348 2197 my $redef = 0;
0cf35e6a
SP		 2198 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2199 my $failed;
8962fc49
SP		 2200 my @relo = (
2201 "CPAN.pm",
8962fc49 2202 "CPAN/Debug.pm",
810a0276
SP		 2203 "CPAN/FirstTime.pm",
2204 "CPAN/HandleConfig.pm",
2205 "CPAN/Kwalify.pm",
135a59c2 2206 "CPAN/Queue.pm",
f04ea8d1
SP		 2207 "CPAN/Reporter/Config.pm",
2208 "CPAN/Reporter/History.pm",
135a59c2 2209 "CPAN/Reporter.pm",
f20de9f0 2210 "CPAN/SQLite.pm",
810a0276
SP		 2211 "CPAN/Tarzip.pm",
2212 "CPAN/Version.pm",
8962fc49 2213 );
8962fc49 2214 MFILE: for my $f (@relo) {
135a59c2
A		 2215 next unless exists $INC{$f};
2216 my $p = $f;
2217 $p =~ s/\.pm$//;
2218 $p =~ s|/|::|g;
2219 $CPAN::Frontend->myprint("($p");
5fc0f0f6 2220 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
810a0276 2221 $self->_reload_this($f) or $failed++;
135a59c2
A		 2222 my $v = eval "$p\::->VERSION";
2223 $CPAN::Frontend->myprint("v$v)");
5fc0f0f6 2224 }
e82b9348 2225 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
0cf35e6a 2226 if ($failed) {
135a59c2
A		 2227 my $errors = $failed == 1 ? "error" : "errors";
2228 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
0cf35e6a
SP		 2229 "this session.\n");
2230 }
135a59c2 2231 } elsif ($command =~ /^index$/i) {
2e2b7522 2232 CPAN::Index->force_reload;
d4fd5c69 2233 } else {
135a59c2 2234 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
f14b5cec 2235index re-reads the index files\n});
05454584
A		 2236 }
2237}
2238
2ccf00a7 2239# reload means only load again what we have loaded before
810a0276
SP		 2240#-> sub CPAN::Shell::_reload_this ;
2241sub _reload_this {
6a935156 2242 my($self,$f,$args) = @_;
7d97ad34 2243 CPAN->debug("f[$f]") if $CPAN::DEBUG;
2ccf00a7
SP		 2244 return 1 unless $INC{$f}; # we never loaded this, so we do not
2245 # reload but say OK
c9869e1c 2246 my $pwd = CPAN::anycwd();
7d97ad34
SP		 2247 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2248 my($file);
c9869e1c 2249 for my $inc (@INC) {
7d97ad34
SP		 2250 $file = File::Spec->catfile($inc,split /\//, $f);
2251 last if -f $file;
2252 $file = "";
2253 }
2254 CPAN->debug("file[$file]") if $CPAN::DEBUG;
2255 my @inc = @INC;
2256 unless ($file && -f $file) {
2257 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2258 $file = $INC{$f};
6658a91b
SP		 2259 unless (CPAN->has_inst("File::Basename")) {
2260 @inc = File::Basename::dirname($file);
2261 } else {
2262 # do we ever need this?
2263 @inc = substr($file,0,-length($f)-1); # bring in back to me!
2264 }
7d97ad34
SP		 2265 }
2266 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2267 unless (-f $file) {
c9869e1c
SP		 2268 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2269 return;
2270 }
6a935156 2271 my $mtime = (stat $file)[9];
f04ea8d1
SP		 2272 if ($reload->{$f}) {
2273 } elsif ($^T < $mtime) {
2274 # since we started the file has changed, force it to be reloaded
2275 $reload->{$f} = -1;
2276 } else {
2277 $reload->{$f} = $mtime;
2278 }
2279 my $must_reload = $mtime != $reload->{$f};
6a935156 2280 $args ||= {};
f04ea8d1 2281 $must_reload ||= $args->{reloforce}; # o conf defaults needs this
6a935156
SP		 2282 if ($must_reload) {
2283 my $fh = FileHandle->new($file) or
2284 $CPAN::Frontend->mydie("Could not open $file: $!");
2285 local($/);
2286 local $^W = 1;
2287 my $content = <$fh>;
2288 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2289 if $CPAN::DEBUG;
2290 delete $INC{$f};
2291 local @INC = @inc;
2292 eval "require '$f'";
f04ea8d1 2293 if ($@) {
6a935156
SP		 2294 warn $@;
2295 return;
2296 }
f04ea8d1 2297 $reload->{$f} = $mtime;
6a935156
SP		 2298 } else {
2299 $CPAN::Frontend->myprint("__unchanged__");
c9869e1c
SP		 2300 }
2301 return 1;
2302}
2303
44d21104
A		 2304#-> sub CPAN::Shell::mkmyconfig ;
2305sub mkmyconfig {
2306 my($self, $cpanpm, %args) = @_;
2307 require CPAN::FirstTime;
87892b73
RGS		 2308 my $home = CPAN::HandleConfig::home;
2309 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2310 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
44d21104 2311 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
87892b73 2312 CPAN::HandleConfig::require_myconfig_or_config;
44d21104
A		 2313 $CPAN::Config ||= {};
2314 $CPAN::Config = {
2315 %$CPAN::Config,
2316 build_dir => undef,
2317 cpan_home => undef,
2318 keep_source_where => undef,
2319 histfile => undef,
2320 };
2321 CPAN::FirstTime::init($cpanpm, %args);
2322}
2323
05454584
A		 2324#-> sub CPAN::Shell::_binary_extensions ;
2325sub _binary_extensions {
2326 my($self) = shift @_;
2327 my(@result,$module,%seen,%need,$headerdone);
2328 for $module ($self->expand('Module','/./')) {
f04ea8d1
SP		 2329 my $file = $module->cpan_file;
2330 next if $file eq "N/A";
2331 next if $file =~ /^Contact Author/;
05d2a450 2332 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
f04ea8d1
SP		 2333 next if $dist->isa_perl;
2334 next unless $module->xs_file;
2335 local($|) = 1;
2336 $CPAN::Frontend->myprint(".");
2337 push @result, $module;
05454584
A		 2338 }
2339# print join " | ", @result;
c356248b 2340 $CPAN::Frontend->myprint("\n");
05454584
A		 2341 return @result;
2342}
2343
2344#-> sub CPAN::Shell::recompile ;
2345sub recompile {
2346 my($self) = shift @_;
2347 my($module,@module,$cpan_file,%dist);
2348 @module = $self->_binary_extensions();
f04ea8d1 2349 for $module (@module) { # we force now and compile later, so we
c356248b 2350 # don't do it twice
f04ea8d1
SP		 2351 $cpan_file = $module->cpan_file;
2352 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2353 $pack->force;
2354 $dist{$cpan_file}++;
05454584
A		 2355 }
2356 for $cpan_file (sort keys %dist) {
f04ea8d1
SP		 2357 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
2358 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2359 $pack->install;
2360 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
05454584
A		 2361 # stop a package from recompiling,
2362 # e.g. IO-1.12 when we have perl5.003_10
2363 }
2364}
2365
ed84aac9
A		 2366#-> sub CPAN::Shell::scripts ;
2367sub scripts {
2368 my($self, $arg) = @_;
2369 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2370
8962fc49
SP		 2371 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2372 unless ($CPAN::META->has_inst($req)) {
2373 $CPAN::Frontend->mywarn(" $req not available\n");
2374 }
2375 }
ed84aac9
A		 2376 my $p = HTML::LinkExtor->new();
2377 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2378 unless (-f $indexfile) {
2379 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2380 }
2381 $p->parse_file($indexfile);
2382 my @hrefs;
2383 my $qrarg;
2384 if ($arg =~ s|^/(.+)/$|$1|) {
8962fc49 2385 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
ed84aac9
A		 2386 }
2387 for my $l ($p->links) {
2388 my $tag = shift @$l;
2389 next unless $tag eq "a";
2390 my %att = @$l;
2391 my $href = $att{href};
2392 next unless $href =~ s|^\.\./authors/id/./../||;
2393 if ($arg) {
2394 if ($qrarg) {
2395 if ($href =~ $qrarg) {
2396 push @hrefs, $href;
2397 }
2398 } else {
2399 if ($href =~ /\Q$arg\E/) {
2400 push @hrefs, $href;
2401 }
2402 }
2403 } else {
2404 push @hrefs, $href;
2405 }
2406 }
2407 # now filter for the latest version if there is more than one of a name
2408 my %stems;
2409 for (sort @hrefs) {
2410 my $href = $_;
2411 s/-v?\d.*//;
2412 my $stem = $_;
2413 $stems{$stem} ||= [];
2414 push @{$stems{$stem}}, $href;
2415 }
2416 for (sort keys %stems) {
2417 my $highest;
2418 if (@{$stems{$_}} > 1) {
2419 $highest = List::Util::reduce {
2420 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2421 } @{$stems{$_}};
2422 } else {
2423 $highest = $stems{$_}[0];
2424 }
2425 $CPAN::Frontend->myprint("$highest\n");
2426 }
2427}
2428
8fc516fe
SP		 2429#-> sub CPAN::Shell::report ;
2430sub report {
2431 my($self,@args) = @_;
2432 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2433 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2434 }
2435 local $CPAN::Config->{test_report} = 1;
6658a91b
SP		 2436 $self->force("test",@args); # force is there so that the test be
2437 # re-run (as documented)
8fc516fe
SP		 2438}
2439
f20de9f0 2440# compare with is_tested
05bab18e
SP		 2441#-> sub CPAN::Shell::install_tested
2442sub install_tested {
2443 my($self,@some) = @_;
b72dd56f 2444 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
05bab18e
SP		 2445 return if @some;
2446 CPAN::Index->reload;
2447
b72dd56f
SP		 2448 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2449 my $yaml = "$b.yml";
f04ea8d1 2450 unless (-f $yaml) {
b72dd56f
SP		 2451 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2452 next;
2453 }
f20de9f0
SP		 2454 my $yaml_content = CPAN->_yaml_loadfile($yaml);
2455 my $id = $yaml_content->[0]{distribution}{ID};
f04ea8d1 2456 unless ($id) {
b72dd56f
SP		 2457 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2458 next;
2459 }
2460 my $do = CPAN::Shell->expandany($id);
f04ea8d1 2461 unless ($do) {
b72dd56f
SP		 2462 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2463 next;
2464 }
2465 unless ($do->{build_dir}) {
2466 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2467 next;
2468 }
2469 unless ($do->{build_dir} eq $b) {
2470 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2471 next;
2472 }
05bab18e
SP		 2473 push @some, $do;
2474 }
2475
2476 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2477 return unless @some;
2478
2479 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2480 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2481 return unless @some;
2482
b72dd56f
SP		 2483 # @some = grep { not $_->uptodate } @some;
2484 # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2485 # return unless @some;
05bab18e
SP		 2486
2487 CPAN->debug("some[@some]");
2488 for my $d (@some) {
2489 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2490 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
b72dd56f 2491 $CPAN::Frontend->mysleep(1);
05bab18e
SP		 2492 $self->install($d);
2493 }
2494}
2495
ed84aac9
A		 2496#-> sub CPAN::Shell::upgrade ;
2497sub upgrade {
135a59c2
A		 2498 my($self,@args) = @_;
2499 $self->install($self->r(@args));
ed84aac9
A		 2500}
2501
05454584
A		 2502#-> sub CPAN::Shell::_u_r_common ;
2503sub _u_r_common {
2504 my($self) = shift @_;
2505 my($what) = shift @_;
2506 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
c4d24d4c
A		 2507 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2508 $what && $what =~ /^[aru]$/;
05454584
A		 2509 my(@args) = @_;
2510 @args = '/./' unless @args;
c356248b 2511 my(@result,$module,%seen,%need,$headerdone,
f04ea8d1
SP		 2512 $version_undefs,$version_zeroes,
2513 @version_undefs,@version_zeroes);
c356248b 2514 $version_undefs = $version_zeroes = 0;
9d61fa1d 2515 my $sprintf = "%s%-25s%s %9s %9s %s\n";
6d29edf5
JH		 2516 my @expand = $self->expand('Module',@args);
2517 my $expand = scalar @expand;
2518 if (0) { # Looks like noise to me, was very useful for debugging
2519 # for metadata cache
2520 $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2521 }
554a9ef5 2522 MODULE: for $module (@expand) {
f04ea8d1
SP		 2523 my $file = $module->cpan_file;
2524 next MODULE unless defined $file; # ??
2525 $file =~ s!^./../!!;
2526 my($latest) = $module->cpan_version;
2527 my($inst_file) = $module->inst_file;
2528 my($have);
2529 return if $CPAN::Signal;
2530 if ($inst_file) {
2531 if ($what eq "a") {
2532 $have = $module->inst_version;
2533 } elsif ($what eq "r") {
2534 $have = $module->inst_version;
2535 local($^W) = 0;
2536 if ($have eq "undef") {
2537 $version_undefs++;
2538 push @version_undefs, $module->as_glimpse;
2539 } elsif (CPAN::Version->vcmp($have,0)==0) {
2540 $version_zeroes++;
2541 push @version_zeroes, $module->as_glimpse;
2542 }
2543 next MODULE unless CPAN::Version->vgt($latest, $have);
c356248b
A		 2544# to be pedantic we should probably say:
2545# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2546# to catch the case where CPAN has a version 0 and we have a version undef
f04ea8d1
SP		 2547 } elsif ($what eq "u") {
2548 next MODULE;
2549 }
2550 } else {
2551 if ($what eq "a") {
2552 next MODULE;
2553 } elsif ($what eq "r") {
2554 next MODULE;
2555 } elsif ($what eq "u") {
2556 $have = "-";
2557 }
2558 }
2559 return if $CPAN::Signal; # this is sometimes lengthy
2560 $seen{$file} ||= 0;
2561 if ($what eq "a") {
2562 push @result, sprintf "%s %s\n", $module->id, $have;
2563 } elsif ($what eq "r") {
2564 push @result, $module->id;
2565 next MODULE if $seen{$file}++;
2566 } elsif ($what eq "u") {
2567 push @result, $module->id;
2568 next MODULE if $seen{$file}++;
2569 next MODULE if $file =~ /^Contact/;
2570 }
2571 unless ($headerdone++) {
2572 $CPAN::Frontend->myprint("\n");
2573 $CPAN::Frontend->myprint(sprintf(
9d61fa1d
A		 2574 $sprintf,
2575 "",
2576 "Package namespace",
2577 "",
2578 "installed",
2579 "latest",
2580 "in CPAN file"
2581 ));
f04ea8d1 2582 }
9d61fa1d
A		 2583 my $color_on = "";
2584 my $color_off = "";
2585 if (
2586 $COLOR_REGISTERED
2587 &&
2588 $CPAN::META->has_inst("Term::ANSIColor")
2589 &&
0cf35e6a 2590 $module->description
9d61fa1d
A		 2591 ) {
2592 $color_on = Term::ANSIColor::color("green");
2593 $color_off = Term::ANSIColor::color("reset");
2594 }
f04ea8d1 2595 $CPAN::Frontend->myprint(sprintf $sprintf,
9d61fa1d 2596 $color_on,
05d2a450 2597 $module->id,
9d61fa1d 2598 $color_off,
05d2a450
A		 2599 $have,
2600 $latest,
2601 $file);
f04ea8d1 2602 $need{$module->id}++;
05454584
A		 2603 }
2604 unless (%need) {
f04ea8d1
SP		 2605 if ($what eq "u") {
2606 $CPAN::Frontend->myprint("No modules found for @args\n");
2607 } elsif ($what eq "r") {
2608 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2609 }
05454584 2610 }
c356248b 2611 if ($what eq "r") {
f04ea8d1
SP		 2612 if ($version_zeroes) {
2613 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2614 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2615 qq{a version number of 0\n});
2616 if ($CPAN::Config->{show_zero_versions}) {
2617 local $" = "\t";
2618 $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
2619 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2620 qq{to hide them)\n});
2621 } else {
2622 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2623 qq{to show them)\n});
2624 }
2625 }
2626 if ($version_undefs) {
2627 my $s_has = $version_undefs > 1 ? "s have" : " has";
2628 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2629 qq{parseable version number\n});
2630 if ($CPAN::Config->{show_unparsable_versions}) {
2631 local $" = "\t";
2632 $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
2633 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2634 qq{to hide them)\n});
2635 } else {
2636 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2637 qq{to show them)\n});
2638 }
2639 }
05454584
A		 2640 }
2641 @result;
2642}
2643
2644#-> sub CPAN::Shell::r ;
2645sub r {
2646 shift->_u_r_common("r",@_);
2647}
2648
2649#-> sub CPAN::Shell::u ;
2650sub u {
2651 shift->_u_r_common("u",@_);
2652}
2653
0cf35e6a
SP		 2654#-> sub CPAN::Shell::failed ;
2655sub failed {
9ddc4ed0 2656 my($self,$only_id,$silent) = @_;
c9869e1c 2657 my @failed;
0cf35e6a
SP		 2658 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2659 my $failed = "";
810a0276 2660 NAY: for my $nosayer ( # order matters!
6658a91b 2661 "unwrapped",
87892b73
RGS		 2662 "writemakefile",
2663 "signature_verify",
2664 "make",
2665 "make_test",
2666 "install",
2667 "make_clean",
2668 ) {
0cf35e6a 2669 next unless exists $d->{$nosayer};
be34b10d 2670 next unless defined $d->{$nosayer};
44d21104 2671 next unless (
be34b10d 2672 UNIVERSAL::can($d->{$nosayer},"failed") ?
44d21104
A		 2673 $d->{$nosayer}->failed :
2674 $d->{$nosayer} =~ /^NO/
2675 );
87892b73 2676 next NAY if $only_id && $only_id != (
be34b10d 2677 UNIVERSAL::can($d->{$nosayer},"commandid")
87892b73
RGS		 2678 ?
2679 $d->{$nosayer}->commandid
2680 :
2681 $CPAN::CurrentCommandId
2682 );
0cf35e6a
SP		 2683 $failed = $nosayer;
2684 last;
2685 }
2686 next DIST unless $failed;
2687 my $id = $d->id;
2688 $id =~ s|^./../||;
c9869e1c
SP		 2689 #$print .= sprintf(
2690 # " %-45s: %s %s\n",
44d21104
A		 2691 push @failed,
2692 (
be34b10d 2693 UNIVERSAL::can($d->{$failed},"failed") ?
44d21104
A		 2694 [
2695 $d->{$failed}->commandid,
2696 $id,
2697 $failed,
2698 $d->{$failed}->text,
be34b10d 2699 $d->{$failed}{TIME}||0,
44d21104
A		 2700 ] :
2701 [
2702 1,
2703 $id,
2704 $failed,
2705 $d->{$failed},
be34b10d 2706 0,
44d21104
A		 2707 ]
2708 );
0cf35e6a 2709 }
be34b10d
SP		 2710 my $scope;
2711 if ($only_id) {
2712 $scope = "this command";
2713 } elsif ($CPAN::Index::HAVE_REANIMATED) {
2714 $scope = "this or a previous session";
2715 # it might be nice to have a section for previous session and
2716 # a second for this
2717 } else {
2718 $scope = "this session";
2719 }
c9869e1c 2720 if (@failed) {
be34b10d
SP		 2721 my $print;
2722 my $debug = 0;
2723 if ($debug) {
2724 $print = join "",
2725 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2726 sort { $a->[0] <=> $b->[0] } @failed;
2727 } else {
2728 $print = join "",
2729 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2730 sort {
2731 $a->[0] <=> $b->[0]
2732 ||
2733 $a->[4] <=> $b->[4]
2734 } @failed;
2735 }
2736 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
9ddc4ed0 2737 } elsif (!$only_id || !$silent) {
be34b10d 2738 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
0cf35e6a
SP		 2739 }
2740}
2741
c9869e1c
SP		 2742# XXX intentionally undocumented because completely bogus, unportable,
2743# useless, etc.
2744
0cf35e6a
SP		 2745#-> sub CPAN::Shell::status ;
2746sub status {
2747 my($self) = @_;
2748 require Devel::Size;
2749 my $ps = FileHandle->new;
2750 open $ps, "/proc/$$/status";
2751 my $vm = 0;
2752 while (<$ps>) {
2753 next unless /VmSize:\s+(\d+)/;
2754 $vm = $1;
2755 last;
2756 }
2757 $CPAN::Frontend->mywarn(sprintf(
2758 "%-27s %6d\n%-27s %6d\n",
2759 "vm",
2760 $vm,
2761 "CPAN::META",
2762 Devel::Size::total_size($CPAN::META)/1024,
2763 ));
2764 for my $k (sort keys %$CPAN::META) {
2765 next unless substr($k,0,4) eq "read";
2766 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2767 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
7d97ad34 2768 warn sprintf " %-25s %6d (keys: %6d)\n",
0cf35e6a
SP		 2769 $k2,
2770 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2771 scalar keys %{$CPAN::META->{$k}{$k2}};
2772 }
2773 }
2774}
2775
f20de9f0 2776# compare with install_tested
b72dd56f 2777#-> sub CPAN::Shell::is_tested
f20de9f0 2778sub is_tested {
b72dd56f 2779 my($self) = @_;
f20de9f0 2780 CPAN::Index->reload;
b72dd56f
SP		 2781 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2782 my $time;
2783 if ($CPAN::META->{is_tested}{$b}) {
2784 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2785 } else {
2786 $time = scalar localtime;
2787 $time =~ s/\S/?/g;
2788 }
2789 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2790 }
2791}
2792
05454584
A		 2793#-> sub CPAN::Shell::autobundle ;
2794sub autobundle {
2795 my($self) = shift;
e82b9348 2796 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
05454584 2797 my(@bundle) = $self->_u_r_common("a",@_);
5de3f0da 2798 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
05454584
A		 2799 File::Path::mkpath($todir);
2800 unless (-d $todir) {
f04ea8d1
SP		 2801 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2802 return;
05454584
A		 2803 }
2804 my($y,$m,$d) = (localtime)[5,4,3];
2805 $y+=1900;
2806 $m++;
2807 my($c) = 0;
2808 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
5de3f0da 2809 my($to) = File::Spec->catfile($todir,"$me.pm");
05454584 2810 while (-f $to) {
f04ea8d1
SP		 2811 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2812 $to = File::Spec->catfile($todir,"$me.pm");
05454584
A		 2813 }
2814 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2815 $fh->print(
f04ea8d1
SP		 2816 "package Bundle::$me;\n\n",
2817 "\$VERSION = '0.01';\n\n",
2818 "1;\n\n",
2819 "__END__\n\n",
2820 "=head1 NAME\n\n",
2821 "Bundle::$me - Snapshot of installation on ",
2822 $Config::Config{'myhostname'},
2823 " on ",
2824 scalar(localtime),
2825 "\n\n=head1 SYNOPSIS\n\n",
2826 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2827 "=head1 CONTENTS\n\n",
2828 join("\n", @bundle),
2829 "\n\n=head1 CONFIGURATION\n\n",
2830 Config->myconfig,
2831 "\n\n=head1 AUTHOR\n\n",
2832 "This Bundle has been generated automatically ",
2833 "by the autobundle routine in CPAN.pm.\n",
2834 );
05454584 2835 $fh->close;
c356248b
A		 2836 $CPAN::Frontend->myprint("\nWrote bundle file
2837 $to\n\n");
05454584
A		 2838}
2839
6d29edf5
JH		 2840#-> sub CPAN::Shell::expandany ;
2841sub expandany {
2842 my($self,$s) = @_;
2843 CPAN->debug("s[$s]") if $CPAN::DEBUG;
8fc516fe 2844 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
8d97e4a1 2845 $s = CPAN::Distribution->normalize($s);
6d29edf5
JH		 2846 return $CPAN::META->instance('CPAN::Distribution',$s);
2847 # Distributions spring into existence, not expand
2848 } elsif ($s =~ m|^Bundle::|) {
2849 $self->local_bundles; # scanning so late for bundles seems
2850 # both attractive and crumpy: always
2851 # current state but easy to forget
2852 # somewhere
2853 return $self->expand('Bundle',$s);
2854 } else {
2855 return $self->expand('Module',$s)
2856 if $CPAN::META->exists('CPAN::Module',$s);
2857 }
2858 return;
2859}
2860
05454584
A		 2861#-> sub CPAN::Shell::expand ;
2862sub expand {
e82b9348 2863 my $self = shift;
05454584 2864 my($type,@args) = @_;
8d97e4a1 2865 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
e82b9348
SP		 2866 my $class = "CPAN::$type";
2867 my $methods = ['id'];
2868 for my $meth (qw(name)) {
e82b9348
SP		 2869 next unless $class->can($meth);
2870 push @$methods, $meth;
2871 }
2872 $self->expand_by_method($class,$methods,@args);
2873}
2874
05bab18e 2875#-> sub CPAN::Shell::expand_by_method ;
e82b9348
SP		 2876sub expand_by_method {
2877 my $self = shift;
2878 my($class,$methods,@args) = @_;
2879 my($arg,@m);
05454584 2880 for $arg (@args) {
f04ea8d1
SP		 2881 my($regex,$command);
2882 if ($arg =~ m|^/(.*)/$|) {
2883 $regex = $1;
b03f445c
RGS		 2884# FIXME: there seem to be some ='s in the author data, which trigger
2885# a failure here. This needs to be contemplated.
2886# } elsif ($arg =~ m/=/) {
2887# $command = 1;
6d29edf5 2888 }
f04ea8d1 2889 my $obj;
8d97e4a1
JH		 2890 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2891 $class,
2892 defined $regex ? $regex : "UNDEFINED",
e82b9348 2893 defined $command ? $command : "UNDEFINED",
8d97e4a1 2894 ) if $CPAN::DEBUG;
f04ea8d1 2895 if (defined $regex) {
810a0276 2896 if (CPAN::_sqlite_running) {
be34b10d
SP		 2897 $CPAN::SQLite->search($class, $regex);
2898 }
6d29edf5 2899 for $obj (
6d29edf5
JH		 2900 $CPAN::META->all_objects($class)
2901 ) {
f04ea8d1 2902 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
6d29edf5 2903 # BUG, we got an empty object somewhere
8d97e4a1 2904 require Data::Dumper;
6d29edf5 2905 CPAN->debug(sprintf(
8d97e4a1 2906 "Bug in CPAN: Empty id on obj[%s][%s]",
6d29edf5 2907 $obj,
8d97e4a1 2908 Data::Dumper::Dumper($obj)
6d29edf5
JH		 2909 )) if $CPAN::DEBUG;
2910 next;
2911 }
e82b9348 2912 for my $method (@$methods) {
135a59c2
A		 2913 my $match = eval {$obj->$method() =~ /$regex/i};
2914 if ($@) {
2915 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2916 $err ||= $@; # if we were too restrictive above
2917 $CPAN::Frontend->mydie("$err\n");
2918 } elsif ($match) {
e82b9348
SP		 2919 push @m, $obj;
2920 last;
2921 }
2922 }
6d29edf5
JH		 2923 }
2924 } elsif ($command) {
8d97e4a1
JH		 2925 die "equal sign in command disabled (immature interface), ".
2926 "you can set
2927 ! \$CPAN::Shell::ADVANCED_QUERY=1
2928to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2929that may go away anytime.\n"
2930 unless $ADVANCED_QUERY;
2931 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2932 my($matchcrit) = $criterion =~ m/^~(.+)/;
6d29edf5
JH		 2933 for my $self (
2934 sort
2935 {$a->id cmp $b->id}
2936 $CPAN::META->all_objects($class)
2937 ) {
8d97e4a1
JH		 2938 my $lhs = $self->$method() or next; # () for 5.00503
2939 if ($matchcrit) {
2940 push @m, $self if $lhs =~ m/$matchcrit/;
2941 } else {
2942 push @m, $self if $lhs eq $criterion;
2943 }
6d29edf5 2944 }
f04ea8d1
SP		 2945 } else {
2946 my($xarg) = $arg;
2947 if ( $class eq 'CPAN::Bundle' ) {
2948 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2949 } elsif ($class eq "CPAN::Distribution") {
8d97e4a1 2950 $xarg = CPAN::Distribution->normalize($arg);
e82b9348
SP		 2951 } else {
2952 $xarg =~ s/:+/::/g;
8d97e4a1 2953 }
f04ea8d1
SP		 2954 if ($CPAN::META->exists($class,$xarg)) {
2955 $obj = $CPAN::META->instance($class,$xarg);
2956 } elsif ($CPAN::META->exists($class,$arg)) {
2957 $obj = $CPAN::META->instance($class,$arg);
2958 } else {
2959 next;
2960 }
2961 push @m, $obj;
2962 }
05454584 2963 }
ecc7fca0 2964 @m = sort {$a->id cmp $b->id} @m;
e82b9348
SP		 2965 if ( $CPAN::DEBUG ) {
2966 my $wantarray = wantarray;
2967 my $join_m = join ",", map {$_->id} @m;
2968 $self->debug("wantarray[$wantarray]join_m[$join_m]");
2969 }
e50380aa 2970 return wantarray ? @m : $m[0];
05454584
A		 2971}
2972
2973#-> sub CPAN::Shell::format_result ;
2974sub format_result {
2975 my($self) = shift;
2976 my($type,@args) = @_;
2977 @args = '/./' unless @args;
2978 my(@result) = $self->expand($type,@args);
8d97e4a1 2979 my $result = @result == 1 ?
f04ea8d1 2980 $result[0]->as_string :
8d97e4a1
JH		 2981 @result == 0 ?
2982 "No objects of type $type found for argument @args\n" :
2983 join("",
2984 (map {$_->as_glimpse} @result),
2985 scalar @result, " items found\n",
2986 );
05454584
A		 2987 $result;
2988}
2989
554a9ef5
SP		 2990#-> sub CPAN::Shell::report_fh ;
2991{
2992 my $installation_report_fh;
2993 my $previously_noticed = 0;
2994
2995 sub report_fh {
2996 return $installation_report_fh if $installation_report_fh;
b03f445c 2997 if ($CPAN::META->has_usable("File::Temp")) {
4d1321a7
A		 2998 $installation_report_fh
2999 = File::Temp->new(
917f1700 3000 dir => File::Spec->tmpdir,
4d1321a7
A		 3001 template => 'cpan_install_XXXX',
3002 suffix => '.txt',
3003 unlink => 0,
3004 );
3005 }
554a9ef5
SP		 3006 unless ( $installation_report_fh ) {
3007 warn("Couldn't open installation report file; " .
3008 "no report file will be generated."
3009 ) unless $previously_noticed++;
3010 }
3011 }
3012}
3013
3014
c356248b
A		 3015# The only reason for this method is currently to have a reliable
3016# debugging utility that reveals which output is going through which
3017# channel. No, I don't like the colors ;-)
8d97e4a1 3018
8962fc49
SP		 3019# to turn colordebugging on, write
3020# cpan> o conf colorize_output 1
3021
3022#-> sub CPAN::Shell::print_ornamented ;
3023{
3024 my $print_ornamented_have_warned = 0;
3025 sub colorize_output {
3026 my $colorize_output = $CPAN::Config->{colorize_output};
3027 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3028 unless ($print_ornamented_have_warned++) {
3029 # no myprint/mywarn within myprint/mywarn!
3030 warn "Colorize_output is set to true but Term::ANSIColor is not
3031installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3032 }
3033 $colorize_output = 0;
3034 }
3035 return $colorize_output;
3036 }
3037}
3038
3039
05bab18e 3040#-> sub CPAN::Shell::print_ornamented ;
c356248b
A		 3041sub print_ornamented {
3042 my($self,$what,$ornament) = @_;
8d97e4a1 3043 return unless defined $what;
c356248b 3044
554a9ef5
SP		 3045 local $| = 1; # Flush immediately
3046 if ( $CPAN::Be_Silent ) {
3047 print {report_fh()} $what;
3048 return;
3049 }
8962fc49 3050 my $swhat = "$what"; # stringify if it is an object
f04ea8d1
SP		 3051 if ($CPAN::Config->{term_is_latin}) {
3052 # note: deprecated, need to switch to $LANG and $LC_*
8d97e4a1 3053 # courtesy jhi:
8962fc49 3054 $swhat
8d97e4a1
JH		 3055 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3056 }
8962fc49 3057 if ($self->colorize_output) {
135a59c2
A		 3058 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3059 # if you want to have this configurable, please file a bugreport
b72dd56f 3060 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
135a59c2 3061 }
8962fc49
SP		 3062 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3063 if ($@) {
3064 print "Term::ANSIColor rejects color[$ornament]: $@\n
f20de9f0 3065Please choose a different color (Hint: try 'o conf init /color/')\n";
8962fc49 3066 }
f04ea8d1
SP		 3067 # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this
3068 # $trailer construct. We want the newline be the last thing if
3069 # there is a newline at the end ensuring that the next line is
3070 # empty for other players
3071 my $trailer = "";
3072 $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
135a59c2
A		 3073 print $color_on,
3074 $swhat,
f04ea8d1
SP		 3075 Term::ANSIColor::color("reset"),
3076 $trailer;
c356248b 3077 } else {
8962fc49 3078 print $swhat;
c356248b
A		 3079 }
3080}
3081
05bab18e
SP		 3082#-> sub CPAN::Shell::myprint ;
3083
f04ea8d1
SP		 3084# where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3085# I think, we send everything to STDOUT and use print for normal/good
3086# news and warn for news that need more attention. Yes, this is our
3087# working contract for now.
c356248b
A		 3088sub myprint {
3089 my($self,$what) = @_;
f04ea8d1
SP		 3090 $self->print_ornamented($what,
3091 $CPAN::Config->{colorize_print}||'bold blue on_white',
3092 );
3093}
8d97e4a1 3094
f04ea8d1
SP		 3095sub optprint {
3096 my($self,$category,$what) = @_;
3097 my $vname = $category . "_verbosity";
3098 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3099 if (!$CPAN::Config->{$vname}
3100 || $CPAN::Config->{$vname} =~ /^v/
3101 ) {
3102 $CPAN::Frontend->myprint($what);
3103 }
c356248b
A		 3104}
3105
05bab18e 3106#-> sub CPAN::Shell::myexit ;
c356248b
A		 3107sub myexit {
3108 my($self,$what) = @_;
3109 $self->myprint($what);
3110 exit;
3111}
3112
05bab18e 3113#-> sub CPAN::Shell::mywarn ;
c356248b
A		 3114sub mywarn {
3115 my($self,$what) = @_;
2ccf00a7 3116 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
c356248b
A		 3117}
3118
b96578bb 3119# only to be used for shell commands
05bab18e 3120#-> sub CPAN::Shell::mydie ;
c356248b
A		 3121sub mydie {
3122 my($self,$what) = @_;
dc053c64 3123 $self->mywarn($what);
b96578bb 3124
dc053c64 3125 # If it is the shell, we want the following die to be silent,
b96578bb
SP		 3126 # but if it is not the shell, we would need a 'die $what'. We need
3127 # to take care that only shell commands use mydie. Is this
3128 # possible?
3129
c356248b
A		 3130 die "\n";
3131}
3132
05bab18e 3133# sub CPAN::Shell::colorable_makemaker_prompt ;
8962fc49
SP		 3134sub colorable_makemaker_prompt {
3135 my($foo,$bar) = @_;
3136 if (CPAN::Shell->colorize_output) {
2ccf00a7 3137 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
8962fc49
SP		 3138 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3139 print $color_on;
3140 }
3141 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3142 if (CPAN::Shell->colorize_output) {
3143 print Term::ANSIColor::color('reset');
3144 }
3145 return $ans;
3146}
3147
c9869e1c 3148# use this only for unrecoverable errors!
05bab18e 3149#-> sub CPAN::Shell::unrecoverable_error ;
c9869e1c
SP		 3150sub unrecoverable_error {
3151 my($self,$what) = @_;
3152 my @lines = split /\n/, $what;
3153 my $longest = 0;
3154 for my $l (@lines) {
3155 $longest = length $l if length $l > $longest;
3156 }
3157 $longest = 62 if $longest > 62;
3158 for my $l (@lines) {
f04ea8d1 3159 if ($l =~ /^\s*$/) {
c9869e1c
SP		 3160 $l = "\n";
3161 next;
3162 }
3163 $l = "==> $l";
3164 if (length $l < 66) {
3165 $l = pack "A66 A*", $l, "<==";
3166 }
3167 $l .= "\n";
3168 }
3169 unshift @lines, "\n";
3170 $self->mydie(join "", @lines);
c9869e1c
SP		 3171}
3172
05bab18e 3173#-> sub CPAN::Shell::mysleep ;
9ddc4ed0
A		 3174sub mysleep {
3175 my($self, $sleep) = @_;
dc053c64
SP		 3176 if (CPAN->has_inst("Time::HiRes")) {
3177 Time::HiRes::sleep($sleep);
3178 } else {
3179 sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3180 }
9ddc4ed0
A		 3181}
3182
05bab18e 3183#-> sub CPAN::Shell::setup_output ;
911a92db
GS		 3184sub setup_output {
3185 return if -t STDOUT;
3186 my $odef = select STDERR;
3187 $| = 1;
3188 select STDOUT;
3189 $| = 1;
3190 select $odef;
3191}
3192
05454584 3193#-> sub CPAN::Shell::rematein ;
810a0276 3194# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
05454584 3195sub rematein {
0cf35e6a 3196 my $self = shift;
05454584 3197 my($meth,@some) = @_;
554a9ef5 3198 my @pragma;
b72dd56f 3199 while($meth =~ /^(ff?orce|notest)$/) {
f04ea8d1
SP		 3200 push @pragma, $meth;
3201 $meth = shift @some or
0cf35e6a
SP		 3202 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3203 "cannot continue");
05454584 3204 }
911a92db 3205 setup_output();
554a9ef5 3206 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
6d29edf5
JH		 3207
3208 # Here is the place to set "test_count" on all involved parties to
3209 # 0. We then can pass this counter on to the involved
3210 # distributions and those can refuse to test if test_count > X. In
3211 # the first stab at it we could use a 1 for "X".
3212
3213 # But when do I reset the distributions to start with 0 again?
3214 # Jost suggested to have a random or cycling interaction ID that
3215 # we pass through. But the ID is something that is just left lying
3216 # around in addition to the counter, so I'd prefer to set the
3217 # counter to 0 now, and repeat at the end of the loop. But what
3218 # about dependencies? They appear later and are not reset, they
3219 # enter the queue but not its copy. How do they get a sensible
3220 # test_count?
3221
f04ea8d1
SP		 3222 # With configure_requires, "get" is vulnerable in recursion.
3223
3224 my $needs_recursion_protection = "get|make|test|install";
f20de9f0 3225
6d29edf5
JH		 3226 # construct the queue
3227 my($s,@s,@qcopy);
0cf35e6a 3228 STHING: foreach $s (@some) {
f04ea8d1
SP		 3229 my $obj;
3230 if (ref $s) {
6d29edf5 3231 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
f04ea8d1
SP		 3232 $obj = $s;
3233 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3234 } elsif ($s =~ m|^/|) { # looks like a regexp
8fc516fe
SP		 3235 if (substr($s,-1,1) eq ".") {
3236 $obj = CPAN::Shell->expandany($s);
3237 } else {
3238 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3239 "not supported.\nRejecting argument '$s'\n");
3240 $CPAN::Frontend->mysleep(2);
3241 next;
3242 }
f04ea8d1 3243 } elsif ($meth eq "ls") {
ca79d794 3244 $self->globls($s,\@pragma);
0cf35e6a
SP		 3245 next STHING;
3246 } else {
6d29edf5 3247 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
f04ea8d1
SP		 3248 $obj = CPAN::Shell->expandany($s);
3249 }
3250 if (0) {
7d97ad34 3251 } elsif (ref $obj) {
f20de9f0 3252 if ($meth =~ /^($needs_recursion_protection)$/) {
ade94d80
SP		 3253 # it would be silly to check for recursion for look or dump
3254 # (we are in CPAN::Shell::rematein)
3255 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3256 eval { $obj->color_cmd_tmps(0,1); };
f04ea8d1 3257 if ($@) {
ade94d80
SP		 3258 if (ref $@
3259 and $@->isa("CPAN::Exception::RecursiveDependency")) {
3260 $CPAN::Frontend->mywarn($@);
3261 } else {
3262 if (0) {
3263 require Carp;
3264 Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3265 }
3266 die;
3267 }
3268 }
f20de9f0 3269 }
f04ea8d1 3270 CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
6d29edf5 3271 push @qcopy, $obj;
f04ea8d1
SP		 3272 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3273 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
dc053c64 3274 if ($meth =~ /^(dump|ls|reports)$/) {
5fc0f0f6 3275 $obj->$meth();
8d97e4a1 3276 } else {
8962fc49
SP		 3277 $CPAN::Frontend->mywarn(
3278 join "",
3279 "Don't be silly, you can't $meth ",
3280 $obj->fullname,
3281 " ;-)\n"
3282 );
3283 $CPAN::Frontend->mysleep(2);
8d97e4a1 3284 }
f04ea8d1 3285 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
135a59c2
A		 3286 CPAN::InfoObj->dump($s);
3287 } else {
f04ea8d1
SP		 3288 $CPAN::Frontend
3289 ->mywarn(qq{Warning: Cannot $meth $s, }.
3290 qq{don't know what it is.
e50380aa
A		 3291Try the command
3292
3293 i /$s/
3294
6d29edf5 3295to find objects with matching identifiers.
c356248b 3296});
8962fc49 3297 $CPAN::Frontend->mysleep(2);
f04ea8d1 3298 }
6d29edf5
JH		 3299 }
3300
3301 # queuerunner (please be warned: when I started to change the
3302 # queue to hold objects instead of names, I made one or two
3303 # mistakes and never found which. I reverted back instead)
135a59c2 3304 while (my $q = CPAN::Queue->first) {
6d29edf5 3305 my $obj;
135a59c2
A		 3306 my $s = $q->as_string;
3307 my $reqtype = $q->reqtype || "";
3308 $obj = CPAN::Shell->expandany($s);
f20de9f0
SP		 3309 unless ($obj) {
3310 # don't know how this can happen, maybe we should panic,
3311 # but maybe we get a solution from the first user who hits
3312 # this unfortunate exception?
3313 $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
2b3bde2a 3314 "to an object. Skipping.\n");
f20de9f0 3315 $CPAN::Frontend->mysleep(5);
2b3bde2a 3316 CPAN::Queue->delete_first($s);
f20de9f0
SP		 3317 next;
3318 }
135a59c2 3319 $obj->{reqtype} ||= "";
810a0276
SP		 3320 {
3321 # force debugging because CPAN::SQLite somehow delivers us
3322 # an empty object;
3323
3324 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3325
3326 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3327 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3328 }
135a59c2
A		 3329 if ($obj->{reqtype}) {
3330 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3331 $obj->{reqtype} = $reqtype;
3332 if (
3333 exists $obj->{install}
3334 &&
3335 (
be34b10d 3336 UNIVERSAL::can($obj->{install},"failed") ?
135a59c2
A		 3337 $obj->{install}->failed :
3338 $obj->{install} =~ /^NO/
3339 )
3340 ) {
3341 delete $obj->{install};
3342 $CPAN::Frontend->mywarn
3343 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3344 }
3345 }
3346 } else {
3347 $obj->{reqtype} = $reqtype;
3348 }
3349
f04ea8d1
SP		 3350 for my $pragma (@pragma) {
3351 if ($pragma
3352 &&
3353 $obj->can($pragma)) {
3354 $obj->$pragma($meth);
3355 }
6d29edf5 3356 }
810a0276 3357 if (UNIVERSAL::can($obj, 'called_for')) {
6d29edf5
JH		 3358 $obj->called_for($s);
3359 }
135a59c2
A		 3360 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3361 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
6d29edf5 3362
6a935156 3363 push @qcopy, $obj;
f04ea8d1
SP		 3364 if ($meth =~ /^(report)$/) { # they came here with a pragma?
3365 $self->$meth($obj);
3366 } elsif (! UNIVERSAL::can($obj,$meth)) {
810a0276
SP		 3367 # Must never happen
3368 my $serialized = "";
3369 if (0) {
3370 } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3371 $serialized = YAML::Syck::Dump($obj);
3372 } elsif ($CPAN::META->has_inst("YAML")) {
3373 $serialized = YAML::Dump($obj);
3374 } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3375 $serialized = Data::Dumper::Dumper($obj);
3376 } else {
3377 require overload;
3378 $serialized = overload::StrVal($obj);
3379 }
23a216b4 3380 CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
810a0276 3381 $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
f04ea8d1 3382 } elsif ($obj->$meth()) {
6d29edf5 3383 CPAN::Queue->delete($s);
23a216b4 3384 CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
6d29edf5 3385 } else {
23a216b4 3386 CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
6d29edf5
JH		 3387 }
3388
3389 $obj->undelay;
f04ea8d1 3390 for my $pragma (@pragma) {
05bab18e 3391 my $unpragma = "un$pragma";
f04ea8d1
SP		 3392 if ($obj->can($unpragma)) {
3393 $obj->$unpragma();
3394 }
05bab18e 3395 }
f04ea8d1 3396 CPAN::Queue->delete_first($s);
05454584 3397 }
f20de9f0
SP		 3398 if ($meth =~ /^($needs_recursion_protection)$/) {
3399 for my $obj (@qcopy) {
3400 $obj->color_cmd_tmps(0,0);
3401 }
6d29edf5 3402 }
05454584
A		 3403}
3404
554a9ef5
SP		 3405#-> sub CPAN::Shell::recent ;
3406sub recent {
f3fe0ae6 3407 my($self) = @_;
f04ea8d1
SP		 3408 if ($CPAN::META->has_inst("XML::LibXML")) {
3409 my $url = $CPAN::Defaultrecent;
3410 $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3411 unless ($CPAN::META->has_usable("LWP")) {
3412 $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3413 }
3414 CPAN::LWP::UserAgent->config;
3415 my $Ua;
3416 eval { $Ua = CPAN::LWP::UserAgent->new; };
3417 if ($@) {
3418 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3419 }
3420 my $resp = $Ua->get($url);
3421 unless ($resp->is_success) {
3422 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3423 }
3424 $CPAN::Frontend->myprint("DONE\n\n");
3425 my $xml = XML::LibXML->new->parse_string($resp->content);
3426 if (0) {
3427 my $s = $xml->serialize(2);
3428 $s =~ s/\n\s*\n/\n/g;
3429 $CPAN::Frontend->myprint($s);
3430 return;
3431 }
3432 my @distros;
3433 if ($url =~ /winnipeg/) {
3434 my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3435 $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
3436 for my $eitem ($xml->findnodes("/rss/channel/item")) {
3437 my $distro = $eitem->findvalue("enclosure/\@url");
3438 $distro =~ s|.*?/authors/id/./../||;
3439 my $size = $eitem->findvalue("enclosure/\@length");
3440 my $desc = $eitem->findvalue("description");
3441\0 $desc =~ s/.+? - //;
3442 $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
3443 push @distros, $distro;
3444 }
3445 } elsif ($url =~ /search.*uploads.rdf/) {
3446 # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3447 # xmlns="http://purl.org/rss/1.0/"
3448 # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3449 # xmlns:dc="http://purl.org/dc/elements/1.1/"
3450 # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3451 # xmlns:admin="http://webns.net/mvcb/"
3452
3453
3454 my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3455 $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
3456 my $finish_eitem = 0;
3457 local $SIG{INT} = sub { $finish_eitem = 1 };
3458 EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3459 my $distro = $eitem->findvalue("\@rdf:about");
3460 $distro =~ s|.*~||; # remove up to the tilde before the name
3461 $distro =~ s|/$||; # remove trailing slash
3462 $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3463 my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3464 my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
3465 my $i = 0;
3466 SUBDIRTEST: while () {
3467 last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3468 if (my @ret = $self->globls("$distro*")) {
3469 @ret = grep {$_->[2] !~ /meta/} @ret;
3470 @ret = grep {length $_->[2]} @ret;
3471 if (@ret) {
3472 $distro = "$author/$ret[0][2]";
3473 last SUBDIRTEST;
3474 }
3475 }
3476 $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3477 }
3478
3479 next EITEM if $distro =~ m|\*|; # did not find the thing
3480 $CPAN::Frontend->myprint("____$desc\n");
3481 push @distros, $distro;
3482 last EITEM if $finish_eitem;
3483 }
3484 }
3485 return \@distros;
3486 } else {
3487 # deprecated old version
3488 $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3489 }
3490}
554a9ef5 3491
f04ea8d1
SP		 3492#-> sub CPAN::Shell::smoke ;
3493sub smoke {
3494 my($self) = @_;
3495 my $distros = $self->recent;
3496 DISTRO: for my $distro (@$distros) {
3497 $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3498 {
3499 my $skip = 0;
3500 local $SIG{INT} = sub { $skip = 1 };
3501 for (0..9) {
3502 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3503 sleep 1;
3504 if ($skip) {
3505 $CPAN::Frontend->myprint(" skipped\n");
3506 next DISTRO;
3507 }
3508 }
3509 }
3510 $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
3511 $self->test($distro);
3512 }
554a9ef5
SP		 3513}
3514
3515{
3516 # set up the dispatching methods
3517 no strict "refs";
3518 for my $command (qw(
0cf35e6a
SP		 3519 clean
3520 cvs_import
3521 dump
3522 force
b72dd56f 3523 fforce
0cf35e6a
SP		 3524 get
3525 install
3526 look
3527 ls
3528 make
3529 notest
3530 perldoc
3531 readme
dc053c64 3532 reports
0cf35e6a 3533 test
554a9ef5
SP		 3534 )) {
3535 *$command = sub { shift->rematein($command, @_); };
3536 }
3537}
05454584 3538
c049f953 3539package CPAN::LWP::UserAgent;
e82b9348 3540use strict;
c049f953
JH		 3541
3542sub config {
3543 return if $SETUPDONE;
3544 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3545 require LWP::UserAgent;
3546 @ISA = qw(Exporter LWP::UserAgent);
3547 $SETUPDONE++;
3548 } else {
8962fc49 3549 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
c049f953
JH		 3550 }
3551}
3552
3553sub get_basic_credentials {
3554 my($self, $realm, $uri, $proxy) = @_;
c049f953 3555 if ($USER && $PASSWD) {
ed84aac9
A		 3556 return ($USER, $PASSWD);
3557 }
3558 if ( $proxy ) {
3559 ($USER,$PASSWD) = $self->get_proxy_credentials();
c049f953 3560 } else {
ed84aac9
A		 3561 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3562 }
3563 return($USER,$PASSWD);
3564}
3565
3566sub get_proxy_credentials {
3567 my $self = shift;
3568 my ($user, $password);
3569 if ( defined $CPAN::Config->{proxy_user} &&
3570 defined $CPAN::Config->{proxy_pass}) {
3571 $user = $CPAN::Config->{proxy_user};
3572 $password = $CPAN::Config->{proxy_pass};
3573 return ($user, $password);
3574 }
3575 my $username_prompt = "\nProxy authentication needed!
c049f953
JH		 3576 (Note: to permanently configure username and password run
3577 o conf proxy_user your_username
3578 o conf proxy_pass your_password
ed84aac9
A		 3579 )\nUsername:";
3580 ($user, $password) =
3581 _get_username_and_password_from_user($username_prompt);
3582 return ($user,$password);
3583}
3584
3585sub get_non_proxy_credentials {
3586 my $self = shift;
3587 my ($user,$password);
3588 if ( defined $CPAN::Config->{username} &&
3589 defined $CPAN::Config->{password}) {
3590 $user = $CPAN::Config->{username};
3591 $password = $CPAN::Config->{password};
3592 return ($user, $password);
3593 }
3594 my $username_prompt = "\nAuthentication needed!
3595 (Note: to permanently configure username and password run
3596 o conf username your_username
3597 o conf password your_password
3598 )\nUsername:";
8962fc49 3599
ed84aac9
A		 3600 ($user, $password) =
3601 _get_username_and_password_from_user($username_prompt);
3602 return ($user,$password);
3603}
3604
3605sub _get_username_and_password_from_user {
ed84aac9
A		 3606 my $username_message = shift;
3607 my ($username,$password);
3608
3609 ExtUtils::MakeMaker->import(qw(prompt));
3610 $username = prompt($username_message);
c049f953
JH		 3611 if ($CPAN::META->has_inst("Term::ReadKey")) {
3612 Term::ReadKey::ReadMode("noecho");
c049f953 3613 }
ed84aac9
A		 3614 else {
3615 $CPAN::Frontend->mywarn(
3616 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3617 );
3618 }
3619 $password = prompt("Password:");
3620
c049f953
JH		 3621 if ($CPAN::META->has_inst("Term::ReadKey")) {
3622 Term::ReadKey::ReadMode("restore");
3623 }
3624 $CPAN::Frontend->myprint("\n\n");
ed84aac9 3625 return ($username,$password);
c049f953
JH		 3626}
3627
1426a145
JH		 3628# mirror(): Its purpose is to deal with proxy authentication. When we
3629# call SUPER::mirror, we relly call the mirror method in
3630# LWP::UserAgent. LWP::UserAgent will then call
3631# $self->get_basic_credentials or some equivalent and this will be
3632# $self->dispatched to our own get_basic_credentials method.
3633
3634# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3635
3636# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3637# although we have gone through our get_basic_credentials, the proxy
3638# server refuses to connect. This could be a case where the username or
3639# password has changed in the meantime, so I'm trying once again without
3640# $USER and $PASSWD to give the get_basic_credentials routine another
3641# chance to set $USER and $PASSWD.
3642
554a9ef5
SP		 3643# mirror(): Its purpose is to deal with proxy authentication. When we
3644# call SUPER::mirror, we relly call the mirror method in
3645# LWP::UserAgent. LWP::UserAgent will then call
3646# $self->get_basic_credentials or some equivalent and this will be
3647# $self->dispatched to our own get_basic_credentials method.
3648
3649# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3650
3651# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3652# although we have gone through our get_basic_credentials, the proxy
3653# server refuses to connect. This could be a case where the username or
3654# password has changed in the meantime, so I'm trying once again without
3655# $USER and $PASSWD to give the get_basic_credentials routine another
3656# chance to set $USER and $PASSWD.
3657
c049f953
JH		 3658sub mirror {
3659 my($self,$url,$aslocal) = @_;
3660 my $result = $self->SUPER::mirror($url,$aslocal);
3661 if ($result->code == 407) {
3662 undef $USER;
3663 undef $PASSWD;
3664 $result = $self->SUPER::mirror($url,$aslocal);
3665 }
3666 $result;
3667}
3668
05454584 3669package CPAN::FTP;
e82b9348 3670use strict;
05454584 3671
05bab18e
SP		 3672#-> sub CPAN::FTP::ftp_statistics
3673# if they want to rewrite, they need to pass in a filehandle
3674sub _ftp_statistics {
3675 my($self,$fh) = @_;
3676 my $locktype = $fh ? LOCK_EX : LOCK_SH;
3677 $fh ||= FileHandle->new;
3678 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3679 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3680 my $sleep = 1;
810a0276 3681 my $waitstart;
f04ea8d1 3682 while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
810a0276 3683 $waitstart ||= localtime();
05bab18e 3684 if ($sleep>3) {
810a0276 3685 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
be34b10d
SP		 3686 }
3687 $CPAN::Frontend->mysleep($sleep);
3688 if ($sleep <= 3) {
3689 $sleep+=0.33;
810a0276
SP		 3690 } elsif ($sleep <=6) {
3691 $sleep+=0.11;
05bab18e 3692 }
05bab18e 3693 }
b72dd56f
SP		 3694 my $stats = eval { CPAN->_yaml_loadfile($file); };
3695 if ($@) {
3696 if (ref $@) {
3697 if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3698 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3699 return;
3700 } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3701 $CPAN::Frontend->mydie($@);
3702 }
3703 } else {
3704 $CPAN::Frontend->mydie($@);
3705 }
3706 }
05bab18e
SP		 3707 return $stats->[0];
3708}
3709
810a0276 3710#-> sub CPAN::FTP::_mytime
05bab18e
SP		 3711sub _mytime () {
3712 if (CPAN->has_inst("Time::HiRes")) {
3713 return Time::HiRes::time();
3714 } else {
3715 return time;
3716 }
3717}
3718
810a0276 3719#-> sub CPAN::FTP::_new_stats
05bab18e
SP		 3720sub _new_stats {
3721 my($self,$file) = @_;
3722 my $ret = {
3723 file => $file,
3724 attempts => [],
3725 start => _mytime,
3726 };
3727 $ret;
3728}
3729
810a0276 3730#-> sub CPAN::FTP::_add_to_statistics
05bab18e
SP		 3731sub _add_to_statistics {
3732 my($self,$stats) = @_;
b72dd56f 3733 my $yaml_module = CPAN::_yaml_module;
f20de9f0 3734 $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
810a0276
SP		 3735 if ($CPAN::META->has_inst($yaml_module)) {
3736 $stats->{thesiteurl} = $ThesiteURL;
3737 if (CPAN->has_inst("Time::HiRes")) {
3738 $stats->{end} = Time::HiRes::time();
3739 } else {
3740 $stats->{end} = time;
3741 }
3742 my $fh = FileHandle->new;
b72dd56f
SP		 3743 my $time = time;
3744 my $sdebug = 0;
3745 my @debug;
3746 @debug = $time if $sdebug;
810a0276 3747 my $fullstats = $self->_ftp_statistics($fh);
b72dd56f 3748 close $fh;
810a0276 3749 $fullstats->{history} ||= [];
b72dd56f
SP		 3750 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3751 push @debug, time if $sdebug;
810a0276 3752 push @{$fullstats->{history}}, $stats;
b72dd56f 3753 # arbitrary hardcoded constants until somebody demands to have
ed756621
SP		 3754 # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3755 # YAML::Syck 0.82 has no noticable performance problem with 999;
b72dd56f 3756 while (
ed756621
SP		 3757 @{$fullstats->{history}} > 99
3758 || $time - $fullstats->{history}[0]{start} > 14*86400
b72dd56f
SP		 3759 ) {
3760 shift @{$fullstats->{history}}
3761 }
3762 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3763 push @debug, time if $sdebug;
3764 push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3765 # need no eval because if this fails, it is serious
3766 my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3767 CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
ade94d80 3768 if ( $sdebug ) {
b72dd56f
SP		 3769 local $CPAN::DEBUG = 512; # FTP
3770 push @debug, time;
3771 CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3772 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
810a0276 3773 @debug,
b72dd56f 3774 ));
810a0276 3775 }
b72dd56f
SP		 3776 # Win32 cannot rename a file to an existing filename
3777 unlink($sfile) if ($^O eq 'MSWin32');
3778 rename "$sfile.$$", $sfile
3779 or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
05bab18e 3780 }
05bab18e
SP		 3781}
3782
3783# if file is CHECKSUMS, suggest the place where we got the file to be
3784# checked from, maybe only for young files?
810a0276 3785#-> sub CPAN::FTP::_recommend_url_for
05bab18e
SP		 3786sub _recommend_url_for {
3787 my($self, $file) = @_;
3788 my $urllist = $self->_get_urllist;
3789 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3790 my $fullstats = $self->_ftp_statistics();
3791 my $history = $fullstats->{history} || [];
3792 while (my $last = pop @$history) {
3793 last if $last->{end} - time > 3600; # only young results are interesting
be34b10d 3794 next unless $last->{file}; # dirname of nothing dies!
05bab18e
SP		 3795 next unless $file eq File::Basename::dirname($last->{file});
3796 return $last->{thesiteurl};
3797 }
3798 }
3799 if ($CPAN::Config->{randomize_urllist}
3800 &&
3801 rand(1) < $CPAN::Config->{randomize_urllist}
3802 ) {
3803 $urllist->[int rand scalar @$urllist];
3804 } else {
3805 return ();
3806 }
3807}
3808
810a0276 3809#-> sub CPAN::FTP::_get_urllist
05bab18e
SP		 3810sub _get_urllist {
3811 my($self) = @_;
3812 $CPAN::Config->{urllist} ||= [];
3813 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3814 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
3815 $CPAN::Config->{urllist} = [];
3816 }
3817 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3818 for my $u (@urllist) {
3819 CPAN->debug("u[$u]") if $CPAN::DEBUG;
3820 if (UNIVERSAL::can($u,"text")) {
3821 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3822 } else {
3823 $u .= "/" unless substr($u,-1) eq "/";
3824 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3825 }
3826 }
3827 \@urllist;
3828}
3829
05454584
A		 3830#-> sub CPAN::FTP::ftp_get ;
3831sub ftp_get {
9ddc4ed0
A		 3832 my($class,$host,$dir,$file,$target) = @_;
3833 $class->debug(
3834 qq[Going to fetch file [$file] from dir [$dir]
05454584 3835 on host [$host] as local [$target]\n]
9ddc4ed0
A		 3836 ) if $CPAN::DEBUG;
3837 my $ftp = Net::FTP->new($host);
3838 unless ($ftp) {
3839 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
3840 return;
3841 }
3842 return 0 unless defined $ftp;
3843 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3844 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
f04ea8d1 3845 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
9ddc4ed0
A		 3846 my $msg = $ftp->message;
3847 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
3848 return;
3849 }
f04ea8d1 3850 unless ( $ftp->cwd($dir) ) {
9ddc4ed0
A		 3851 my $msg = $ftp->message;
3852 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
3853 return;
3854 }
3855 $ftp->binary;
3856 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
f04ea8d1 3857 unless ( $ftp->get($file,$target) ) {
9ddc4ed0
A		 3858 my $msg = $ftp->message;
3859 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
3860 return;
3861 }
3862 $ftp->quit; # it's ok if this fails
3863 return 1;
05454584
A		 3864}
3865
09d9d230 3866# If more accuracy is wanted/needed, Chris Leach sent me this patch...
f610777f 3867
6d29edf5
JH		 3868 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
3869 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
3870 # > ***************
3871 # > *** 1562,1567 ****
3872 # > --- 1562,1580 ----
3873 # > return 1 if substr($url,0,4) eq "file";
3874 # > return 1 unless $url =~ m|://([^/]+)|;
3875 # > my $host = $1;
3876 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3877 # > + if ($proxy) {
3878 # > + $proxy =~ m|://([^/:]+)|;
3879 # > + $proxy = $1;
3880 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3881 # > + if ($noproxy) {
3882 # > + if ($host !~ /$noproxy$/) {
3883 # > + $host = $proxy;
3884 # > + }
3885 # > + } else {
3886 # > + $host = $proxy;
3887 # > + }
3888 # > + }
3889 # > require Net::Ping;
3890 # > return 1 unless $Net::Ping::VERSION >= 2;
3891 # > my $p;
09d9d230
A		 3892
3893
05454584
A		 3894#-> sub CPAN::FTP::localize ;
3895sub localize {
3896 my($self,$file,$aslocal,$force) = @_;
3897 $force ||= 0;
3898 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
f04ea8d1 3899 unless defined $aslocal;
55e314ee 3900 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
f04ea8d1 3901 if $CPAN::DEBUG;
05454584 3902
f14b5cec 3903 if ($^O eq 'MacOS') {
6d29edf5
JH		 3904 # Comment by AK on 2000-09-03: Uniq short filenames would be
3905 # available in CHECKSUMS file
f14b5cec
JH		 3906 my($name, $path) = File::Basename::fileparse($aslocal, '');
3907 if (length($name) > 31) {
6d29edf5
JH		 3908 $name =~ s/(
3909 \.(
3910 readme(\.(gz|Z))? |
3911 (tar\.)?(gz|Z) |
3912 tgz |
3913 zip |
3914 pm\.(gz|Z)
3915 )
3916 )$//x;
f14b5cec
JH		 3917 my $suf = $1;
3918 my $size = 31 - length($suf);
3919 while (length($name) > $size) {
3920 chop $name;
3921 }
3922 $name .= $suf;
3923 $aslocal = File::Spec->catfile($path, $name);
3924 }
3925 }
3926
f04ea8d1 3927 if (-f $aslocal && -r _ && !($force & 1)) {
b96578bb
SP		 3928 my $size;
3929 if ($size = -s $aslocal) {
3930 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3931 return $aslocal;
3932 } else {
3933 # empty file from a previous unsuccessful attempt to download it
3934 unlink $aslocal or
ed84aac9
A		 3935 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3936 "could not remove.");
b96578bb 3937 }
0cf35e6a 3938 }
05bab18e 3939 my($maybe_restore) = 0;
f04ea8d1
SP		 3940 if (-f $aslocal) {
3941 rename $aslocal, "$aslocal.bak$$";
3942 $maybe_restore++;
55e314ee 3943 }
05454584
A		 3944
3945 my($aslocal_dir) = File::Basename::dirname($aslocal);
f04ea8d1 3946 $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
05454584 3947 # Inheritance is not easier to manage than a few if/else branches
de34a54b 3948 if ($CPAN::META->has_usable('LWP::UserAgent')) {
f04ea8d1 3949 unless ($Ua) {
c049f953 3950 CPAN::LWP::UserAgent->config;
f04ea8d1 3951 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
d8773709 3952 if ($@) {
5fc0f0f6 3953 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
d8773709
JH		 3954 if $CPAN::DEBUG;
3955 } else {
3956 my($var);
3957 $Ua->proxy('ftp', $var)
3958 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3959 $Ua->proxy('http', $var)
3960 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3961 $Ua->no_proxy($var)
3962 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3963 }
f04ea8d1 3964 }
05454584 3965 }
35576f8c
A		 3966 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3967 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3968 }
05454584
A		 3969
3970 # Try the list of urls for each single object. We keep a record
3971 # where we did get a file from
c356248b 3972 my(@reordered,$last);
05bab18e
SP		 3973 my $ccurllist = $self->_get_urllist;
3974 $last = $#$ccurllist;
c356248b 3975 if ($force & 2) { # local cpans probably out of date, don't reorder
f04ea8d1 3976 @reordered = (0..$last);
c356248b 3977 } else {
f04ea8d1
SP		 3978 @reordered =
3979 sort {
3980 (substr($ccurllist->[$b],0,4) eq "file")
3981 <=>
3982 (substr($ccurllist->[$a],0,4) eq "file")
3983 or
3984 defined($ThesiteURL)
3985 and
05bab18e 3986 ($ccurllist->[$b] eq $ThesiteURL)
f04ea8d1 3987 <=>
05bab18e 3988 ($ccurllist->[$a] eq $ThesiteURL)
f04ea8d1 3989 } 0..$last;
c356248b 3990 }
c4d24d4c 3991 my(@levels);
7fefbd44 3992 $Themethod ||= "";
05bab18e 3993 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
f04ea8d1
SP		 3994 my @all_levels = (
3995 ["dleasy", "file"],
3996 ["dleasy"],
3997 ["dlhard"],
3998 ["dlhardest"],
3999 ["dleasy", "http","defaultsites"],
4000 ["dlhard", "http","defaultsites"],
4001 ["dleasy", "ftp", "defaultsites"],
4002 ["dlhard", "ftp", "defaultsites"],
4003 ["dlhardest","", "defaultsites"],
4004 );
c356248b 4005 if ($Themethod) {
f04ea8d1
SP		 4006 @levels = grep {$_->[0] eq $Themethod} @all_levels;
4007 push @levels, grep {$_->[0] ne $Themethod} @all_levels;
c356248b 4008 } else {
f04ea8d1 4009 @levels = @all_levels;
c356248b 4010 }
f04ea8d1 4011 @levels = qw/dleasy/ if $^O eq 'MacOS';
c4d24d4c 4012 my($levelno);
f04ea8d1 4013 local $ENV{FTP_PASSIVE} =
4d1321a7
A		 4014 exists $CPAN::Config->{ftp_passive} ?
4015 $CPAN::Config->{ftp_passive} : 1;
05bab18e
SP		 4016 my $ret;
4017 my $stats = $self->_new_stats($file);
4018 LEVEL: for $levelno (0..$#levels) {
f04ea8d1
SP		 4019 my $level_tuple = $levels[$levelno];
4020 my($level,$scheme,$sitetag) = @$level_tuple;
4021 my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4022 my @urllist;
4023 if ($defaultsites) {
4024 unless (defined $connect_to_internet_ok) {
4025 $CPAN::Frontend->myprint(sprintf qq{
4026I would like to connect to one of the following sites to get '%s':
4027
4028%s
4029},
4030 $file,
4031 join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4032 );
4033 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4034 if ($answer =~ /^y/i) {
4035 $connect_to_internet_ok = 1;
4036 } else {
4037 $connect_to_internet_ok = 0;
4038 }
4039 }
4040 if ($connect_to_internet_ok) {
4041 @urllist = @CPAN::Defaultsites;
4042 } else {
4043 @urllist = ();
4044 }
4045 } else {
4046 my @host_seq = $level =~ /dleasy/ ?
4047 @reordered : 0..$last; # reordered has file and $Thesiteurl first
4048 @urllist = map { $ccurllist->[$_] } @host_seq;
ca79d794
SP		 4049 }
4050 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
05bab18e
SP		 4051 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4052 if (my $recommend = $self->_recommend_url_for($file)) {
4053 @urllist = grep { $_ ne $recommend } @urllist;
4054 unshift @urllist, $recommend;
4055 }
4056 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
f04ea8d1
SP		 4057 $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4058 if ($ret) {
05bab18e
SP		 4059 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4060 if ($ret eq $aslocal_tempfile) {
4061 # if we got it exactly as we asked for, only then we
4062 # want to rename
4063 rename $aslocal_tempfile, $aslocal
4064 or $CPAN::Frontend->mydie("Error while trying to rename ".
4065 "'$ret' to '$aslocal': $!");
4066 $ret = $aslocal;
4067 }
4068 $Themethod = $level;
4069 my $now = time;
4070 # utime $now, $now, $aslocal; # too bad, if we do that, we
4071 # might alter a local mirror
4072 $self->debug("level[$level]") if $CPAN::DEBUG;
4073 last LEVEL;
f04ea8d1 4074 } else {
05bab18e
SP		 4075 unlink $aslocal_tempfile;
4076 last if $CPAN::Signal; # need to cleanup
f04ea8d1 4077 }
c356248b 4078 }
05bab18e
SP		 4079 if ($ret) {
4080 $stats->{filesize} = -s $ret;
4081 }
f20de9f0 4082 $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
05bab18e 4083 $self->_add_to_statistics($stats);
f20de9f0 4084 $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
05bab18e 4085 if ($ret) {
be34b10d 4086 unlink "$aslocal.bak$$";
05bab18e
SP		 4087 return $ret;
4088 }
c4d24d4c
A		 4089 unless ($CPAN::Signal) {
4090 my(@mess);
8962fc49
SP		 4091 local $" = " ";
4092 if (@{$CPAN::Config->{urllist}}) {
4093 push @mess,
4094 qq{Please check, if the URLs I found in your configuration file \(}.
4095 join(", ", @{$CPAN::Config->{urllist}}).
4096 qq{\) are valid.};
4097 } else {
4098 push @mess, qq{Your urllist is empty!};
4099 }
4100 push @mess, qq{The urllist can be edited.},
4101 qq{E.g. with 'o conf urllist push ftp://myurl/'};
4102 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4103 $CPAN::Frontend->mywarn("Could not fetch $file\n");
4104 $CPAN::Frontend->mysleep(2);
c4d24d4c 4105 }
05bab18e 4106 if ($maybe_restore) {
f04ea8d1
SP		 4107 rename "$aslocal.bak$$", $aslocal;
4108 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4109 $self->ls($aslocal));
4110 return $aslocal;
c356248b
A		 4111 }
4112 return;
4113}
4114
f04ea8d1
SP		 4115sub mymkpath {
4116 my($self, $aslocal_dir) = @_;
4117 File::Path::mkpath($aslocal_dir);
4118 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4119 qq{directory "$aslocal_dir".
4120 I\'ll continue, but if you encounter problems, they may be due
4121 to insufficient permissions.\n}) unless -w $aslocal_dir;
4122}
4123
4124sub hostdlxxx {
4125 my $self = shift;
4126 my $level = shift;
4127 my $scheme = shift;
4128 my $h = shift;
4129 $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4130 my $method = "host$level";
4131 $self->$method($h, @_);
4132}
4133
05bab18e
SP		 4134sub _set_attempt {
4135 my($self,$stats,$method,$url) = @_;
4136 push @{$stats->{attempts}}, {
4137 method => $method,
4138 start => _mytime,
4139 url => $url,
4140 };
4141}
4142
ca79d794 4143# package CPAN::FTP;
f04ea8d1 4144sub hostdleasy {
05bab18e 4145 my($self,$host_seq,$file,$aslocal,$stats) = @_;
ca79d794
SP		 4146 my($ro_url);
4147 HOSTEASY: for $ro_url (@$host_seq) {
f04ea8d1
SP		 4148 $self->_set_attempt($stats,"dleasy",$ro_url);
4149 my $url .= "$ro_url$file";
4150 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4151 if ($url =~ /^file:/) {
4152 my $l;
4153 if ($CPAN::META->has_inst('URI::URL')) {
4154 my $u = URI::URL->new($url);
4155 $l = $u->path;
4156 } else { # works only on Unix, is poorly constructed, but
4157 # hopefully better than nothing.
4158 # RFC 1738 says fileurl BNF is
4159 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4160 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4161 # the code
4162 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4163 $l =~ s|^file:||; # assume they
36263cb3
GS		 4164 # meant
4165 # file://localhost
f04ea8d1 4166 $l =~ s|^/||s
4d1321a7 4167 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
f04ea8d1 4168 }
4d1321a7 4169 $self->debug("local file[$l]") if $CPAN::DEBUG;
f04ea8d1
SP		 4170 if ( -f $l && -r _) {
4171 $ThesiteURL = $ro_url;
4172 return $l;
4173 }
4d1321a7
A		 4174 if ($l =~ /(.+)\.gz$/) {
4175 my $ungz = $1;
4176 if ( -f $ungz && -r _) {
4177 $ThesiteURL = $ro_url;
4178 return $ungz;
4179 }
4180 }
f04ea8d1
SP		 4181 # Maybe mirror has compressed it?
4182 if (-f "$l.gz") {
4183 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4184 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4185 if ( -f $aslocal) {
4186 $ThesiteURL = $ro_url;
4187 return $aslocal;
4188 }
4189 }
4190 $CPAN::Frontend->mywarn("Could not find '$l'\n");
4191 }
4192 $self->debug("it was not a file URL") if $CPAN::DEBUG;
c4d24d4c 4193 if ($CPAN::META->has_usable('LWP')) {
7fefbd44 4194 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
A		 4195 $url
4196");
7fefbd44
RGS		 4197 unless ($Ua) {
4198 CPAN::LWP::UserAgent->config;
4199 eval { $Ua = CPAN::LWP::UserAgent->new; };
4200 if ($@) {
4201 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4202 }
4203 }
4204 my $res = $Ua->mirror($url, $aslocal);
4205 if ($res->is_success) {
4206 $ThesiteURL = $ro_url;
4207 my $now = time;
4208 utime $now, $now, $aslocal; # download time is more
4209 # important than upload
4210 # time
4211 return $aslocal;
4212 } elsif ($url !~ /\.gz(?!\n)\Z/) {
4213 my $gzurl = "$url.gz";
4214 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
A		 4215 $gzurl
4216");
7fefbd44 4217 $res = $Ua->mirror($gzurl, "$aslocal.gz");
be34b10d
SP		 4218 if ($res->is_success) {
4219 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4220 $ThesiteURL = $ro_url;
4221 return $aslocal;
4222 }
7fefbd44
RGS		 4223 }
4224 } else {
4225 $CPAN::Frontend->myprint(sprintf(
4226 "LWP failed with code[%s] message[%s]\n",
4227 $res->code,
4228 $res->message,
4229 ));
4230 # Alan Burlison informed me that in firewall environments
4231 # Net::FTP can still succeed where LWP fails. So we do not
4232 # skip Net::FTP anymore when LWP is available.
4233 }
7fefbd44 4234 } else {
8962fc49 4235 $CPAN::Frontend->mywarn(" LWP not available\n");
f04ea8d1 4236 }
c4d24d4c 4237 return if $CPAN::Signal;
f04ea8d1
SP		 4238 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4239 # that's the nice and easy way thanks to Graham
05bab18e 4240 $self->debug("recognized ftp") if $CPAN::DEBUG;
f04ea8d1
SP		 4241 my($host,$dir,$getfile) = ($1,$2,$3);
4242 if ($CPAN::META->has_usable('Net::FTP')) {
4243 $dir =~ s|/+|/|g;
4244 $CPAN::Frontend->myprint("Fetching with Net::FTP:
09d9d230 4245 $url
c356248b 4246");
f04ea8d1
SP		 4247 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4248 "aslocal[$aslocal]") if $CPAN::DEBUG;
4249 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4250 $ThesiteURL = $ro_url;
4251 return $aslocal;
4252 }
4253 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4254 my $gz = "$aslocal.gz";
4255 $CPAN::Frontend->myprint("Fetching with Net::FTP
09d9d230 4256 $url.gz
c356248b 4257");
e82b9348
SP		 4258 if (CPAN::FTP->ftp_get($host,
4259 $dir,
4260 "$getfile.gz",
4261 $gz) &&
f04ea8d1
SP		 4262 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4263 ) {
4264 $ThesiteURL = $ro_url;
4265 return $aslocal;
4266 }
4267 }
4268 # next HOSTEASY;
4269 } else {
05bab18e
SP		 4270 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4271 }
f04ea8d1 4272 }
05bab18e
SP		 4273 if (
4274 UNIVERSAL::can($ro_url,"text")
4275 and
4276 $ro_url->{FROM} eq "USER"
f04ea8d1 4277 ) {
05bab18e
SP		 4278 ##address #17973: default URLs should not try to override
4279 ##user-defined URLs just because LWP is not available
f04ea8d1 4280 my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
05bab18e
SP		 4281 return $ret if $ret;
4282 }
c4d24d4c 4283 return if $CPAN::Signal;
c356248b
A		 4284 }
4285}
05454584 4286
ca79d794 4287# package CPAN::FTP;
f04ea8d1
SP		 4288sub hostdlhard {
4289 my($self,$host_seq,$file,$aslocal,$stats) = @_;
4290
4291 # Came back if Net::FTP couldn't establish connection (or
4292 # failed otherwise) Maybe they are behind a firewall, but they
4293 # gave us a socksified (or other) ftp program...
4294
4295 my($ro_url);
4296 my($devnull) = $CPAN::Config->{devnull} || "";
4297 # < /dev/null ";
4298 my($aslocal_dir) = File::Basename::dirname($aslocal);
4299 File::Path::mkpath($aslocal_dir);
ca79d794 4300 HOSTHARD: for $ro_url (@$host_seq) {
f04ea8d1
SP		 4301 $self->_set_attempt($stats,"dlhard",$ro_url);
4302 my $url = "$ro_url$file";
4303 my($proto,$host,$dir,$getfile);
4304
4305 # Courtesy Mark Conty mark_conty@cargill.com change from
4306 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4307 # to
4308 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4309 # proto not yet used
4310 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4311 } else {
4312 next HOSTHARD; # who said, we could ftp anything except ftp?
4313 }
5a5fac02
JH		 4314 next HOSTHARD if $proto eq "file"; # file URLs would have had
4315 # success above. Likely a bogus URL
911a92db 4316
f04ea8d1 4317 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
73beb80c 4318
f04ea8d1 4319 # Try the most capable first and leave ncftp* for last as it only
73beb80c 4320 # does FTP.
44d21104 4321 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
f04ea8d1
SP		 4322 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4323 next unless defined $funkyftp;
4324 next if $funkyftp =~ /^\s*$/;
4325
4326 my($asl_ungz, $asl_gz);
4327 ($asl_ungz = $aslocal) =~ s/\.gz//;
4328 $asl_gz = "$asl_ungz.gz";
4329
4330 my($src_switch) = "";
4331 my($chdir) = "";
4332 my($stdout_redir) = " > $asl_ungz";
4333 if ($f eq "lynx") {
4334 $src_switch = " -source";
4335 } elsif ($f eq "ncftp") {
4336 $src_switch = " -c";
4337 } elsif ($f eq "wget") {
4338 $src_switch = " -O $asl_ungz";
4339 $stdout_redir = "";
4340 } elsif ($f eq 'curl') {
4341 $src_switch = ' -L -f -s -S --netrc-optional';
4342 }
4343
4344 if ($f eq "ncftpget") {
4345 $chdir = "cd $aslocal_dir && ";
4346 $stdout_redir = "";
4347 }
4348 $CPAN::Frontend->myprint(
4349 qq[
de34a54b 4350Trying with "$funkyftp$src_switch" to get
c356248b 4351 $url
2e2b7522 4352]);
f04ea8d1
SP		 4353 my($system) =
4354 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4355 $self->debug("system[$system]") if $CPAN::DEBUG;
4356 my($wstatus) = system($system);
4357 if ($f eq "lynx") {
4358 # lynx returns 0 when it fails somewhere
4359 if (-s $asl_ungz) {
4360 my $content = do { local *FH;
4361 open FH, $asl_ungz or die;
4362 local $/;
4363 <FH> };
4364 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4365 $CPAN::Frontend->mywarn(qq{
4366No success, the file that lynx has downloaded looks like an error message:
44d21104
A		 4367$content
4368});
f04ea8d1
SP		 4369 $CPAN::Frontend->mysleep(1);
4370 next DLPRG;
4371 }
be34b10d 4372 } else {
f04ea8d1
SP		 4373 $CPAN::Frontend->myprint(qq{
4374No success, the file that lynx has downloaded is an empty file.
4375});
4376 next DLPRG;
4377 }
4378 }
4379 if ($wstatus == 0) {
4380 if (-s $aslocal) {
4381 # Looks good
4382 } elsif ($asl_ungz ne $aslocal) {
4383 # test gzip integrity
4384 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4385 # e.g. foo.tar is gzipped --> foo.tar.gz
4386 rename $asl_ungz, $aslocal;
4387 } else {
4388 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4389 }
be34b10d
SP		 4390 }
4391 $ThesiteURL = $ro_url;
4392 return $aslocal;
f04ea8d1
SP		 4393 } elsif ($url !~ /\.gz(?!\n)\Z/) {
4394 unlink $asl_ungz if
4395 -f $asl_ungz && -s _ == 0;
4396 my $gz = "$aslocal.gz";
4397 my $gzurl = "$url.gz";
4398 $CPAN::Frontend->myprint(
4399 qq[
4400 Trying with "$funkyftp$src_switch" to get
4401 $url.gz
4402 ]);
4403 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4404 $self->debug("system[$system]") if $CPAN::DEBUG;
4405 my($wstatus);
4406 if (($wstatus = system($system)) == 0
4407 &&
4408 -s $asl_gz
4409 ) {
4410 # test gzip integrity
4411 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4412 if ($ct && $ct->gtest) {
4413 $ct->gunzip($aslocal);
4414 } else {
4415 # somebody uncompressed file for us?
4416 rename $asl_ungz, $aslocal;
4417 }
4418 $ThesiteURL = $ro_url;
4419 return $aslocal;
4420 } else {
4421 unlink $asl_gz if -f $asl_gz;
4422 }
4423 } else {
4424 my $estatus = $wstatus >> 8;
4425 my $size = -f $aslocal ?
4426 ", left\n$aslocal with size ".-s _ :
4427 "\nWarning: expected file [$aslocal] doesn't exist";
4428 $CPAN::Frontend->myprint(qq{
4429 System call "$system"
4430 returned status $estatus (wstat $wstatus)$size
4431 });
4432 }
4433 return if $CPAN::Signal;
4434 } # transfer programs
c4d24d4c 4435 } # host
c356248b 4436}
05454584 4437
ca79d794 4438# package CPAN::FTP;
f04ea8d1 4439sub hostdlhardest {
05bab18e 4440 my($self,$host_seq,$file,$aslocal,$stats) = @_;
c356248b 4441
f04ea8d1 4442 return unless @$host_seq;
ca79d794 4443 my($ro_url);
c356248b
A		 4444 my($aslocal_dir) = File::Basename::dirname($aslocal);
4445 File::Path::mkpath($aslocal_dir);
35576f8c 4446 my $ftpbin = $CPAN::Config->{ftp};
8fc516fe 4447 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
ca79d794
SP		 4448 $CPAN::Frontend->myprint("No external ftp command available\n\n");
4449 return;
4450 }
8962fc49 4451 $CPAN::Frontend->mywarn(qq{
ca79d794
SP		 4452As a last ressort we now switch to the external ftp command '$ftpbin'
4453to get '$aslocal'.
4454
8962fc49 4455Doing so often leads to problems that are hard to diagnose.
ca79d794
SP		 4456
4457If you're victim of such problems, please consider unsetting the ftp
4458config variable with
4459
4460 o conf ftp ""
4461 o conf commit
4462
4463});
8962fc49 4464 $CPAN::Frontend->mysleep(2);
ca79d794 4465 HOSTHARDEST: for $ro_url (@$host_seq) {
f04ea8d1
SP		 4466 $self->_set_attempt($stats,"dlhardest",$ro_url);
4467 my $url = "$ro_url$file";
4468 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4469 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4470 next;
4471 }
4472 my($host,$dir,$getfile) = ($1,$2,$3);
4473 my $timestamp = 0;
4474 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4475 $ctime,$blksize,$blocks) = stat($aslocal);
4476 $timestamp = $mtime ||= 0;
4477 my($netrc) = CPAN::FTP::netrc->new;
4478 my($netrcfile) = $netrc->netrc;
4479 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4480 my $targetfile = File::Basename::basename($aslocal);
4481 my(@dialog);
4482 push(
4483 @dialog,
4484 "lcd $aslocal_dir",
4485 "cd /",
4486 map("cd $_", split /\//, $dir), # RFC 1738
4487 "bin",
4488 "get $getfile $targetfile",
4489 "quit"
4490 );
4491 if (! $netrcfile) {
4492 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4493 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4494 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4495 $netrc->hasdefault,
4496 $netrc->contains($host))) if $CPAN::DEBUG;
4497 if ($netrc->protected) {
ca79d794
SP		 4498 my $dialog = join "", map { " $_\n" } @dialog;
4499 my $netrc_explain;
4500 if ($netrc->contains($host)) {
4501 $netrc_explain = "Relying that your .netrc entry for '$host' ".
4502 "manages the login";
4503 } else {
4504 $netrc_explain = "Relying that your default .netrc entry ".
4505 "manages the login";
4506 }
f04ea8d1 4507 $CPAN::Frontend->myprint(qq{
05454584
A		 4508 Trying with external ftp to get
4509 $url
ca79d794
SP		 4510 $netrc_explain
4511 Going to send the dialog
4512$dialog
05454584 4513}
f04ea8d1
SP		 4514 );
4515 $self->talk_ftp("$ftpbin$verbose $host",
4516 @dialog);
4517 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4518 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4519 $mtime ||= 0;
4520 if ($mtime > $timestamp) {
4521 $CPAN::Frontend->myprint("GOT $aslocal\n");
4522 $ThesiteURL = $ro_url;
4523 return $aslocal;
4524 } else {
4525 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4526 }
4527 return if $CPAN::Signal;
4528 } else {
4529 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4530 qq{correctly protected.\n});
4531 }
4532 } else {
4533 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
c356248b 4534 nor does it have a default entry\n");
f04ea8d1
SP		 4535 }
4536
4537 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4538 # then and login manually to host, using e-mail as
4539 # password.
4540 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4541 unshift(
4542 @dialog,
4543 "open $host",
4544 "user anonymous $Config::Config{'cf_email'}"
4545 );
ca79d794
SP		 4546 my $dialog = join "", map { " $_\n" } @dialog;
4547 $CPAN::Frontend->myprint(qq{
4548 Trying with external ftp to get
4549 $url
4550 Going to send the dialog
4551$dialog
4552}
f04ea8d1
SP		 4553 );
4554 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4555 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4556 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4557 $mtime ||= 0;
4558 if ($mtime > $timestamp) {
4559 $CPAN::Frontend->myprint("GOT $aslocal\n");
4560 $ThesiteURL = $ro_url;
4561 return $aslocal;
4562 } else {
4563 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4564 }
c4d24d4c 4565 return if $CPAN::Signal;
f04ea8d1
SP		 4566 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4567 $CPAN::Frontend->mysleep(2);
c4d24d4c 4568 } # host
c356248b
A		 4569}
4570
ca79d794 4571# package CPAN::FTP;
c356248b
A		 4572sub talk_ftp {
4573 my($self,$command,@dialog) = @_;
4574 my $fh = FileHandle->new;
4575 $fh->open("|$command") or die "Couldn't open ftp: $!";
4576 foreach (@dialog) { $fh->print("$_\n") }
f04ea8d1 4577 $fh->close; # Wait for process to complete
c356248b
A		 4578 my $wstatus = $?;
4579 my $estatus = $wstatus >> 8;
4580 $CPAN::Frontend->myprint(qq{
4581Subprocess "|$command"
4582 returned status $estatus (wstat $wstatus)
4583}) if $wstatus;
05454584
A		 4584}
4585
e50380aa
A		 4586# find2perl needs modularization, too, all the following is stolen
4587# from there
09d9d230 4588# CPAN::FTP::ls
e50380aa
A		 4589sub ls {
4590 my($self,$name) = @_;
4591 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4592 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4593
4594 my($perms,%user,%group);
4595 my $pname = $name;
4596
55e314ee 4597 if ($blocks) {
f04ea8d1 4598 $blocks = int(($blocks + 1) / 2);
e50380aa
A		 4599 }
4600 else {
f04ea8d1 4601 $blocks = int(($sizemm + 1023) / 1024);
e50380aa
A		 4602 }
4603
4604 if (-f _) { $perms = '-'; }
4605 elsif (-d _) { $perms = 'd'; }
4606 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4607 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4608 elsif (-p _) { $perms = 'p'; }
4609 elsif (-S _) { $perms = 's'; }
4610 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4611
4612 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4613 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4614 my $tmpmode = $mode;
4615 my $tmp = $rwx[$tmpmode & 7];
4616 $tmpmode >>= 3;
4617 $tmp = $rwx[$tmpmode & 7] . $tmp;
4618 $tmpmode >>= 3;
4619 $tmp = $rwx[$tmpmode & 7] . $tmp;
4620 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4621 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4622 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4623 $perms .= $tmp;
4624
4625 my $user = $user{$uid} || $uid; # too lazy to implement lookup
4626 my $group = $group{$gid} || $gid;
4627
4628 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4629 my($timeyear);
4630 my($moname) = $moname[$mon];
4631 if (-M _ > 365.25 / 2) {
f04ea8d1 4632 $timeyear = $year + 1900;
e50380aa
A		 4633 }
4634 else {
f04ea8d1 4635 $timeyear = sprintf("%02d:%02d", $hour, $min);
e50380aa
A		 4636 }
4637
4638 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
f04ea8d1
SP		 4639 $ino,
4640 $blocks,
4641 $perms,
4642 $nlink,
4643 $user,
4644 $group,
4645 $sizemm,
4646 $moname,
4647 $mday,
4648 $timeyear,
4649 $pname;
e50380aa
A		 4650}
4651
05454584 4652package CPAN::FTP::netrc;
e82b9348 4653use strict;
05454584 4654
ca79d794 4655# package CPAN::FTP::netrc;
05454584
A		 4656sub new {
4657 my($class) = @_;
87892b73
RGS		 4658 my $home = CPAN::HandleConfig::home;
4659 my $file = File::Spec->catfile($home,".netrc");
05454584
A		 4660
4661 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4662 $atime,$mtime,$ctime,$blksize,$blocks)
f04ea8d1 4663 = stat($file);
05454584
A		 4664 $mode ||= 0;
4665 my $protected = 0;
4666
42d3b621
A		 4667 my($fh,@machines,$hasdefault);
4668 $hasdefault = 0;
da199366
A		 4669 $fh = FileHandle->new or die "Could not create a filehandle";
4670
f04ea8d1
SP		 4671 if($fh->open($file)) {
4672 $protected = ($mode & 077) == 0;
4673 local($/) = "";
42d3b621 4674 NETRC: while (<$fh>) {
f04ea8d1
SP		 4675 my(@tokens) = split " ", $_;
4676 TOKEN: while (@tokens) {
4677 my($t) = shift @tokens;
4678 if ($t eq "default") {
4679 $hasdefault++;
4680 last NETRC;
4681 }
4682 last TOKEN if $t eq "macdef";
4683 if ($t eq "machine") {
4684 push @machines, shift @tokens;
4685 }
4686 }
4687 }
10b2abe6 4688 } else {
f04ea8d1 4689 $file = $hasdefault = $protected = "";
10b2abe6 4690 }
da199366 4691
10b2abe6 4692 bless {
f04ea8d1
SP		 4693 'mach' => [@machines],
4694 'netrc' => $file,
4695 'hasdefault' => $hasdefault,
4696 'protected' => $protected,
4697 }, $class;
10b2abe6
CS		 4698}
4699
ca79d794 4700# CPAN::FTP::netrc::hasdefault;
42d3b621 4701sub hasdefault { shift->{'hasdefault'} }
da199366
A		 4702sub netrc { shift->{'netrc'} }
4703sub protected { shift->{'protected'} }
10b2abe6
CS		 4704sub contains {
4705 my($self,$mach) = @_;
da199366 4706 for ( @{$self->{'mach'}} ) {
f04ea8d1 4707 return 1 if $_ eq $mach;
da199366
A		 4708 }
4709 return 0;
10b2abe6
CS		 4710}
4711
5f05dabc 4712package CPAN::Complete;
e82b9348 4713use strict;
5f05dabc 4714
36263cb3
GS		 4715sub gnu_cpl {
4716 my($text, $line, $start, $end) = @_;
4717 my(@perlret) = cpl($text, $line, $start);
4718 # find longest common match. Can anybody show me how to peruse
4719 # T::R::Gnu to have this done automatically? Seems expensive.
4720 return () unless @perlret;
4721 my($newtext) = $text;
4722 for (my $i = length($text)+1;;$i++) {
f04ea8d1
SP		 4723 last unless length($perlret[0]) && length($perlret[0]) >= $i;
4724 my $try = substr($perlret[0],0,$i);
4725 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4726 # warn "try[$try]tries[@tries]";
4727 if (@tries == @perlret) {
4728 $newtext = $try;
4729 } else {
4730 last;
4731 }
36263cb3
GS		 4732 }
4733 ($newtext,@perlret);
4734}
4735
55e314ee
A		 4736#-> sub CPAN::Complete::cpl ;
4737sub cpl {
5f05dabc 4738 my($word,$line,$pos) = @_;
4739 $word ||= "";
4740 $line ||= "";
4741 $pos ||= 0;
4742 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4743 $line =~ s/^\s*//;
f20de9f0 4744 if ($line =~ s/^((?:notest|f?force)\s*)//) {
f04ea8d1 4745 $pos -= length($1);
da199366 4746 }
5f05dabc 4747 my @return;
f04ea8d1
SP		 4748 if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4749 @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
c049f953 4750 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
f04ea8d1 4751 @return = ();
8d97e4a1 4752 } elsif ($line =~ /^(a|ls)\s/) {
f04ea8d1 4753 @return = cplx('CPAN::Author',uc($word));
5f05dabc 4754 } elsif ($line =~ /^b\s/) {
8d97e4a1 4755 CPAN::Shell->local_bundles;
f04ea8d1 4756 @return = cplx('CPAN::Bundle',$word);
5f05dabc 4757 } elsif ($line =~ /^d\s/) {
f04ea8d1 4758 @return = cplx('CPAN::Distribution',$word);
6d29edf5 4759 } elsif ($line =~ m/^(
554a9ef5 4760 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
6d29edf5 4761 )\s/x ) {
d8773709
JH		 4762 if ($word =~ /^Bundle::/) {
4763 CPAN::Shell->local_bundles;
4764 }
f04ea8d1 4765 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 4766 } elsif ($line =~ /^i\s/) {
f04ea8d1 4767 @return = cpl_any($word);
5f05dabc 4768 } elsif ($line =~ /^reload\s/) {
f04ea8d1 4769 @return = cpl_reload($word,$line,$pos);
5f05dabc 4770 } elsif ($line =~ /^o\s/) {
f04ea8d1 4771 @return = cpl_option($word,$line,$pos);
9d61fa1d
A		 4772 } elsif ($line =~ m/^\S+\s/ ) {
4773 # fallback for future commands and what we have forgotten above
f04ea8d1 4774 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 4775 } else {
f04ea8d1 4776 @return = ();
5f05dabc 4777 }
4778 return @return;
4779}
4780
55e314ee
A		 4781#-> sub CPAN::Complete::cplx ;
4782sub cplx {
5f05dabc 4783 my($class, $word) = @_;
b72dd56f
SP		 4784 if (CPAN::_sqlite_running) {
4785 $CPAN::SQLite->search($class, "^\Q$word\E");
4786 }
de34a54b 4787 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
5f05dabc 4788}
4789
55e314ee
A		 4790#-> sub CPAN::Complete::cpl_any ;
4791sub cpl_any {
5f05dabc 4792 my($word) = shift;
4793 return (
f04ea8d1
SP		 4794 cplx('CPAN::Author',$word),
4795 cplx('CPAN::Bundle',$word),
4796 cplx('CPAN::Distribution',$word),
4797 cplx('CPAN::Module',$word),
4798 );
5f05dabc 4799}
4800
55e314ee
A		 4801#-> sub CPAN::Complete::cpl_reload ;
4802sub cpl_reload {
5f05dabc 4803 my($word,$line,$pos) = @_;
4804 $word ||= "";
4805 my(@words) = split " ", $line;
4806 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4807 my(@ok) = qw(cpan index);
e50380aa
A		 4808 return @ok if @words == 1;
4809 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
5f05dabc 4810}
4811
55e314ee
A		 4812#-> sub CPAN::Complete::cpl_option ;
4813sub cpl_option {
5f05dabc 4814 my($word,$line,$pos) = @_;
4815 $word ||= "";
4816 my(@words) = split " ", $line;
4817 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4818 my(@ok) = qw(conf debug);
e50380aa 4819 return @ok if @words == 1;
c356248b 4820 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
5f05dabc 4821 if (0) {
4822 } elsif ($words[1] eq 'index') {
f04ea8d1 4823 return ();
5f05dabc 4824 } elsif ($words[1] eq 'conf') {
f04ea8d1 4825 return CPAN::HandleConfig::cpl(@_);
5f05dabc 4826 } elsif ($words[1] eq 'debug') {
f04ea8d1 4827 return sort grep /^\Q$word\E/i,
554a9ef5 4828 sort keys %CPAN::DEBUG, 'all';
5f05dabc 4829 }
4830}
4831
4832package CPAN::Index;
e82b9348 4833use strict;
5f05dabc 4834
10b2abe6 4835#-> sub CPAN::Index::force_reload ;
5f05dabc 4836sub force_reload {
4837 my($class) = @_;
c049f953 4838 $CPAN::Index::LAST_TIME = 0;
5f05dabc 4839 $class->reload(1);
4840}
4841
10b2abe6 4842#-> sub CPAN::Index::reload ;
5f05dabc 4843sub reload {
05bab18e 4844 my($self,$force) = @_;
5f05dabc 4845 my $time = time;
4846
c356248b
A		 4847 # XXX check if a newer one is available. (We currently read it
4848 # from time to time)
e50380aa 4849 for ($CPAN::Config->{index_expire}) {
f04ea8d1 4850 $_ = 0.001 unless $_ && $_ > 0.001;
e50380aa 4851 }
9d61fa1d
A		 4852 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4853 # debug here when CPAN doesn't seem to read the Metadata
4854 require Carp;
4855 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4856 }
4857 unless ($CPAN::META->{PROTOCOL}) {
05bab18e 4858 $self->read_metadata_cache;
9d61fa1d
A		 4859 $CPAN::META->{PROTOCOL} ||= "1.0";
4860 }
6d29edf5
JH		 4861 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
4862 # warn "Setting last_time to 0";
c049f953 4863 $LAST_TIME = 0; # No warning necessary
6d29edf5 4864 }
05bab18e 4865 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
f04ea8d1 4866 and ! $force) {
05bab18e
SP		 4867 # called too often
4868 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4869 } elsif (0) {
6d29edf5
JH		 4870 # IFF we are developing, it helps to wipe out the memory
4871 # between reloads, otherwise it is not what a user expects.
4872 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4873 $CPAN::META = CPAN->new;
05bab18e 4874 } else {
6d29edf5 4875 my($debug,$t2);
c049f953 4876 local $LAST_TIME = $time;
6d29edf5
JH		 4877 local $CPAN::META->{PROTOCOL} = PROTOCOL;
4878
4879 my $needshort = $^O eq "dos";
4880
05bab18e 4881 $self->rd_authindex($self
6d29edf5
JH		 4882 ->reload_x(
4883 "authors/01mailrc.txt.gz",
4884 $needshort ?
4885 File::Spec->catfile('authors', '01mailrc.gz') :
4886 File::Spec->catfile('authors', '01mailrc.txt.gz'),
4887 $force));
4888 $t2 = time;
4889 $debug = "timing reading 01[".($t2 - $time)."]";
4890 $time = $t2;
4891 return if $CPAN::Signal; # this is sometimes lengthy
05bab18e 4892 $self->rd_modpacks($self
6d29edf5
JH		 4893 ->reload_x(
4894 "modules/02packages.details.txt.gz",
4895 $needshort ?
4896 File::Spec->catfile('modules', '02packag.gz') :
4897 File::Spec->catfile('modules', '02packages.details.txt.gz'),
4898 $force));
4899 $t2 = time;
4900 $debug .= "02[".($t2 - $time)."]";
4901 $time = $t2;
4902 return if $CPAN::Signal; # this is sometimes lengthy
05bab18e 4903 $self->rd_modlist($self
6d29edf5
JH		 4904 ->reload_x(
4905 "modules/03modlist.data.gz",
4906 $needshort ?
4907 File::Spec->catfile('modules', '03mlist.gz') :
4908 File::Spec->catfile('modules', '03modlist.data.gz'),
4909 $force));
05bab18e 4910 $self->write_metadata_cache;
6d29edf5
JH		 4911 $t2 = time;
4912 $debug .= "03[".($t2 - $time)."]";
4913 $time = $t2;
4914 CPAN->debug($debug) if $CPAN::DEBUG;
4915 }
05bab18e
SP		 4916 if ($CPAN::Config->{build_dir_reuse}) {
4917 $self->reanimate_build_dir;
4918 }
810a0276 4919 if (CPAN::_sqlite_running) {
be34b10d
SP		 4920 $CPAN::SQLite->reload(time => $time, force => $force)
4921 if not $LAST_TIME;
4922 }
c049f953 4923 $LAST_TIME = $time;
6d29edf5 4924 $CPAN::META->{PROTOCOL} = PROTOCOL;
5f05dabc 4925}
4926
05bab18e
SP		 4927#-> sub CPAN::Index::reanimate_build_dir ;
4928sub reanimate_build_dir {
4929 my($self) = @_;
4930 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4931 return;
4932 }
4933 return if $HAVE_REANIMATED++;
4934 my $d = $CPAN::Config->{build_dir};
4935 my $dh = DirHandle->new;
4936 opendir $dh, $d or return; # does not exist
4937 my $dirent;
4938 my $i = 0;
4939 my $painted = 0;
4940 my $restored = 0;
4941 $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
be34b10d
SP		 4942 my @candidates = map { $_->[0] }
4943 sort { $b->[1] <=> $a->[1] }
4944 map { [ $_, -M File::Spec->catfile($d,$_) ] }
4945 grep {/\.yml$/} readdir $dh;
23a216b4
SP		 4946 DISTRO: for $i (0..$#candidates) {
4947 my $dirent = $candidates[$i];
b72dd56f 4948 my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
23a216b4
SP		 4949 if ($@) {
4950 warn "Error while parsing file '$dirent'; error: '$@'";
4951 next DISTRO;
4952 }
b72dd56f 4953 my $c = $y->[0];
05bab18e
SP		 4954 if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4955 my $key = $c->{distribution}{ID};
4956 for my $k (keys %{$c->{distribution}}) {
4957 if ($c->{distribution}{$k}
4958 && ref $c->{distribution}{$k}
4959 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
be34b10d 4960 $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
05bab18e
SP		 4961 }
4962 }
4963
4964 #we tried to restore only if element already
4965 #exists; but then we do not work with metadata
4966 #turned off.
b72dd56f
SP		 4967 my $do
4968 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4969 = $c->{distribution};
f04ea8d1
SP		 4970 for my $skipper (qw(
4971 badtestcnt
4972 configure_requires_later
4973 configure_requires_later_for
4974 force_update
4975 later
4976 later_for
4977 notest
4978 should_report
4979 sponsored_mods
4980 )) {
23a216b4
SP		 4981 delete $do->{$skipper};
4982 }
b72dd56f
SP		 4983 # $DB::single = 1;
4984 if ($do->{make_test}
4985 && $do->{build_dir}
917f1700
SP		 4986 && !(UNIVERSAL::can($do->{make_test},"failed") ?
4987 $do->{make_test}->failed :
4988 $do->{make_test} =~ /^YES/
4989 )
b72dd56f
SP		 4990 && (
4991 !$do->{install}
4992 ||
4993 $do->{install}->failed
4994 )
4995 ) {
4996 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4997 }
05bab18e
SP		 4998 $restored++;
4999 }
5000 $i++;
5001 while (($painted/76) < ($i/@candidates)) {
5002 $CPAN::Frontend->myprint(".");
5003 $painted++;
5004 }
5005 }
5006 $CPAN::Frontend->myprint(sprintf(
23a216b4 5007 "DONE\nFound %s old build%s, restored the state of %s\n",
05bab18e 5008 @candidates ? sprintf("%d",scalar @candidates) : "no",
23a216b4 5009 @candidates==1 ? "" : "s",
05bab18e
SP		 5010 $restored || "none",
5011 ));
5012}
5013
5014
10b2abe6 5015#-> sub CPAN::Index::reload_x ;
5f05dabc 5016sub reload_x {
5017 my($cl,$wanted,$localname,$force) = @_;
c356248b 5018 $force |= 2; # means we're dealing with an index here
135a59c2
A		 5019 CPAN::HandleConfig->load; # we should guarantee loading wherever
5020 # we rely on Config XXX
c356248b 5021 $localname ||= $wanted;
5de3f0da 5022 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
f04ea8d1 5023 $localname);
e50380aa 5024 if (
f04ea8d1
SP		 5025 -f $abs_wanted &&
5026 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5027 !($force & 1)
e50380aa 5028 ) {
f04ea8d1
SP		 5029 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5030 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5031 qq{day$s. I\'ll use that.});
5032 return $abs_wanted;
5f05dabc 5033 } else {
f04ea8d1 5034 $force |= 1; # means we're quite serious about it.
5f05dabc 5035 }
5036 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5037}
5038
55e314ee
A		 5039#-> sub CPAN::Index::rd_authindex ;
5040sub rd_authindex {
f14b5cec 5041 my($cl, $index_target) = @_;
c356248b 5042 return unless defined $index_target;
810a0276
SP		 5043 return if CPAN::_sqlite_running;
5044 my @lines;
c356248b 5045 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 5046 local(*FH);
ec5fee46 5047 tie *FH, 'CPAN::Tarzip', $index_target;
52128c7b 5048 local($/) = "\n";
e82b9348 5049 local($_);
f14b5cec 5050 push @lines, split /\012/ while <FH>;
7d97ad34 5051 my $i = 0;
be34b10d 5052 my $painted = 0;
f14b5cec 5053 foreach (@lines) {
f04ea8d1
SP		 5054 my($userid,$fullname,$email) =
5055 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
8fc516fe 5056 $fullname ||= $email;
f04ea8d1 5057 if ($userid && $fullname && $email) {
8fc516fe
SP		 5058 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5059 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5060 } else {
5061 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5062 }
be34b10d
SP		 5063 $i++;
5064 while (($painted/76) < ($i/@lines)) {
5065 $CPAN::Frontend->myprint(".");
5066 $painted++;
5067 }
f04ea8d1 5068 return if $CPAN::Signal;
5f05dabc 5069 }
7d97ad34 5070 $CPAN::Frontend->myprint("DONE\n");
09d9d230
A		 5071}
5072
5073sub userid {
5074 my($self,$dist) = @_;
5075 $dist = $self->{'id'} unless defined $dist;
5076 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5077 $ret;
5f05dabc 5078}
5079
55e314ee
A		 5080#-> sub CPAN::Index::rd_modpacks ;
5081sub rd_modpacks {
05d2a450 5082 my($self, $index_target) = @_;
c356248b 5083 return unless defined $index_target;
810a0276 5084 return if CPAN::_sqlite_running;
c356248b 5085 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 5086 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
e82b9348 5087 local $_;
7d97ad34
SP		 5088 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5089 my $slurp = "";
5090 my $chunk;
5091 while (my $bytes = $fh->READ(\$chunk,8192)) {
5092 $slurp.=$chunk;
5093 }
5094 my @lines = split /\012/, $slurp;
5095 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5096 undef $fh;
de34a54b 5097 # read header
c049f953 5098 my($line_count,$last_updated);
f14b5cec 5099 while (@lines) {
f04ea8d1
SP		 5100 my $shift = shift(@lines);
5101 last if $shift =~ /^\s*$/;
5102 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
c049f953 5103 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
f14b5cec 5104 }
7d97ad34 5105 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
de34a54b 5106 if (not defined $line_count) {
05d2a450 5107
f04ea8d1 5108 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
05d2a450
A		 5109Please check the validity of the index file by comparing it to more
5110than one CPAN mirror. I'll continue but problems seem likely to
5111happen.\a
8962fc49 5112});
05d2a450 5113
f04ea8d1 5114 $CPAN::Frontend->mysleep(5);
de34a54b
JH		 5115 } elsif ($line_count != scalar @lines) {
5116
f04ea8d1 5117 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
de34a54b
JH		 5118contains a Line-Count header of %d but I see %d lines there. Please
5119check the validity of the index file by comparing it to more than one
5120CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
7fefbd44 5121$index_target, $line_count, scalar(@lines));
de34a54b
JH		 5122
5123 }
c049f953
JH		 5124 if (not defined $last_updated) {
5125
f04ea8d1 5126 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
c049f953
JH		 5127Please check the validity of the index file by comparing it to more
5128than one CPAN mirror. I'll continue but problems seem likely to
5129happen.\a
8962fc49 5130});
c049f953 5131
f04ea8d1 5132 $CPAN::Frontend->mysleep(5);
c049f953
JH		 5133 } else {
5134
f04ea8d1 5135 $CPAN::Frontend
c049f953
JH		 5136 ->myprint(sprintf qq{ Database was generated on %s\n},
5137 $last_updated);
5138 $DATE_OF_02 = $last_updated;
5139
9ddc4ed0 5140 my $age = time;
ec5fee46 5141 if ($CPAN::META->has_inst('HTTP::Date')) {
c049f953 5142 require HTTP::Date;
9ddc4ed0
A		 5143 $age -= HTTP::Date::str2time($last_updated);
5144 } else {
8962fc49 5145 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
9ddc4ed0
A		 5146 require Time::Local;
5147 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5148 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5149 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5150 }
5151 $age /= 3600*24;
5152 if ($age > 30) {
c049f953 5153
9ddc4ed0
A		 5154 $CPAN::Frontend
5155 ->mywarn(sprintf
5156 qq{Warning: This index file is %d days old.
c049f953
JH		 5157 Please check the host you chose as your CPAN mirror for staleness.
5158 I'll continue but problems seem likely to happen.\a\n},
9ddc4ed0
A		 5159 $age);
5160
5161 } elsif ($age < -1) {
5162
5163 $CPAN::Frontend
5164 ->mywarn(sprintf
5165 qq{Warning: Your system date is %d days behind this index file!
5166 System time: %s
5167 Timestamp index file: %s
5168 Please fix your system time, problems with the make command expected.\n},
5169 -$age,
5170 scalar gmtime,
5171 $DATE_OF_02,
5172 );
c049f953 5173
c049f953
JH		 5174 }
5175 }
5176
5177
c4d24d4c
A		 5178 # A necessity since we have metadata_cache: delete what isn't
5179 # there anymore
5180 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5181 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5182 my(%exists);
7d97ad34 5183 my $i = 0;
be34b10d 5184 my $painted = 0;
f14b5cec 5185 foreach (@lines) {
05d2a450
A		 5186 # before 1.56 we split into 3 and discarded the rest. From
5187 # 1.57 we assign remaining text to $comment thus allowing to
5188 # influence isa_perl
f04ea8d1
SP		 5189 my($mod,$version,$dist,$comment) = split " ", $_, 4;
5190 my($bundle,$id,$userid);
5191
5192 if ($mod eq 'CPAN' &&
5193 ! (
5194 CPAN::Queue->exists('Bundle::CPAN') ||
5195 CPAN::Queue->exists('CPAN')
5196 )
5197 ) {
c4d24d4c 5198 local($^W)= 0;
f04ea8d1 5199 if ($version > $CPAN::VERSION) {
8962fc49 5200 $CPAN::Frontend->mywarn(qq{
ed84aac9
A		 5201 New CPAN.pm version (v$version) available.
5202 [Currently running version is v$CPAN::VERSION]
e50380aa 5203 You might want to try
b96578bb 5204 install CPAN
5f05dabc 5205 reload cpan
ed84aac9
A		 5206 to both upgrade CPAN.pm and run the new version without leaving
5207 the current session.
5208
c4d24d4c 5209}); #});
8962fc49 5210 $CPAN::Frontend->mysleep(2);
f04ea8d1
SP		 5211 $CPAN::Frontend->myprint(qq{\n});
5212 }
5213 last if $CPAN::Signal;
5214 } elsif ($mod =~ /^Bundle::(.*)/) {
5215 $bundle = $1;
5216 }
5217
5218 if ($bundle) {
5219 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
5220 # Let's make it a module too, because bundles have so much
5221 # in common with modules.
6d29edf5
JH		 5222
5223 # Changed in 1.57_63: seems like memory bloat now without
5224 # any value, so commented out
5225
f04ea8d1 5226 # $CPAN::META->instance('CPAN::Module',$mod);
c356248b 5227
f04ea8d1 5228 } else {
c356248b 5229
f04ea8d1
SP		 5230 # instantiate a module object
5231 $id = $CPAN::META->instance('CPAN::Module',$mod);
c4d24d4c 5232
f04ea8d1 5233 }
5f05dabc 5234
ec5fee46
A		 5235 # Although CPAN prohibits same name with different version the
5236 # indexer may have changed the version for the same distro
5237 # since the last time ("Force Reindexing" feature)
f04ea8d1 5238 if ($id->cpan_file ne $dist
ec5fee46
A		 5239 ||
5240 $id->cpan_version ne $version
f04ea8d1
SP		 5241 ) {
5242 $userid = $id->userid || $self->userid($dist);
5243 $id->set(
5244 'CPAN_USERID' => $userid,
5245 'CPAN_VERSION' => $version,
5246 'CPAN_FILE' => $dist,
5247 );
5248 }
5249
5250 # instantiate a distribution object
5251 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5252 # we do not need CONTAINSMODS unless we do something with
5253 # this dist, so we better produce it on demand.
5254
5255 ## my $obj = $CPAN::META->instance(
5256 ## 'CPAN::Distribution' => $dist
5257 ## );
5258 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5259 } else {
5260 $CPAN::META->instance(
5261 'CPAN::Distribution' => $dist
5262 )->set(
5263 'CPAN_USERID' => $userid,
5264 'CPAN_COMMENT' => $comment,
5265 );
5266 }
c4d24d4c
A		 5267 if ($secondtime) {
5268 for my $name ($mod,$dist) {
7d97ad34 5269 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
c4d24d4c
A		 5270 $exists{$name} = undef;
5271 }
5272 }
be34b10d
SP		 5273 $i++;
5274 while (($painted/76) < ($i/@lines)) {
5275 $CPAN::Frontend->myprint(".");
5276 $painted++;
5277 }
f04ea8d1 5278 return if $CPAN::Signal;
5f05dabc 5279 }
7d97ad34 5280 $CPAN::Frontend->myprint("DONE\n");
c4d24d4c
A		 5281 if ($secondtime) {
5282 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5283 for my $o ($CPAN::META->all_objects($class)) {
5284 next if exists $exists{$o->{ID}};
5285 $CPAN::META->delete($class,$o->{ID});
7d97ad34
SP		 5286 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5287 # if $CPAN::DEBUG;
c4d24d4c
A		 5288 }
5289 }
5290 }
5f05dabc 5291}
5292
55e314ee
A		 5293#-> sub CPAN::Index::rd_modlist ;
5294sub rd_modlist {
05454584 5295 my($cl,$index_target) = @_;
c356248b 5296 return unless defined $index_target;
810a0276 5297 return if CPAN::_sqlite_running;
c356248b 5298 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 5299 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
e82b9348 5300 local $_;
7d97ad34
SP		 5301 my $slurp = "";
5302 my $chunk;
5303 while (my $bytes = $fh->READ(\$chunk,8192)) {
5304 $slurp.=$chunk;
5305 }
5306 my @eval2 = split /\012/, $slurp;
5307
5308 while (@eval2) {
f04ea8d1
SP		 5309 my $shift = shift(@eval2);
5310 if ($shift =~ /^Date:\s+(.*)/) {
5311 if ($DATE_OF_03 eq $1) {
7d97ad34
SP		 5312 $CPAN::Frontend->myprint("Unchanged.\n");
5313 return;
5314 }
f04ea8d1
SP		 5315 ($DATE_OF_03) = $1;
5316 }
5317 last if $shift =~ /^\s*$/;
05454584 5318 }
7d97ad34 5319 push @eval2, q{CPAN::Modulelist->data;};
05454584
A		 5320 local($^W) = 0;
5321 my($comp) = Safe->new("CPAN::Safe1");
7d97ad34
SP		 5322 my($eval2) = join("\n", @eval2);
5323 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5324 my $ret = $comp->reval($eval2);
05454584
A		 5325 Carp::confess($@) if $@;
5326 return if $CPAN::Signal;
7d97ad34 5327 my $i = 0;
be34b10d
SP		 5328 my $until = keys(%$ret);
5329 my $painted = 0;
7d97ad34 5330 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
05454584 5331 for (keys %$ret) {
f04ea8d1 5332 my $obj = $CPAN::META->instance("CPAN::Module",$_);
6d29edf5 5333 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
f04ea8d1 5334 $obj->set(%{$ret->{$_}});
be34b10d
SP		 5335 $i++;
5336 while (($painted/76) < ($i/$until)) {
5337 $CPAN::Frontend->myprint(".");
5338 $painted++;
5339 }
f04ea8d1 5340 return if $CPAN::Signal;
05454584 5341 }
7d97ad34 5342 $CPAN::Frontend->myprint("DONE\n");
05454584 5343}
5f05dabc 5344
5e05dca5
A		 5345#-> sub CPAN::Index::write_metadata_cache ;
5346sub write_metadata_cache {
5347 my($self) = @_;
5348 return unless $CPAN::Config->{'cache_metadata'};
810a0276 5349 return if CPAN::_sqlite_running;
5e05dca5
A		 5350 return unless $CPAN::META->has_usable("Storable");
5351 my $cache;
5352 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
f04ea8d1
SP		 5353 CPAN::Distribution)) {
5354 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5e05dca5 5355 }
5de3f0da 5356 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
c049f953
JH		 5357 $cache->{last_time} = $LAST_TIME;
5358 $cache->{DATE_OF_02} = $DATE_OF_02;
6d29edf5
JH		 5359 $cache->{PROTOCOL} = PROTOCOL;
5360 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
c4d24d4c 5361 eval { Storable::nstore($cache, $metadata_file) };
5fc0f0f6 5362 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5e05dca5
A		 5363}
5364
5365#-> sub CPAN::Index::read_metadata_cache ;
5366sub read_metadata_cache {
5367 my($self) = @_;
5368 return unless $CPAN::Config->{'cache_metadata'};
810a0276 5369 return if CPAN::_sqlite_running;
5e05dca5 5370 return unless $CPAN::META->has_usable("Storable");
5de3f0da 5371 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5e05dca5
A		 5372 return unless -r $metadata_file and -f $metadata_file;
5373 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5374 my $cache;
5375 eval { $cache = Storable::retrieve($metadata_file) };
5fc0f0f6 5376 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
f04ea8d1 5377 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
c049f953 5378 $LAST_TIME = 0;
6d29edf5
JH		 5379 return;
5380 }
5381 if (exists $cache->{PROTOCOL}) {
5382 if (PROTOCOL > $cache->{PROTOCOL}) {
5383 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5fc0f0f6 5384 "with protocol v%s, requiring v%s\n",
6d29edf5
JH		 5385 $cache->{PROTOCOL},
5386 PROTOCOL)
5387 );
5388 return;
5389 }
5390 } else {
5391 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5fc0f0f6 5392 "with protocol v1.0\n");
6d29edf5
JH		 5393 return;
5394 }
5395 my $clcnt = 0;
5396 my $idcnt = 0;
5397 while(my($class,$v) = each %$cache) {
f04ea8d1
SP		 5398 next unless $class =~ /^CPAN::/;
5399 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
6d29edf5
JH		 5400 while (my($id,$ro) = each %$v) {
5401 $CPAN::META->{readwrite}{$class}{$id} ||=
5402 $class->new(ID=>$id, RO=>$ro);
5403 $idcnt++;
c4d24d4c 5404 }
6d29edf5 5405 $clcnt++;
5e05dca5 5406 }
6d29edf5
JH		 5407 unless ($clcnt) { # sanity check
5408 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5409 return;
5410 }
5411 if ($idcnt < 1000) {
5412 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5413 "in $metadata_file\n");
5414 return;
5415 }
5416 $CPAN::META->{PROTOCOL} ||=
5417 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5418 # does initialize to some protocol
c049f953
JH		 5419 $LAST_TIME = $cache->{last_time};
5420 $DATE_OF_02 = $cache->{DATE_OF_02};
d5a05a34 5421 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
f04ea8d1 5422 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
c049f953 5423 return;
5e05dca5
A		 5424}
5425
05454584 5426package CPAN::InfoObj;
e82b9348 5427use strict;
5f05dabc 5428
0cf35e6a
SP		 5429sub ro {
5430 my $self = shift;
5431 exists $self->{RO} and return $self->{RO};
5432}
5433
6658a91b 5434#-> sub CPAN::InfoObj::cpan_userid
35576f8c
A		 5435sub cpan_userid {
5436 my $self = shift;
6658a91b
SP		 5437 my $ro = $self->ro;
5438 if ($ro) {
5439 return $ro->{CPAN_USERID} || "N/A";
5440 } else {
5441 $self->debug("ID[$self->{ID}]");
5442 # N/A for bundles found locally
5443 return "N/A";
5444 }
35576f8c
A		 5445}
5446
c049f953 5447sub id { shift->{ID}; }
6d29edf5 5448
05454584 5449#-> sub CPAN::InfoObj::new ;
6d29edf5
JH		 5450sub new {
5451 my $this = bless {}, shift;
5452 %$this = @_;
5453 $this
5454}
5455
5456# The set method may only be used by code that reads index data or
5457# otherwise "objective" data from the outside world. All session
5458# related material may do anything else with instance variables but
5459# must not touch the hash under the RO attribute. The reason is that
5460# the RO hash gets written to Metadata file and is thus persistent.
5f05dabc 5461
b96578bb
SP		 5462#-> sub CPAN::InfoObj::safe_chdir ;
5463sub safe_chdir {
5464 my($self,$todir) = @_;
5465 # we die if we cannot chdir and we are debuggable
5466 Carp::confess("safe_chdir called without todir argument")
5467 unless defined $todir and length $todir;
5468 if (chdir $todir) {
5469 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5470 if $CPAN::DEBUG;
5471 } else {
5472 if (-e $todir) {
5473 unless (-x $todir) {
5474 unless (chmod 0755, $todir) {
5475 my $cwd = CPAN::anycwd();
5476 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5477 "permission to change the permission; cannot ".
5478 "chdir to '$todir'\n");
5479 $CPAN::Frontend->mysleep(5);
5480 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5481 qq{to todir[$todir]: $!});
5482 }
5483 }
5484 } else {
5485 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5486 }
5487 if (chdir $todir) {
5488 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5489 if $CPAN::DEBUG;
5490 } else {
5491 my $cwd = CPAN::anycwd();
5492 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5493 qq{to todir[$todir] (a chmod has been issued): $!});
5494 }
5495 }
5496}
5497
05454584
A		 5498#-> sub CPAN::InfoObj::set ;
5499sub set {
5500 my($self,%att) = @_;
6d29edf5
JH		 5501 my $class = ref $self;
5502
5503 # This must be ||=, not ||, because only if we write an empty
5504 # reference, only then the set method will write into the readonly
5505 # area. But for Distributions that spring into existence, maybe
5506 # because of a typo, we do not like it that they are written into
5507 # the readonly area and made permanent (at least for a while) and
5508 # that is why we do not "allow" other places to call ->set.
8d97e4a1
JH		 5509 unless ($self->id) {
5510 CPAN->debug("Bug? Empty ID, rejecting");
5511 return;
5512 }
6d29edf5
JH		 5513 my $ro = $self->{RO} =
5514 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
da199366 5515
6d29edf5
JH		 5516 while (my($k,$v) = each %att) {
5517 $ro->{$k} = $v;
5518 }
5519}
5f05dabc 5520
05454584
A		 5521#-> sub CPAN::InfoObj::as_glimpse ;
5522sub as_glimpse {
5f05dabc 5523 my($self) = @_;
05454584
A		 5524 my(@m);
5525 my $class = ref($self);
5526 $class =~ s/^CPAN:://;
135a59c2
A		 5527 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5528 push @m, sprintf "%-15s %s\n", $class, $id;
05454584 5529 join "", @m;
5f05dabc 5530}
5531
05454584
A		 5532#-> sub CPAN::InfoObj::as_string ;
5533sub as_string {
5534 my($self) = @_;
5535 my(@m);
5536 my $class = ref($self);
5537 $class =~ s/^CPAN:://;
5538 push @m, $class, " id = $self->{ID}\n";
4d1321a7
A		 5539 my $ro;
5540 unless ($ro = $self->ro) {
8fc516fe
SP		 5541 if (substr($self->{ID},-1,1) eq ".") { # directory
5542 $ro = +{};
5543 } else {
f04ea8d1
SP		 5544 $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5545 $CPAN::Frontend->mysleep(5);
5546 return;
8fc516fe 5547 }
4d1321a7 5548 }
0cf35e6a 5549 for (sort keys %$ro) {
f04ea8d1
SP		 5550 # next if m/^(ID|RO)$/;
5551 my $extra = "";
5552 if ($_ eq "CPAN_USERID") {
4d1321a7
A		 5553 $extra .= " (";
5554 $extra .= $self->fullname;
9d61fa1d
A		 5555 my $email; # old perls!
5556 if ($email = $CPAN::META->instance("CPAN::Author",
5557 $self->cpan_userid
5558 )->email) {
5559 $extra .= " <$email>";
5560 } else {
5561 $extra .= " <no email>";
5562 }
5563 $extra .= ")";
5564 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5565 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
5566 next;
5567 }
0cf35e6a
SP		 5568 next unless defined $ro->{$_};
5569 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
6d29edf5 5570 }
8fc516fe 5571 KEY: for (sort keys %$self) {
f04ea8d1 5572 next if m/^(ID|RO)$/;
8fc516fe
SP		 5573 unless (defined $self->{$_}) {
5574 delete $self->{$_};
5575 next KEY;
5576 }
f04ea8d1
SP		 5577 if (ref($self->{$_}) eq "ARRAY") {
5578 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
5579 } elsif (ref($self->{$_}) eq "HASH") {
8fc516fe
SP		 5580 my $value;
5581 if (/^CONTAINSMODS$/) {
5582 $value = join(" ",sort keys %{$self->{$_}});
5583 } elsif (/^prereq_pm$/) {
5584 my @value;
5585 my $v = $self->{$_};
5586 for my $x (sort keys %$v) {
5587 my @svalue;
5588 for my $y (sort keys %{$v->{$x}}) {
5589 push @svalue, "$y=>$v->{$x}{$y}";
5590 }
05bab18e 5591 push @value, "$x\:" . join ",", @svalue if @svalue;
8fc516fe
SP		 5592 }
5593 $value = join ";", @value;
5594 } else {
5595 $value = $self->{$_};
5596 }
f04ea8d1
SP		 5597 push @m, sprintf(
5598 " %-12s %s\n",
5599 $_,
5600 $value,
5601 );
5602 } else {
5603 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
5604 }
5f05dabc 5605 }
05454584 5606 join "", @m, "\n";
5f05dabc 5607}
5608
4d1321a7
A		 5609#-> sub CPAN::InfoObj::fullname ;
5610sub fullname {
05454584 5611 my($self) = @_;
9d61fa1d 5612 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5f05dabc 5613}
5614
6d29edf5 5615#-> sub CPAN::InfoObj::dump ;
36263cb3 5616sub dump {
f04ea8d1
SP		 5617 my($self, $what) = @_;
5618 unless ($CPAN::META->has_inst("Data::Dumper")) {
5619 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5620 }
5621 local $Data::Dumper::Sortkeys;
5622 $Data::Dumper::Sortkeys = 1;
5623 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5624 if (length $out > 100000) {
5625 my $fh_pager = FileHandle->new;
5626 local($SIG{PIPE}) = "IGNORE";
5627 my $pager = $CPAN::Config->{'pager'} || "cat";
5628 $fh_pager->open("|$pager")
5629 or die "Could not open pager $pager\: $!";
5630 $fh_pager->print($out);
5631 close $fh_pager;
5632 } else {
5633 $CPAN::Frontend->myprint($out);
5634 }
36263cb3
GS		 5635}
5636
05454584 5637package CPAN::Author;
e82b9348 5638use strict;
05454584 5639
9ddc4ed0
A		 5640#-> sub CPAN::Author::force
5641sub force {
5642 my $self = shift;
5643 $self->{force}++;
5644}
5645
5646#-> sub CPAN::Author::force
5647sub unforce {
5648 my $self = shift;
5649 delete $self->{force};
5650}
5651
c049f953
JH		 5652#-> sub CPAN::Author::id
5653sub id {
5654 my $self = shift;
5655 my $id = $self->{ID};
5656 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5657 $id;
5658}
5659
05454584
A		 5660#-> sub CPAN::Author::as_glimpse ;
5661sub as_glimpse {
5f05dabc 5662 my($self) = @_;
05454584
A		 5663 my(@m);
5664 my $class = ref($self);
5665 $class =~ s/^CPAN:://;
c049f953
JH		 5666 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5667 $class,
5668 $self->{ID},
5669 $self->fullname,
5670 $self->email);
05454584 5671 join "", @m;
5f05dabc 5672}
5673
05454584 5674#-> sub CPAN::Author::fullname ;
9d61fa1d 5675sub fullname {
0cf35e6a 5676 shift->ro->{FULLNAME};
9d61fa1d 5677}
05454584 5678*name = \&fullname;
36263cb3 5679
05454584 5680#-> sub CPAN::Author::email ;
0cf35e6a 5681sub email { shift->ro->{EMAIL}; }
8d97e4a1 5682
d8773709 5683#-> sub CPAN::Author::ls ;
8d97e4a1
JH		 5684sub ls {
5685 my $self = shift;
e82b9348 5686 my $glob = shift || "";
554a9ef5 5687 my $silent = shift || 0;
8d97e4a1
JH		 5688 my $id = $self->id;
5689
e82b9348 5690 # adapted from CPAN::Distribution::verifyCHECKSUM ;
c049f953
JH		 5691 my(@csf); # chksumfile
5692 @csf = $self->id =~ /(.)(.)(.*)/;
5693 $csf[1] = join "", @csf[0,1];
554a9ef5 5694 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
c049f953 5695 my(@dl);
554a9ef5 5696 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
c049f953 5697 unless (grep {$_->[2] eq $csf[1]} @dl) {
f3fe0ae6 5698 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
c049f953
JH		 5699 return;
5700 }
554a9ef5 5701 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
c049f953 5702 unless (grep {$_->[2] eq $csf[2]} @dl) {
f3fe0ae6 5703 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
c049f953
JH		 5704 return;
5705 }
554a9ef5 5706 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
e82b9348 5707 if ($glob) {
4d1321a7
A		 5708 if ($CPAN::META->has_inst("Text::Glob")) {
5709 my $rglob = Text::Glob::glob_to_regex($glob);
5710 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5711 } else {
5712 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5713 }
e82b9348 5714 }
f04ea8d1
SP		 5715 unless ($silent >= 2) {
5716 $CPAN::Frontend->myprint(join "", map {
5717 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5718 } sort { $a->[2] cmp $b->[2] } @dl);
5719 }
ca79d794 5720 @dl;
8d97e4a1
JH		 5721}
5722
c049f953 5723# returns an array of arrays, the latter contain (size,mtime,filename)
d8773709 5724#-> sub CPAN::Author::dir_listing ;
8d97e4a1
JH		 5725sub dir_listing {
5726 my $self = shift;
5727 my $chksumfile = shift;
c049f953 5728 my $recursive = shift;
554a9ef5 5729 my $may_ftp = shift;
b96578bb 5730
8d97e4a1 5731 my $lc_want =
f04ea8d1
SP		 5732 File::Spec->catfile($CPAN::Config->{keep_source_where},
5733 "authors", "id", @$chksumfile);
f3fe0ae6 5734
554a9ef5
SP		 5735 my $fh;
5736
5737 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5738 # hazard. (Without GPG installed they are not that much better,
5739 # though.)
5740 $fh = FileHandle->new;
5741 if (open($fh, $lc_want)) {
f04ea8d1
SP		 5742 my $line = <$fh>; close $fh;
5743 unlink($lc_want) unless $line =~ /PGP/;
554a9ef5 5744 }
f3fe0ae6 5745
8d97e4a1 5746 local($") = "/";
c049f953 5747 # connect "force" argument with "index_expire".
9ddc4ed0 5748 my $force = $self->{force};
c049f953 5749 if (my @stat = stat $lc_want) {
9ddc4ed0 5750 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
c049f953 5751 }
554a9ef5
SP		 5752 my $lc_file;
5753 if ($may_ftp) {
5754 $lc_file = CPAN::FTP->localize(
5755 "authors/id/@$chksumfile",
5756 $lc_want,
5757 $force,
5758 );
5759 unless ($lc_file) {
5760 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5761 $chksumfile->[-1] .= ".gz";
5762 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5763 "$lc_want.gz",1);
5764 if ($lc_file) {
5765 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
be34b10d 5766 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
554a9ef5
SP		 5767 } else {
5768 return;
5769 }
5770 }
5771 } else {
5772 $lc_file = $lc_want;
5773 # we *could* second-guess and if the user has a file: URL,
5774 # then we could look there. But on the other hand, if they do
5775 # have a file: URL, wy did they choose to set
5776 # $CPAN::Config->{show_upload_date} to false?
8d97e4a1
JH		 5777 }
5778
e82b9348 5779 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
554a9ef5 5780 $fh = FileHandle->new;
8d97e4a1 5781 my($cksum);
f04ea8d1
SP		 5782 if (open $fh, $lc_file) {
5783 local($/);
5784 my $eval = <$fh>;
5785 $eval =~ s/\015?\012/\n/g;
5786 close $fh;
5787 my($comp) = Safe->new();
5788 $cksum = $comp->reval($eval);
5789 if ($@) {
5790 rename $lc_file, "$lc_file.bad";
5791 Carp::confess($@) if $@;
5792 }
554a9ef5 5793 } elsif ($may_ftp) {
f04ea8d1 5794 Carp::carp "Could not open '$lc_file' for reading.";
8d97e4a1 5795 } else {
554a9ef5 5796 # Maybe should warn: "You may want to set show_upload_date to a true value"
f04ea8d1 5797 return;
8d97e4a1
JH		 5798 }
5799 my(@result,$f);
5800 for $f (sort keys %$cksum) {
5801 if (exists $cksum->{$f}{isdir}) {
c049f953
JH		 5802 if ($recursive) {
5803 my(@dir) = @$chksumfile;
5804 pop @dir;
5805 push @dir, $f, "CHECKSUMS";
5806 push @result, map {
5807 [$_->[0], $_->[1], "$f/$_->[2]"]
554a9ef5 5808 } $self->dir_listing(\@dir,1,$may_ftp);
c049f953
JH		 5809 } else {
5810 push @result, [ 0, "-", $f ];
5811 }
8d97e4a1
JH		 5812 } else {
5813 push @result, [
5814 ($cksum->{$f}{"size"}||0),
5815 $cksum->{$f}{"mtime"}||"---",
5816 $f
5817 ];
5818 }
5819 }
5820 @result;
5821}
5f05dabc 5822
dc053c64
SP		 5823#-> sub CPAN::Author::reports
5824sub reports {
5825 $CPAN::Frontend->mywarn("reports on authors not implemented.
5826Please file a bugreport if you need this.\n");
5827}
5828
05454584 5829package CPAN::Distribution;
e82b9348 5830use strict;
5f05dabc 5831
6d29edf5 5832# Accessors
e8a27a4e
A		 5833sub cpan_comment {
5834 my $self = shift;
5835 my $ro = $self->ro or return;
5836 $ro->{CPAN_COMMENT}
5837}
6d29edf5 5838
dc053c64 5839#-> CPAN::Distribution::undelay
6d29edf5
JH		 5840sub undelay {
5841 my $self = shift;
f04ea8d1
SP		 5842 for my $delayer (
5843 "configure_requires_later",
5844 "configure_requires_later_for",
5845 "later",
5846 "later_for",
5847 ) {
5848 delete $self->{$delayer};
5849 }
6d29edf5
JH		 5850}
5851
dc053c64
SP		 5852#-> CPAN::Distribution::is_dot_dist
5853sub is_dot_dist {
5854 my($self) = @_;
8ce4ea0b 5855 return substr($self->id,-1,1) eq ".";
dc053c64
SP		 5856}
5857
e8a27a4e 5858# add the A/AN/ stuff
dc053c64 5859#-> CPAN::Distribution::normalize
8d97e4a1
JH		 5860sub normalize {
5861 my($self,$s) = @_;
d8773709 5862 $s = $self->id unless defined $s;
8fc516fe 5863 if (substr($s,-1,1) eq ".") {
05bab18e
SP		 5864 # using a global because we are sometimes called as static method
5865 if (!$CPAN::META->{LOCK}
5866 && !$CPAN::Have_warned->{"$s is unlocked"}++
5867 ) {
5868 $CPAN::Frontend->mywarn("You are visiting the local directory
5869 '$s'
5870 without lock, take care that concurrent processes do not do likewise.\n");
5871 $CPAN::Frontend->mysleep(1);
5872 }
8fc516fe
SP		 5873 if ($s eq ".") {
5874 $s = "$CPAN::iCwd/.";
5875 } elsif (File::Spec->file_name_is_absolute($s)) {
5876 } elsif (File::Spec->can("rel2abs")) {
5877 $s = File::Spec->rel2abs($s);
5878 } else {
5879 $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5880 }
5881 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5882 unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5883 for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5884 $_->{build_dir} = $s;
5885 $_->{archived} = "local_directory";
6658a91b 5886 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
8fc516fe
SP		 5887 }
5888 }
5889 } elsif (
c049f953
JH		 5890 $s =~ tr|/|| == 1
5891 or
5892 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5893 ) {
5894 return $s if $s =~ m:^N/A|^Contact Author: ;
8d97e4a1 5895 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5fc0f0f6 5896 $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
8d97e4a1
JH		 5897 CPAN->debug("s[$s]") if $CPAN::DEBUG;
5898 }
5899 $s;
5900}
5901
4d1321a7
A		 5902#-> sub CPAN::Distribution::author ;
5903sub author {
5904 my($self) = @_;
6658a91b
SP		 5905 my($authorid);
5906 if (substr($self->id,-1,1) eq ".") {
5907 $authorid = "LOCAL";
5908 } else {
5909 ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5910 }
4d1321a7
A		 5911 CPAN::Shell->expand("Author",$authorid);
5912}
5913
5914# tries to get the yaml from CPAN instead of the distro itself:
5915# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5916sub fast_yaml {
5917 my($self) = @_;
5918 my $meta = $self->pretty_id;
5919 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5920 my(@ls) = CPAN::Shell->globls($meta);
5921 my $norm = $self->normalize($meta);
5922
5923 my($local_file);
5924 my($local_wanted) =
5925 File::Spec->catfile(
f04ea8d1
SP		 5926 $CPAN::Config->{keep_source_where},
5927 "authors",
5928 "id",
5929 split(/\//,$norm)
5930 );
4d1321a7
A		 5931 $self->debug("Doing localize") if $CPAN::DEBUG;
5932 unless ($local_file =
5933 CPAN::FTP->localize("authors/id/$norm",
5934 $local_wanted)) {
5935 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5936 }
6658a91b
SP		 5937 my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5938}
5939
5940#-> sub CPAN::Distribution::cpan_userid
5941sub cpan_userid {
5942 my $self = shift;
5943 if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5944 return $1;
5945 }
5946 return $self->SUPER::cpan_userid;
4d1321a7
A		 5947}
5948
135a59c2 5949#-> sub CPAN::Distribution::pretty_id
e8a27a4e
A		 5950sub pretty_id {
5951 my $self = shift;
5952 my $id = $self->id;
5953 return $id unless $id =~ m|^./../|;
5954 substr($id,5);
5955}
5956
f04ea8d1
SP		 5957#-> sub CPAN::Distribution::base_id
5958sub base_id {
5959 my $self = shift;
5960 my $id = $self->pretty_id();
5961 my $base_id = File::Basename::basename($id);
5962 $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
5963 return $base_id;
5964}
5965
f20de9f0
SP		 5966# mark as dirty/clean for the sake of recursion detection. $color=1
5967# means "in use", $color=0 means "not in use anymore". $color=2 means
5968# we have determined prereqs now and thus insist on passing this
5969# through (at least) once again.
5970
6d29edf5
JH		 5971#-> sub CPAN::Distribution::color_cmd_tmps ;
5972sub color_cmd_tmps {
5973 my($self) = shift;
5974 my($depth) = shift || 0;
5975 my($color) = shift || 0;
35576f8c 5976 my($ancestors) = shift || [];
6d29edf5
JH		 5977 # a distribution needs to recurse into its prereq_pms
5978
5979 return if exists $self->{incommandcolor}
f20de9f0 5980 && $color==1
6d29edf5 5981 && $self->{incommandcolor}==$color;
f04ea8d1 5982 if ($depth>=$CPAN::MAX_RECURSION) {
ade94d80 5983 die(CPAN::Exception::RecursiveDependency->new($ancestors));
35576f8c
A		 5984 }
5985 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6d29edf5
JH		 5986 my $prereq_pm = $self->prereq_pm;
5987 if (defined $prereq_pm) {
135a59c2
A		 5988 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5989 keys %{$prereq_pm->{build_requires}||{}}) {
7d97ad34 5990 next PREREQ if $pre eq "perl";
44d21104
A		 5991 my $premo;
5992 unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5993 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5994 $CPAN::Frontend->mysleep(2);
5995 next PREREQ;
5996 }
35576f8c 5997 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6d29edf5
JH		 5998 }
5999 }
6000 if ($color==0) {
6001 delete $self->{sponsored_mods};
b72dd56f
SP		 6002
6003 # as we are at the end of a command, we'll give up this
6004 # reminder of a broken test. Other commands may test this guy
6005 # again. Maybe 'badtestcnt' should be renamed to
f20de9f0 6006 # 'make_test_failed_within_command'?
6d29edf5
JH		 6007 delete $self->{badtestcnt};
6008 }
6009 $self->{incommandcolor} = $color;
6010}
6011
911a92db
GS		 6012#-> sub CPAN::Distribution::as_string ;
6013sub as_string {
f04ea8d1
SP		 6014 my $self = shift;
6015 $self->containsmods;
6016 $self->upload_date;
6017 $self->SUPER::as_string(@_);
911a92db
GS		 6018}
6019
6020#-> sub CPAN::Distribution::containsmods ;
6021sub containsmods {
f04ea8d1
SP		 6022 my $self = shift;
6023 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6024 my $dist_id = $self->{ID};
6025 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6026 my $mod_file = $mod->cpan_file or next;
6027 my $mod_id = $mod->{ID} or next;
6028 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6029 # sleep 1;
6030 if ($CPAN::Signal) {
6031 delete $self->{CONTAINSMODS};
6032 return;
6033 }
6034 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
b72dd56f 6035 }
b03f445c 6036 keys %{$self->{CONTAINSMODS}||={}};
911a92db
GS		 6037}
6038
554a9ef5
SP		 6039#-> sub CPAN::Distribution::upload_date ;
6040sub upload_date {
f04ea8d1
SP		 6041 my $self = shift;
6042 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6043 my(@local_wanted) = split(/\//,$self->id);
6044 my $filename = pop @local_wanted;
6045 push @local_wanted, "CHECKSUMS";
6046 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6047 return unless $author;
6048 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6049 return unless @dl;
6050 my($dirent) = grep { $_->[2] eq $filename } @dl;
6051 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6052 return unless $dirent->[1];
6053 return $self->{UPLOAD_DATE} = $dirent->[1];
554a9ef5
SP		 6054}
6055
d8773709
JH		 6056#-> sub CPAN::Distribution::uptodate ;
6057sub uptodate {
6058 my($self) = @_;
6059 my $c;
6060 foreach $c ($self->containsmods) {
6061 my $obj = CPAN::Shell->expandany($c);
f04ea8d1 6062 unless ($obj->uptodate) {
8962fc49
SP		 6063 my $id = $self->pretty_id;
6064 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6065 return 0;
6066 }
d8773709
JH		 6067 }
6068 return 1;
6069}
6070
05454584
A		 6071#-> sub CPAN::Distribution::called_for ;
6072sub called_for {
6073 my($self,$id) = @_;
6d29edf5
JH		 6074 $self->{CALLED_FOR} = $id if defined $id;
6075 return $self->{CALLED_FOR};
5f05dabc 6076}
6077
05454584
A		 6078#-> sub CPAN::Distribution::get ;
6079sub get {
5f05dabc 6080 my($self) = @_;
b72dd56f 6081 $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
be34b10d
SP		 6082 if (my $goto = $self->prefs->{goto}) {
6083 $CPAN::Frontend->mywarn
6084 (sprintf(
6085 "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6086 $goto,
6087 $self->{prefs_file},
6088 $self->{prefs_file_doc},
6089 ));
6090 return $self->goto($goto);
6091 }
6658a91b
SP		 6092 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6093 ? $ENV{PERL5LIB}
6094 : ($ENV{PERLLIB} || "");
6095
6096 $CPAN::META->set_perl5lib;
6097 local $ENV{MAKEFLAGS}; # protect us from outer make calls
6098
da199366 6099 EXCUSE: {
f04ea8d1 6100 my @e;
8ce4ea0b 6101 my $goodbye_message;
b72dd56f 6102 $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
05bab18e 6103 if ($self->prefs->{disabled}) {
810a0276
SP		 6104 my $why = sprintf(
6105 "Disabled via prefs file '%s' doc %d",
6106 $self->{prefs_file},
6107 $self->{prefs_file_doc},
6108 );
6109 push @e, $why;
8ce4ea0b
SP		 6110 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6111 $goodbye_message = "[disabled] -- NA $why";
810a0276
SP		 6112 # note: not intended to be persistent but at least visible
6113 # during this session
6114 } else {
dc053c64
SP		 6115 if (exists $self->{build_dir} && -d $self->{build_dir}
6116 && ($self->{modulebuild}||$self->{writemakefile})
6117 ) {
b72dd56f
SP		 6118 # this deserves print, not warn:
6119 $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
6120 "$self->{build_dir}\n"
6121 );
23a216b4 6122 return 1;
b72dd56f 6123 }
6658a91b 6124
b72dd56f
SP		 6125 # although we talk about 'force' we shall not test on
6126 # force directly. New model of force tries to refrain from
6127 # direct checking of force.
810a0276
SP		 6128 exists $self->{unwrapped} and (
6129 UNIVERSAL::can($self->{unwrapped},"failed") ?
6130 $self->{unwrapped}->failed :
6131 $self->{unwrapped} =~ /^NO/
6132 )
6133 and push @e, "Unwrapping had some problem, won't try again without force";
6134 }
8ce4ea0b
SP		 6135 if (@e) {
6136 $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6137 if ($goodbye_message) {
6138 $self->goodbye($goodbye_message);
6139 }
6140 return;
6141 }
da199366 6142 }
f04ea8d1
SP		 6143 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6144
6145 my($local_file);
6146 unless ($self->{build_dir} && -d $self->{build_dir}) {
6147 $self->get_file_onto_local_disk;
6148 return if $CPAN::Signal;
6149 $self->check_integrity;
6150 return if $CPAN::Signal;
6151 (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
6152 $packagedir ||= $self->{build_dir};
6153 $self->{build_dir} = $packagedir;
6154 }
d8773709 6155
f04ea8d1 6156 if ($CPAN::Signal) {
dc053c64
SP		 6157 $self->safe_chdir($sub_wd);
6158 return;
6159 }
f04ea8d1 6160 return $self->run_MM_or_MB($local_file);
dc053c64
SP		 6161}
6162
6163#-> CPAN::Distribution::get_file_onto_local_disk
6164sub get_file_onto_local_disk {
6165 my($self) = @_;
6166
6167 return if $self->is_dot_dist;
05454584
A		 6168 my($local_file);
6169 my($local_wanted) =
5de3f0da 6170 File::Spec->catfile(
f04ea8d1
SP		 6171 $CPAN::Config->{keep_source_where},
6172 "authors",
6173 "id",
6174 split(/\//,$self->id)
6175 );
05454584
A		 6176
6177 $self->debug("Doing localize") if $CPAN::DEBUG;
c049f953
JH		 6178 unless ($local_file =
6179 CPAN::FTP->localize("authors/id/$self->{ID}",
6180 $local_wanted)) {
6181 my $note = "";
6182 if ($CPAN::Index::DATE_OF_02) {
6183 $note = "Note: Current database in memory was generated ".
6184 "on $CPAN::Index::DATE_OF_02\n";
6185 }
6186 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6187 }
6658a91b
SP		 6188
6189 $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
05454584 6190 $self->{localfile} = $local_file;
dc053c64 6191}
05454584 6192
dc053c64
SP		 6193
6194#-> CPAN::Distribution::check_integrity
6195sub check_integrity {
6196 my($self) = @_;
6197
6198 return if $self->is_dot_dist;
e82b9348 6199 if ($CPAN::META->has_inst("Digest::SHA")) {
f04ea8d1
SP		 6200 $self->debug("Digest::SHA is installed, verifying");
6201 $self->verifyCHECKSUM;
55e314ee 6202 } else {
f04ea8d1 6203 $self->debug("Digest::SHA is NOT installed");
55e314ee 6204 }
dc053c64
SP		 6205}
6206
6207#-> CPAN::Distribution::run_preps_on_packagedir
6208sub run_preps_on_packagedir {
6209 my($self) = @_;
6210 return if $self->is_dot_dist;
d8773709 6211
d8773709
JH		 6212 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6213 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6214 $self->safe_chdir($builddir);
05bab18e
SP		 6215 $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6216 File::Path::rmtree("tmp-$$");
6217 unless (mkdir "tmp-$$", 0755) {
c9869e1c 6218 $CPAN::Frontend->unrecoverable_error(<<EOF);
05bab18e 6219Couldn't mkdir '$builddir/tmp-$$': $!
c9869e1c
SP		 6220
6221Cannot continue: Please find the reason why I cannot make the
6222directory
05bab18e 6223$builddir/tmp-$$
c9869e1c
SP		 6224and fix the problem, then retry.
6225
6226EOF
6227 }
f04ea8d1 6228 if ($CPAN::Signal) {
d8773709
JH		 6229 return;
6230 }
05bab18e 6231 $self->safe_chdir("tmp-$$");
d8773709
JH		 6232
6233 #
6234 # Unpack the goods
6235 #
dc053c64 6236 my $local_file = $self->{localfile};
be34b10d
SP		 6237 my $ct = eval{CPAN::Tarzip->new($local_file)};
6238 unless ($ct) {
6239 $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6240 delete $self->{build_dir};
6241 return;
6242 }
f04ea8d1 6243 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
be34b10d 6244 $self->{was_uncompressed}++ unless eval{$ct->gtest()};
f04ea8d1 6245 $self->untar_me($ct);
05d2a450 6246 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
f04ea8d1 6247 $self->unzip_me($ct);
55e314ee 6248 } else {
ed84aac9 6249 $self->{was_uncompressed}++ unless $ct->gtest();
f04ea8d1 6250 $local_file = $self->handle_singlefile($local_file);
5f05dabc 6251 }
d8773709
JH		 6252
6253 # we are still in the tmp directory!
6254 # Let's check if the package has its own directory.
6255 my $dh = DirHandle->new(File::Spec->curdir)
6256 or Carp::croak("Couldn't opendir .: $!");
6257 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
6258 $dh->close;
05bab18e
SP		 6259 my ($packagedir);
6260 # XXX here we want in each branch File::Temp to protect all build_dir directories
b03f445c 6261 if (CPAN->has_usable("File::Temp")) {
05bab18e
SP		 6262 my $tdir_base;
6263 my $from_dir;
6264 my @dirents;
6265 if (@readdir == 1 && -d $readdir[0]) {
6266 $tdir_base = $readdir[0];
6267 $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
6268 my $dh2 = DirHandle->new($from_dir)
6269 or Carp::croak("Couldn't opendir $from_dir: $!");
6270 @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6271 } else {
6272 my $userid = $self->cpan_userid;
6273 CPAN->debug("userid[$userid]");
6274 if (!$userid or $userid eq "N/A") {
6275 $userid = "anon";
6276 }
6277 $tdir_base = $userid;
6278 $from_dir = File::Spec->curdir;
6279 @dirents = @readdir;
6280 }
6281 $packagedir = File::Temp::tempdir(
6282 "$tdir_base-XXXXXX",
6283 DIR => $builddir,
6284 CLEANUP => 0,
6285 );
6286 my $f;
6287 for $f (@dirents) { # is already without "." and ".."
6288 my $from = File::Spec->catdir($from_dir,$f);
6289 my $to = File::Spec->catdir($packagedir,$f);
810a0276
SP		 6290 unless (File::Copy::move($from,$to)) {
6291 my $err = $!;
6292 $from = File::Spec->rel2abs($from);
6293 Carp::confess("Couldn't move $from to $to: $err");
6294 }
05bab18e
SP		 6295 }
6296 } else { # older code below, still better than nothing when there is no File::Temp
6297 my($distdir);
6298 if (@readdir == 1 && -d $readdir[0]) {
6299 $distdir = $readdir[0];
6300 $packagedir = File::Spec->catdir($builddir,$distdir);
6301 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6302 if $CPAN::DEBUG;
6303 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6304 "$packagedir\n");
6305 File::Path::rmtree($packagedir);
6306 unless (File::Copy::move($distdir,$packagedir)) {
6307 $CPAN::Frontend->unrecoverable_error(<<EOF);
c9869e1c
SP		 6308Couldn't move '$distdir' to '$packagedir': $!
6309
6310Cannot continue: Please find the reason why I cannot move
05bab18e 6311$builddir/tmp-$$/$distdir
c9869e1c
SP		 6312to
6313$packagedir
6314and fix the problem, then retry
6315
6316EOF
05bab18e
SP		 6317 }
6318 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6319 $distdir,
6320 $packagedir,
6321 -e $packagedir,
6322 -d $packagedir,
6323 )) if $CPAN::DEBUG;
6324 } else {
6325 my $userid = $self->cpan_userid;
b72dd56f 6326 CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
05bab18e
SP		 6327 if (!$userid or $userid eq "N/A") {
6328 $userid = "anon";
6329 }
6330 my $pragmatic_dir = $userid . '000';
6331 $pragmatic_dir =~ s/\W_//g;
6332 $pragmatic_dir++ while -d "../$pragmatic_dir";
6333 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6334 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6335 File::Path::mkpath($packagedir);
6336 my($f);
6337 for $f (@readdir) { # is already without "." and ".."
6338 my $to = File::Spec->catdir($packagedir,$f);
6339 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6340 }
9d61fa1d 6341 }
d8773709 6342 }
b72dd56f 6343 $self->{build_dir} = $packagedir;
6f14f089 6344 $self->safe_chdir($builddir);
05bab18e 6345 File::Path::rmtree("tmp-$$");
d8773709 6346
554a9ef5 6347 $self->safe_chdir($packagedir);
6658a91b 6348 $self->_signature_business();
554a9ef5 6349 $self->safe_chdir($builddir);
554a9ef5 6350
dc053c64
SP		 6351 return($packagedir,$local_file);
6352}
554a9ef5 6353
f04ea8d1
SP		 6354#-> sub CPAN::Distribution::parse_meta_yml ;
6355sub parse_meta_yml {
6356 my($self) = @_;
6357 my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6358 my $yaml = File::Spec->catfile($build_dir,"META.yml");
6359 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6360 return unless -f $yaml;
6361 my $early_yaml;
6362 eval {
6363 require Parse::Metayaml; # hypothetical
6364 $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6365 };
6366 unless ($early_yaml) {
6367 eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6368 }
6369 unless ($early_yaml) {
6370 return;
6371 }
6372 return $early_yaml;
6373}
6374
6375#-> sub CPAN::Distribution::satisfy_configure_requires ;
6376sub satisfy_configure_requires {
6377 my($self) = @_;
6378 my $enable_configure_requires = 1;
6379 if (!$enable_configure_requires) {
6380 return 1;
6381 # if we return 1 here, everything is as before we introduced
6382 # configure_requires that means, things with
6383 # configure_requires simply fail, all others succeed
6384 }
6385 my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6386 if ($self->{configure_requires_later}) {
6387 for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6388 if ($self->{configure_requires_later_for}{$k}>1) {
6389 # we must not come here a second time
6390 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6391 require YAML::Syck;
6392 $CPAN::Frontend->mydie
6393 (
6394 YAML::Syck::Dump
6395 ({self=>$self, prereq=>\@prereq})
6396 );
6397 }
6398 }
6399 }
6400 if ($prereq[0][0] eq "perl") {
6401 my $need = "requires perl '$prereq[0][1]'";
6402 my $id = $self->pretty_id;
6403 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6404 $self->{make} = CPAN::Distrostatus->new("NO $need");
6405 $self->store_persistent_state;
6406 return $self->goodbye("[prereq] -- NOT OK");
6407 } else {
6408 my $follow = eval {
6409 $self->follow_prereqs("configure_requires_later", @prereq);
6410 };
6411 if (0) {
6412 } elsif ($follow) {
6413 return;
6414 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6415 $CPAN::Frontend->mywarn($@);
6416 return $self->goodbye("[depend] -- NOT OK");
6417 }
6418 }
6419 die "never reached";
6420}
6421
6422#-> sub CPAN::Distribution::run_MM_or_MB ;
dc053c64 6423sub run_MM_or_MB {
f04ea8d1
SP		 6424 my($self,$local_file) = @_;
6425 $self->satisfy_configure_requires() or return;
6426 my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
d8773709
JH		 6427 my($mpl_exists) = -f $mpl;
6428 unless ($mpl_exists) {
c049f953
JH		 6429 # NFS has been reported to have racing problems after the
6430 # renaming of a directory in some environments.
6431 # This trick helps.
8962fc49 6432 $CPAN::Frontend->mysleep(1);
f04ea8d1
SP		 6433 my $mpldh = DirHandle->new($self->{build_dir})
6434 or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
c049f953
JH		 6435 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6436 $mpldh->close;
d8773709 6437 }
e82b9348 6438 my $prefer_installer = "eumm"; # eumm|mb
f04ea8d1 6439 if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
e82b9348 6440 if ($mpl_exists) { # they *can* choose
f20de9f0
SP		 6441 if ($CPAN::META->has_inst("Module::Build")) {
6442 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6443 q{prefer_installer});
6444 }
e82b9348
SP		 6445 } else {
6446 $prefer_installer = "mb";
6447 }
6448 }
6658a91b 6449 return unless $self->patch;
f04ea8d1
SP		 6450 if (lc($prefer_installer) eq "rand") {
6451 $prefer_installer = rand()<.5 ? "eumm" : "mb";
6452 }
e82b9348 6453 if (lc($prefer_installer) eq "mb") {
c9869e1c 6454 $self->{modulebuild} = 1;
2b3bde2a
SP		 6455 } elsif ($self->{archived} eq "patch") {
6456 # not an edge case, nothing to install for sure
6457 my $why = "A patch file cannot be installed";
6458 $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6459 $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
e82b9348 6460 } elsif (! $mpl_exists) {
f04ea8d1 6461 $self->_edge_cases($mpl,$local_file);
6658a91b 6462 }
05bab18e
SP		 6463 if ($self->{build_dir}
6464 &&
6465 $CPAN::Config->{build_dir_reuse}
6466 ) {
6467 $self->store_persistent_state;
6468 }
6658a91b
SP		 6469 return $self;
6470}
6471
05bab18e
SP		 6472#-> CPAN::Distribution::store_persistent_state
6473sub store_persistent_state {
6474 my($self) = @_;
be34b10d 6475 my $dir = $self->{build_dir};
810a0276 6476 unless (File::Spec->canonpath(File::Basename::dirname($dir))
f04ea8d1 6477 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
be34b10d
SP		 6478 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6479 "will not store persistent state\n");
6480 return;
6481 }
6482 my $file = sprintf "%s.yml", $dir;
b72dd56f
SP		 6483 my $yaml_module = CPAN::_yaml_module;
6484 if ($CPAN::META->has_inst($yaml_module)) {
6485 CPAN->_yaml_dumpfile(
6486 $file,
6487 {
6488 time => time,
6489 perl => CPAN::_perl_fingerprint,
6490 distribution => $self,
6491 }
6492 );
6493 } else {
6494 $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6495 "will not store persistent state\n");
6496 }
05bab18e
SP		 6497}
6498
b03f445c 6499#-> CPAN::Distribution::try_download
6658a91b
SP		 6500sub try_download {
6501 my($self,$patch) = @_;
6502 my $norm = $self->normalize($patch);
6503 my($local_wanted) =
6504 File::Spec->catfile(
6505 $CPAN::Config->{keep_source_where},
6506 "authors",
6507 "id",
6508 split(/\//,$norm),
f04ea8d1 6509 );
6658a91b
SP		 6510 $self->debug("Doing localize") if $CPAN::DEBUG;
6511 return CPAN::FTP->localize("authors/id/$norm",
6512 $local_wanted);
6513}
6514
8ce4ea0b
SP		 6515{
6516 my $stdpatchargs = "";
6517 #-> CPAN::Distribution::patch
6518 sub patch {
6519 my($self) = @_;
6520 $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6521 my $patches = $self->prefs->{patches};
6522 $patches ||= "";
6523 $self->debug("patches[$patches]") if $CPAN::DEBUG;
6524 if ($patches) {
6525 return unless @$patches;
6526 $self->safe_chdir($self->{build_dir});
6527 CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6528 my $patchbin = $CPAN::Config->{patch};
6529 unless ($patchbin && length $patchbin) {
6530 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6531 "Please run 'o conf init /patch/'\n\n");
6532 }
6533 unless (MM->maybe_command($patchbin)) {
6534 $CPAN::Frontend->mydie("No external patch command available\n\n".
6535 "Please run 'o conf init /patch/'\n\n");
6536 }
6537 $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6538 local $ENV{PATCH_GET} = 0; # formerly known as -g0
6539 unless ($stdpatchargs) {
6540 my $system = "$patchbin --version |";
6541 local *FH;
6542 open FH, $system or die "Could not fork '$system': $!";
6543 local $/ = "\n";
6544 my $pversion;
6545 PARSEVERSION: while (<FH>) {
6546 if (/^patch\s+([\d\.]+)/) {
6547 $pversion = $1;
6548 last PARSEVERSION;
6549 }
6550 }
6551 if ($pversion) {
6552 $stdpatchargs = "-N --fuzz=3";
6553 } else {
6554 $stdpatchargs = "-N";
6555 }
6556 }
6557 my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6558 $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6559 for my $patch (@$patches) {
6560 unless (-f $patch) {
6561 if (my $trydl = $self->try_download($patch)) {
6562 $patch = $trydl;
6563 } else {
6564 my $fail = "Could not find patch '$patch'";
6565 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6566 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6567 delete $self->{build_dir};
6568 return;
6569 }
6570 }
6571 $CPAN::Frontend->myprint(" $patch\n");
6572 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6573
6574 my $pcommand;
6575 my $ppp = $self->_patch_p_parameter($readfh);
6576 if ($ppp eq "applypatch") {
6577 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6658a91b 6578 } else {
8ce4ea0b
SP		 6579 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6580 $pcommand = "$patchbin $thispatchargs";
6581 }
6582
6583 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6584 my $writefh = FileHandle->new;
6585 $CPAN::Frontend->myprint(" $pcommand\n");
6586 unless (open $writefh, "|$pcommand") {
6587 my $fail = "Could not fork '$pcommand'";
6588 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6589 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6590 delete $self->{build_dir};
6591 return;
6592 }
6593 while (my $x = $readfh->READLINE) {
6594 print $writefh $x;
6595 }
6596 unless (close $writefh) {
6597 my $fail = "Could not apply patch '$patch'";
6658a91b
SP		 6598 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6599 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6600 delete $self->{build_dir};
6601 return;
6602 }
6603 }
8ce4ea0b 6604 $self->{patched}++;
6658a91b 6605 }
8ce4ea0b 6606 return 1;
6658a91b 6607 }
6658a91b
SP		 6608}
6609
05bab18e
SP		 6610sub _patch_p_parameter {
6611 my($self,$fh) = @_;
be34b10d
SP		 6612 my $cnt_files = 0;
6613 my $cnt_p0files = 0;
05bab18e
SP		 6614 local($_);
6615 while ($_ = $fh->READLINE) {
b72dd56f
SP		 6616 if (
6617 $CPAN::Config->{applypatch}
6618 &&
6619 /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6620 ) {
6621 return "applypatch"
6622 }
05bab18e
SP		 6623 next unless /^[\*\+]{3}\s(\S+)/;
6624 my $file = $1;
6625 $cnt_files++;
6626 $cnt_p0files++ if -f $file;
b72dd56f
SP		 6627 CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6628 if $CPAN::DEBUG;
05bab18e 6629 }
be34b10d 6630 return "-p1" unless $cnt_files;
05bab18e
SP		 6631 return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6632}
6633
6658a91b
SP		 6634#-> sub CPAN::Distribution::_edge_cases
6635# with "configure" or "Makefile" or single file scripts
6636sub _edge_cases {
f04ea8d1 6637 my($self,$mpl,$local_file) = @_;
6658a91b
SP		 6638 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6639 $mpl,
6640 CPAN::anycwd(),
6641 )) if $CPAN::DEBUG;
f04ea8d1
SP		 6642 my $build_dir = $self->{build_dir};
6643 my($configure) = File::Spec->catfile($build_dir,"Configure");
6658a91b
SP		 6644 if (-f $configure) {
6645 # do we have anything to do?
6646 $self->{configure} = $configure;
f04ea8d1 6647 } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6658a91b 6648 $CPAN::Frontend->mywarn(qq{
09d9d230
A		 6649Package comes with a Makefile and without a Makefile.PL.
6650We\'ll try to build it with that Makefile then.
6651});
6658a91b
SP		 6652 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6653 $CPAN::Frontend->mysleep(2);
6654 } else {
6655 my $cf = $self->called_for || "unknown";
6656 if ($cf =~ m|/|) {
6657 $cf =~ s|.*/||;
6658 $cf =~ s|\W.*||;
6659 }
6660 $cf =~ s|[/\\:]||g; # risk of filesystem damage
6661 $cf = "unknown" unless length($cf);
6662 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
d8773709
JH		 6663 (The test -f "$mpl" returned false.)
6664 Writing one on our own (setting NAME to $cf)\a\n});
6658a91b
SP		 6665 $self->{had_no_makefile_pl}++;
6666 $CPAN::Frontend->mysleep(3);
ed84aac9 6667
6658a91b
SP		 6668 # Writing our own Makefile.PL
6669
6670 my $script = "";
6671 if ($self->{archived} eq "maybe_pl") {
6672 my $fh = FileHandle->new;
f04ea8d1 6673 my $script_file = File::Spec->catfile($build_dir,$local_file);
6658a91b 6674 $fh->open($script_file)
dc053c64 6675 or Carp::croak("Could not open script '$script_file': $!");
6658a91b
SP		 6676 local $/ = "\n";
6677 # name parsen und prereq
6678 my($state) = "poddir";
6679 my($name, $prereq) = ("", "");
6680 while (<$fh>) {
6681 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6682 if ($1 eq 'NAME') {
6683 $state = "name";
6684 } elsif ($1 eq 'PREREQUISITES') {
6685 $state = "prereq";
6686 }
6687 } elsif ($state =~ m{^(name|prereq)$}) {
6688 if (/^=/) {
6689 $state = "poddir";
6690 } elsif (/^\s*$/) {
6691 # nop
6692 } elsif ($state eq "name") {
6693 if ($name eq "") {
6694 ($name) = /^(\S+)/;
6695 $state = "poddir";
6696 }
6697 } elsif ($state eq "prereq") {
6698 $prereq .= $_;
ed84aac9 6699 }
6658a91b
SP		 6700 } elsif (/^=cut\b/) {
6701 last;
6702 }
6703 }
6704 $fh->close;
6705
6706 for ($name) {
6707 s{.*<}{}; # strip X<...>
6708 s{>.*}{};
6709 }
6710 chomp $prereq;
6711 $prereq = join " ", split /\s+/, $prereq;
6712 my($PREREQ_PM) = join("\n", map {
6713 s{.*<}{}; # strip X<...>
6714 s{>.*}{};
6715 if (/[\s\'\"]/) { # prose?
6716 } else {
6717 s/[^\w:]$//; # period?
6718 " "x28 . "'$_' => 0,";
6719 }
6720 } split /\s*,\s*/, $prereq);
ed84aac9 6721
6658a91b 6722 $script = "
ed84aac9
A		 6723 EXE_FILES => ['$name'],
6724 PREREQ_PM => {
6725$PREREQ_PM
6726 },
6727";
6658a91b 6728 if ($name) {
f04ea8d1 6729 my $to_file = File::Spec->catfile($build_dir, $name);
6658a91b
SP		 6730 rename $script_file, $to_file
6731 or die "Can't rename $script_file to $to_file: $!";
6732 }
6733 }
ed84aac9 6734
6658a91b
SP		 6735 my $fh = FileHandle->new;
6736 $fh->open(">$mpl")
6737 or Carp::croak("Could not open >$mpl: $!");
6738 $fh->print(
6739 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
55e314ee 6740# because there was no Makefile.PL supplied.
05454584 6741# Autogenerated on: }.scalar localtime().qq{
55e314ee 6742
09d9d230 6743use ExtUtils::MakeMaker;
ed84aac9
A		 6744WriteMakefile(
6745 NAME => q[$cf],$script
6746 );
05454584 6747});
6658a91b 6748 $fh->close;
5f05dabc 6749 }
6658a91b 6750}
d8773709 6751
6658a91b
SP		 6752#-> CPAN::Distribution::_signature_business
6753sub _signature_business {
6754 my($self) = @_;
be34b10d
SP		 6755 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6756 q{check_sigs});
6757 if ($check_sigs) {
6658a91b
SP		 6758 if ($CPAN::META->has_inst("Module::Signature")) {
6759 if (-f "SIGNATURE") {
6760 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6761 my $rv = Module::Signature::verify();
6762 if ($rv != Module::Signature::SIGNATURE_OK() and
6763 $rv != Module::Signature::SIGNATURE_MISSING()) {
05bab18e
SP		 6764 $CPAN::Frontend->mywarn(
6765 qq{\nSignature invalid for }.
6766 qq{distribution file. }.
6767 qq{Please investigate.\n\n}
6768 );
6658a91b
SP		 6769
6770 my $wrap =
23a216b4
SP		 6771 sprintf(qq{I'd recommend removing %s. Some error occured }.
6772 qq{while checking its signature, so it could }.
6773 qq{be invalid. Maybe you have configured }.
6774 qq{your 'urllist' with a bad URL. Please check this }.
6775 qq{array with 'o conf urllist' and retry. Or }.
6776 qq{examine the distribution in a subshell. Try
6658a91b 6777 look %s
23a216b4 6778and run
6658a91b
SP		 6779 cpansign -v
6780},
6781 $self->{localfile},
6782 $self->pretty_id,
6783 );
6784 $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6785 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6786 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6787 } else {
6788 $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6789 $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6790 }
6791 } else {
6792 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6793 }
6794 } else {
6795 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6796 }
6797 }
5f05dabc 6798}
6799
6658a91b 6800#-> CPAN::Distribution::untar_me ;
55e314ee 6801sub untar_me {
e82b9348 6802 my($self,$ct) = @_;
55e314ee 6803 $self->{archived} = "tar";
e82b9348 6804 if ($ct->untar()) {
f04ea8d1 6805 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
55e314ee 6806 } else {
f04ea8d1 6807 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
55e314ee
A		 6808 }
6809}
6810
6d29edf5 6811# CPAN::Distribution::unzip_me ;
55e314ee 6812sub unzip_me {
e82b9348 6813 my($self,$ct) = @_;
05d2a450 6814 $self->{archived} = "zip";
e82b9348 6815 if ($ct->unzip()) {
f04ea8d1 6816 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
55e314ee 6817 } else {
f04ea8d1 6818 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
55e314ee 6819 }
c4d24d4c 6820 return;
55e314ee
A		 6821}
6822
ed84aac9 6823sub handle_singlefile {
55e314ee 6824 my($self,$local_file) = @_;
ed84aac9 6825
f04ea8d1
SP		 6826 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
6827 $self->{archived} = "pm";
2b3bde2a 6828 } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
f04ea8d1 6829 $self->{archived} = "patch";
ed84aac9 6830 } else {
f04ea8d1 6831 $self->{archived} = "maybe_pl";
ed84aac9
A		 6832 }
6833
55e314ee 6834 my $to = File::Basename::basename($local_file);
554a9ef5 6835 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
be34b10d 6836 if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6658a91b 6837 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
554a9ef5 6838 } else {
6658a91b 6839 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
554a9ef5 6840 }
55e314ee 6841 } else {
2b3bde2a
SP		 6842 if (File::Copy::cp($local_file,".")) {
6843 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6844 } else {
6845 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6846 }
55e314ee 6847 }
ed84aac9 6848 return $to;
55e314ee
A		 6849}
6850
05454584
A		 6851#-> sub CPAN::Distribution::new ;
6852sub new {
6853 my($class,%att) = @_;
5f05dabc 6854
5e05dca5 6855 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5f05dabc 6856
05454584
A		 6857 my $this = { %att };
6858 return bless $this, $class;
5f05dabc 6859}
6860
05454584
A		 6861#-> sub CPAN::Distribution::look ;
6862sub look {
5f05dabc 6863 my($self) = @_;
36263cb3
GS		 6864
6865 if ($^O eq 'MacOS') {
be708cc0 6866 $self->Mac::BuildTools::look;
36263cb3
GS		 6867 return;
6868 }
6869
05454584 6870 if ( $CPAN::Config->{'shell'} ) {
f04ea8d1 6871 $CPAN::Frontend->myprint(qq{
05454584 6872Trying to open a subshell in the build directory...
c356248b 6873});
05454584 6874 } else {
f04ea8d1 6875 $CPAN::Frontend->myprint(qq{
05454584
A		 6876Your configuration does not define a value for subshells.
6877Please define it with "o conf shell <your shell>"
c356248b 6878});
f04ea8d1 6879 return;
5f05dabc 6880 }
05454584 6881 my $dist = $self->id;
c049f953
JH		 6882 my $dir;
6883 unless ($dir = $self->dir) {
6884 $self->get;
6885 }
6886 unless ($dir ||= $self->dir) {
f04ea8d1 6887 $CPAN::Frontend->mywarn(qq{
c049f953
JH		 6888Could not determine which directory to use for looking at $dist.
6889});
f04ea8d1 6890 return;
c049f953 6891 }
9d61fa1d 6892 my $pwd = CPAN::anycwd();
c049f953 6893 $self->safe_chdir($dir);
c356248b 6894 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
9ddc4ed0 6895 {
f04ea8d1 6896 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
9ddc4ed0 6897 $ENV{CPAN_SHELL_LEVEL} += 1;
f04ea8d1
SP		 6898 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6899 unless (system($shell) == 0) {
6900 my $code = $? >> 8;
6901 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6902 }
35576f8c 6903 }
c049f953 6904 $self->safe_chdir($pwd);
5f05dabc 6905}
6906
6d29edf5 6907# CPAN::Distribution::cvs_import ;
911a92db
GS		 6908sub cvs_import {
6909 my($self) = @_;
6910 $self->get;
6911 my $dir = $self->dir;
6912
6913 my $package = $self->called_for;
6914 my $module = $CPAN::META->instance('CPAN::Module', $package);
6d29edf5 6915 my $version = $module->cpan_version;
911a92db 6916
6d29edf5 6917 my $userid = $self->cpan_userid;
911a92db 6918
5fc0f0f6 6919 my $cvs_dir = (split /\//, $dir)[-1];
05d2a450 6920 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
f04ea8d1 6921 my $cvs_root =
911a92db 6922 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
f04ea8d1 6923 my $cvs_site_perl =
911a92db
GS		 6924 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6925 if ($cvs_site_perl) {
f04ea8d1 6926 $cvs_dir = "$cvs_site_perl/$cvs_dir";
911a92db
GS		 6927 }
6928 my $cvs_log = qq{"imported $package $version sources"};
6929 $version =~ s/\./_/g;
135a59c2 6930 # XXX cvs: undocumented and unclear how it was meant to work
911a92db 6931 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
f04ea8d1 6932 "$cvs_dir", $userid, "v$version");
911a92db 6933
9d61fa1d 6934 my $pwd = CPAN::anycwd();
05d2a450 6935 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
911a92db
GS		 6936
6937 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6938
6939 $CPAN::Frontend->myprint(qq{@cmd\n});
de34a54b 6940 system(@cmd) == 0 or
ed84aac9 6941 # XXX cvs
f04ea8d1 6942 $CPAN::Frontend->mydie("cvs import failed");
05d2a450 6943 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
911a92db
GS		 6944}
6945
05454584
A		 6946#-> sub CPAN::Distribution::readme ;
6947sub readme {
5f05dabc 6948 my($self) = @_;
05454584
A		 6949 my($dist) = $self->id;
6950 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6951 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6952 my($local_file);
6953 my($local_wanted) =
f04ea8d1
SP		 6954 File::Spec->catfile(
6955 $CPAN::Config->{keep_source_where},
6956 "authors",
6957 "id",
6958 split(/\//,"$sans.readme"),
6959 );
05454584 6960 $self->debug("Doing localize") if $CPAN::DEBUG;
c356248b 6961 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
f04ea8d1
SP		 6962 $local_wanted)
6963 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
f14b5cec
JH		 6964
6965 if ($^O eq 'MacOS') {
be708cc0 6966 Mac::BuildTools::launch_file($local_file);
f14b5cec
JH		 6967 return;
6968 }
6969
05454584 6970 my $fh_pager = FileHandle->new;
c356248b 6971 local($SIG{PIPE}) = "IGNORE";
ed84aac9
A		 6972 my $pager = $CPAN::Config->{'pager'} || "cat";
6973 $fh_pager->open("|$pager")
f04ea8d1 6974 or die "Could not open pager $pager\: $!";
05454584 6975 my $fh_readme = FileHandle->new;
c356248b 6976 $fh_readme->open($local_file)
f04ea8d1 6977 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
c356248b
A		 6978 $CPAN::Frontend->myprint(qq{
6979Displaying file
6980 $local_file
ed84aac9 6981with pager "$pager"
c356248b 6982});
05454584 6983 $fh_pager->print(<$fh_readme>);
554a9ef5 6984 $fh_pager->close;
5f05dabc 6985}
6986
e82b9348
SP		 6987#-> sub CPAN::Distribution::verifyCHECKSUM ;
6988sub verifyCHECKSUM {
5f05dabc 6989 my($self) = @_;
05454584 6990 EXCUSE: {
f04ea8d1
SP		 6991 my @e;
6992 $self->{CHECKSUM_STATUS} ||= "";
6993 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6994 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 6995 }
55e314ee 6996 my($lc_want,$lc_file,@local,$basename);
5fc0f0f6 6997 @local = split(/\//,$self->id);
55e314ee 6998 pop @local;
05454584 6999 push @local, "CHECKSUMS";
55e314ee 7000 $lc_want =
f04ea8d1
SP		 7001 File::Spec->catfile($CPAN::Config->{keep_source_where},
7002 "authors", "id", @local);
05454584 7003 local($") = "/";
b96578bb
SP		 7004 if (my $size = -s $lc_want) {
7005 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7006 if ($self->CHECKSUM_check_file($lc_want,1)) {
7007 return $self->{CHECKSUM_STATUS} = "OK";
7008 }
05454584 7009 }
55e314ee 7010 $lc_file = CPAN::FTP->localize("authors/id/@local",
f04ea8d1 7011 $lc_want,1);
55e314ee 7012 unless ($lc_file) {
8d97e4a1 7013 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
f04ea8d1
SP		 7014 $local[-1] .= ".gz";
7015 $lc_file = CPAN::FTP->localize("authors/id/@local",
7016 "$lc_want.gz",1);
7017 if ($lc_file) {
7018 $lc_file =~ s/\.gz(?!\n)\Z//;
7019 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7020 } else {
7021 return;
7022 }
05454584 7023 }
b96578bb
SP		 7024 if ($self->CHECKSUM_check_file($lc_file)) {
7025 return $self->{CHECKSUM_STATUS} = "OK";
7026 }
5f05dabc 7027}
7028
4d1321a7 7029#-> sub CPAN::Distribution::SIG_check_file ;
554a9ef5
SP		 7030sub SIG_check_file {
7031 my($self,$chk_file) = @_;
7032 my $rv = eval { Module::Signature::_verify($chk_file) };
7033
7034 if ($rv == Module::Signature::SIGNATURE_OK()) {
f04ea8d1
SP		 7035 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7036 return $self->{SIG_STATUS} = "OK";
554a9ef5 7037 } else {
f04ea8d1
SP		 7038 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7039 qq{distribution file. }.
7040 qq{Please investigate.\n\n}.
7041 $self->as_string,
7042 $CPAN::META->instance(
7043 'CPAN::Author',
7044 $self->cpan_userid
7045 )->as_string);
7046
7047 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
554a9ef5
SP		 7048is invalid. Maybe you have configured your 'urllist' with
7049a bad URL. Please check this array with 'o conf urllist', and
7050retry.};
7051
f04ea8d1 7052 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
554a9ef5
SP		 7053 }
7054}
7055
e82b9348 7056#-> sub CPAN::Distribution::CHECKSUM_check_file ;
b96578bb
SP		 7057
7058# sloppy is 1 when we have an old checksums file that maybe is good
7059# enough
7060
e82b9348 7061sub CHECKSUM_check_file {
b96578bb 7062 my($self,$chk_file,$sloppy) = @_;
55e314ee 7063 my($cksum,$file,$basename);
554a9ef5 7064
b96578bb
SP		 7065 $sloppy ||= 0;
7066 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
be34b10d
SP		 7067 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7068 q{check_sigs});
7069 if ($check_sigs) {
6658a91b 7070 if ($CPAN::META->has_inst("Module::Signature")) {
b72dd56f 7071 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
ed84aac9
A		 7072 $self->SIG_check_file($chk_file);
7073 } else {
b72dd56f 7074 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
ed84aac9 7075 }
554a9ef5
SP		 7076 }
7077
c356248b 7078 $file = $self->{localfile};
55e314ee
A		 7079 $basename = File::Basename::basename($file);
7080 my $fh = FileHandle->new;
f04ea8d1
SP		 7081 if (open $fh, $chk_file) {
7082 local($/);
7083 my $eval = <$fh>;
7084 $eval =~ s/\015?\012/\n/g;
7085 close $fh;
7086 my($comp) = Safe->new();
7087 $cksum = $comp->reval($eval);
7088 if ($@) {
7089 rename $chk_file, "$chk_file.bad";
7090 Carp::confess($@) if $@;
7091 }
55e314ee 7092 } else {
f04ea8d1 7093 Carp::carp "Could not open $chk_file for reading";
55e314ee 7094 }
09d9d230 7095
44d21104
A		 7096 if (! ref $cksum or ref $cksum ne "HASH") {
7097 $CPAN::Frontend->mywarn(qq{
7098Warning: checksum file '$chk_file' broken.
7099
7100When trying to read that file I expected to get a hash reference
7101for further processing, but got garbage instead.
7102});
8962fc49 7103 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
b96578bb
SP		 7104 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7105 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
44d21104
A		 7106 return;
7107 } elsif (exists $cksum->{$basename}{sha256}) {
f04ea8d1
SP		 7108 $self->debug("Found checksum for $basename:" .
7109 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7110
7111 open($fh, $file);
7112 binmode $fh;
7113 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7114 $fh->close;
7115 $fh = CPAN::Tarzip->TIEHANDLE($file);
7116
7117 unless ($eq) {
7118 my $dg = Digest::SHA->new(256);
7119 my($data,$ref);
7120 $ref = \$data;
7121 while ($fh->READ($ref, 4096) > 0) {
7122 $dg->add($data);
7123 }
7124 my $hexdigest = $dg->hexdigest;
7125 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7126 }
7127
7128 if ($eq) {
7129 $CPAN::Frontend->myprint("Checksum for $file ok\n");
7130 return $self->{CHECKSUM_STATUS} = "OK";
7131 } else {
7132 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7133 qq{distribution file. }.
7134 qq{Please investigate.\n\n}.
7135 $self->as_string,
7136 $CPAN::META->instance(
7137 'CPAN::Author',
7138 $self->cpan_userid
7139 )->as_string);
7140
7141 my $wrap = qq{I\'d recommend removing $file. Its
c4d24d4c
A		 7142checksum is incorrect. Maybe you have configured your 'urllist' with
7143a bad URL. Please check this array with 'o conf urllist', and
55e314ee 7144retry.};
de34a54b 7145
c4d24d4c
A		 7146 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7147
7148 # former versions just returned here but this seems a
7149 # serious threat that deserves a die
7150
f04ea8d1
SP		 7151 # $CPAN::Frontend->myprint("\n\n");
7152 # sleep 3;
7153 # return;
7154 }
7155 # close $fh if fileno($fh);
5f05dabc 7156 } else {
b96578bb 7157 return if $sloppy;
f04ea8d1
SP		 7158 unless ($self->{CHECKSUM_STATUS}) {
7159 $CPAN::Frontend->mywarn(qq{
e82b9348 7160Warning: No checksum for $basename in $chk_file.
5a5fac02
JH		 7161
7162The cause for this may be that the file is very new and the checksum
7163has not yet been calculated, but it may also be that something is
7164going awry right now.
c356248b 7165});
8962fc49 7166 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
b96578bb 7167 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
f04ea8d1 7168 }
b96578bb 7169 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
f04ea8d1 7170 return;
5f05dabc 7171 }
7172}
7173
e82b9348
SP		 7174#-> sub CPAN::Distribution::eq_CHECKSUM ;
7175sub eq_CHECKSUM {
7176 my($self,$fh,$expect) = @_;
87892b73
RGS		 7177 if ($CPAN::META->has_inst("Digest::SHA")) {
7178 my $dg = Digest::SHA->new(256);
7179 my($data);
f04ea8d1 7180 while (read($fh, $data, 4096)) {
87892b73
RGS		 7181 $dg->add($data);
7182 }
7183 my $hexdigest = $dg->hexdigest;
7184 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7185 return $hexdigest eq $expect;
09d9d230 7186 }
87892b73 7187 return 1;
05454584 7188}
5f05dabc 7189
05454584 7190#-> sub CPAN::Distribution::force ;
c4d24d4c 7191
e82b9348
SP		 7192# Both CPAN::Modules and CPAN::Distributions know if "force" is in
7193# effect by autoinspection, not by inspecting a global variable. One
7194# of the reason why this was chosen to work that way was the treatment
7195# of dependencies. They should not automatically inherit the force
c4d24d4c
A		 7196# status. But this has the downside that ^C and die() will return to
7197# the prompt but will not be able to reset the force_update
7198# attributes. We try to correct for it currently in the read_metadata
7199# routine, and immediately before we check for a Signal. I hope this
7200# works out in one of v1.57_53ff
7201
4d1321a7
A		 7202# "Force get forgets previous error conditions"
7203
b72dd56f
SP		 7204#-> sub CPAN::Distribution::fforce ;
7205sub fforce {
7206 my($self, $method) = @_;
7207 $self->force($method,1);
7208}
7209
4d1321a7 7210#-> sub CPAN::Distribution::force ;
5f05dabc 7211sub force {
b72dd56f 7212 my($self, $method,$fforce) = @_;
810a0276
SP		 7213 my %phase_map = (
7214 get => [
7215 "unwrapped",
7216 "build_dir",
7217 "archived",
7218 "localfile",
7219 "CHECKSUM_STATUS",
7220 "signature_verify",
7221 "prefs",
7222 "prefs_file",
7223 "prefs_file_doc",
7224 ],
7225 make => [
7226 "writemakefile",
7227 "make",
7228 "modulebuild",
7229 "prereq_pm",
7230 "prereq_pm_detected",
7231 ],
7232 test => [
7233 "badtestcnt",
7234 "make_test",
7235 ],
7236 install => [
7237 "install",
7238 ],
7239 unknown => [
7240 "reqtype",
7241 "yaml_content",
7242 ],
7243 );
b72dd56f
SP		 7244 my $methodmatch = 0;
7245 my $ldebug = 0;
7246 PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7247 $methodmatch = 1 if $fforce || $phase eq $method;
7248 next unless $methodmatch;
810a0276 7249 ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
b72dd56f
SP		 7250 if ($phase eq "get") {
7251 if (substr($self->id,-1,1) eq "."
7252 && $att =~ /(unwrapped|build_dir|archived)/ ) {
7253 # cannot be undone for local distros
7254 next ATTRIBUTE;
7255 }
7256 if ($att eq "build_dir"
7257 && $self->{build_dir}
7258 && $CPAN::META->{is_tested}
7259 ) {
7260 delete $CPAN::META->{is_tested}{$self->{build_dir}};
7261 }
7262 } elsif ($phase eq "test") {
7263 if ($att eq "make_test"
7264 && $self->{make_test}
7265 && $self->{make_test}{COMMANDID}
7266 && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7267 ) {
7268 # endless loop too likely
7269 next ATTRIBUTE;
7270 }
810a0276
SP		 7271 }
7272 delete $self->{$att};
b72dd56f
SP		 7273 if ($ldebug || $CPAN::DEBUG) {
7274 # local $CPAN::DEBUG = 16; # Distribution
7275 CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7276 }
810a0276 7277 }
f610777f 7278 }
9ddc4ed0 7279 if ($method && $method =~ /make|test|install/) {
b72dd56f 7280 $self->{force_update} = 1; # name should probably have been force_install
c4d24d4c
A		 7281 }
7282}
7283
05bab18e 7284#-> sub CPAN::Distribution::notest ;
554a9ef5 7285sub notest {
f3fe0ae6 7286 my($self, $method) = @_;
23a216b4 7287 # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
554a9ef5
SP		 7288 $self->{"notest"}++; # name should probably have been force_install
7289}
7290
05bab18e 7291#-> sub CPAN::Distribution::unnotest ;
554a9ef5 7292sub unnotest {
f3fe0ae6 7293 my($self) = @_;
554a9ef5 7294 # warn "XDEBUG: deleting notest";
23a216b4 7295 delete $self->{notest};
554a9ef5
SP		 7296}
7297
c4d24d4c
A		 7298#-> sub CPAN::Distribution::unforce ;
7299sub unforce {
7300 my($self) = @_;
b72dd56f 7301 delete $self->{force_update};
5f05dabc 7302}
7303
de34a54b 7304#-> sub CPAN::Distribution::isa_perl ;
09d9d230
A		 7305sub isa_perl {
7306 my($self) = @_;
7307 my $file = File::Basename::basename($self->id);
05d2a450
A		 7308 if ($file =~ m{ ^ perl
7309 -?
f04ea8d1
SP		 7310 (5)
7311 ([._-])
7312 (
05d2a450
A		 7313 \d{3}(_[0-4][0-9])?
7314 |
ed84aac9 7315 \d+\.\d+
05d2a450 7316 )
f04ea8d1
SP		 7317 \.tar[._-](?:gz|bz2)
7318 (?!\n)\Z
7319 }xs) {
05d2a450 7320 return "$1.$3";
6d29edf5
JH		 7321 } elsif ($self->cpan_comment
7322 &&
f04ea8d1 7323 $self->cpan_comment =~ /isa_perl\(.+?\)/) {
05d2a450
A		 7324 return $1;
7325 }
09d9d230
A		 7326}
7327
607a774b 7328
d4fd5c69
A		 7329#-> sub CPAN::Distribution::perl ;
7330sub perl {
ed84aac9
A		 7331 my ($self) = @_;
7332 if (! $self) {
7333 use Carp qw(carp);
7334 carp __PACKAGE__ . "::perl was called without parameters.";
7335 }
7336 return CPAN::HandleConfig->safe_quote($CPAN::Perl);
d4fd5c69
A		 7337}
7338
607a774b 7339
05454584
A		 7340#-> sub CPAN::Distribution::make ;
7341sub make {
7342 my($self) = @_;
be34b10d
SP		 7343 if (my $goto = $self->prefs->{goto}) {
7344 return $self->goto($goto);
7345 }
e82b9348 7346 my $make = $self->{modulebuild} ? "Build" : "make";
09d9d230
A		 7347 # Emergency brake if they said install Pippi and get newest perl
7348 if ($self->isa_perl) {
f04ea8d1
SP		 7349 if (
7350 $self->called_for ne $self->id &&
7351 ! $self->{force_update}
7352 ) {
7353 # if we die here, we break bundles
7354 $CPAN::Frontend
7355 ->mywarn(sprintf(
7356 qq{The most recent version "%s" of the module "%s"
6a935156
SP		 7357is part of the perl-%s distribution. To install that, you need to run
7358 force install %s --or--
7359 install %s
09d9d230 7360},
6a935156
SP		 7361 $CPAN::META->instance(
7362 'CPAN::Module',
7363 $self->called_for
7364 )->cpan_version,
7365 $self->called_for,
7366 $self->isa_perl,
7367 $self->called_for,
7368 $self->id,
7369 ));
f04ea8d1
SP		 7370 $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7371 $CPAN::Frontend->mysleep(1);
7372 return;
7373 }
09d9d230 7374 }
6a935156 7375 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
05454584 7376 $self->get;
f04ea8d1
SP		 7377 if ($self->{configure_requires_later}) {
7378 return;
7379 }
6658a91b
SP		 7380 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7381 ? $ENV{PERL5LIB}
7382 : ($ENV{PERLLIB} || "");
6658a91b
SP		 7383 $CPAN::META->set_perl5lib;
7384 local $ENV{MAKEFLAGS}; # protect us from outer make calls
7385
f04ea8d1
SP		 7386 if ($CPAN::Signal) {
7387 delete $self->{force_update};
7388 return;
4d1321a7 7389 }
b72dd56f
SP		 7390
7391 my $builddir;
05454584 7392 EXCUSE: {
0cf35e6a 7393 my @e;
6658a91b
SP		 7394 if (!$self->{archived} || $self->{archived} eq "NO") {
7395 push @e, "Is neither a tar nor a zip archive.";
7396 }
5f05dabc 7397
6658a91b
SP		 7398 if (!$self->{unwrapped}
7399 || (
be34b10d 7400 UNIVERSAL::can($self->{unwrapped},"failed") ?
6658a91b
SP		 7401 $self->{unwrapped}->failed :
7402 $self->{unwrapped} =~ /^NO/
7403 )) {
7404 push @e, "Had problems unarchiving. Please build manually";
7405 }
9ddc4ed0
A		 7406
7407 unless ($self->{force_update}) {
be34b10d
SP		 7408 exists $self->{signature_verify} and
7409 (
7410 UNIVERSAL::can($self->{signature_verify},"failed") ?
7411 $self->{signature_verify}->failed :
7412 $self->{signature_verify} =~ /^NO/
7413 )
9ddc4ed0
A		 7414 and push @e, "Did not pass the signature test.";
7415 }
05454584 7416
4d1321a7
A		 7417 if (exists $self->{writemakefile} &&
7418 (
be34b10d 7419 UNIVERSAL::can($self->{writemakefile},"failed") ?
4d1321a7
A		 7420 $self->{writemakefile}->failed :
7421 $self->{writemakefile} =~ /^NO/
7422 )) {
7423 # XXX maybe a retry would be in order?
be34b10d 7424 my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
4d1321a7
A		 7425 $self->{writemakefile}->text :
7426 $self->{writemakefile};
7427 $err =~ s/^NO\s*//;
7428 $err ||= "Had some problem writing Makefile";
7429 $err .= ", won't make";
7430 push @e, $err;
7431 }
05454584 7432
f04ea8d1 7433 if (defined $self->{make}) {
8ce4ea0b
SP		 7434 if (UNIVERSAL::can($self->{make},"failed") ?
7435 $self->{make}->failed :
7436 $self->{make} =~ /^NO/) {
ade94d80
SP		 7437 if ($self->{force_update}) {
7438 # Trying an already failed 'make' (unless somebody else blocks)
7439 } else {
7440 # introduced for turning recursion detection into a distrostatus
23a216b4
SP		 7441 my $error = length $self->{make}>3
7442 ? substr($self->{make},3) : "Unknown error";
7443 $CPAN::Frontend->mywarn("Could not make: $error\n");
ade94d80
SP		 7444 $self->store_persistent_state;
7445 return;
7446 }
7447 } else {
7448 push @e, "Has already been made";
7449 }
7450 }
6d29edf5 7451
f04ea8d1
SP		 7452 my $later = $self->{later} || $self->{configure_requires_later};
7453 if ($later) { # see also undelay
7454 if ($later) {
7455 push @e, $later;
c9869e1c
SP		 7456 }
7457 }
05454584 7458
f04ea8d1 7459 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
b72dd56f
SP		 7460 $builddir = $self->dir or
7461 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7462 unless (chdir $builddir) {
7463 push @e, "Couldn't chdir to '$builddir': $!";
7464 }
f04ea8d1 7465 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
5f05dabc 7466 }
f04ea8d1
SP		 7467 if ($CPAN::Signal) {
7468 delete $self->{force_update};
7469 return;
4d1321a7 7470 }
c356248b 7471 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
05454584
A		 7472 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7473
f14b5cec 7474 if ($^O eq 'MacOS') {
be708cc0 7475 Mac::BuildTools::make($self);
f14b5cec
JH		 7476 return;
7477 }
7478
810a0276
SP		 7479 my %env;
7480 while (my($k,$v) = each %ENV) {
7481 next unless defined $v;
7482 $env{$k} = $v;
7483 }
7484 local %ENV = %env;
05454584 7485 my $system;
810a0276
SP		 7486 if (my $commandline = $self->prefs->{pl}{commandline}) {
7487 $system = $commandline;
7488 $ENV{PERL} = $^X;
7489 } elsif ($self->{'configure'}) {
e82b9348
SP		 7490 $system = $self->{'configure'};
7491 } elsif ($self->{modulebuild}) {
f04ea8d1 7492 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
e82b9348 7493 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
5f05dabc 7494 } else {
f04ea8d1
SP		 7495 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7496 my $switch = "";
d4fd5c69 7497# This needs a handler that can be turned on or off:
f04ea8d1
SP		 7498# $switch = "-MExtUtils::MakeMaker ".
7499# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7500# if $] > 5.00310;
1e8f9a0a 7501 my $makepl_arg = $self->make_x_arg("pl");
f04ea8d1
SP		 7502 $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7503 "Makefile.PL");
7504 $system = sprintf("%s%s Makefile.PL%s",
4d1321a7
A		 7505 $perl,
7506 $switch ? " $switch" : "",
1e8f9a0a 7507 $makepl_arg ? " $makepl_arg" : "",
4d1321a7 7508 );
d4fd5c69 7509 }
1e8f9a0a
SP		 7510 if (my $env = $self->prefs->{pl}{env}) {
7511 for my $e (keys %$env) {
7512 $ENV{$e} = $env->{$e};
7513 }
7514 }
7515 if (exists $self->{writemakefile}) {
7516 } else {
f04ea8d1
SP		 7517 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7518 my($ret,$pid,$output);
7519 $@ = "";
2ccf00a7 7520 my $go_via_alarm;
f04ea8d1 7521 if ($CPAN::Config->{inactivity_timeout}) {
2ccf00a7
SP		 7522 require Config;
7523 if ($Config::Config{d_alarm}
7524 &&
7525 $Config::Config{d_alarm} eq "define"
7526 ) {
7527 $go_via_alarm++
7528 } else {
7529 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7530 "variable 'inactivity_timeout' to ".
7531 "'$CPAN::Config->{inactivity_timeout}'. But ".
7532 "on this machine the system call 'alarm' ".
7533 "isn't available. This means that we cannot ".
7534 "provide the feature of intercepting long ".
7535 "waiting code and will turn this feature off.\n"
7536 );
7537 $CPAN::Config->{inactivity_timeout} = 0;
7538 }
7539 }
7540 if ($go_via_alarm) {
f04ea8d1
SP		 7541 if ( $self->_should_report('pl') ) {
7542 ($output, $ret) = CPAN::Reporter::record_command(
7543 $system,
7544 $CPAN::Config->{inactivity_timeout},
7545 );
7546 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7547 }
7548 else {
7549 eval {
7550 alarm $CPAN::Config->{inactivity_timeout};
7551 local $SIG{CHLD}; # = sub { wait };
7552 if (defined($pid = fork)) {
7553 if ($pid) { #parent
7554 # wait;
7555 waitpid $pid, 0;
7556 } else { #child
7557 # note, this exec isn't necessary if
7558 # inactivity_timeout is 0. On the Mac I'd
7559 # suggest, we set it always to 0.
7560 exec $system;
7561 }
7562 } else {
7563 $CPAN::Frontend->myprint("Cannot fork: $!");
7564 return;
2ccf00a7 7565 }
f04ea8d1
SP		 7566 };
7567 alarm 0;
7568 if ($@) {
7569 kill 9, $pid;
7570 waitpid $pid, 0;
7571 my $err = "$@";
7572 $CPAN::Frontend->myprint($err);
7573 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7574 $@ = "";
7575 $self->store_persistent_state;
7576 return $self->goodbye("$system -- TIMED OUT");
2ccf00a7 7577 }
2ccf00a7 7578 }
f04ea8d1 7579 } else {
05bab18e 7580 if (my $expect_model = $self->_prefs_with_expect("pl")) {
f04ea8d1
SP		 7581 # XXX probably want to check _should_report here and warn
7582 # about not being able to use CPAN::Reporter with expect
05bab18e
SP		 7583 $ret = $self->_run_via_expect($system,$expect_model);
7584 if (! defined $ret
7585 && $self->{writemakefile}
7586 && $self->{writemakefile}->failed) {
7587 # timeout
7588 return;
7589 }
f04ea8d1
SP		 7590 }
7591 elsif ( $self->_should_report('pl') ) {
7592 ($output, $ret) = CPAN::Reporter::record_command($system);
7593 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7594 }
7595 else {
1e8f9a0a
SP		 7596 $ret = system($system);
7597 }
7598 if ($ret != 0) {
7599 $self->{writemakefile} = CPAN::Distrostatus
7600 ->new("NO '$system' returned status $ret");
7601 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
05bab18e 7602 $self->store_persistent_state;
f04ea8d1
SP		 7603 return $self->goodbye("$system -- NOT OK");
7604 }
7605 }
7606 if (-f "Makefile" || -f "Build") {
7607 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7608 delete $self->{make_clean}; # if cleaned before, enable next
7609 } else {
7610 my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
7611 $self->{writemakefile} = CPAN::Distrostatus
7612 ->new(qq{NO -- No $makefile created});
7613 $self->store_persistent_state;
7614 return $self->goodbye("$system -- NO $makefile created");
7615 }
7616 }
7617 if ($CPAN::Signal) {
7618 delete $self->{force_update};
7619 return;
c4d24d4c 7620 }
f04ea8d1 7621 if (my @prereq = $self->unsat_prereq("later")) {
7d97ad34
SP		 7622 if ($prereq[0][0] eq "perl") {
7623 my $need = "requires perl '$prereq[0][1]'";
7624 my $id = $self->pretty_id;
7625 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7626 $self->{make} = CPAN::Distrostatus->new("NO $need");
05bab18e 7627 $self->store_persistent_state;
f04ea8d1 7628 return $self->goodbye("[prereq] -- NOT OK");
7d97ad34 7629 } else {
f04ea8d1 7630 my $follow = eval { $self->follow_prereqs("later",@prereq); };
ade94d80 7631 if (0) {
f04ea8d1 7632 } elsif ($follow) {
ade94d80
SP		 7633 # signal success to the queuerunner
7634 return 1;
7635 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7636 $CPAN::Frontend->mywarn($@);
f04ea8d1 7637 return $self->goodbye("[depend] -- NOT OK");
ade94d80 7638 }
7d97ad34 7639 }
6d29edf5 7640 }
f04ea8d1
SP		 7641 if ($CPAN::Signal) {
7642 delete $self->{force_update};
7643 return;
1e8f9a0a 7644 }
810a0276
SP		 7645 if (my $commandline = $self->prefs->{make}{commandline}) {
7646 $system = $commandline;
b03f445c 7647 $ENV{PERL} = CPAN::find_perl;
e82b9348 7648 } else {
810a0276
SP		 7649 if ($self->{modulebuild}) {
7650 unless (-f "Build") {
7651 my $cwd = CPAN::anycwd();
7652 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
8ce4ea0b 7653 " in cwd[$cwd]. Danger, Will Robinson!\n");
810a0276
SP		 7654 $CPAN::Frontend->mysleep(5);
7655 }
b72dd56f 7656 $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
810a0276 7657 } else {
b72dd56f 7658 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
810a0276 7659 }
b72dd56f 7660 $system =~ s/\s+$//;
810a0276
SP		 7661 my $make_arg = $self->make_x_arg("make");
7662 $system = sprintf("%s%s",
7663 $system,
7664 $make_arg ? " $make_arg" : "",
7665 );
e82b9348 7666 }
1e8f9a0a
SP		 7667 if (my $env = $self->prefs->{make}{env}) { # overriding the local
7668 # ENV of PL, not the
7669 # outer ENV, but
7670 # unlikely to be a risk
7671 for my $e (keys %$env) {
7672 $ENV{$e} = $env->{$e};
7673 }
7674 }
05bab18e
SP		 7675 my $expect_model = $self->_prefs_with_expect("make");
7676 my $want_expect = 0;
7677 if ( $expect_model && @{$expect_model->{talk}} ) {
7678 my $can_expect = $CPAN::META->has_inst("Expect");
7679 if ($can_expect) {
7680 $want_expect = 1;
7681 } else {
7682 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
be34b10d 7683 "system()\n");
05bab18e
SP		 7684 }
7685 }
7686 my $system_ok;
7687 if ($want_expect) {
f04ea8d1
SP		 7688 # XXX probably want to check _should_report here and
7689 # warn about not being able to use CPAN::Reporter with expect
05bab18e 7690 $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
f04ea8d1
SP		 7691 }
7692 elsif ( $self->_should_report('make') ) {
7693 my ($output, $ret) = CPAN::Reporter::record_command($system);
7694 CPAN::Reporter::grade_make( $self, $system, $output, $ret );
7695 $system_ok = ! $ret;
7696 }
7697 else {
05bab18e
SP		 7698 $system_ok = system($system) == 0;
7699 }
7700 $self->introduce_myself;
7701 if ( $system_ok ) {
f04ea8d1
SP		 7702 $CPAN::Frontend->myprint(" $system -- OK\n");
7703 $self->{make} = CPAN::Distrostatus->new("YES");
6d29edf5 7704 } else {
f04ea8d1
SP		 7705 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7706 $self->{make} = CPAN::Distrostatus->new("NO");
7707 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
6d29edf5 7708 }
05bab18e 7709 $self->store_persistent_state;
6d29edf5 7710}
f610777f 7711
8ce4ea0b
SP		 7712# CPAN::Distribution::goodbye ;
7713sub goodbye {
7714 my($self,$goodbye) = @_;
7715 my $id = $self->pretty_id;
f04ea8d1 7716 $CPAN::Frontend->mywarn(" $id\n $goodbye\n");
8ce4ea0b
SP		 7717 return;
7718}
7719
7720# CPAN::Distribution::_run_via_expect ;
6658a91b 7721sub _run_via_expect {
05bab18e
SP		 7722 my($self,$system,$expect_model) = @_;
7723 CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
1e8f9a0a 7724 if ($CPAN::META->has_inst("Expect")) {
05bab18e 7725 my $expo = Expect->new; # expo Expect object;
1e8f9a0a 7726 $expo->spawn($system);
810a0276
SP		 7727 $expect_model->{mode} ||= "deterministic";
7728 if ($expect_model->{mode} eq "deterministic") {
7729 return $self->_run_via_expect_deterministic($expo,$expect_model);
7730 } elsif ($expect_model->{mode} eq "anyorder") {
7731 return $self->_run_via_expect_anyorder($expo,$expect_model);
05bab18e
SP		 7732 } else {
7733 die "Panic: Illegal expect mode: $expect_model->{mode}";
1e8f9a0a 7734 }
1e8f9a0a
SP		 7735 } else {
7736 $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7737 return system($system);
7738 }
7739}
7740
05bab18e 7741sub _run_via_expect_anyorder {
810a0276
SP		 7742 my($self,$expo,$expect_model) = @_;
7743 my $timeout = $expect_model->{timeout} || 5;
f04ea8d1 7744 my $reuse = $expect_model->{reuse};
810a0276 7745 my @expectacopy = @{$expect_model->{talk}}; # we trash it!
05bab18e
SP		 7746 my $but = "";
7747 EXPECT: while () {
7748 my($eof,$ran_into_timeout);
7749 my @match = $expo->expect($timeout,
7750 [ eof => sub {
7751 $eof++;
7752 } ],
7753 [ timeout => sub {
7754 $ran_into_timeout++;
7755 } ],
7756 -re => eval"qr{.}",
7757 );
7758 if ($match[2]) {
7759 $but .= $match[2];
7760 }
7761 $but .= $expo->clear_accum;
7762 if ($eof) {
7763 $expo->soft_close;
7764 return $expo->exitstatus();
7765 } elsif ($ran_into_timeout) {
7766 # warn "DEBUG: they are asking a question, but[$but]";
7767 for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7768 my($next,$send) = @expectacopy[$i,$i+1];
7769 my $regex = eval "qr{$next}";
7770 # warn "DEBUG: will compare with regex[$regex].";
7771 if ($but =~ /$regex/) {
7772 # warn "DEBUG: will send send[$send]";
7773 $expo->send($send);
f04ea8d1
SP		 7774 # never allow reusing an QA pair unless they told us
7775 splice @expectacopy, $i, 2 unless $reuse;
05bab18e
SP		 7776 next EXPECT;
7777 }
7778 }
7779 my $why = "could not answer a question during the dialog";
7780 $CPAN::Frontend->mywarn("Failing: $why\n");
7781 $self->{writemakefile} =
7782 CPAN::Distrostatus->new("NO $why");
7783 return;
7784 }
7785 }
7786}
7787
7788sub _run_via_expect_deterministic {
810a0276 7789 my($self,$expo,$expect_model) = @_;
05bab18e 7790 my $ran_into_timeout;
810a0276
SP		 7791 my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7792 my $expecta = $expect_model->{talk};
05bab18e 7793 EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
810a0276 7794 my($re,$send) = @$expecta[$i,$i+1];
05bab18e
SP		 7795 CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7796 my $regex = eval "qr{$re}";
7797 $expo->expect($timeout,
7798 [ eof => sub {
7799 my $but = $expo->clear_accum;
7800 $CPAN::Frontend->mywarn("EOF (maybe harmless)
7801expected[$regex]\nbut[$but]\n\n");
7802 last EXPECT;
7803 } ],
7804 [ timeout => sub {
7805 my $but = $expo->clear_accum;
7806 $CPAN::Frontend->mywarn("TIMEOUT
7807expected[$regex]\nbut[$but]\n\n");
7808 $ran_into_timeout++;
7809 } ],
7810 -re => $regex);
f04ea8d1 7811 if ($ran_into_timeout) {
05bab18e
SP		 7812 # note that the caller expects 0 for success
7813 $self->{writemakefile} =
7814 CPAN::Distrostatus->new("NO timeout during expect dialog");
7815 return;
7816 }
7817 $expo->send($send);
7818 }
7819 $expo->soft_close;
7820 return $expo->exitstatus();
7821}
7822
b72dd56f 7823#-> CPAN::Distribution::_validate_distropref
810a0276
SP		 7824sub _validate_distropref {
7825 my($self,@args) = @_;
7826 if (
7827 $CPAN::META->has_inst("CPAN::Kwalify")
7828 &&
7829 $CPAN::META->has_inst("Kwalify")
7830 ) {
7831 eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7832 if ($@) {
7833 $CPAN::Frontend->mywarn($@);
7834 }
7835 } else {
7836 CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7837 }
7838}
7839
b72dd56f 7840#-> CPAN::Distribution::_find_prefs
1e8f9a0a 7841sub _find_prefs {
6658a91b
SP		 7842 my($self) = @_;
7843 my $distroid = $self->pretty_id;
b72dd56f 7844 #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
1e8f9a0a 7845 my $prefs_dir = $CPAN::Config->{prefs_dir};
b03f445c 7846 return if $prefs_dir =~ /^\s*$/;
1e8f9a0a
SP		 7847 eval { File::Path::mkpath($prefs_dir); };
7848 if ($@) {
7849 $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7850 }
b72dd56f 7851 my $yaml_module = CPAN::_yaml_module;
be34b10d 7852 my @extensions;
1e8f9a0a 7853 if ($CPAN::META->has_inst($yaml_module)) {
be34b10d
SP		 7854 push @extensions, "yml";
7855 } else {
7856 my @fallbacks;
7857 if ($CPAN::META->has_inst("Data::Dumper")) {
7858 push @extensions, "dd";
7859 push @fallbacks, "Data::Dumper";
7860 }
7861 if ($CPAN::META->has_inst("Storable")) {
7862 push @extensions, "st";
7863 push @fallbacks, "Storable";
7864 }
7865 if (@fallbacks) {
7866 local $" = " and ";
7867 unless ($self->{have_complained_about_missing_yaml}++) {
7868 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7869 "to @fallbacks to read prefs '$prefs_dir'\n");
7870 }
7871 } else {
7872 unless ($self->{have_complained_about_missing_yaml}++) {
7873 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7874 "read prefs '$prefs_dir'\n");
7875 }
7876 }
7877 }
7878 if (@extensions) {
1e8f9a0a
SP		 7879 my $dh = DirHandle->new($prefs_dir)
7880 or die Carp::croak("Couldn't open '$prefs_dir': $!");
7881 DIRENT: for (sort $dh->read) {
7882 next if $_ eq "." || $_ eq "..";
be34b10d
SP		 7883 my $exte = join "|", @extensions;
7884 next unless /\.($exte)$/;
7885 my $thisexte = $1;
1e8f9a0a 7886 my $abs = File::Spec->catfile($prefs_dir, $_);
1e8f9a0a 7887 if (-f $abs) {
b72dd56f 7888 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
be34b10d
SP		 7889 my @distropref;
7890 if ($thisexte eq "yml") {
b72dd56f
SP		 7891 # need no eval because if we have no YAML we do not try to read *.yml
7892 #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
be34b10d 7893 @distropref = @{CPAN->_yaml_loadfile($abs)};
b72dd56f 7894 #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
be34b10d
SP		 7895 } elsif ($thisexte eq "dd") {
7896 package CPAN::Eval;
7897 no strict;
7898 open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7899 local $/;
7900 my $eval = <FH>;
7901 close FH;
7902 eval $eval;
7903 if ($@) {
7904 $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7905 }
7906 my $i = 1;
7907 while (${"VAR".$i}) {
7908 push @distropref, ${"VAR".$i};
7909 $i++;
7910 }
7911 } elsif ($thisexte eq "st") {
7912 # eval because Storable is never forward compatible
7913 eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7914 if ($@) {
7915 $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7916 "$_, skipping\: $@");
7917 $CPAN::Frontend->mysleep(4);
7918 next DIRENT;
7919 }
7920 }
6658a91b 7921 # $DB::single=1;
b72dd56f 7922 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
be34b10d
SP		 7923 ELEMENT: for my $y (0..$#distropref) {
7924 my $distropref = $distropref[$y];
810a0276 7925 $self->_validate_distropref($distropref,$abs,$y);
be34b10d 7926 my $match = $distropref->{match};
6658a91b 7927 unless ($match) {
b72dd56f 7928 #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
6658a91b
SP		 7929 next ELEMENT;
7930 }
7931 my $ok = 1;
b72dd56f
SP		 7932 # do not take the order of C<keys %$match> because
7933 # "module" is by far the slowest
2b3bde2a
SP		 7934 my $saw_valid_subkeys = 0;
7935 for my $sub_attribute (qw(distribution perl perlconfig module)) {
b72dd56f 7936 next unless exists $match->{$sub_attribute};
2b3bde2a 7937 $saw_valid_subkeys++;
be34b10d 7938 my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
6658a91b
SP		 7939 if ($sub_attribute eq "module") {
7940 my $okm = 0;
b72dd56f 7941 #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
6658a91b 7942 my @modules = $self->containsmods;
b72dd56f 7943 #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
6658a91b
SP		 7944 MODULE: for my $module (@modules) {
7945 $okm ||= $module =~ /$qr/;
7946 last MODULE if $okm;
7947 }
7948 $ok &&= $okm;
7949 } elsif ($sub_attribute eq "distribution") {
7950 my $okd = $distroid =~ /$qr/;
7951 $ok &&= $okd;
7952 } elsif ($sub_attribute eq "perl") {
b03f445c 7953 my $okp = CPAN::find_perl =~ /$qr/;
6658a91b 7954 $ok &&= $okp;
f04ea8d1
SP		 7955 } elsif ($sub_attribute eq "perlconfig") {
7956 for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7957 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7958 # XXX should probably warn if Config does not exist
7959 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7960 $ok &&= $okpc;
7961 last if $ok == 0;
7962 }
6658a91b 7963 } else {
be34b10d 7964 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
6658a91b
SP		 7965 "unknown sub_attribut '$sub_attribute'. ".
7966 "Please ".
7967 "remove, cannot continue.");
1e8f9a0a 7968 }
b72dd56f 7969 last if $ok == 0; # short circuit
1e8f9a0a 7970 }
2b3bde2a
SP		 7971 unless ($saw_valid_subkeys) {
7972 $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7973 "missing match/* subattribute. ".
7974 "Please ".
7975 "remove, cannot continue.");
7976 }
b72dd56f 7977 #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
6658a91b
SP		 7978 if ($ok) {
7979 return {
be34b10d 7980 prefs => $distropref,
6658a91b 7981 prefs_file => $abs,
05bab18e 7982 prefs_file_doc => $y,
6658a91b
SP		 7983 };
7984 }
7985
1e8f9a0a
SP		 7986 }
7987 }
7988 }
b72dd56f 7989 $dh->close;
1e8f9a0a
SP		 7990 }
7991 return;
7992}
7993
7994# CPAN::Distribution::prefs
7995sub prefs {
7996 my($self) = @_;
f20de9f0
SP		 7997 if (exists $self->{negative_prefs_cache}
7998 &&
7999 $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
8000 ) {
8001 delete $self->{negative_prefs_cache};
8002 delete $self->{prefs};
8003 }
1e8f9a0a
SP		 8004 if (exists $self->{prefs}) {
8005 return $self->{prefs}; # XXX comment out during debugging
8006 }
8007 if ($CPAN::Config->{prefs_dir}) {
8008 CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
6658a91b 8009 my $prefs = $self->_find_prefs();
b72dd56f
SP		 8010 $prefs ||= ""; # avoid warning next line
8011 CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
1e8f9a0a 8012 if ($prefs) {
05bab18e 8013 for my $x (qw(prefs prefs_file prefs_file_doc)) {
1e8f9a0a
SP		 8014 $self->{$x} = $prefs->{$x};
8015 }
6658a91b
SP		 8016 my $bs = sprintf(
8017 "%s[%s]",
8018 File::Basename::basename($self->{prefs_file}),
05bab18e 8019 $self->{prefs_file_doc},
6658a91b 8020 );
1e8f9a0a 8021 my $filler1 = "_" x 22;
6658a91b 8022 my $filler2 = int(66 - length($bs))/2;
1e8f9a0a
SP		 8023 $filler2 = 0 if $filler2 < 0;
8024 $filler2 = " " x $filler2;
8025 $CPAN::Frontend->myprint("
8026$filler1 D i s t r o P r e f s $filler1
6658a91b 8027$filler2 $bs $filler2
1e8f9a0a
SP		 8028");
8029 $CPAN::Frontend->mysleep(1);
8030 return $self->{prefs};
8031 }
8032 }
f20de9f0
SP		 8033 $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8034 return $self->{prefs} = +{};
1e8f9a0a
SP		 8035}
8036
8037# CPAN::Distribution::make_x_arg
8038sub make_x_arg {
8039 my($self, $whixh) = @_;
8040 my $make_x_arg;
8041 my $prefs = $self->prefs;
8042 if (
8043 $prefs
8044 && exists $prefs->{$whixh}
8045 && exists $prefs->{$whixh}{args}
8046 && $prefs->{$whixh}{args}
8047 ) {
8048 $make_x_arg = join(" ",
8049 map {CPAN::HandleConfig
8050 ->safe_quote($_)} @{$prefs->{$whixh}{args}},
8051 );
8052 }
8053 my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
8054 $make_x_arg ||= $CPAN::Config->{$what};
8055 return $make_x_arg;
8056}
8057
8058# CPAN::Distribution::_make_command
9ddc4ed0 8059sub _make_command {
ed84aac9
A		 8060 my ($self) = @_;
8061 if ($self) {
8062 return
1e8f9a0a 8063 CPAN::HandleConfig
ed84aac9 8064 ->safe_quote(
6658a91b
SP		 8065 CPAN::HandleConfig->prefs_lookup($self,
8066 q{make})
1e8f9a0a
SP		 8067 || $Config::Config{make}
8068 || 'make'
ed84aac9
A		 8069 );
8070 } else {
8071 # Old style call, without object. Deprecated
8072 Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8073 return
1e8f9a0a 8074 safe_quote(undef,
6658a91b 8075 CPAN::HandleConfig->prefs_lookup($self,q{make})
1e8f9a0a
SP		 8076 || $CPAN::Config->{make}
8077 || $Config::Config{make}
8078 || 'make');
ed84aac9 8079 }
9ddc4ed0
A		 8080}
8081
c9869e1c 8082#-> sub CPAN::Distribution::follow_prereqs ;
6d29edf5
JH		 8083sub follow_prereqs {
8084 my($self) = shift;
f04ea8d1 8085 my($slot) = shift;
135a59c2
A		 8086 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8087 return unless @prereq_tuples;
8088 my @prereq = map { $_->[0] } @prereq_tuples;
6658a91b 8089 my $pretty_id = $self->pretty_id;
135a59c2
A		 8090 my %map = (
8091 b => "build_requires",
8092 r => "requires",
8093 c => "commandline",
8094 );
6658a91b 8095 my($filler1,$filler2,$filler3,$filler4);
f20de9f0 8096 # $DB::single=1;
6658a91b
SP		 8097 my $unsat = "Unsatisfied dependencies detected during";
8098 my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8099 {
8100 my $r = int(($w - length($unsat))/2);
8101 my $l = $w - length($unsat) - $r;
8102 $filler1 = "-"x4 . " "x$l;
8103 $filler2 = " "x$r . "-"x4 . "\n";
8104 }
8105 {
8106 my $r = int(($w - length($pretty_id))/2);
8107 my $l = $w - length($pretty_id) - $r;
8108 $filler3 = "-"x4 . " "x$l;
8109 $filler4 = " "x$r . "-"x4 . "\n";
8110 }
135a59c2 8111 $CPAN::Frontend->
6658a91b
SP		 8112 myprint("$filler1 $unsat $filler2".
8113 "$filler3 $pretty_id $filler4".
135a59c2
A		 8114 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
8115 );
6d29edf5
JH		 8116 my $follow = 0;
8117 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
f04ea8d1 8118 $follow = 1;
6d29edf5 8119 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
f04ea8d1 8120 my $answer = CPAN::Shell::colorable_makemaker_prompt(
f610777f
A		 8121"Shall I follow them and prepend them to the queue
8122of modules we are processing right now?", "yes");
f04ea8d1 8123 $follow = $answer =~ /^\s*y/i;
6d29edf5 8124 } else {
f04ea8d1
SP		 8125 local($") = ", ";
8126 $CPAN::Frontend->
de34a54b 8127 myprint(" Ignoring dependencies on modules @prereq\n");
f610777f 8128 }
6d29edf5 8129 if ($follow) {
6658a91b 8130 my $id = $self->id;
6d29edf5
JH		 8131 # color them as dirty
8132 for my $p (@prereq) {
35576f8c 8133 # warn "calling color_cmd_tmps(0,1)";
810a0276 8134 my $any = CPAN::Shell->expandany($p);
f04ea8d1 8135 $self->{$slot . "_for"}{$any->id}++;
810a0276 8136 if ($any) {
f20de9f0 8137 $any->color_cmd_tmps(0,2);
810a0276
SP		 8138 } else {
8139 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8140 $CPAN::Frontend->mysleep(2);
8141 }
6d29edf5 8142 }
135a59c2 8143 # queue them and re-queue yourself
f04ea8d1
SP		 8144 CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
8145 map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples);
8146 $self->{$slot} = "Delayed until after prerequisites";
6d29edf5
JH		 8147 return 1; # signal success to the queuerunner
8148 }
f04ea8d1 8149 return;
6d29edf5
JH		 8150}
8151
8152#-> sub CPAN::Distribution::unsat_prereq ;
7d97ad34
SP		 8153# return ([Foo=>1],[Bar=>1.2]) for normal modules
8154# return ([perl=>5.008]) if we need a newer perl than we are running under
6d29edf5 8155sub unsat_prereq {
f04ea8d1
SP		 8156 my($self,$slot) = @_;
8157 my(%merged,$prereq_pm);
8158 my $prefs_depends = $self->prefs->{depends}||{};
8159 if ($slot eq "configure_requires_later") {
8160 my $meta_yml = $self->parse_meta_yml();
8161 %merged = (%{$meta_yml->{configure_requires}||{}},
8162 %{$prefs_depends->{configure_requires}||{}});
8163 $prereq_pm = {}; # configure_requires defined as "b"
8164 } elsif ($slot eq "later") {
8165 my $prereq_pm_0 = $self->prereq_pm || {};
8166 for my $reqtype (qw(requires build_requires)) {
8167 $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
8168 for my $k (keys %{$prefs_depends->{$reqtype}||{}}) {
8169 $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k};
8170 }
8171 }
8172 %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8173 } else {
8174 die "Panic: illegal slot '$slot'";
8175 }
6d29edf5 8176 my(@need);
f20de9f0
SP		 8177 my @merged = %merged;
8178 CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
135a59c2 8179 NEED: while (my($need_module, $need_version) = each %merged) {
f20de9f0 8180 my($available_version,$available_file,$nmo);
7d97ad34 8181 if ($need_module eq "perl") {
b72dd56f 8182 $available_version = $];
b03f445c 8183 $available_file = CPAN::find_perl;
7d97ad34 8184 } else {
f20de9f0 8185 $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7d97ad34 8186 next if $nmo->uptodate;
b72dd56f 8187 $available_file = $nmo->available_file;
7d97ad34
SP		 8188
8189 # if they have not specified a version, we accept any installed one
ade94d80
SP		 8190 if (defined $available_file
8191 and ( # a few quick shortcurcuits
8192 not defined $need_version
8193 or $need_version eq '0' # "==" would trigger warning when not numeric
8194 or $need_version eq "undef"
8195 )) {
8196 next NEED;
7d97ad34
SP		 8197 }
8198
b72dd56f 8199 $available_version = $nmo->available_version;
6d29edf5
JH		 8200 }
8201
8202 # We only want to install prereqs if either they're not installed
8203 # or if the installed version is too old. We cannot omit this
8204 # check, because if 'force' is in effect, nobody else will check.
b72dd56f 8205 if (defined $available_file) {
e82b9348 8206 my(@all_requirements) = split /\s*,\s*/, $need_version;
6d29edf5 8207 local($^W) = 0;
e82b9348
SP		 8208 my $ok = 0;
8209 RQ: for my $rq (@all_requirements) {
8210 if ($rq =~ s|>=\s*||) {
8211 } elsif ($rq =~ s|>\s*||) {
8212 # 2005-12: one user
f04ea8d1 8213 if (CPAN::Version->vgt($available_version,$rq)) {
e82b9348
SP		 8214 $ok++;
8215 }
8216 next RQ;
8217 } elsif ($rq =~ s|!=\s*||) {
8218 # 2005-12: no user
f04ea8d1 8219 if (CPAN::Version->vcmp($available_version,$rq)) {
e82b9348
SP		 8220 $ok++;
8221 next RQ;
8222 } else {
8223 last RQ;
8224 }
8225 } elsif ($rq =~ m|<=?\s*|) {
8226 # 2005-12: no user
810a0276 8227 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
e82b9348
SP		 8228 $ok++;
8229 next RQ;
8230 }
f04ea8d1 8231 if (! CPAN::Version->vgt($rq, $available_version)) {
e82b9348
SP		 8232 $ok++;
8233 }
b72dd56f
SP		 8234 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8235 "available_version[%s]rq[%s]ok[%d]",
7d97ad34 8236 $need_module,
b72dd56f
SP		 8237 $available_file,
8238 $available_version,
7d97ad34
SP		 8239 CPAN::Version->readable($rq),
8240 $ok,
8241 )) if $CPAN::DEBUG;
6d29edf5 8242 }
e82b9348 8243 next NEED if $ok == @all_requirements;
6d29edf5
JH		 8244 }
8245
7d97ad34
SP		 8246 if ($need_module eq "perl") {
8247 return ["perl", $need_version];
8248 }
f04ea8d1
SP		 8249 $self->{sponsored_mods}{$need_module} ||= 0;
8250 CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
8251 if ($self->{sponsored_mods}{$need_module}++) {
6d29edf5 8252 # We have already sponsored it and for some reason it's still
f20de9f0
SP		 8253 # not available. So we do ... what??
8254
6d29edf5 8255 # if we push it again, we have a potential infinite loop
f20de9f0
SP		 8256
8257 # The following "next" was a very problematic construct.
23a216b4
SP		 8258 # It helped a lot but broke some day and had to be
8259 # replaced.
f20de9f0
SP		 8260
8261 # We must be able to deal with modules that come again and
8262 # again as a prereq and have themselves prereqs and the
8263 # queue becomes long but finally we would find the correct
8264 # order. The RecursiveDependency check should trigger a
8265 # die when it's becoming too weird. Unfortunately removing
8266 # this next breaks many other things.
8267
8268 # The bug that brought this up is described in Todo under
8269 # "5.8.9 cannot install Compress::Zlib"
8270
23a216b4 8271 # next; # this is the next that had to go away
f20de9f0
SP		 8272
8273 # The following "next NEED" are fine and the error message
8274 # explains well what is going on. For example when the DBI
8275 # fails and consequently DBD::SQLite fails and now we are
8276 # processing CPAN::SQLite. Then we must have a "next" for
8277 # DBD::SQLite. How can we get it and how can we identify
8278 # all other cases we must identify?
8279
8280 my $do = $nmo->distribution;
8281 next NEED unless $do; # not on CPAN
ecc7fca0 8282 if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
b03f445c
RGS		 8283 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8284 "'$need_module => $need_version' ".
8285 "for '$self->{ID}' seems ".
ecc7fca0 8286 "not available according to the indexes\n"
b03f445c
RGS		 8287 );
8288 next NEED;
8289 }
f20de9f0
SP		 8290 NOSAYER: for my $nosayer (
8291 "unwrapped",
8292 "writemakefile",
8293 "signature_verify",
8294 "make",
8295 "make_test",
8296 "install",
8297 "make_clean",
8298 ) {
23a216b4
SP		 8299 if ($do->{$nosayer}) {
8300 if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8301 $do->{$nosayer}->failed :
8302 $do->{$nosayer} =~ /^NO/) {
8303 if ($nosayer eq "make_test"
8304 &&
8305 $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8306 ) {
8307 next NOSAYER;
8308 }
8309 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8310 "'$need_module => $need_version' ".
8311 "for '$self->{ID}' failed when ".
8312 "processing '$do->{ID}' with ".
8313 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8314 "but chances to succeed are limited.\n"
8315 );
8316 next NEED;
8317 } else { # the other guy succeeded
8318 if ($nosayer eq "install") {
8319 # we had this with
8320 # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
8321 # 2007-03
8322 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8323 "'$need_module => $need_version' ".
8324 "for '$self->{ID}' already installed ".
8325 "but installation looks suspicious. ".
8326 "Skipping another installation attempt, ".
8327 "to prevent looping endlessly.\n"
8328 );
8329 next NEED;
8330 }
f20de9f0 8331 }
f20de9f0
SP		 8332 }
8333 }
6d29edf5 8334 }
135a59c2
A		 8335 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8336 push @need, [$need_module,$needed_as];
5f05dabc 8337 }
f20de9f0
SP		 8338 my @unfolded = map { "[".join(",",@$_)."]" } @need;
8339 CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
6d29edf5 8340 @need;
5f05dabc 8341}
8342
e82b9348
SP		 8343#-> sub CPAN::Distribution::read_yaml ;
8344sub read_yaml {
8345 my($self) = @_;
8346 return $self->{yaml_content} if exists $self->{yaml_content};
8347 my $build_dir = $self->{build_dir};
8348 my $yaml = File::Spec->catfile($build_dir,"META.yml");
44d21104 8349 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
e82b9348 8350 return unless -f $yaml;
6658a91b 8351 eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
1e8f9a0a 8352 if ($@) {
b72dd56f 8353 $CPAN::Frontend->mywarn("Could not read ".
be34b10d
SP		 8354 "'$yaml'. Falling back to other ".
8355 "methods to determine prerequisites\n");
b72dd56f
SP		 8356 return $self->{yaml_content} = undef; # if we die, then we
8357 # cannot read YAML's own
8358 # META.yml
1e8f9a0a 8359 }
f20de9f0 8360 # not "authoritative"
1e8f9a0a
SP		 8361 if (not exists $self->{yaml_content}{dynamic_config}
8362 or $self->{yaml_content}{dynamic_config}
8363 ) {
8364 $self->{yaml_content} = undef;
e82b9348 8365 }
135a59c2
A		 8366 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8367 if $CPAN::DEBUG;
e82b9348
SP		 8368 return $self->{yaml_content};
8369}
8370
6d29edf5
JH		 8371#-> sub CPAN::Distribution::prereq_pm ;
8372sub prereq_pm {
e82b9348 8373 my($self) = @_;
be34b10d 8374 $self->{prereq_pm_detected} ||= 0;
f20de9f0 8375 CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
be34b10d 8376 return $self->{prereq_pm} if $self->{prereq_pm_detected};
e82b9348
SP		 8377 return unless $self->{writemakefile} # no need to have succeeded
8378 # but we must have run it
c9869e1c 8379 || $self->{modulebuild};
be34b10d
SP		 8380 CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8381 $self->{writemakefile}||"",
8382 $self->{modulebuild}||"",
8383 ) if $CPAN::DEBUG;
135a59c2
A		 8384 my($req,$breq);
8385 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8386 $req = $yaml->{requires} || {};
8387 $breq = $yaml->{build_requires} || {};
e82b9348
SP		 8388 undef $req unless ref $req eq "HASH" && %$req;
8389 if ($req) {
810a0276
SP		 8390 if ($yaml->{generated_by} &&
8391 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
e82b9348
SP		 8392 my $eummv = do { local $^W = 0; $1+0; };
8393 if ($eummv < 6.2501) {
8394 # thanks to Slaven for digging that out: MM before
8395 # that could be wrong because it could reflect a
8396 # previous release
8397 undef $req;
8398 }
8399 }
8400 my $areq;
8401 my $do_replace;
3ff97d55 8402 while (my($k,$v) = each %{$req||{}}) {
e82b9348
SP		 8403 if ($v =~ /\d/) {
8404 $areq->{$k} = $v;
8405 } elsif ($k =~ /[A-Za-z]/ &&
8406 $v =~ /[A-Za-z]/ &&
8407 $CPAN::META->exists("Module",$v)
8408 ) {
8409 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8410 "requires hash: $k => $v; I'll take both ".
8411 "key and value as a module name\n");
8962fc49 8412 $CPAN::Frontend->mysleep(1);
e82b9348
SP		 8413 $areq->{$k} = 0;
8414 $areq->{$v} = 0;
8415 $do_replace++;
8416 }
8417 }
8418 $req = $areq if $do_replace;
8419 }
e82b9348 8420 }
135a59c2 8421 unless ($req || $breq) {
e82b9348
SP		 8422 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8423 my $makefile = File::Spec->catfile($build_dir,"Makefile");
8424 my $fh;
8425 if (-f $makefile
8426 and
8427 $fh = FileHandle->new("<$makefile\0")) {
be34b10d 8428 CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
e82b9348
SP		 8429 local($/) = "\n";
8430 while (<$fh>) {
8431 last if /MakeMaker post_initialize section/;
8432 my($p) = m{^[\#]
8433 \s+PREREQ_PM\s+=>\s+(.+)
8434 }x;
8435 next unless $p;
8436 # warn "Found prereq expr[$p]";
8437
8438 # Regexp modified by A.Speer to remember actual version of file
8439 # PREREQ_PM hash key wants, then add to
f04ea8d1 8440 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
e82b9348
SP		 8441 # In case a prereq is mentioned twice, complain.
8442 if ( defined $req->{$1} ) {
8443 warn "Warning: PREREQ_PM mentions $1 more than once, ".
8444 "last mention wins";
8445 }
f20de9f0
SP		 8446 my($m,$n) = ($1,$2);
8447 if ($n =~ /^q\[(.*?)\]$/) {
8448 $n = $1;
8449 }
8450 $req->{$m} = $n;
e82b9348
SP		 8451 }
8452 last;
8453 }
be34b10d
SP		 8454 }
8455 }
8456 unless ($req || $breq) {
8457 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8458 my $buildfile = File::Spec->catfile($build_dir,"Build");
8459 if (-f $buildfile) {
8460 CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8461 my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8462 if (-f $build_prereqs) {
8463 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8464 my $content = do { local *FH;
8465 open FH, $build_prereqs
8466 or $CPAN::Frontend->mydie("Could not open ".
8467 "'$build_prereqs': $!");
8468 local $/;
8469 <FH>;
8470 };
8471 my $bphash = eval $content;
6a935156 8472 if ($@) {
be34b10d
SP		 8473 } else {
8474 $req = $bphash->{requires} || +{};
8475 $breq = $bphash->{build_requires} || +{};
6a935156 8476 }
9ddc4ed0 8477 }
e82b9348
SP		 8478 }
8479 }
7d97ad34
SP		 8480 if (-f "Build.PL"
8481 && ! -f "Makefile.PL"
8482 && ! exists $req->{"Module::Build"}
8483 && ! $CPAN::META->has_inst("Module::Build")) {
c9869e1c
SP		 8484 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
8485 "undeclared prerequisite.\n".
135a59c2 8486 " Adding it now as such.\n"
c9869e1c
SP		 8487 );
8488 $CPAN::Frontend->mysleep(5);
8489 $req->{"Module::Build"} = 0;
8490 delete $self->{writemakefile};
8491 }
be34b10d
SP		 8492 if ($req || $breq) {
8493 $self->{prereq_pm_detected}++;
8494 return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8495 }
f610777f
A		 8496}
8497
05454584
A		 8498#-> sub CPAN::Distribution::test ;
8499sub test {
5f05dabc 8500 my($self) = @_;
be34b10d
SP		 8501 if (my $goto = $self->prefs->{goto}) {
8502 return $self->goto($goto);
8503 }
05454584 8504 $self->make;
f04ea8d1 8505 if ($CPAN::Signal) {
c4d24d4c
A		 8506 delete $self->{force_update};
8507 return;
8508 }
554a9ef5
SP		 8509 # warn "XDEBUG: checking for notest: $self->{notest} $self";
8510 if ($self->{notest}) {
e82b9348
SP		 8511 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8512 return 1;
554a9ef5
SP		 8513 }
8514
e82b9348 8515 my $make = $self->{modulebuild} ? "Build" : "make";
6658a91b
SP		 8516
8517 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8518 ? $ENV{PERL5LIB}
8519 : ($ENV{PERLLIB} || "");
8520
8521 $CPAN::META->set_perl5lib;
8522 local $ENV{MAKEFLAGS}; # protect us from outer make calls
8523
e82b9348 8524 $CPAN::Frontend->myprint("Running $make test\n");
f20de9f0 8525
05454584 8526 EXCUSE: {
f04ea8d1 8527 my @e;
23a216b4
SP		 8528 if ($self->{make} or $self->{later}) {
8529 # go ahead
8530 } else {
4d1321a7
A		 8531 push @e,
8532 "Make had some problems, won't test";
8533 }
05454584 8534
f04ea8d1
SP		 8535 exists $self->{make} and
8536 (
be34b10d 8537 UNIVERSAL::can($self->{make},"failed") ?
44d21104
A		 8538 $self->{make}->failed :
8539 $self->{make} =~ /^NO/
8540 ) and push @e, "Can't test without successful make";
6d29edf5 8541 $self->{badtestcnt} ||= 0;
f20de9f0
SP		 8542 if ($self->{badtestcnt} > 0) {
8543 require Data::Dumper;
8544 CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
6d29edf5 8545 push @e, "Won't repeat unsuccessful test during this command";
f20de9f0 8546 }
6d29edf5 8547
23a216b4 8548 push @e, $self->{later} if $self->{later};
f04ea8d1 8549 push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
6d29edf5 8550
6a935156 8551 if (exists $self->{build_dir}) {
23a216b4
SP		 8552 if (exists $self->{make_test}) {
8553 if (
8554 UNIVERSAL::can($self->{make_test},"failed") ?
8555 $self->{make_test}->failed :
8556 $self->{make_test} =~ /^NO/
8557 ) {
8558 if (
8559 UNIVERSAL::can($self->{make_test},"commandid")
8560 &&
8561 $self->{make_test}->commandid == $CPAN::CurrentCommandId
8562 ) {
8563 push @e, "Has already been tested within this command";
8564 }
8565 } else {
8566 push @e, "Has already been tested successfully";
8567 }
6a935156
SP		 8568 }
8569 } elsif (!@e) {
8570 push @e, "Has no own directory";
135a59c2 8571 }
f04ea8d1 8572 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
b72dd56f
SP		 8573 unless (chdir $self->{build_dir}) {
8574 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8575 }
f04ea8d1 8576 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
05454584 8577 }
b72dd56f 8578 $self->debug("Changed directory to $self->{build_dir}")
f04ea8d1 8579 if $CPAN::DEBUG;
f14b5cec
JH		 8580
8581 if ($^O eq 'MacOS') {
be708cc0 8582 Mac::BuildTools::make_test($self);
f14b5cec
JH		 8583 return;
8584 }
8585
7d97ad34
SP		 8586 if ($self->{modulebuild}) {
8587 my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8588 if (CPAN::Version->vlt($v,2.62)) {
8589 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8590 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8591 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8592 return;
8593 }
8594 }
8595
e82b9348 8596 my $system;
f04ea8d1
SP		 8597 my $prefs_test = $self->prefs->{test};
8598 if (my $commandline
8599 = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
810a0276 8600 $system = $commandline;
b03f445c 8601 $ENV{PERL} = CPAN::find_perl;
810a0276 8602 } elsif ($self->{modulebuild}) {
44d21104 8603 $system = sprintf "%s test", $self->_build_command();
e82b9348 8604 } else {
ed84aac9 8605 $system = join " ", $self->_make_command(), "test";
e82b9348 8606 }
f20de9f0
SP		 8607 my $make_test_arg = $self->make_x_arg("test");
8608 $system = sprintf("%s%s",
8609 $system,
8610 $make_test_arg ? " $make_test_arg" : "",
8611 );
1e8f9a0a 8612 my($tests_ok);
6658a91b
SP		 8613 my %env;
8614 while (my($k,$v) = each %ENV) {
8615 next unless defined $v;
8616 $env{$k} = $v;
8617 }
8618 local %ENV = %env;
1e8f9a0a
SP		 8619 if (my $env = $self->prefs->{test}{env}) {
8620 for my $e (keys %$env) {
8621 $ENV{$e} = $env->{$e};
8622 }
8623 }
05bab18e 8624 my $expect_model = $self->_prefs_with_expect("test");
6658a91b 8625 my $want_expect = 0;
05bab18e
SP		 8626 if ( $expect_model && @{$expect_model->{talk}} ) {
8627 my $can_expect = $CPAN::META->has_inst("Expect");
6658a91b
SP		 8628 if ($can_expect) {
8629 $want_expect = 1;
8630 } else {
8631 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8632 "testing without\n");
8633 }
8634 }
6658a91b 8635 if ($want_expect) {
f04ea8d1 8636 if ($self->_should_report('test')) {
6658a91b
SP		 8637 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8638 "not supported when distroprefs specify ".
8639 "an interactive test\n");
8640 }
05bab18e 8641 $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
f04ea8d1 8642 } elsif ( $self->_should_report('test') ) {
6a935156 8643 $tests_ok = CPAN::Reporter::test($self, $system);
8962fc49 8644 } else {
6a935156 8645 $tests_ok = system($system) == 0;
8962fc49 8646 }
05bab18e 8647 $self->introduce_myself;
8962fc49 8648 if ( $tests_ok ) {
6a935156
SP		 8649 {
8650 my @prereq;
810a0276 8651
b72dd56f 8652 # local $CPAN::DEBUG = 16; # Distribution
6a935156 8653 for my $m (keys %{$self->{sponsored_mods}}) {
f04ea8d1 8654 next unless $self->{sponsored_mods}{$m} > 0;
f20de9f0 8655 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
810a0276
SP		 8656 # XXX we need available_version which reflects
8657 # $ENV{PERL5LIB} so that already tested but not yet
8658 # installed modules are counted.
8659 my $available_version = $m_obj->available_version;
b72dd56f 8660 my $available_file = $m_obj->available_file;
810a0276 8661 if ($available_version &&
b72dd56f 8662 !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
810a0276
SP		 8663 ) {
8664 CPAN->debug("m[$m] good enough available_version[$available_version]")
8665 if $CPAN::DEBUG;
b72dd56f
SP		 8666 } elsif ($available_file
8667 && (
8668 !$self->{prereq_pm}{$m}
8669 ||
8670 $self->{prereq_pm}{$m} == 0
8671 )
8672 ) {
8673 # lex Class::Accessor::Chained::Fast which has no $VERSION
8674 CPAN->debug("m[$m] have available_file[$available_file]")
8675 if $CPAN::DEBUG;
810a0276
SP		 8676 } else {
8677 push @prereq, $m;
6a935156
SP		 8678 }
8679 }
f04ea8d1 8680 if (@prereq) {
6a935156
SP		 8681 my $cnt = @prereq;
8682 my $which = join ",", @prereq;
810a0276 8683 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
6a935156 8684 "$cnt dependencies missing ($which)";
810a0276
SP		 8685 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8686 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
05bab18e 8687 $self->store_persistent_state;
8ce4ea0b 8688 return $self->goodbye("[dependencies] -- NA");
6a935156
SP		 8689 }
8690 }
8691
8692 $CPAN::Frontend->myprint(" $system -- OK\n");
6a935156 8693 $self->{make_test} = CPAN::Distrostatus->new("YES");
b72dd56f
SP		 8694 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8695 # probably impossible to need the next line because badtestcnt
8696 # has a lifespan of one command
8697 delete $self->{badtestcnt};
05454584 8698 } else {
6a935156
SP		 8699 $self->{make_test} = CPAN::Distrostatus->new("NO");
8700 $self->{badtestcnt}++;
8701 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
b03f445c
RGS		 8702 CPAN::Shell->optprint
8703 ("hint",
8704 sprintf
8705 ("//hint// to see the cpan-testers results for installing this module, try:
8706 reports %s\n",
8707 $self->pretty_id));
5f05dabc 8708 }
05bab18e
SP		 8709 $self->store_persistent_state;
8710}
8711
8712sub _prefs_with_expect {
8713 my($self,$where) = @_;
8714 return unless my $prefs = $self->prefs;
8715 return unless my $where_prefs = $prefs->{$where};
8716 if ($where_prefs->{expect}) {
8717 return {
810a0276
SP		 8718 mode => "deterministic",
8719 timeout => 15,
05bab18e
SP		 8720 talk => $where_prefs->{expect},
8721 };
810a0276
SP		 8722 } elsif ($where_prefs->{"eexpect"}) {
8723 return $where_prefs->{"eexpect"};
05bab18e
SP		 8724 }
8725 return;
5f05dabc 8726}
8727
05454584
A		 8728#-> sub CPAN::Distribution::clean ;
8729sub clean {
5f05dabc 8730 my($self) = @_;
e82b9348
SP		 8731 my $make = $self->{modulebuild} ? "Build" : "make";
8732 $CPAN::Frontend->myprint("Running $make clean\n");
4d1321a7
A		 8733 unless (exists $self->{archived}) {
8734 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8735 "/untarred, nothing done\n");
8736 return 1;
8737 }
e82b9348
SP		 8738 unless (exists $self->{build_dir}) {
8739 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8740 return 1;
8741 }
ade94d80
SP		 8742 if (exists $self->{writemakefile}
8743 and $self->{writemakefile}->failed
8744 ) {
8745 $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8746 return 1;
8747 }
05454584 8748 EXCUSE: {
f04ea8d1 8749 my @e;
c4d24d4c
A		 8750 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8751 push @e, "make clean already called once";
f04ea8d1 8752 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 8753 }
b72dd56f 8754 chdir $self->{build_dir} or
f04ea8d1 8755 Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
b72dd56f 8756 $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
f14b5cec
JH		 8757
8758 if ($^O eq 'MacOS') {
be708cc0 8759 Mac::BuildTools::make_clean($self);
f14b5cec
JH		 8760 return;
8761 }
8762
e82b9348
SP		 8763 my $system;
8764 if ($self->{modulebuild}) {
8962fc49 8765 unless (-f "Build") {
810a0276 8766 my $cwd = CPAN::anycwd();
8962fc49
SP		 8767 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8768 " in cwd[$cwd]. Danger, Will Robinson!");
8769 $CPAN::Frontend->mysleep(5);
8770 }
44d21104 8771 $system = sprintf "%s clean", $self->_build_command();
e82b9348 8772 } else {
ed84aac9 8773 $system = join " ", $self->_make_command(), "clean";
e82b9348 8774 }
05bab18e
SP		 8775 my $system_ok = system($system) == 0;
8776 $self->introduce_myself;
8777 if ( $system_ok ) {
c4d24d4c
A		 8778 $CPAN::Frontend->myprint(" $system -- OK\n");
8779
8780 # $self->force;
8781
8782 # Jost Krieger pointed out that this "force" was wrong because
8783 # it has the effect that the next "install" on this distribution
8784 # will untar everything again. Instead we should bring the
8785 # object's state back to where it is after untarring.
8786
e82b9348
SP		 8787 for my $k (qw(
8788 force_update
8789 install
8790 writemakefile
8791 make
8792 make_test
8793 )) {
8794 delete $self->{$k};
8795 }
87892b73 8796 $self->{make_clean} = CPAN::Distrostatus->new("YES");
c4d24d4c 8797
05454584 8798 } else {
c4d24d4c
A		 8799 # Hmmm, what to do if make clean failed?
8800
87892b73 8801 $self->{make_clean} = CPAN::Distrostatus->new("NO");
8962fc49 8802 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
c4d24d4c 8803
87892b73
RGS		 8804 # 2006-02-27: seems silly to me to force a make now
8805 # $self->force("make"); # so that this directory won't be used again
c4d24d4c 8806
5f05dabc 8807 }
05bab18e 8808 $self->store_persistent_state;
5f05dabc 8809}
8810
810a0276 8811#-> sub CPAN::Distribution::goto ;
be34b10d
SP		 8812sub goto {
8813 my($self,$goto) = @_;
810a0276 8814 $goto = $self->normalize($goto);
f04ea8d1
SP		 8815 my $why = sprintf(
8816 "Goto '$goto' via prefs file '%s' doc %d",
8817 $self->{prefs_file},
8818 $self->{prefs_file_doc},
8819 );
8820 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
8821 # 2007-07-16 akoenig : Better than NA would be if we could inherit
8822 # the status of the $goto distro but given the exceptional nature
8823 # of 'goto' I feel reluctant to implement it
8824 my $goodbye_message = "[goto] -- NA $why";
8825 $self->goodbye($goodbye_message);
810a0276
SP		 8826
8827 # inject into the queue
8828
8829 CPAN::Queue->delete($self->id);
f04ea8d1 8830 CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
810a0276
SP		 8831
8832 # and run where we left off
8833
be34b10d 8834 my($method) = (caller(1))[3];
8ce4ea0b 8835 CPAN->instance("CPAN::Distribution",$goto)->$method();
b72dd56f 8836 CPAN::Queue->delete_first($goto);
be34b10d
SP		 8837}
8838
8839#-> sub CPAN::Distribution::install ;
05454584 8840sub install {
5f05dabc 8841 my($self) = @_;
be34b10d
SP		 8842 if (my $goto = $self->prefs->{goto}) {
8843 return $self->goto($goto);
8844 }
23a216b4 8845 # $DB::single=1;
f20de9f0
SP		 8846 unless ($self->{badtestcnt}) {
8847 $self->test;
8848 }
f04ea8d1 8849 if ($CPAN::Signal) {
c4d24d4c
A		 8850 delete $self->{force_update};
8851 return;
8852 }
e82b9348
SP		 8853 my $make = $self->{modulebuild} ? "Build" : "make";
8854 $CPAN::Frontend->myprint("Running $make install\n");
05454584 8855 EXCUSE: {
f04ea8d1
SP		 8856 my @e;
8857 if ($self->{make} or $self->{later}) {
23a216b4
SP		 8858 # go ahead
8859 } else {
4d1321a7
A		 8860 push @e,
8861 "Make had some problems, won't install";
8862 }
5f05dabc 8863
f04ea8d1
SP		 8864 exists $self->{make} and
8865 (
be34b10d 8866 UNIVERSAL::can($self->{make},"failed") ?
44d21104
A		 8867 $self->{make}->failed :
8868 $self->{make} =~ /^NO/
8869 ) and
f04ea8d1 8870 push @e, "Make had returned bad status, install seems impossible";
6a935156
SP		 8871
8872 if (exists $self->{build_dir}) {
8873 } elsif (!@e) {
8874 push @e, "Has no own directory";
8875 }
05454584 8876
9ddc4ed0 8877 if (exists $self->{make_test} and
f04ea8d1 8878 (
be34b10d 8879 UNIVERSAL::can($self->{make_test},"failed") ?
44d21104
A		 8880 $self->{make_test}->failed :
8881 $self->{make_test} =~ /^NO/
f04ea8d1
SP		 8882 )) {
8883 if ($self->{force_update}) {
9ddc4ed0
A		 8884 $self->{make_test}->text("FAILED but failure ignored because ".
8885 "'force' in effect");
8886 } else {
8887 push @e, "make test had returned bad status, ".
8888 "won't install without force"
8889 }
8890 }
f04ea8d1 8891 if (exists $self->{install}) {
be34b10d
SP		 8892 if (UNIVERSAL::can($self->{install},"text") ?
8893 $self->{install}->text eq "YES" :
8894 $self->{install} =~ /^YES/
4d1321a7 8895 ) {
23a216b4
SP		 8896 $CPAN::Frontend->myprint(" Already done\n");
8897 $CPAN::META->is_installed($self->{build_dir});
8898 return 1;
4d1321a7
A		 8899 } else {
8900 # comment in Todo on 2006-02-11; maybe retry?
8901 push @e, "Already tried without success";
8902 }
8903 }
05454584 8904
23a216b4 8905 push @e, $self->{later} if $self->{later};
f04ea8d1 8906 push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
6d29edf5 8907
f04ea8d1 8908 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
b72dd56f
SP		 8909 unless (chdir $self->{build_dir}) {
8910 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8911 }
f04ea8d1 8912 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
05454584 8913 }
b72dd56f 8914 $self->debug("Changed directory to $self->{build_dir}")
f04ea8d1 8915 if $CPAN::DEBUG;
f14b5cec
JH		 8916
8917 if ($^O eq 'MacOS') {
be708cc0 8918 Mac::BuildTools::make_install($self);
f14b5cec
JH		 8919 return;
8920 }
8921
e82b9348 8922 my $system;
810a0276
SP		 8923 if (my $commandline = $self->prefs->{install}{commandline}) {
8924 $system = $commandline;
b03f445c 8925 $ENV{PERL} = CPAN::find_perl;
810a0276 8926 } elsif ($self->{modulebuild}) {
44d21104
A		 8927 my($mbuild_install_build_command) =
8928 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8929 $CPAN::Config->{mbuild_install_build_command} ?
8930 $CPAN::Config->{mbuild_install_build_command} :
8931 $self->_build_command();
8932 $system = sprintf("%s install %s",
8933 $mbuild_install_build_command,
8934 $CPAN::Config->{mbuild_install_arg},
8935 );
e82b9348 8936 } else {
1e8f9a0a 8937 my($make_install_make_command) =
6658a91b
SP		 8938 CPAN::HandleConfig->prefs_lookup($self,
8939 q{make_install_make_command})
8940 || $self->_make_command();
44d21104
A		 8941 $system = sprintf("%s install %s",
8942 $make_install_make_command,
8943 $CPAN::Config->{make_install_arg},
8944 );
e82b9348
SP		 8945 }
8946
87892b73 8947 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
6658a91b
SP		 8948 my $brip = CPAN::HandleConfig->prefs_lookup($self,
8949 q{build_requires_install_policy});
1e8f9a0a 8950 $brip ||="ask/yes";
135a59c2 8951 my $id = $self->id;
6a935156 8952 my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
135a59c2
A		 8953 my $want_install = "yes";
8954 if ($reqtype eq "b") {
1e8f9a0a 8955 if ($brip eq "no") {
135a59c2 8956 $want_install = "no";
1e8f9a0a 8957 } elsif ($brip =~ m|^ask/(.+)|) {
135a59c2
A		 8958 my $default = $1;
8959 $default = "yes" unless $default =~ /^(y|n)/i;
8960 $want_install =
8961 CPAN::Shell::colorable_makemaker_prompt
8962 ("$id is just needed temporarily during building or testing. ".
8963 "Do you want to install it permanently? (Y/n)",
8964 $default);
8965 }
8966 }
8967 unless ($want_install =~ /^y/i) {
8968 my $is_only = "is only 'build_requires'";
8969 $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8970 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8971 delete $self->{force_update};
8972 return;
8973 }
f04ea8d1
SP		 8974 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8975 ? $ENV{PERL5LIB}
8976 : ($ENV{PERLLIB} || "");
8977
8978 $CPAN::META->set_perl5lib;
f610777f 8979 my($pipe) = FileHandle->new("$system $stderr |");
05454584 8980 my($makeout) = "";
f04ea8d1
SP		 8981 while (<$pipe>) {
8982 print $_; # intentionally NOT use Frontend->myprint because it
8962fc49
SP		 8983 # looks irritating when we markup in color what we
8984 # just pass through from an external program
f04ea8d1 8985 $makeout .= $_;
05454584
A		 8986 }
8987 $pipe->close;
05bab18e
SP		 8988 my $close_ok = $? == 0;
8989 $self->introduce_myself;
8990 if ( $close_ok ) {
44d21104
A		 8991 $CPAN::Frontend->myprint(" $system -- OK\n");
8992 $CPAN::META->is_installed($self->{build_dir});
b72dd56f 8993 $self->{install} = CPAN::Distrostatus->new("YES");
5f05dabc 8994 } else {
44d21104 8995 $self->{install} = CPAN::Distrostatus->new("NO");
8962fc49 8996 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
1e8f9a0a 8997 my $mimc =
6658a91b
SP		 8998 CPAN::HandleConfig->prefs_lookup($self,
8999 q{make_install_make_command});
44d21104
A		 9000 if (
9001 $makeout =~ /permission/s
9002 && $> > 0
9003 && (
1e8f9a0a 9004 ! $mimc
6658a91b
SP		 9005 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9006 q{make}))
44d21104
A		 9007 )
9008 ) {
9009 $CPAN::Frontend->myprint(
9010 qq{----\n}.
9011 qq{ You may have to su }.
9012 qq{to root to install the package\n}.
9013 qq{ (Or you may want to run something like\n}.
9014 qq{ o conf make_install_make_command 'sudo make'\n}.
9015 qq{ to raise your permissions.}
9016 );
9017 }
5f05dabc 9018 }
c4d24d4c 9019 delete $self->{force_update};
b72dd56f 9020 # $DB::single = 1;
05bab18e
SP		 9021 $self->store_persistent_state;
9022}
9023
9024sub introduce_myself {
9025 my($self) = @_;
9026 $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
5f05dabc 9027}
9028
05454584
A		 9029#-> sub CPAN::Distribution::dir ;
9030sub dir {
b72dd56f 9031 shift->{build_dir};
5f05dabc 9032}
9033
554a9ef5
SP		 9034#-> sub CPAN::Distribution::perldoc ;
9035sub perldoc {
f3fe0ae6 9036 my($self) = @_;
554a9ef5
SP		 9037
9038 my($dist) = $self->id;
9039 my $package = $self->called_for;
9040
9041 $self->_display_url( $CPAN::Defaultdocs . $package );
9042}
9043
9044#-> sub CPAN::Distribution::_check_binary ;
9045sub _check_binary {
f3fe0ae6 9046 my ($dist,$shell,$binary) = @_;
4d1321a7 9047 my ($pid,$out);
554a9ef5
SP		 9048
9049 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9050 if $CPAN::DEBUG;
9051
05bab18e
SP		 9052 if ($CPAN::META->has_inst("File::Which")) {
9053 return File::Which::which($binary);
9054 } else {
9055 local *README;
9056 $pid = open README, "which $binary|"
9057 or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9058 return unless $pid;
9059 while (<README>) {
9060 $out .= $_;
9061 }
9062 close README
9063 or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9064 and return;
554a9ef5 9065 }
554a9ef5
SP		 9066
9067 $CPAN::Frontend->myprint(qq{ + $out \n})
9068 if $CPAN::DEBUG && $out;
9069
9070 return $out;
9071}
9072
9073#-> sub CPAN::Distribution::_display_url ;
9074sub _display_url {
f3fe0ae6 9075 my($self,$url) = @_;
4d1321a7 9076 my($res,$saved_file,$pid,$out);
554a9ef5
SP		 9077
9078 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9079 if $CPAN::DEBUG;
9080
9081 # should we define it in the config instead?
f04ea8d1 9082 my $html_converter = "html2text.pl";
554a9ef5
SP		 9083
9084 my $web_browser = $CPAN::Config->{'lynx'} || undef;
9085 my $web_browser_out = $web_browser
f04ea8d1
SP		 9086 ? CPAN::Distribution->_check_binary($self,$web_browser)
9087 : undef;
554a9ef5 9088
4d1321a7
A		 9089 if ($web_browser_out) {
9090 # web browser found, run the action
f04ea8d1 9091 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
4d1321a7 9092 $CPAN::Frontend->myprint(qq{system[$browser $url]})
f04ea8d1
SP		 9093 if $CPAN::DEBUG;
9094 $CPAN::Frontend->myprint(qq{
4d1321a7
A		 9095Displaying URL
9096 $url
9097with browser $browser
9098});
f04ea8d1 9099 $CPAN::Frontend->mysleep(1);
4d1321a7 9100 system("$browser $url");
f04ea8d1 9101 if ($saved_file) { 1 while unlink($saved_file) }
4d1321a7 9102 } else {
554a9ef5 9103 # web browser not found, let's try text only
f04ea8d1
SP		 9104 my $html_converter_out =
9105 CPAN::Distribution->_check_binary($self,$html_converter);
ed84aac9 9106 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
554a9ef5
SP		 9107
9108 if ($html_converter_out ) {
9109 # html2text found, run it
9110 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
4d1321a7
A		 9111 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9112 unless defined($saved_file);
554a9ef5 9113
4d1321a7 9114 local *README;
f04ea8d1
SP		 9115 $pid = open README, "$html_converter $saved_file |"
9116 or $CPAN::Frontend->mydie(qq{
0a78cd5d 9117Could not fork '$html_converter $saved_file': $!});
4d1321a7 9118 my($fh,$filename);
b03f445c 9119 if ($CPAN::META->has_usable("File::Temp")) {
4d1321a7 9120 $fh = File::Temp->new(
917f1700 9121 dir => File::Spec->tmpdir,
4d1321a7
A		 9122 template => 'cpan_htmlconvert_XXXX',
9123 suffix => '.txt',
9124 unlink => 0,
9125 );
9126 $filename = $fh->filename;
9127 } else {
9128 $filename = "cpan_htmlconvert_$$.txt";
9129 $fh = FileHandle->new();
9130 open $fh, ">$filename" or die;
9131 }
9132 while (<README>) {
554a9ef5
SP		 9133 $fh->print($_);
9134 }
4d1321a7
A		 9135 close README or
9136 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
554a9ef5 9137 my $tmpin = $fh->filename;
4d1321a7 9138 $CPAN::Frontend->myprint(sprintf(qq{
554a9ef5
SP		 9139Run '%s %s' and
9140saved output to %s\n},
9141 $html_converter,
9142 $saved_file,
9143 $tmpin,
9144 )) if $CPAN::DEBUG;
4d1321a7
A		 9145 close $fh;
9146 local *FH;
9147 open FH, $tmpin
9148 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
554a9ef5
SP		 9149 my $fh_pager = FileHandle->new;
9150 local($SIG{PIPE}) = "IGNORE";
ed84aac9 9151 my $pager = $CPAN::Config->{'pager'} || "cat";
135a59c2 9152 $fh_pager->open("|$pager")
4d1321a7 9153 or $CPAN::Frontend->mydie(qq{
135a59c2 9154Could not open pager '$pager': $!});
4d1321a7 9155 $CPAN::Frontend->myprint(qq{
554a9ef5
SP		 9156Displaying URL
9157 $url
ed84aac9 9158with pager "$pager"
554a9ef5 9159});
8962fc49 9160 $CPAN::Frontend->mysleep(1);
4d1321a7
A		 9161 $fh_pager->print(<FH>);
9162 $fh_pager->close;
554a9ef5
SP		 9163 } else {
9164 # coldn't find the web browser or html converter
9165 $CPAN::Frontend->myprint(qq{
9166You need to install lynx or $html_converter to use this feature.});
9167 }
554a9ef5
SP		 9168 }
9169}
9170
9171#-> sub CPAN::Distribution::_getsave_url ;
9172sub _getsave_url {
f3fe0ae6 9173 my($dist, $shell, $url) = @_;
554a9ef5
SP		 9174
9175 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9176 if $CPAN::DEBUG;
9177
4d1321a7 9178 my($fh,$filename);
b03f445c 9179 if ($CPAN::META->has_usable("File::Temp")) {
4d1321a7 9180 $fh = File::Temp->new(
917f1700 9181 dir => File::Spec->tmpdir,
554a9ef5
SP		 9182 template => "cpan_getsave_url_XXXX",
9183 suffix => ".html",
9184 unlink => 0,
9185 );
4d1321a7
A		 9186 $filename = $fh->filename;
9187 } else {
9188 $fh = FileHandle->new;
9189 $filename = "cpan_getsave_url_$$.html";
9190 }
9191 my $tmpin = $filename;
554a9ef5
SP		 9192 if ($CPAN::META->has_usable('LWP')) {
9193 $CPAN::Frontend->myprint("Fetching with LWP:
9194 $url
9195");
9196 my $Ua;
9197 CPAN::LWP::UserAgent->config;
4d1321a7
A		 9198 eval { $Ua = CPAN::LWP::UserAgent->new; };
9199 if ($@) {
9200 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9201 return;
9202 } else {
9203 my($var);
9204 $Ua->proxy('http', $var)
554a9ef5 9205 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
4d1321a7 9206 $Ua->no_proxy($var)
554a9ef5 9207 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
4d1321a7 9208 }
554a9ef5
SP		 9209
9210 my $req = HTTP::Request->new(GET => $url);
9211 $req->header('Accept' => 'text/html');
9212 my $res = $Ua->request($req);
9213 if ($res->is_success) {
9214 $CPAN::Frontend->myprint(" + request successful.\n")
9215 if $CPAN::DEBUG;
9216 print $fh $res->content;
9217 close $fh;
9218 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9219 if $CPAN::DEBUG;
9220 return $tmpin;
9221 } else {
9222 $CPAN::Frontend->myprint(sprintf(
9223 "LWP failed with code[%s], message[%s]\n",
9224 $res->code,
9225 $res->message,
9226 ));
9227 return;
9228 }
9229 } else {
8962fc49 9230 $CPAN::Frontend->mywarn(" LWP not available\n");
554a9ef5
SP		 9231 return;
9232 }
9233}
9234
f04ea8d1 9235#-> sub CPAN::Distribution::_build_command
44d21104
A		 9236sub _build_command {
9237 my($self) = @_;
9238 if ($^O eq "MSWin32") { # special code needed at least up to
9239 # Module::Build 0.2611 and 0.2706; a fix
9240 # in M:B has been promised 2006-01-30
9241 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9242 return "$perl ./Build";
9243 }
9244 return "./Build";
9245}
9246
f04ea8d1
SP		 9247#-> sub CPAN::Distribution::_should_report
9248sub _should_report {
9249 my($self, $phase) = @_;
9250 die "_should_report() requires a 'phase' argument"
9251 if ! defined $phase;
9252
9253 # configured
9254 my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9255 q{test_report});
9256 return unless $test_report;
9257
9258 # don't repeat if we cached a result
9259 return $self->{should_report}
9260 if exists $self->{should_report};
9261
9262 # available
9263 if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9264 $CPAN::Frontend->mywarn(
9265 "CPAN::Reporter not installed. No reports will be sent.\n"
9266 );
9267 return $self->{should_report} = 0;
9268 }
9269
9270 # capable
9271 my $crv = CPAN::Reporter->VERSION;
9272 if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9273 # don't cache $self->{should_report} -- need to check each phase
9274 if ( $phase eq 'test' ) {
9275 return 1;
9276 }
9277 else {
9278 $CPAN::Frontend->mywarn(
9279 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9280 "you only have version $crv\. Only 'test' phase reports will be sent.\n"
9281 );
9282 return;
9283 }
9284 }
9285
9286 # appropriate
9287 if ($self->is_dot_dist) {
9288 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9289 "for local directories\n");
9290 return $self->{should_report} = 0;
9291 }
9292 if ($self->prefs->{patches}
9293 &&
9294 @{$self->prefs->{patches}}
9295 &&
9296 $self->{patched}
9297 ) {
9298 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9299 "when the source has been patched\n");
9300 return $self->{should_report} = 0;
9301 }
9302
9303 # proceed and cache success
9304 return $self->{should_report} = 1;
9305}
9306
dc053c64
SP		 9307#-> sub CPAN::Distribution::reports
9308sub reports {
9309 my($self) = @_;
9310 my $pathname = $self->id;
9311 $CPAN::Frontend->myprint("Distribution: $pathname\n");
9312
9313 unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9314 $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9315 }
9316 unless ($CPAN::META->has_usable("LWP")) {
9317 $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9318 }
b03f445c 9319 unless ($CPAN::META->has_usable("File::Temp")) {
dc053c64
SP		 9320 $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9321 }
9322
9323 my $d = CPAN::DistnameInfo->new($pathname);
9324
9325 my $dist = $d->dist; # "CPAN-DistnameInfo"
9326 my $version = $d->version; # "0.02"
9327 my $maturity = $d->maturity; # "released"
9328 my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
9329 my $cpanid = $d->cpanid; # "GBARR"
9330 my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9331
9332 my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9333
9334 CPAN::LWP::UserAgent->config;
9335 my $Ua;
9336 eval { $Ua = CPAN::LWP::UserAgent->new; };
9337 if ($@) {
9338 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9339 }
9340 $CPAN::Frontend->myprint("Fetching '$url'...");
9341 my $resp = $Ua->get($url);
9342 unless ($resp->is_success) {
9343 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9344 }
9345 $CPAN::Frontend->myprint("DONE\n\n");
9346 my $yaml = $resp->content;
9347 # was fuer ein Umweg!
9348 my $fh = File::Temp->new(
917f1700 9349 dir => File::Spec->tmpdir,
dc053c64
SP		 9350 template => 'cpan_reports_XXXX',
9351 suffix => '.yaml',
9352 unlink => 0,
9353 );
9354 my $tfilename = $fh->filename;
9355 print $fh $yaml;
9356 close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9357 my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9358 unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9359 my %other_versions;
9360 my $this_version_seen;
9361 for my $rep (@$unserialized) {
9362 my $rversion = $rep->{version};
f04ea8d1 9363 if ($rversion eq $version) {
dc053c64
SP		 9364 unless ($this_version_seen++) {
9365 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9366 }
9367 $CPAN::Frontend->myprint
9368 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9369 $rep->{archname} eq $Config::Config{archname}?"*":"",
9370 $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9371 $rep->{action},
9372 $rep->{perl},
9373 ucfirst $rep->{osname},
9374 $rep->{osvers},
9375 $rep->{archname},
9376 ));
9377 } else {
9378 $other_versions{$rep->{version}}++;
9379 }
9380 }
9381 unless ($this_version_seen) {
9382 $CPAN::Frontend->myprint("No reports found for version '$version'
9383Reports for other versions:\n");
9384 for my $v (sort keys %other_versions) {
9385 $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9386 }
9387 }
9388 $url =~ s/\.yaml/.html/;
9389 $CPAN::Frontend->myprint("See $url for details\n");
9390}
9391
05454584 9392package CPAN::Bundle;
e82b9348 9393use strict;
5f05dabc 9394
e662ec5f
A		 9395sub look {
9396 my $self = shift;
35576f8c 9397 $CPAN::Frontend->myprint($self->as_string);
e662ec5f
A		 9398}
9399
23a216b4 9400#-> CPAN::Bundle::undelay
6d29edf5
JH		 9401sub undelay {
9402 my $self = shift;
9403 delete $self->{later};
9404 for my $c ( $self->contains ) {
9405 my $obj = CPAN::Shell->expandany($c) or next;
9406 $obj->undelay;
9407 }
9408}
9409
e82b9348 9410# mark as dirty/clean
6d29edf5
JH		 9411#-> sub CPAN::Bundle::color_cmd_tmps ;
9412sub color_cmd_tmps {
9413 my($self) = shift;
9414 my($depth) = shift || 0;
9415 my($color) = shift || 0;
35576f8c 9416 my($ancestors) = shift || [];
6d29edf5
JH		 9417 # a module needs to recurse to its cpan_file, a distribution needs
9418 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9419
9420 return if exists $self->{incommandcolor}
f20de9f0 9421 && $color==1
6d29edf5 9422 && $self->{incommandcolor}==$color;
f04ea8d1 9423 if ($depth>=$CPAN::MAX_RECURSION) {
ade94d80 9424 die(CPAN::Exception::RecursiveDependency->new($ancestors));
35576f8c
A		 9425 }
9426 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6d29edf5
JH		 9427
9428 for my $c ( $self->contains ) {
9429 my $obj = CPAN::Shell->expandany($c) or next;
9430 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
35576f8c 9431 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6d29edf5 9432 }
b72dd56f
SP		 9433 # never reached code?
9434 #if ($color==0) {
9435 #delete $self->{badtestcnt};
9436 #}
6d29edf5
JH		 9437 $self->{incommandcolor} = $color;
9438}
9439
05454584
A		 9440#-> sub CPAN::Bundle::as_string ;
9441sub as_string {
9442 my($self) = @_;
9443 $self->contains;
5e05dca5 9444 # following line must be "=", not "||=" because we have a moving target
6d29edf5 9445 $self->{INST_VERSION} = $self->inst_version;
05454584
A		 9446 return $self->SUPER::as_string;
9447}
9448
9449#-> sub CPAN::Bundle::contains ;
9450sub contains {
c049f953
JH		 9451 my($self) = @_;
9452 my($inst_file) = $self->inst_file || "";
9453 my($id) = $self->id;
9454 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
b96578bb
SP		 9455 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9456 undef $inst_file;
9457 }
c049f953
JH		 9458 unless ($inst_file) {
9459 # Try to get at it in the cpan directory
9460 $self->debug("no inst_file") if $CPAN::DEBUG;
9461 my $cpan_file;
9462 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9463 $cpan_file = $self->cpan_file;
9464 if ($cpan_file eq "N/A") {
9465 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9466 Maybe stale symlink? Maybe removed during session? Giving up.\n");
9467 }
9468 my $dist = $CPAN::META->instance('CPAN::Distribution',
9469 $self->cpan_file);
b72dd56f 9470 $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
c049f953 9471 $dist->get;
b72dd56f 9472 $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
c049f953
JH		 9473 my($todir) = $CPAN::Config->{'cpan_home'};
9474 my(@me,$from,$to,$me);
9475 @me = split /::/, $self->id;
9476 $me[-1] .= ".pm";
5de3f0da 9477 $me = File::Spec->catfile(@me);
b72dd56f 9478 $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
5de3f0da 9479 $to = File::Spec->catfile($todir,$me);
c049f953
JH		 9480 File::Path::mkpath(File::Basename::dirname($to));
9481 File::Copy::copy($from, $to)
9482 or Carp::confess("Couldn't copy $from to $to: $!");
9483 $inst_file = $to;
9484 }
9485 my @result;
9486 my $fh = FileHandle->new;
9487 local $/ = "\n";
9488 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9489 my $in_cont = 0;
9490 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9491 while (<$fh>) {
9492 $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
9493 m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
9494 next unless $in_cont;
9495 next if /^=/;
9496 s/\#.*//;
9497 next if /^\s+$/;
9498 chomp;
9499 push @result, (split " ", $_, 2)[0];
9500 }
9501 close $fh;
9502 delete $self->{STATUS};
9503 $self->{CONTAINS} = \@result;
9504 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9505 unless (@result) {
9506 $CPAN::Frontend->mywarn(qq{
9507The bundle file "$inst_file" may be a broken
2e2b7522
GS		 9508bundlefile. It seems not to contain any bundle definition.
9509Please check the file and if it is bogus, please delete it.
9510Sorry for the inconvenience.
9511});
c049f953
JH		 9512 }
9513 @result;
5f05dabc 9514}
9515
e50380aa 9516#-> sub CPAN::Bundle::find_bundle_file
b96578bb 9517# $where is in local format, $what is in unix format
e50380aa
A		 9518sub find_bundle_file {
9519 my($self,$where,$what) = @_;
c356248b 9520 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
2e2b7522 9521### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5de3f0da 9522### my $bu = File::Spec->catfile($where,$what);
2e2b7522 9523### return $bu if -f $bu;
5de3f0da 9524 my $manifest = File::Spec->catfile($where,"MANIFEST");
e50380aa 9525 unless (-f $manifest) {
f04ea8d1
SP		 9526 require ExtUtils::Manifest;
9527 my $cwd = CPAN::anycwd();
9528 $self->safe_chdir($where);
9529 ExtUtils::Manifest::mkmanifest();
9530 $self->safe_chdir($cwd);
e50380aa 9531 }
c356248b 9532 my $fh = FileHandle->new($manifest)
f04ea8d1 9533 or Carp::croak("Couldn't open $manifest: $!");
e50380aa 9534 local($/) = "\n";
b96578bb
SP		 9535 my $bundle_filename = $what;
9536 $bundle_filename =~ s|Bundle.*/||;
9537 my $bundle_unixpath;
e50380aa 9538 while (<$fh>) {
f04ea8d1
SP		 9539 next if /^\s*\#/;
9540 my($file) = /(\S+)/;
9541 if ($file =~ m|\Q$what\E$|) {
9542 $bundle_unixpath = $file;
9543 # return File::Spec->catfile($where,$bundle_unixpath); # bad
9544 last;
9545 }
9546 # retry if she managed to have no Bundle directory
9547 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
e50380aa 9548 }
b96578bb
SP		 9549 return File::Spec->catfile($where, split /\//, $bundle_unixpath)
9550 if $bundle_unixpath;
c356248b 9551 Carp::croak("Couldn't find a Bundle file in $where");
e50380aa
A		 9552}
9553
d8773709
JH		 9554# needs to work quite differently from Module::inst_file because of
9555# cpan_home/Bundle/ directory and the possibility that we have
9556# shadowing effect. As it makes no sense to take the first in @INC for
9557# Bundles, we parse them all for $VERSION and take the newest.
6d29edf5 9558
05454584
A		 9559#-> sub CPAN::Bundle::inst_file ;
9560sub inst_file {
9561 my($self) = @_;
6d29edf5
JH		 9562 my($inst_file);
9563 my(@me);
9564 @me = split /::/, $self->id;
9565 $me[-1] .= ".pm";
d8773709
JH		 9566 my($incdir,$bestv);
9567 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5de3f0da 9568 my $bfile = File::Spec->catfile($incdir, @me);
d8773709
JH		 9569 CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
9570 next unless -f $bfile;
9571 my $foundv = MM->parse_version($bfile);
9572 if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
9573 $self->{INST_FILE} = $bfile;
9574 $self->{INST_VERSION} = $bestv = $foundv;
9575 }
9576 }
9577 $self->{INST_FILE};
9578}
9579
9580#-> sub CPAN::Bundle::inst_version ;
9581sub inst_version {
9582 my($self) = @_;
9583 $self->inst_file; # finds INST_VERSION as side effect
9584 $self->{INST_VERSION};
5f05dabc 9585}
9586
05454584
A		 9587#-> sub CPAN::Bundle::rematein ;
9588sub rematein {
9589 my($self,$meth) = @_;
9590 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
c356248b
A		 9591 my($id) = $self->id;
9592 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
f04ea8d1 9593 unless $self->inst_file || $self->cpan_file;
f610777f 9594 my($s,%fail);
05454584 9595 for $s ($self->contains) {
f04ea8d1
SP		 9596 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9597 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9598 if ($type eq 'CPAN::Distribution') {
9599 $CPAN::Frontend->mywarn(qq{
05454584 9600The Bundle }.$self->id.qq{ contains
6658a91b
SP		 9601explicitly a file '$s'.
9602Going to $meth that.
c356248b 9603});
f04ea8d1
SP		 9604 $CPAN::Frontend->mysleep(5);
9605 }
9606 # possibly noisy action:
de34a54b 9607 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
f04ea8d1 9608 my $obj = $CPAN::META->instance($type,$s);
135a59c2 9609 $obj->{reqtype} = $self->{reqtype};
f04ea8d1 9610 $obj->$meth();
5f05dabc 9611 }
5f05dabc 9612}
9613
87892b73
RGS		 9614# If a bundle contains another that contains an xs_file we have here,
9615# we just don't bother I suppose
9616#-> sub CPAN::Bundle::xs_file
e50380aa 9617sub xs_file {
e50380aa
A		 9618 return 0;
9619}
9620
05454584 9621#-> sub CPAN::Bundle::force ;
b72dd56f
SP		 9622sub fforce { shift->rematein('fforce',@_); }
9623#-> sub CPAN::Bundle::force ;
05454584 9624sub force { shift->rematein('force',@_); }
554a9ef5
SP		 9625#-> sub CPAN::Bundle::notest ;
9626sub notest { shift->rematein('notest',@_); }
05454584
A		 9627#-> sub CPAN::Bundle::get ;
9628sub get { shift->rematein('get',@_); }
9629#-> sub CPAN::Bundle::make ;
9630sub make { shift->rematein('make',@_); }
9631#-> sub CPAN::Bundle::test ;
6d29edf5
JH		 9632sub test {
9633 my $self = shift;
b72dd56f 9634 # $self->{badtestcnt} ||= 0;
6d29edf5
JH		 9635 $self->rematein('test',@_);
9636}
05454584 9637#-> sub CPAN::Bundle::install ;
09d9d230
A		 9638sub install {
9639 my $self = shift;
9640 $self->rematein('install',@_);
09d9d230 9641}
05454584
A		 9642#-> sub CPAN::Bundle::clean ;
9643sub clean { shift->rematein('clean',@_); }
5f05dabc 9644
d8773709
JH		 9645#-> sub CPAN::Bundle::uptodate ;
9646sub uptodate {
9647 my($self) = @_;
9648 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9649 my $c;
9650 foreach $c ($self->contains) {
9651 my $obj = CPAN::Shell->expandany($c);
9652 return 0 unless $obj->uptodate;
9653 }
9654 return 1;
9655}
9656
05454584
A		 9657#-> sub CPAN::Bundle::readme ;
9658sub readme {
9659 my($self) = @_;
c356248b
A		 9660 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9661No File found for bundle } . $self->id . qq{\n}), return;
05454584
A		 9662 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9663 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5f05dabc 9664}
9665
05454584 9666package CPAN::Module;
e82b9348 9667use strict;
5f05dabc 9668
6d29edf5 9669# Accessors
dc053c64 9670#-> sub CPAN::Module::userid
6d29edf5
JH		 9671sub userid {
9672 my $self = shift;
0cf35e6a
SP		 9673 my $ro = $self->ro;
9674 return unless $ro;
9675 return $ro->{userid} || $ro->{CPAN_USERID};
6d29edf5 9676}
dc053c64 9677#-> sub CPAN::Module::description
9ddc4ed0
A		 9678sub description {
9679 my $self = shift;
9680 my $ro = $self->ro or return "";
9681 $ro->{description}
9682}
6d29edf5 9683
dc053c64 9684#-> sub CPAN::Module::distribution
c9869e1c
SP		 9685sub distribution {
9686 my($self) = @_;
9687 CPAN::Shell->expand("Distribution",$self->cpan_file);
9688}
9689
dc053c64 9690#-> sub CPAN::Module::undelay
6d29edf5
JH		 9691sub undelay {
9692 my $self = shift;
9693 delete $self->{later};
9694 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9695 $dist->undelay;
9696 }
9697}
9698
e82b9348 9699# mark as dirty/clean
6d29edf5
JH		 9700#-> sub CPAN::Module::color_cmd_tmps ;
9701sub color_cmd_tmps {
9702 my($self) = shift;
9703 my($depth) = shift || 0;
9704 my($color) = shift || 0;
35576f8c 9705 my($ancestors) = shift || [];
6d29edf5
JH		 9706 # a module needs to recurse to its cpan_file
9707
9708 return if exists $self->{incommandcolor}
f20de9f0 9709 && $color==1
6d29edf5 9710 && $self->{incommandcolor}==$color;
f20de9f0
SP		 9711 return if $color==0 && !$self->{incommandcolor};
9712 if ($color>=1) {
9713 if ( $self->uptodate ) {
9714 $self->{incommandcolor} = $color;
9715 return;
9716 } elsif (my $have_version = $self->available_version) {
9717 # maybe what we have is good enough
9718 if (@$ancestors) {
9719 my $who_asked_for_me = $ancestors->[-1];
9720 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9721 if (0) {
9722 } elsif ($obj->isa("CPAN::Bundle")) {
9723 # bundles cannot specify a minimum version
9724 return;
9725 } elsif ($obj->isa("CPAN::Distribution")) {
9726 if (my $prereq_pm = $obj->prereq_pm) {
9727 for my $k (keys %$prereq_pm) {
9728 if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9729 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9730 $self->{incommandcolor} = $color;
9731 return;
9732 }
9733 }
9734 }
9735 }
9736 }
9737 }
9738 }
9739 } else {
9740 $self->{incommandcolor} = $color; # set me before recursion,
9741 # so we can break it
9742 }
f04ea8d1 9743 if ($depth>=$CPAN::MAX_RECURSION) {
ade94d80 9744 die(CPAN::Exception::RecursiveDependency->new($ancestors));
35576f8c
A		 9745 }
9746 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6d29edf5
JH		 9747
9748 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
35576f8c 9749 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6d29edf5 9750 }
b72dd56f
SP		 9751 # unreached code?
9752 # if ($color==0) {
9753 # delete $self->{badtestcnt};
9754 # }
6d29edf5
JH		 9755 $self->{incommandcolor} = $color;
9756}
9757
05454584
A		 9758#-> sub CPAN::Module::as_glimpse ;
9759sub as_glimpse {
9760 my($self) = @_;
9761 my(@m);
9762 my $class = ref($self);
9763 $class =~ s/^CPAN:://;
9d61fa1d
A		 9764 my $color_on = "";
9765 my $color_off = "";
9766 if (
9767 $CPAN::Shell::COLOR_REGISTERED
9768 &&
9769 $CPAN::META->has_inst("Term::ANSIColor")
9770 &&
0cf35e6a 9771 $self->description
9d61fa1d
A		 9772 ) {
9773 $color_on = Term::ANSIColor::color("green");
9774 $color_off = Term::ANSIColor::color("reset");
9775 }
ed84aac9 9776 my $uptodateness = " ";
ecc7fca0
A		 9777 unless ($class eq "Bundle") {
9778 my $u = $self->uptodate;
9779 $uptodateness = $u ? "=" : "<" if defined $u;
9780 };
9781 my $id = do {
9782 my $d = $self->distribution;
9783 $d ? $d -> pretty_id : $self->cpan_userid;
9784 };
ed84aac9 9785 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9d61fa1d 9786 $class,
ed84aac9 9787 $uptodateness,
9d61fa1d
A		 9788 $color_on,
9789 $self->id,
9790 $color_off,
ecc7fca0 9791 $id,
c9869e1c 9792 );
05454584
A		 9793 join "", @m;
9794}
5f05dabc 9795
87892b73
RGS		 9796#-> sub CPAN::Module::dslip_status
9797sub dslip_status {
9798 my($self) = @_;
9799 my($stat);
f20de9f0 9800 # development status
87892b73
RGS		 9801 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
9802 pre-alpha alpha beta released
9803 mature standard,;
f20de9f0 9804 # support level
87892b73
RGS		 9805 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
9806 developer comp.lang.perl.*
9807 none abandoned,;
f20de9f0 9808 # language
87892b73 9809 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
f20de9f0 9810 # interface
87892b73
RGS		 9811 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
9812 references+ties
9813 object-oriented pragma
9814 hybrid none,;
f20de9f0 9815 # public licence
f04ea8d1 9816 @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
87892b73 9817 GPL LGPL
f04ea8d1 9818 BSD Artistic Artistic_2
87892b73
RGS		 9819 open-source
9820 distribution_allowed
9821 restricted_distribution
9822 no_licence,;
9823 for my $x (qw(d s l i p)) {
9824 $stat->{$x}{' '} = 'unknown';
9825 $stat->{$x}{'?'} = 'unknown';
9826 }
9827 my $ro = $self->ro;
9828 return +{} unless $ro && $ro->{statd};
9829 return {
9830 D => $ro->{statd},
9831 S => $ro->{stats},
9832 L => $ro->{statl},
9833 I => $ro->{stati},
9834 P => $ro->{statp},
9835 DV => $stat->{D}{$ro->{statd}},
9836 SV => $stat->{S}{$ro->{stats}},
9837 LV => $stat->{L}{$ro->{statl}},
9838 IV => $stat->{I}{$ro->{stati}},
9839 PV => $stat->{P}{$ro->{statp}},
9840 };
9841}
9842
05454584
A		 9843#-> sub CPAN::Module::as_string ;
9844sub as_string {
9845 my($self) = @_;
9846 my(@m);
35576f8c 9847 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
05454584
A		 9848 my $class = ref($self);
9849 $class =~ s/^CPAN:://;
9850 local($^W) = 0;
9851 push @m, $class, " id = $self->{ID}\n";
9852 my $sprintf = " %-12s %s\n";
6d29edf5 9853 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
f04ea8d1 9854 if $self->description;
05454584
A		 9855 my $sprintf2 = " %-12s %s (%s)\n";
9856 my($userid);
35576f8c 9857 $userid = $self->userid;
f04ea8d1
SP		 9858 if ( $userid ) {
9859 my $author;
9860 if ($author = CPAN::Shell->expand('Author',$userid)) {
9861 my $email = "";
9862 my $m; # old perls
9863 if ($m = $author->email) {
9864 $email = " <$m>";
9865 }
9866 push @m, sprintf(
9867 $sprintf2,
9868 'CPAN_USERID',
9869 $userid,
9870 $author->fullname . $email
9871 );
9872 }
c356248b 9873 }
6d29edf5 9874 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
f04ea8d1
SP		 9875 if $self->cpan_version;
9876 if (my $cpan_file = $self->cpan_file) {
554a9ef5
SP		 9877 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9878 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9879 my $upload_date = $dist->upload_date;
9880 if ($upload_date) {
9881 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9882 }
9883 }
9884 }
87892b73
RGS		 9885 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9886 my $dslip = $self->dslip_status;
05454584 9887 push @m, sprintf(
87892b73
RGS		 9888 $sprintf3,
9889 'DSLIP_STATUS',
9890 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
ed84aac9 9891 ) if $dslip->{D};
05454584 9892 my $local_file = $self->inst_file;
9d61fa1d 9893 unless ($self->{MANPAGE}) {
ed84aac9 9894 my $manpage;
9d61fa1d 9895 if ($local_file) {
ed84aac9 9896 $manpage = $self->manpage_headline($local_file);
9d61fa1d
A		 9897 } else {
9898 # If we have already untarred it, we should look there
9899 my $dist = $CPAN::META->instance('CPAN::Distribution',
9900 $self->cpan_file);
9901 # warn "dist[$dist]";
9902 # mff=manifest file; mfh=manifest handle
9903 my($mff,$mfh);
c049f953
JH		 9904 if (
9905 $dist->{build_dir}
9906 and
5de3f0da 9907 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
c049f953 9908 and
9d61fa1d
A		 9909 $mfh = FileHandle->new($mff)
9910 ) {
8d97e4a1 9911 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9d61fa1d
A		 9912 my $lfre = $self->id; # local file RE
9913 $lfre =~ s/::/./g;
9914 $lfre .= "\\.pm\$";
9915 my($lfl); # local file file
9916 local $/ = "\n";
9917 my(@mflines) = <$mfh>;
8d97e4a1
JH		 9918 for (@mflines) {
9919 s/^\s+//;
9920 s/\s.*//s;
9921 }
9d61fa1d
A		 9922 while (length($lfre)>5 and !$lfl) {
9923 ($lfl) = grep /$lfre/, @mflines;
8d97e4a1 9924 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9d61fa1d 9925 $lfre =~ s/.+?\.//;
9d61fa1d
A		 9926 }
9927 $lfl =~ s/\s.*//; # remove comments
9928 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5de3f0da 9929 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9d61fa1d
A		 9930 # warn "lfl_abs[$lfl_abs]";
9931 if (-f $lfl_abs) {
ed84aac9 9932 $manpage = $self->manpage_headline($lfl_abs);
9d61fa1d
A		 9933 }
9934 }
9935 }
ed84aac9 9936 $self->{MANPAGE} = $manpage if $manpage;
5f05dabc 9937 }
d4fd5c69 9938 my($item);
6d29edf5 9939 for $item (qw/MANPAGE/) {
f04ea8d1
SP		 9940 push @m, sprintf($sprintf, $item, $self->{$item})
9941 if exists $self->{$item};
d4fd5c69 9942 }
6d29edf5 9943 for $item (qw/CONTAINS/) {
f04ea8d1
SP		 9944 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9945 if exists $self->{$item} && @{$self->{$item}};
6d29edf5 9946 }
c356248b 9947 push @m, sprintf($sprintf, 'INST_FILE',
f04ea8d1 9948 $local_file || "(not installed)");
c356248b 9949 push @m, sprintf($sprintf, 'INST_VERSION',
f04ea8d1 9950 $self->inst_version) if $local_file;
05454584 9951 join "", @m, "\n";
5f05dabc 9952}
9953
dc053c64 9954#-> sub CPAN::Module::manpage_headline
09d9d230 9955sub manpage_headline {
f04ea8d1
SP		 9956 my($self,$local_file) = @_;
9957 my(@local_file) = $local_file;
9958 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9959 push @local_file, $local_file;
9960 my(@result,$locf);
9961 for $locf (@local_file) {
9962 next unless -f $locf;
9963 my $fh = FileHandle->new($locf)
9964 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9965 my $inpod = 0;
9966 local $/ = "\n";
9967 while (<$fh>) {
9968 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9969 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9970 next unless $inpod;
9971 next if /^=/;
9972 next if /^\s+$/;
9973 chomp;
9974 push @result, $_;
9975 }
9976 close $fh;
9977 last if @result;
09d9d230 9978 }
f04ea8d1
SP		 9979 for (@result) {
9980 s/^\s+//;
9981 s/\s+$//;
9982 }
9983 join " ", @result;
09d9d230
A		 9984}
9985
05454584 9986#-> sub CPAN::Module::cpan_file ;
c049f953
JH		 9987# Note: also inherited by CPAN::Bundle
9988sub cpan_file {
05454584 9989 my $self = shift;
6658a91b 9990 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
0cf35e6a 9991 unless ($self->ro) {
f04ea8d1 9992 CPAN::Index->reload;
05454584 9993 }
0cf35e6a 9994 my $ro = $self->ro;
f04ea8d1
SP		 9995 if ($ro && defined $ro->{CPAN_FILE}) {
9996 return $ro->{CPAN_FILE};
10b2abe6 9997 } else {
8d97e4a1
JH		 9998 my $userid = $self->userid;
9999 if ( $userid ) {
10000 if ($CPAN::META->exists("CPAN::Author",$userid)) {
10001 my $author = $CPAN::META->instance("CPAN::Author",
10002 $userid);
10003 my $fullname = $author->fullname;
10004 my $email = $author->email;
10005 unless (defined $fullname && defined $email) {
10006 return sprintf("Contact Author %s",
10007 $userid,
10008 );
10009 }
10010 return "Contact Author $fullname <$email>";
10011 } else {
1426a145 10012 return "Contact Author $userid (Email address not available)";
8d97e4a1
JH		 10013 }
10014 } else {
10015 return "N/A";
10016 }
5f05dabc 10017 }
10018}
10019
05454584 10020#-> sub CPAN::Module::cpan_version ;
c356248b
A		 10021sub cpan_version {
10022 my $self = shift;
6d29edf5 10023
0cf35e6a
SP		 10024 my $ro = $self->ro;
10025 unless ($ro) {
10026 # Can happen with modules that are not on CPAN
10027 $ro = {};
10028 }
10029 $ro->{CPAN_VERSION} = 'undef'
f04ea8d1 10030 unless defined $ro->{CPAN_VERSION};
0cf35e6a 10031 $ro->{CPAN_VERSION};
c356248b 10032}
5f05dabc 10033
05454584
A		 10034#-> sub CPAN::Module::force ;
10035sub force {
10036 my($self) = @_;
b72dd56f
SP		 10037 $self->{force_update} = 1;
10038}
10039
10040#-> sub CPAN::Module::fforce ;
10041sub fforce {
10042 my($self) = @_;
10043 $self->{force_update} = 2;
5f05dabc 10044}
10045
23a216b4 10046#-> sub CPAN::Module::notest ;
554a9ef5 10047sub notest {
f3fe0ae6 10048 my($self) = @_;
23a216b4
SP		 10049 # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10050 $self->{notest}++;
554a9ef5
SP		 10051}
10052
05454584
A		 10053#-> sub CPAN::Module::rematein ;
10054sub rematein {
10055 my($self,$meth) = @_;
6a935156 10056 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
6d29edf5
JH		 10057 $meth,
10058 $self->id));
05454584 10059 my $cpan_file = $self->cpan_file;
f04ea8d1
SP		 10060 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10061 $CPAN::Frontend->mywarn(sprintf qq{
09d9d230
A		 10062 The module %s isn\'t available on CPAN.
10063
10064 Either the module has not yet been uploaded to CPAN, or it is
10065 temporary unavailable. Please contact the author to find out
c4d24d4c 10066 more about the status. Try 'i %s'.
09d9d230 10067},
f04ea8d1
SP		 10068 $self->id,
10069 $self->id,
10070 );
10071 return;
09d9d230 10072 }
05454584
A		 10073 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10074 $pack->called_for($self->id);
f04ea8d1 10075 if (exists $self->{force_update}) {
b72dd56f
SP		 10076 if ($self->{force_update} == 2) {
10077 $pack->fforce($meth);
10078 } else {
10079 $pack->force($meth);
10080 }
10081 }
23a216b4 10082 $pack->notest($meth) if exists $self->{notest} && $self->{notest};
135a59c2
A		 10083
10084 $pack->{reqtype} ||= "";
10085 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10086 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10087 if ($pack->{reqtype}) {
10088 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10089 $pack->{reqtype} = $self->{reqtype};
10090 if (
10091 exists $pack->{install}
10092 &&
10093 (
be34b10d 10094 UNIVERSAL::can($pack->{install},"failed") ?
135a59c2
A		 10095 $pack->{install}->failed :
10096 $pack->{install} =~ /^NO/
10097 )
10098 ) {
10099 delete $pack->{install};
10100 $CPAN::Frontend->mywarn
10101 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10102 }
10103 }
10104 } else {
10105 $pack->{reqtype} = $self->{reqtype};
10106 }
10107
23a216b4 10108 my $success = eval {
f04ea8d1 10109 $pack->$meth();
554a9ef5
SP		 10110 };
10111 my $err = $@;
b72dd56f 10112 $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
23a216b4 10113 $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
b72dd56f 10114 delete $self->{force_update};
23a216b4 10115 delete $self->{notest};
554a9ef5 10116 if ($err) {
f04ea8d1 10117 die $err;
554a9ef5 10118 }
23a216b4 10119 return $success;
5f05dabc 10120}
10121
554a9ef5
SP		 10122#-> sub CPAN::Module::perldoc ;
10123sub perldoc { shift->rematein('perldoc') }
05454584 10124#-> sub CPAN::Module::readme ;
554a9ef5 10125sub readme { shift->rematein('readme') }
05454584 10126#-> sub CPAN::Module::look ;
554a9ef5 10127sub look { shift->rematein('look') }
911a92db
GS		 10128#-> sub CPAN::Module::cvs_import ;
10129sub cvs_import { shift->rematein('cvs_import') }
05454584 10130#-> sub CPAN::Module::get ;
554a9ef5 10131sub get { shift->rematein('get',@_) }
05454584 10132#-> sub CPAN::Module::make ;
554a9ef5 10133sub make { shift->rematein('make') }
05454584 10134#-> sub CPAN::Module::test ;
6d29edf5
JH		 10135sub test {
10136 my $self = shift;
b72dd56f 10137 # $self->{badtestcnt} ||= 0;
6d29edf5
JH		 10138 $self->rematein('test',@_);
10139}
ecc7fca0 10140
f610777f
A		 10141#-> sub CPAN::Module::uptodate ;
10142sub uptodate {
ecc7fca0
A		 10143 my ($self) = @_;
10144 local ($_);
10145 my $inst = $self->inst_version or return undef;
10146 my $cpan = $self->cpan_version;
10147 local ($^W) = 0;
10148 CPAN::Version->vgt($cpan,$inst) and return 0;
b03f445c 10149 CPAN->debug(join("",
ecc7fca0
A		 10150 "returning uptodate. inst_file[",
10151 $self->inst_file,
10152 "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10153 return 1;
f610777f 10154}
ecc7fca0 10155
f610777f
A		 10156#-> sub CPAN::Module::install ;
10157sub install {
10158 my($self) = @_;
10159 my($doit) = 0;
10160 if ($self->uptodate
f04ea8d1
SP		 10161 &&
10162 not exists $self->{force_update}
f610777f 10163 ) {
f04ea8d1 10164 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
0cf35e6a
SP		 10165 $self->id,
10166 $self->inst_version,
10167 ));
f610777f 10168 } else {
f04ea8d1 10169 $doit = 1;
f610777f 10170 }
0cf35e6a
SP		 10171 my $ro = $self->ro;
10172 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
35576f8c
A		 10173 $CPAN::Frontend->mywarn(qq{
10174\n\n\n ***WARNING***
10175 The module $self->{ID} has no active maintainer.\n\n\n
10176});
8962fc49 10177 $CPAN::Frontend->mysleep(5);
35576f8c 10178 }
05454584 10179 $self->rematein('install') if $doit;
5f05dabc 10180}
05454584
A		 10181#-> sub CPAN::Module::clean ;
10182sub clean { shift->rematein('clean') }
5f05dabc 10183
05454584
A		 10184#-> sub CPAN::Module::inst_file ;
10185sub inst_file {
10186 my($self) = @_;
810a0276
SP		 10187 $self->_file_in_path([@INC]);
10188}
10189
10190#-> sub CPAN::Module::available_file ;
10191sub available_file {
10192 my($self) = @_;
10193 my $sep = $Config::Config{path_sep};
10194 my $perllib = $ENV{PERL5LIB};
10195 $perllib = $ENV{PERLLIB} unless defined $perllib;
10196 my @perllib = split(/$sep/,$perllib) if defined $perllib;
10197 $self->_file_in_path([@perllib,@INC]);
10198}
10199
10200#-> sub CPAN::Module::file_in_path ;
10201sub _file_in_path {
10202 my($self,$path) = @_;
05454584
A		 10203 my($dir,@packpath);
10204 @packpath = split /::/, $self->{ID};
10205 $packpath[-1] .= ".pm";
8962fc49
SP		 10206 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10207 unshift @packpath, "Term", "ReadLine"; # historical reasons
10208 }
810a0276 10209 foreach $dir (@$path) {
f04ea8d1
SP		 10210 my $pmfile = File::Spec->catfile($dir,@packpath);
10211 if (-f $pmfile) {
10212 return $pmfile;
10213 }
5f05dabc 10214 }
d4fd5c69 10215 return;
5f05dabc 10216}
10217
05454584
A		 10218#-> sub CPAN::Module::xs_file ;
10219sub xs_file {
10220 my($self) = @_;
10221 my($dir,@packpath);
10222 @packpath = split /::/, $self->{ID};
10223 push @packpath, $packpath[-1];
10224 $packpath[-1] .= "." . $Config::Config{'dlext'};
10225 foreach $dir (@INC) {
f04ea8d1
SP		 10226 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10227 if (-f $xsfile) {
10228 return $xsfile;
10229 }
05454584 10230 }
d4fd5c69 10231 return;
5f05dabc 10232}
10233
05454584
A		 10234#-> sub CPAN::Module::inst_version ;
10235sub inst_version {
10236 my($self) = @_;
c356248b 10237 my $parsefile = $self->inst_file or return;
810a0276
SP		 10238 my $have = $self->parse_version($parsefile);
10239 $have;
10240}
10241
10242#-> sub CPAN::Module::inst_version ;
10243sub available_version {
10244 my($self) = @_;
10245 my $parsefile = $self->available_file or return;
10246 my $have = $self->parse_version($parsefile);
10247 $have;
10248}
de34a54b 10249
810a0276
SP		 10250#-> sub CPAN::Module::parse_version ;
10251sub parse_version {
10252 my($self,$parsefile) = @_;
10253 my $have = MM->parse_version($parsefile);
be34b10d 10254 $have = "undef" unless defined $have && length $have;
05d2a450
A		 10255 $have =~ s/^ //; # since the %vd hack these two lines here are needed
10256 $have =~ s/ $//; # trailing whitespace happens all the time
10257
5e05dca5 10258 $have = CPAN::Version->readable($have);
c4d24d4c 10259
911a92db 10260 $have =~ s/\s*//g; # stringify to float around floating point issues
de34a54b 10261 $have; # no stringify needed, \s* above matches always
5f05dabc 10262}
10263
dc053c64
SP		 10264#-> sub CPAN::Module::reports
10265sub reports {
10266 my($self) = @_;
10267 $self->distribution->reports;
10268}
10269
55e314ee 10270package CPAN;
e82b9348 10271use strict;
d4fd5c69 10272
5f05dabc 102731;
55e314ee 10274
ed84aac9 10275
e50380aa 10276__END__
5f05dabc 10277
10278=head1 NAME
10279
10280CPAN - query, download and build perl modules from CPAN sites
10281
10282=head1 SYNOPSIS
10283
10284Interactive mode:
10285
f20de9f0 10286 perl -MCPAN -e shell
5f05dabc 10287
f20de9f0 10288--or--
5f05dabc 10289
f20de9f0
SP		 10290 cpan
10291
10292Basic commands:
5f05dabc 10293
1e8f9a0a
SP		 10294 # Modules:
10295
10296 cpan> install Acme::Meta # in the shell
10297
10298 CPAN::Shell->install("Acme::Meta"); # in perl
10299
10300 # Distributions:
10301
10302 cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
10303
10304 CPAN::Shell->
10305 install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
10306
10307 # module objects:
c9869e1c 10308
1e8f9a0a
SP		 10309 $mo = CPAN::Shell->expandany($mod);
10310 $mo = CPAN::Shell->expand("Module",$mod); # same thing
c9869e1c 10311
1e8f9a0a 10312 # distribution objects:
c9869e1c 10313
1e8f9a0a
SP		 10314 $do = CPAN::Shell->expand("Module",$mod)->distribution;
10315 $do = CPAN::Shell->expandany($distro); # same thing
10316 $do = CPAN::Shell->expand("Distribution",
10317 $distro); # same thing
5f05dabc 10318
10319=head1 DESCRIPTION
10320
f20de9f0
SP		 10321The CPAN module automates or at least simplifies the make and install
10322of perl modules and extensions. It includes some primitive searching
10323capabilities and knows how to use Net::FTP or LWP or some external
10324download clients to fetch the distributions from the net.
5f05dabc 10325
f20de9f0
SP		 10326These are fetched from one or more of the mirrored CPAN (Comprehensive
10327Perl Archive Network) sites and unpacked in a dedicated directory.
5f05dabc 10328
10329The CPAN module also supports the concept of named and versioned
911a92db
GS		 10330I<bundles> of modules. Bundles simplify the handling of sets of
10331related modules. See Bundles below.
5f05dabc 10332
b72dd56f
SP		 10333The package contains a session manager and a cache manager. The
10334session manager keeps track of what has been fetched, built and
10335installed in the current session. The cache manager keeps track of the
10336disk space occupied by the make processes and deletes excess space
10337according to a simple FIFO mechanism.
5f05dabc 10338
c9869e1c 10339All methods provided are accessible in a programmer style and in an
10b2abe6
CS		 10340interactive shell style.
10341
2ccf00a7 10342=head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
5f05dabc 10343
10344The interactive mode is entered by running
10345
10346 perl -MCPAN -e shell
10347
f20de9f0
SP		 10348or
10349
10350 cpan
10351
10352which puts you into a readline interface. If C<Term::ReadKey> and
10353either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10354it supports both history and command completion.
5f05dabc 10355
f20de9f0 10356Once you are on the command line, type C<h> to get a one page help
b72dd56f 10357screen and the rest should be self-explanatory.
5f05dabc 10358
9d61fa1d
A		 10359The function call C<shell> takes two optional arguments, one is the
10360prompt, the second is the default initial command line (the latter
10361only works if a real ReadLine interface module is installed).
10362
10b2abe6
CS		 10363The most common uses of the interactive modes are
10364
10365=over 2
10366
10367=item Searching for authors, bundles, distribution files and modules
10368
10369There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
42d3b621
A		 10370for each of the four categories and another, C<i> for any of the
10371mentioned four. Each of the four entities is implemented as a class
10372with slightly differing methods for displaying an object.
10b2abe6 10373
09d9d230 10374Arguments you pass to these commands are either strings exactly matching
10b2abe6
CS		 10375the identification string of an object or regular expressions that are
10376then matched case-insensitively against various attributes of the
09d9d230 10377objects. The parser recognizes a regular expression only if you
10b2abe6
CS		 10378enclose it between two slashes.
10379
10380The principle is that the number of found objects influences how an
911a92db
GS		 10381item is displayed. If the search finds one item, the result is
10382displayed with the rather verbose method C<as_string>, but if we find
10383more than one, we display each object with the terse method
c9869e1c 10384C<as_glimpse>.
10b2abe6 10385
f20de9f0 10386=item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10b2abe6 10387
911a92db 10388These commands take any number of arguments and investigate what is
09d9d230 10389necessary to perform the action. If the argument is a distribution
f14b5cec
JH		 10390file name (recognized by embedded slashes), it is processed. If it is
10391a module, CPAN determines the distribution file in which this module
10392is included and processes that, following any dependencies named in
e82b9348 10393the module's META.yml or Makefile.PL (this behavior is controlled by
c9869e1c 10394the configuration parameter C<prerequisites_policy>.)
10b2abe6 10395
b72dd56f
SP		 10396C<get> downloads a distribution file and untars or unzips it, C<make>
10397builds it, C<test> runs the test suite, and C<install> installs it.
10398
09d9d230 10399Any C<make> or C<test> are run unconditionally. An
42d3b621 10400
05454584 10401 install <distribution_file>
42d3b621 10402
09d9d230 10403also is run unconditionally. But for
42d3b621 10404
05454584 10405 install <module>
42d3b621
A		 10406
10407CPAN checks if an install is actually needed for it and prints
09d9d230 10408I<module up to date> in the case that the distribution file containing
de34a54b 10409the module doesn't need to be updated.
10b2abe6
CS		 10410
10411CPAN also keeps track of what it has done within the current session
de34a54b 10412and doesn't try to build a package a second time regardless if it
b72dd56f
SP		 10413succeeded or not. It does not repeat a test run if the test
10414has been run successfully before. Same for install runs.
10b2abe6 10415
b72dd56f
SP		 10416The C<force> pragma may precede another command (currently: C<get>,
10417C<make>, C<test>, or C<install>) and executes the command from scratch
10418and tries to continue in case of some errors. See the section below on
f20de9f0 10419the C<force> and the C<fforce> pragma.
10b2abe6 10420
b72dd56f 10421The C<notest> pragma may be used to skip the test part in the build
554a9ef5
SP		 10422process.
10423
10424Example:
10425
10426 cpan> notest install Tk
10427
f610777f 10428A C<clean> command results in a
09d9d230
A		 10429
10430 make clean
10431
10432being executed within the distribution file's working directory.
10433
f20de9f0 10434=item C<readme>, C<perldoc>, C<look> module or distribution
da199366 10435
b72dd56f
SP		 10436C<readme> displays the README file of the associated distribution.
10437C<Look> gets and untars (if not yet done) the distribution file,
10438changes to the appropriate directory and opens a subshell process in
10439that directory. C<perldoc> displays the pod documentation of the
10440module in html or plain text format.
09d9d230 10441
f20de9f0 10442=item C<ls> author
c049f953 10443
f20de9f0 10444=item C<ls> globbing_expression
e82b9348
SP		 10445
10446The first form lists all distribution files in and below an author's
ca79d794
SP		 10447CPAN directory as they are stored in the CHECKUMS files distributed on
10448CPAN. The listing goes recursive into all subdirectories.
e82b9348
SP		 10449
10450The second form allows to limit or expand the output with shell
10451globbing as in the following examples:
10452
f04ea8d1
SP		 10453 ls JV/make*
10454 ls GSAR/*make*
10455 ls */*make*
e82b9348
SP		 10456
10457The last example is very slow and outputs extra progress indicators
10458that break the alignment of the result.
c049f953 10459
ca79d794
SP		 10460Note that globbing only lists directories explicitly asked for, for
10461example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
10462regarded as a bug and may be changed in future versions.
10463
f20de9f0 10464=item C<failed>
9ddc4ed0
A		 10465
10466The C<failed> command reports all distributions that failed on one of
10467C<make>, C<test> or C<install> for some reason in the currently
10468running shell session.
10469
b72dd56f
SP		 10470=item Persistence between sessions
10471
b03f445c 10472If the C<YAML> or the C<YAML::Syck> module is installed a record of
b72dd56f
SP		 10473the internal state of all modules is written to disk after each step.
10474The files contain a signature of the currently running perl version
10475for later perusal.
10476
10477If the configurations variable C<build_dir_reuse> is set to a true
10478value, then CPAN.pm reads the collected YAML files. If the stored
10479signature matches the currently running perl the stored state is
10480loaded into memory such that effectively persistence between sessions
10481is established.
10482
10483=item The C<force> and the C<fforce> pragma
10484
10485To speed things up in complex installation scenarios, CPAN.pm keeps
10486track of what it has already done and refuses to do some things a
10487second time. A C<get>, a C<make>, and an C<install> are not repeated.
10488A C<test> is only repeated if the previous test was unsuccessful. The
10489diagnostic message when CPAN.pm refuses to do something a second time
10490is one of I<Has already been >C<unwrapped|made|tested successfully> or
10491something similar. Another situation where CPAN refuses to act is an
10492C<install> if the according C<test> was not successful.
10493
10494In all these cases, the user can override the goatish behaviour by
10495prepending the command with the word force, for example:
10496
10497 cpan> force get Foo
10498 cpan> force make AUTHOR/Bar-3.14.tar.gz
10499 cpan> force test Baz
10500 cpan> force install Acme::Meta
10501
10502Each I<forced> command is executed with the according part of its
10503memory erased.
10504
10505The C<fforce> pragma is a variant that emulates a C<force get> which
10506erases the entire memory followed by the action specified, effectively
10507restarting the whole get/make/test/install procedure from scratch.
10508
c9869e1c
SP		 10509=item Lockfile
10510
be34b10d
SP		 10511Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
10512Batch jobs can run without a lockfile and do not disturb each other.
c9869e1c 10513
be34b10d
SP		 10514The shell offers to run in I<degraded mode> when another process is
10515holding the lockfile. This is an experimental feature that is not yet
10516tested very well. This second shell then does not write the history
10517file, does not use the metadata file and has a different prompt.
c9869e1c 10518
09d9d230
A		 10519=item Signals
10520
10521CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
10522in the cpan-shell it is intended that you can press C<^C> anytime and
10523return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
10524to clean up and leave the shell loop. You can emulate the effect of a
10525SIGTERM by sending two consecutive SIGINTs, which usually means by
10526pressing C<^C> twice.
10527
b03f445c 10528CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
e82b9348
SP		 10529SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
10530Build.PL> subprocess.
da199366 10531
10b2abe6
CS		 10532=back
10533
5f05dabc 10534=head2 CPAN::Shell
10535
10536The commands that are available in the shell interface are methods in
10537the package CPAN::Shell. If you enter the shell command, all your
10b2abe6
CS		 10538input is split by the Text::ParseWords::shellwords() routine which
10539acts like most shells do. The first word is being interpreted as the
10540method to be called and the rest of the words are treated as arguments
c356248b
A		 10541to this method. Continuation lines are supported if a line ends with a
10542literal backslash.
10b2abe6 10543
da199366
A		 10544=head2 autobundle
10545
10546C<autobundle> writes a bundle file into the
10547C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
10548a list of all modules that are both available from CPAN and currently
10549installed within @INC. The name of the bundle file is based on the
10550current date and a counter.
10551
05bab18e
SP		 10552=head2 hosts
10553
ed756621
SP		 10554Note: this feature is still in alpha state and may change in future
10555versions of CPAN.pm
10556
05bab18e
SP		 10557This commands provides a statistical overview over recent download
10558activities. The data for this is collected in the YAML file
10559C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
10560configured or YAML not installed, then no stats are provided.
10561
10562=head2 mkmyconfig
10563
10564mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
10565directory so that you can save your own preferences instead of the
10566system wide ones.
10567
f04ea8d1
SP		 10568=head2 recent ***EXPERIMENTAL COMMAND***
10569
10570The C<recent> command downloads a list of recent uploads to CPAN and
10571displays them I<slowly>. While the command is running $SIG{INT} is
10572defined to mean that the loop shall be left after having displayed the
10573current item.
10574
10575B<Note>: This command requires XML::LibXML installed.
10576
10577B<Note>: This whole command currently is a bit klunky and will
10578probably change in future versions of CPAN.pm but the general
10579approach will likely stay.
10580
10581B<Note>: See also L<smoke>
10582
da199366
A		 10583=head2 recompile
10584
10585recompile() is a very special command in that it takes no argument and
10586runs the make/test/install cycle with brute force over all installed
10587dynamically loadable extensions (aka XS modules) with 'force' in
09d9d230 10588effect. The primary purpose of this command is to finish a network
da199366
A		 10589installation. Imagine, you have a common source tree for two different
10590architectures. You decide to do a completely independent fresh
10591installation. You start on one architecture with the help of a Bundle
10592file produced earlier. CPAN installs the whole Bundle for you, but
10593when you try to repeat the job on the second architecture, CPAN
10594responds with a C<"Foo up to date"> message for all modules. So you
de34a54b 10595invoke CPAN's recompile on the second architecture and you're done.
da199366
A		 10596
10597Another popular use for C<recompile> is to act as a rescue in case your
10598perl breaks binary compatibility. If one of the modules that CPAN uses
10599is in turn depending on binary compatibility (so you cannot run CPAN
10600commands), then you should try the CPAN::Nox module for recovery.
10601
8fc516fe
SP		 10602=head2 report Bundle|Distribution|Module
10603
10604The C<report> command temporarily turns on the C<test_report> config
6658a91b
SP		 10605variable, then runs the C<force test> command with the given
10606arguments. The C<force> pragma is used to re-run the tests and repeat
10607every step that might have failed before.
8fc516fe 10608
f04ea8d1
SP		 10609=head2 smoke ***EXPERIMENTAL COMMAND***
10610
10611B<*** WARNING: this command downloads and executes software from CPAN to
b03f445c
RGS		 10612your computer of completely unknown status. You should never do
10613this with your normal account and better have a dedicated well
10614separated and secured machine to do this. ***>
f04ea8d1
SP		 10615
10616The C<smoke> command takes the list of recent uploads to CPAN as
10617provided by the C<recent> command and tests them all. While the
10618command is running $SIG{INT} is defined to mean that the current item
10619shall be skipped.
10620
10621B<Note>: This whole command currently is a bit klunky and will
10622probably change in future versions of CPAN.pm but the general
10623approach will likely stay.
10624
10625B<Note>: See also L<recent>
10626
135a59c2 10627=head2 upgrade [Module|/Regex/]...
ed84aac9 10628
135a59c2
A		 10629The C<upgrade> command first runs an C<r> command with the given
10630arguments and then installs the newest versions of all modules that
10631were listed by that.
ed84aac9 10632
c356248b 10633=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
e50380aa 10634
09d9d230
A		 10635Although it may be considered internal, the class hierarchy does matter
10636for both users and programmer. CPAN.pm deals with above mentioned four
10637classes, and all those classes share a set of methods. A classical
10638single polymorphism is in effect. A metaclass object registers all
10639objects of all kinds and indexes them with a string. The strings
10640referencing objects have a separated namespace (well, not completely
10641separated):
e50380aa
A		 10642
10643 Namespace Class
10644
10645 words containing a "/" (slash) Distribution
10646 words starting with Bundle:: Bundle
10647 everything else Module or Author
10648
10649Modules know their associated Distribution objects. They always refer
09d9d230
A		 10650to the most recent official release. Developers may mark their releases
10651as unstable development versions (by inserting an underbar into the
16703a00 10652module version number which will also be reflected in the distribution
6658a91b
SP		 10653name when you run 'make dist'), so the really hottest and newest
10654distribution is not always the default. If a module Foo circulates
10655on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
16703a00 10656way to install version 1.23 by saying
e50380aa
A		 10657
10658 install Foo
10659
10660This would install the complete distribution file (say
09d9d230
A		 10661BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10662like to install version 1.23_90, you need to know where the
e50380aa 10663distribution file resides on CPAN relative to the authors/id/
09d9d230 10664directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
c356248b 10665so you would have to say
e50380aa
A		 10666
10667 install BAR/Foo-1.23_90.tar.gz
10668
10669The first example will be driven by an object of the class
c356248b 10670CPAN::Module, the second by an object of class CPAN::Distribution.
e50380aa 10671
6658a91b
SP		 10672=head2 Integrating local directories
10673
ed756621
SP		 10674Note: this feature is still in alpha state and may change in future
10675versions of CPAN.pm
10676
6658a91b 10677Distribution objects are normally distributions from the CPAN, but
b72dd56f
SP		 10678there is a slightly degenerate case for Distribution objects, too, of
10679projects held on the local disk. These distribution objects have the
10680same name as the local directory and end with a dot. A dot by itself
10681is also allowed for the current directory at the time CPAN.pm was
10682used. All actions such as C<make>, C<test>, and C<install> are applied
6658a91b
SP		 10683directly to that directory. This gives the command C<cpan .> an
10684interesting touch: while the normal mantra of installing a CPAN module
10685without CPAN.pm is one of
10686
10687 perl Makefile.PL perl Build.PL
10688 ( go and get prerequisites )
10689 make ./Build
10690 make test ./Build test
10691 make install ./Build install
10692
10693the command C<cpan .> does all of this at once. It figures out which
10694of the two mantras is appropriate, fetches and installs all
10695prerequisites, cares for them recursively and finally finishes the
10696installation of the module in the current directory, be it a CPAN
10697module or not.
10698
b72dd56f
SP		 10699The typical usage case is for private modules or working copies of
10700projects from remote repositories on the local disk.
10701
f20de9f0 10702=head1 CONFIGURATION
55e314ee 10703
f20de9f0
SP		 10704When the CPAN module is used for the first time, a configuration
10705dialog tries to determine a couple of site specific options. The
10706result of the dialog is stored in a hash reference C< $CPAN::Config >
10707in a file CPAN/Config.pm.
de34a54b 10708
f20de9f0
SP		 10709The default values defined in the CPAN/Config.pm file can be
10710overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10711best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10712added to the search path of the CPAN module before the use() or
10713require() statements. The mkmyconfig command writes this file for you.
36263cb3 10714
f20de9f0 10715The C<o conf> command has various bells and whistles:
36263cb3 10716
f20de9f0 10717=over
36263cb3 10718
f20de9f0 10719=item completion support
36263cb3 10720
f20de9f0
SP		 10721If you have a ReadLine module installed, you can hit TAB at any point
10722of the commandline and C<o conf> will offer you completion for the
10723built-in subcommands and/or config variable names.
36263cb3 10724
f20de9f0 10725=item displaying some help: o conf help
36263cb3 10726
f20de9f0 10727Displays a short help
36263cb3 10728
f20de9f0 10729=item displaying current values: o conf [KEY]
36263cb3 10730
f20de9f0
SP		 10731Displays the current value(s) for this config variable. Without KEY
10732displays all subcommands and config variables.
36263cb3 10733
f20de9f0 10734Example:
5f05dabc 10735
f20de9f0 10736 o conf shell
d8773709 10737
f04ea8d1
SP		 10738If KEY starts and ends with a slash the string in between is
10739interpreted as a regular expression and only keys matching this regex
10740are displayed
10741
10742Example:
10743
10744 o conf /color/
10745
f20de9f0 10746=item changing of scalar values: o conf KEY VALUE
d8773709 10747
f20de9f0
SP		 10748Sets the config variable KEY to VALUE. The empty string can be
10749specified as usual in shells, with C<''> or C<"">
d8773709 10750
f20de9f0 10751Example:
d8773709 10752
f20de9f0 10753 o conf wget /usr/bin/wget
d8773709 10754
f20de9f0 10755=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
d8773709 10756
f20de9f0
SP		 10757If a config variable name ends with C<list>, it is a list. C<o conf
10758KEY shift> removes the first element of the list, C<o conf KEY pop>
10759removes the last element of the list. C<o conf KEYS unshift LIST>
10760prepends a list of values to the list, C<o conf KEYS push LIST>
10761appends a list of valued to the list.
d8773709 10762
f20de9f0
SP		 10763Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10764splice command.
d8773709 10765
f20de9f0
SP		 10766Finally, any other list of arguments is taken as a new list value for
10767the KEY variable discarding the previous value.
d8773709 10768
f20de9f0 10769Examples:
d8773709 10770
f20de9f0
SP		 10771 o conf urllist unshift http://cpan.dev.local/CPAN
10772 o conf urllist splice 3 1
10773 o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
d8773709 10774
f20de9f0 10775=item reverting to saved: o conf defaults
d8773709 10776
f20de9f0 10777Reverts all config variables to the state in the saved config file.
d8773709 10778
f20de9f0 10779=item saving the config: o conf commit
d8773709 10780
f20de9f0
SP		 10781Saves all config variables to the current config file (CPAN/Config.pm
10782or CPAN/MyConfig.pm that was loaded at start).
d8773709 10783
f20de9f0 10784=back
d8773709 10785
f20de9f0
SP		 10786The configuration dialog can be started any time later again by
10787issuing the command C< o conf init > in the CPAN shell. A subset of
10788the configuration dialog can be run by issuing C<o conf init WORD>
10789where WORD is any valid config variable or a regular expression.
d8773709 10790
f20de9f0 10791=head2 Config Variables
d8773709 10792
f20de9f0
SP		 10793Currently the following keys in the hash reference $CPAN::Config are
10794defined:
d8773709 10795
f20de9f0
SP		 10796 applypatch path to external prg
10797 auto_commit commit all changes to config variables to disk
10798 build_cache size of cache for directories to build modules
10799 build_dir locally accessible directory to build modules
10800 build_dir_reuse boolean if distros in build_dir are persistent
10801 build_requires_install_policy
10802 to install or not to install when a module is
10803 only needed for building. yes|no|ask/yes|ask/no
10804 bzip2 path to external prg
10805 cache_metadata use serializer to cache metadata
10806 commands_quote prefered character to use for quoting external
10807 commands when running them. Defaults to double
10808 quote on Windows, single tick everywhere else;
10809 can be set to space to disable quoting
10810 check_sigs if signatures should be verified
10811 colorize_debug Term::ANSIColor attributes for debugging output
10812 colorize_output boolean if Term::ANSIColor should colorize output
10813 colorize_print Term::ANSIColor attributes for normal output
10814 colorize_warn Term::ANSIColor attributes for warnings
10815 commandnumber_in_prompt
10816 boolean if you want to see current command number
10817 cpan_home local directory reserved for this package
10818 curl path to external prg
10819 dontload_hash DEPRECATED
10820 dontload_list arrayref: modules in the list will not be
10821 loaded by the CPAN::has_inst() routine
10822 ftp path to external prg
10823 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
10824 ftp_proxy proxy host for ftp requests
10825 getcwd see below
10826 gpg path to external prg
f04ea8d1 10827 gzip location of external program gzip
f20de9f0
SP		 10828 histfile file to maintain history between sessions
10829 histsize maximum number of lines to keep in histfile
10830 http_proxy proxy host for http requests
10831 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10832 after this many seconds inactivity. Set to 0 to
10833 never break.
10834 index_expire after this many days refetch index files
10835 inhibit_startup_message
10836 if true, does not print the startup message
10837 keep_source_where directory in which to keep the source (if we do)
f04ea8d1
SP		 10838 load_module_verbosity
10839 report loading of optional modules used by CPAN.pm
f20de9f0
SP		 10840 lynx path to external prg
10841 make location of external make program
f04ea8d1 10842 make_arg arguments that should always be passed to 'make'
f20de9f0
SP		 10843 make_install_make_command
10844 the make command for running 'make install', for
10845 example 'sudo make'
10846 make_install_arg same as make_arg for 'make install'
f04ea8d1
SP		 10847 makepl_arg arguments passed to 'perl Makefile.PL'
10848 mbuild_arg arguments passed to './Build'
f20de9f0
SP		 10849 mbuild_install_arg arguments passed to './Build install'
10850 mbuild_install_build_command
10851 command to use instead of './Build' when we are
10852 in the install stage, for example 'sudo ./Build'
10853 mbuildpl_arg arguments passed to 'perl Build.PL'
10854 ncftp path to external prg
10855 ncftpget path to external prg
10856 no_proxy don't proxy to these hosts/domains (comma separated list)
10857 pager location of external program more (or any pager)
10858 password your password if you CPAN server wants one
10859 patch path to external prg
10860 prefer_installer legal values are MB and EUMM: if a module comes
10861 with both a Makefile.PL and a Build.PL, use the
10862 former (EUMM) or the latter (MB); if the module
10863 comes with only one of the two, that one will be
10864 used in any case
10865 prerequisites_policy
10866 what to do if you are missing module prerequisites
10867 ('follow' automatically, 'ask' me, or 'ignore')
10868 prefs_dir local directory to store per-distro build options
10869 proxy_user username for accessing an authenticating proxy
10870 proxy_pass password for accessing an authenticating proxy
10871 randomize_urllist add some randomness to the sequence of the urllist
f04ea8d1 10872 scan_cache controls scanning of cache ('atstart' or 'never')
f20de9f0 10873 shell your favorite shell
f04ea8d1
SP		 10874 show_unparsable_versions
10875 boolean if r command tells which modules are versionless
f20de9f0 10876 show_upload_date boolean if commands should try to determine upload date
f04ea8d1 10877 show_zero_versions boolean if r command tells for which modules $version==0
f20de9f0 10878 tar location of external program tar
f04ea8d1
SP		 10879 tar_verbosity verbosity level for the tar command
10880 term_is_latin deprecated: if true Unicode is translated to ISO-8859-1
f20de9f0
SP		 10881 (and nonsense for characters outside latin range)
10882 term_ornaments boolean to turn ReadLine ornamenting on/off
10883 test_report email test reports (if CPAN::Reporter is installed)
10884 unzip location of external program unzip
f04ea8d1 10885 urllist arrayref to nearby CPAN sites (or equivalent locations)
f20de9f0
SP		 10886 use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
10887 username your username if you CPAN server wants one
10888 wait_list arrayref to a wait server to try (See CPAN::WAIT)
10889 wget path to external prg
f04ea8d1 10890 yaml_load_code enable YAML code deserialisation
f20de9f0 10891 yaml_module which module to use to read/write YAML files
d8773709 10892
f20de9f0
SP		 10893You can set and query each of these options interactively in the cpan
10894shell with the C<o conf> or the C<o conf init> command as specified below.
d8773709 10895
f20de9f0 10896=over 2
d8773709 10897
f20de9f0 10898=item C<o conf E<lt>scalar optionE<gt>>
d8773709 10899
f20de9f0 10900prints the current value of the I<scalar option>
d8773709 10901
f20de9f0 10902=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
d8773709 10903
f20de9f0 10904Sets the value of the I<scalar option> to I<value>
d8773709 10905
f20de9f0 10906=item C<o conf E<lt>list optionE<gt>>
d8773709 10907
f20de9f0
SP		 10908prints the current value of the I<list option> in MakeMaker's
10909neatvalue format.
d8773709 10910
f20de9f0 10911=item C<o conf E<lt>list optionE<gt> [shift|pop]>
d8773709 10912
f20de9f0 10913shifts or pops the array in the I<list option> variable
d8773709 10914
f20de9f0 10915=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
d8773709 10916
f20de9f0 10917works like the corresponding perl commands.
d8773709 10918
f20de9f0 10919=item interactive editing: o conf init [MATCH|LIST]
d8773709 10920
f20de9f0
SP		 10921Runs an interactive configuration dialog for matching variables.
10922Without argument runs the dialog over all supported config variables.
10923To specify a MATCH the argument must be enclosed by slashes.
d8773709 10924
f20de9f0 10925Examples:
d8773709 10926
f20de9f0
SP		 10927 o conf init ftp_passive ftp_proxy
10928 o conf init /color/
d8773709 10929
f20de9f0
SP		 10930Note: this method of setting config variables often provides more
10931explanation about the functioning of a variable than the manpage.
d8773709 10932
f20de9f0 10933=back
d8773709 10934
f20de9f0 10935=head2 CPAN::anycwd($path): Note on config variable getcwd
d8773709 10936
f20de9f0
SP		 10937CPAN.pm changes the current working directory often and needs to
10938determine its own current working directory. Per default it uses
10939Cwd::cwd but if this doesn't work on your system for some reason,
10940alternatives can be configured according to the following table:
d8773709 10941
f20de9f0 10942=over 4
d8773709 10943
f20de9f0 10944=item cwd
d8773709 10945
f20de9f0 10946Calls Cwd::cwd
4d1321a7 10947
f20de9f0 10948=item getcwd
4d1321a7 10949
f20de9f0 10950Calls Cwd::getcwd
d8773709 10951
f20de9f0 10952=item fastcwd
d8773709 10953
f20de9f0 10954Calls Cwd::fastcwd
d8773709 10955
f20de9f0 10956=item backtickcwd
d8773709 10957
f20de9f0 10958Calls the external command cwd.
d8773709 10959
f20de9f0 10960=back
d8773709 10961
f20de9f0 10962=head2 Note on the format of the urllist parameter
d8773709 10963
f20de9f0
SP		 10964urllist parameters are URLs according to RFC 1738. We do a little
10965guessing if your URL is not compliant, but if you have problems with
10966C<file> URLs, please try the correct format. Either:
d8773709 10967
f20de9f0 10968 file://localhost/whatever/ftp/pub/CPAN/
d8773709 10969
f20de9f0 10970or
d8773709 10971
f20de9f0 10972 file:///home/ftp/pub/CPAN/
d8773709 10973
f20de9f0 10974=head2 The urllist parameter has CD-ROM support
d8773709 10975
f20de9f0
SP		 10976The C<urllist> parameter of the configuration table contains a list of
10977URLs that are to be used for downloading. If the list contains any
10978C<file> URLs, CPAN always tries to get files from there first. This
10979feature is disabled for index files. So the recommendation for the
10980owner of a CD-ROM with CPAN contents is: include your local, possibly
10981outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
d8773709 10982
f20de9f0 10983 o conf urllist push file://localhost/CDROM/CPAN
d8773709 10984
f20de9f0
SP		 10985CPAN.pm will then fetch the index files from one of the CPAN sites
10986that come at the beginning of urllist. It will later check for each
10987module if there is a local copy of the most recent version.
d8773709 10988
f20de9f0
SP		 10989Another peculiarity of urllist is that the site that we could
10990successfully fetch the last file from automatically gets a preference
10991token and is tried as the first site for the next request. So if you
10992add a new site at runtime it may happen that the previously preferred
10993site will be tried another time. This means that if you want to disallow
10994a site for the next transfer, it must be explicitly removed from
10995urllist.
d8773709 10996
f20de9f0 10997=head2 Maintaining the urllist parameter
1e8f9a0a 10998
f20de9f0
SP		 10999If you have YAML.pm (or some other YAML module configured in
11000C<yaml_module>) installed, CPAN.pm collects a few statistical data
11001about recent downloads. You can view the statistics with the C<hosts>
11002command or inspect them directly by looking into the C<FTPstats.yml>
11003file in your C<cpan_home> directory.
8962fc49 11004
f20de9f0
SP		 11005To get some interesting statistics it is recommended to set the
11006C<randomize_urllist> parameter that introduces some amount of
11007randomness into the URL selection.
d8773709 11008
f20de9f0 11009=head2 The C<requires> and C<build_requires> dependency declarations
d8773709 11010
f20de9f0
SP		 11011Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11012a distribution are treated differently depending on the config
11013variable C<build_requires_install_policy>. By setting
11014C<build_requires_install_policy> to C<no> such a module is not being
11015installed. It is only built and tested and then kept in the list of
11016tested but uninstalled modules. As such it is available during the
11017build of the dependent module by integrating the path to the
11018C<blib/arch> and C<blib/lib> directories in the environment variable
11019PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11020both modules declared as C<requires> and those declared as
11021C<build_requires> are treated alike. By setting to C<ask/yes> or
11022C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
d8773709 11023
f20de9f0 11024=head2 Configuration for individual distributions (I<Distroprefs>)
d8773709 11025
f20de9f0
SP		 11026(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11027still considered beta quality)
d8773709 11028
f20de9f0
SP		 11029Distributions on the CPAN usually behave according to what we call the
11030CPAN mantra. Or since the event of Module::Build we should talk about
11031two mantras:
d8773709 11032
f20de9f0
SP		 11033 perl Makefile.PL perl Build.PL
11034 make ./Build
11035 make test ./Build test
11036 make install ./Build install
4d1321a7 11037
f20de9f0
SP		 11038But some modules cannot be built with this mantra. They try to get
11039some extra data from the user via the environment, extra arguments or
11040interactively thus disturbing the installation of large bundles like
11041Phalanx100 or modules with many dependencies like Plagger.
4d1321a7 11042
f20de9f0
SP		 11043The distroprefs system of C<CPAN.pm> addresses this problem by
11044allowing the user to specify extra informations and recipes in YAML
11045files to either
1e8f9a0a 11046
f20de9f0 11047=over
d8773709 11048
f20de9f0 11049=item
d8773709 11050
f20de9f0 11051pass additional arguments to one of the four commands,
d8773709 11052
f20de9f0 11053=item
554a9ef5 11054
f20de9f0 11055set environment variables
554a9ef5 11056
f20de9f0 11057=item
d8773709 11058
f20de9f0
SP		 11059instantiate an Expect object that reads from the console, waits for
11060some regular expressions and enters some answers
d8773709 11061
f20de9f0 11062=item
d8773709 11063
f20de9f0 11064temporarily override assorted C<CPAN.pm> configuration variables
d8773709 11065
f20de9f0 11066=item
d8773709 11067
f04ea8d1
SP		 11068specify dependencies that the original maintainer forgot to specify
11069
11070=item
11071
f20de9f0 11072disable the installation of an object altogether
d8773709 11073
f20de9f0 11074=back
d8773709 11075
f20de9f0
SP		 11076See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11077distribution in the C<distroprefs/> directory for examples.
d8773709 11078
f20de9f0 11079=head2 Filenames
d8773709 11080
f20de9f0
SP		 11081The YAML files themselves must have the C<.yml> extension, all other
11082files are ignored (for two exceptions see I<Fallback Data::Dumper and
11083Storable> below). The containing directory can be specified in
11084C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11085prefs_dir> in the CPAN shell to set and activate the distroprefs
11086system.
d8773709 11087
f20de9f0
SP		 11088Every YAML file may contain arbitrary documents according to the YAML
11089specification and every single document is treated as an entity that
11090can specify the treatment of a single distribution.
d8773709 11091
f20de9f0
SP		 11092The names of the files can be picked freely, C<CPAN.pm> always reads
11093all files (in alphabetical order) and takes the key C<match> (see
11094below in I<Language Specs>) as a hashref containing match criteria
11095that determine if the current distribution matches the YAML document
11096or not.
d8773709 11097
f20de9f0 11098=head2 Fallback Data::Dumper and Storable
d8773709 11099
f20de9f0
SP		 11100If neither your configured C<yaml_module> nor YAML.pm is installed
11101CPAN.pm falls back to using Data::Dumper and Storable and looks for
11102files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11103directory. These files are expected to contain one or more hashrefs.
11104For Data::Dumper generated files, this is expected to be done with by
11105defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11106with the command
d8773709 11107
f20de9f0 11108 ysh < somefile.yml > somefile.dd
d8773709 11109
f20de9f0
SP		 11110For Storable files the rule is that they must be constructed such that
11111C<Storable::retrieve(file)> returns an array reference and the array
11112elements represent one distropref object each. The conversion from
11113YAML would look like so:
d8773709 11114
f20de9f0
SP		 11115 perl -MYAML=LoadFile -MStorable=nstore -e '
11116 @y=LoadFile(shift);
11117 nstore(\@y, shift)' somefile.yml somefile.st
d8773709 11118
f20de9f0
SP		 11119In bootstrapping situations it is usually sufficient to translate only
11120a few YAML files to Data::Dumper for the crucial modules like
11121C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11122over Data::Dumper, remember to pull out a Storable version that writes
11123an older format than all the other Storable versions that will need to
11124read them.
d8773709 11125
f20de9f0 11126=head2 Blueprint
d8773709 11127
f20de9f0
SP		 11128The following example contains all supported keywords and structures
11129with the exception of C<eexpect> which can be used instead of
11130C<expect>.
d8773709 11131
f20de9f0
SP		 11132 ---
11133 comment: "Demo"
11134 match:
11135 module: "Dancing::Queen"
11136 distribution: "^CHACHACHA/Dancing-"
11137 perl: "/usr/local/cariba-perl/bin/perl"
2b3bde2a
SP		 11138 perlconfig:
11139 archname: "freebsd"
f20de9f0
SP		 11140 disabled: 1
11141 cpanconfig:
11142 make: gmake
11143 pl:
11144 args:
11145 - "--somearg=specialcase"
d8773709 11146
f20de9f0 11147 env: {}
d8773709 11148
f20de9f0
SP		 11149 expect:
11150 - "Which is your favorite fruit"
11151 - "apple\n"
d8773709 11152
f20de9f0
SP		 11153 make:
11154 args:
11155 - all
11156 - extra-all
d8773709 11157
f20de9f0 11158 env: {}
4d1321a7 11159
f20de9f0 11160 expect: []
4d1321a7 11161
f20de9f0 11162 commendline: "echo SKIPPING make"
87892b73 11163
f20de9f0
SP		 11164 test:
11165 args: []
87892b73 11166
f20de9f0 11167 env: {}
87892b73 11168
f20de9f0 11169 expect: []
87892b73 11170
f20de9f0
SP		 11171 install:
11172 args: []
87892b73 11173
f20de9f0
SP		 11174 env:
11175 WANT_TO_INSTALL: YES
87892b73 11176
f20de9f0
SP		 11177 expect:
11178 - "Do you really want to install"
11179 - "y\n"
87892b73 11180
f20de9f0
SP		 11181 patches:
11182 - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
87892b73 11183
f04ea8d1
SP		 11184 depends:
11185 configure_requires:
11186 LWP: 5.8
11187 build_requires:
11188 Test::Exception: 0.25
11189 requires:
11190 Spiffy: 0.30
11191
d8773709 11192
f20de9f0 11193=head2 Language Specs
d8773709 11194
f20de9f0
SP		 11195Every YAML document represents a single hash reference. The valid keys
11196in this hash are as follows:
d8773709 11197
f20de9f0 11198=over
d8773709 11199
f20de9f0 11200=item comment [scalar]
d8773709 11201
f20de9f0 11202A comment
d8773709 11203
f20de9f0 11204=item cpanconfig [hash]
810a0276 11205
f20de9f0 11206Temporarily override assorted C<CPAN.pm> configuration variables.
810a0276 11207
f20de9f0
SP		 11208Supported are: C<build_requires_install_policy>, C<check_sigs>,
11209C<make>, C<make_install_make_command>, C<prefer_installer>,
11210C<test_report>. Please report as a bug when you need another one
11211supported.
d8773709 11212
f04ea8d1
SP		 11213=item depends [hash] *** EXPERIMENTAL FEATURE ***
11214
11215All three types, namely C<configure_requires>, C<build_requires>, and
11216C<requires> are supported in the way specified in the META.yml
11217specification. The current implementation I<merges> the specified
11218dependencies with those declared by the package maintainer. In a
11219future implementation this may be changed to override the original
11220declaration.
11221
f20de9f0 11222=item disabled [boolean]
810a0276 11223
f20de9f0 11224Specifies that this distribution shall not be processed at all.
810a0276 11225
f20de9f0 11226=item goto [string]
d8773709 11227
f20de9f0
SP		 11228The canonical name of a delegate distribution that shall be installed
11229instead. Useful when a new version, although it tests OK itself,
11230breaks something else or a developer release or a fork is already
11231uploaded that is better than the last released version.
d8773709 11232
f20de9f0 11233=item install [hash]
d8773709 11234
f20de9f0
SP		 11235Processing instructions for the C<make install> or C<./Build install>
11236phase of the CPAN mantra. See below under I<Processiong Instructions>.
d8773709 11237
f20de9f0 11238=item make [hash]
d8773709 11239
f20de9f0
SP		 11240Processing instructions for the C<make> or C<./Build> phase of the
11241CPAN mantra. See below under I<Processiong Instructions>.
d8773709 11242
f20de9f0 11243=item match [hash]
d8773709 11244
2b3bde2a
SP		 11245A hashref with one or more of the keys C<distribution>, C<modules>,
11246C<perl>, and C<perlconfig> that specify if a document is targeted at a
11247specific CPAN distribution or installation.
d8773709 11248
f20de9f0
SP		 11249The corresponding values are interpreted as regular expressions. The
11250C<distribution> related one will be matched against the canonical
11251distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
d8773709 11252
f20de9f0
SP		 11253The C<module> related one will be matched against I<all> modules
11254contained in the distribution until one module matches.
554a9ef5 11255
b03f445c
RGS		 11256The C<perl> related one will be matched against C<$^X> (but with the
11257absolute path).
554a9ef5 11258
2b3bde2a
SP		 11259The value associated with C<perlconfig> is itself a hashref that is
11260matched against corresponding values in the C<%Config::Config> hash
11261living in the C< Config.pm > module.
11262
f20de9f0
SP		 11263If more than one restriction of C<module>, C<distribution>, and
11264C<perl> is specified, the results of the separately computed match
11265values must all match. If this is the case then the hashref
11266represented by the YAML document is returned as the preference
11267structure for the current distribution.
4d1321a7 11268
f20de9f0 11269=item patches [array]
4d1321a7 11270
f20de9f0
SP		 11271An array of patches on CPAN or on the local disk to be applied in
11272order via the external patch program. If the value for the C<-p>
11273parameter is C<0> or C<1> is determined by reading the patch
11274beforehand.
d8773709 11275
f20de9f0
SP		 11276Note: if the C<applypatch> program is installed and C<CPAN::Config>
11277knows about it B<and> a patch is written by the C<makepatch> program,
11278then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11279and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11280distribution.
d8773709 11281
f20de9f0 11282=item pl [hash]
d8773709 11283
f20de9f0
SP		 11284Processing instructions for the C<perl Makefile.PL> or C<perl
11285Build.PL> phase of the CPAN mantra. See below under I<Processiong
11286Instructions>.
d8773709 11287
f20de9f0 11288=item test [hash]
d8773709 11289
f20de9f0
SP		 11290Processing instructions for the C<make test> or C<./Build test> phase
11291of the CPAN mantra. See below under I<Processiong Instructions>.
d8773709 11292
d8773709 11293=back
55e314ee 11294
f20de9f0 11295=head2 Processing Instructions
5f05dabc 11296
f20de9f0 11297=over
5f05dabc 11298
f20de9f0 11299=item args [array]
5f05dabc 11300
f20de9f0 11301Arguments to be added to the command line
5f05dabc 11302
f20de9f0 11303=item commandline
5f05dabc 11304
f20de9f0
SP		 11305A full commandline that will be executed as it stands by a system
11306call. During the execution the environment variable PERL will is set
b03f445c
RGS		 11307to $^X (but with an absolute path). If C<commandline> is specified,
11308the content of C<args> is not used.
5f05dabc 11309
f20de9f0 11310=item eexpect [hash]
5f05dabc 11311
f04ea8d1
SP		 11312Extended C<expect>. This is a hash reference with four allowed keys,
11313C<mode>, C<timeout>, C<reuse>, and C<talk>.
5f05dabc 11314
f20de9f0
SP		 11315C<mode> may have the values C<deterministic> for the case where all
11316questions come in the order written down and C<anyorder> for the case
11317where the questions may come in any order. The default mode is
11318C<deterministic>.
5f05dabc 11319
f20de9f0
SP		 11320C<timeout> denotes a timeout in seconds. Floating point timeouts are
11321OK. In the case of a C<mode=deterministic> the timeout denotes the
11322timeout per question, in the case of C<mode=anyorder> it denotes the
11323timeout per byte received from the stream or questions.
5f05dabc 11324
f20de9f0
SP		 11325C<talk> is a reference to an array that contains alternating questions
11326and answers. Questions are regular expressions and answers are literal
11327strings. The Expect module will then watch the stream coming from the
11328execution of the external program (C<perl Makefile.PL>, C<perl
11329Build.PL>, C<make>, etc.).
5f05dabc 11330
f20de9f0
SP		 11331In the case of C<mode=deterministic> the CPAN.pm will inject the
11332according answer as soon as the stream matches the regular expression.
f04ea8d1
SP		 11333
11334In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11335as the timeout is reached for the next byte in the input stream. In
11336this mode you can use the C<reuse> parameter to decide what shall
11337happen with a question-answer pair after it has been used. In the
11338default case (reuse=0) it is removed from the array, so it cannot be
11339used again accidentally. In this case, if you want to answer the
11340question C<Do you really want to do that> several times, then it must
11341be included in the array at least as often as you want this answer to
11342be given. Setting the parameter C<reuse> to 1 makes this repetition
11343unnecessary.
5f05dabc 11344
f20de9f0 11345=item env [hash]
5f05dabc 11346
f20de9f0 11347Environment variables to be set during the command
2ccf00a7 11348
f20de9f0 11349=item expect [array]
09d9d230 11350
f20de9f0 11351C<< expect: <array> >> is a short notation for
5f05dabc 11352
f20de9f0
SP		 11353 eexpect:
11354 mode: deterministic
11355 timeout: 15
11356 talk: <array>
da199366 11357
f20de9f0 11358=back
da199366 11359
f20de9f0 11360=head2 Schema verification with C<Kwalify>
da199366 11361
f20de9f0
SP		 11362If you have the C<Kwalify> module installed (which is part of the
11363Bundle::CPANxxl), then all your distroprefs files are checked for
11364syntactical correctness.
da199366 11365
f20de9f0 11366=head2 Example Distroprefs Files
da199366 11367
f20de9f0
SP		 11368C<CPAN.pm> comes with a collection of example YAML files. Note that these
11369are really just examples and should not be used without care because
11370they cannot fit everybody's purpose. After all the authors of the
11371packages that ask questions had a need to ask, so you should watch
11372their questions and adjust the examples to your environment and your
11373needs. You have beend warned:-)
da199366 11374
f20de9f0 11375=head1 PROGRAMMER'S INTERFACE
da199366 11376
f20de9f0
SP		 11377If you do not enter the shell, the available shell commands are both
11378available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11379functions in the calling package (C<install(...)>). Before calling low-level
11380commands it makes sense to initialize components of CPAN you need, e.g.:
da199366 11381
f20de9f0
SP		 11382 CPAN::HandleConfig->load;
11383 CPAN::Shell::setup_output;
11384 CPAN::Index->reload;
da199366 11385
f20de9f0 11386High-level commands do such initializations automatically.
da199366 11387
f20de9f0
SP		 11388There's currently only one class that has a stable interface -
11389CPAN::Shell. All commands that are available in the CPAN shell are
11390methods of the class CPAN::Shell. Each of the commands that produce
11391listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11392the IDs of all modules within the list.
7d97ad34
SP		 11393
11394=over 2
11395
f20de9f0 11396=item expand($type,@things)
7d97ad34 11397
f20de9f0
SP		 11398The IDs of all objects available within a program are strings that can
11399be expanded to the corresponding real objects with the
11400C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11401list of CPAN::Module objects according to the C<@things> arguments
11402given. In scalar context it only returns the first element of the
11403list.
7d97ad34 11404
f20de9f0 11405=item expandany(@things)
7d97ad34 11406
f20de9f0
SP		 11407Like expand, but returns objects of the appropriate type, i.e.
11408CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11409CPAN::Distribution objects for distributions. Note: it does not expand
11410to CPAN::Author objects.
7d97ad34 11411
f20de9f0
SP		 11412=item Programming Examples
11413
11414This enables the programmer to do operations that combine
11415functionalities that are available in the shell.
11416
11417 # install everything that is outdated on my disk:
11418 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11419
11420 # install my favorite programs if necessary:
f04ea8d1 11421 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
f20de9f0
SP		 11422 CPAN::Shell->install($mod);
11423 }
11424
11425 # list all modules on my disk that have no VERSION number
f04ea8d1
SP		 11426 for $mod (CPAN::Shell->expand("Module","/./")) {
11427 next unless $mod->inst_file;
f20de9f0 11428 # MakeMaker convention for undefined $VERSION:
f04ea8d1
SP		 11429 next unless $mod->inst_version eq "undef";
11430 print "No VERSION in ", $mod->id, "\n";
f20de9f0
SP		 11431 }
11432
11433 # find out which distribution on CPAN contains a module:
11434 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
11435
11436Or if you want to write a cronjob to watch The CPAN, you could list
11437all modules that need updating. First a quick and dirty way:
11438
11439 perl -e 'use CPAN; CPAN::Shell->r;'
11440
11441If you don't want to get any output in the case that all modules are
11442up to date, you can parse the output of above command for the regular
11443expression //modules are up to date// and decide to mail the output
11444only if it doesn't match. Ick?
11445
11446If you prefer to do it more in a programmer style in one single
11447process, maybe something like this suits you better:
11448
11449 # list all modules on my disk that have newer versions on CPAN
f04ea8d1 11450 for $mod (CPAN::Shell->expand("Module","/./")) {
f20de9f0
SP		 11451 next unless $mod->inst_file;
11452 next if $mod->uptodate;
11453 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
11454 $mod->id, $mod->inst_version, $mod->cpan_version;
11455 }
11456
11457If that gives you too much output every day, you maybe only want to
11458watch for three modules. You can write
11459
f04ea8d1 11460 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
f20de9f0
SP		 11461
11462as the first line instead. Or you can combine some of the above
11463tricks:
11464
11465 # watch only for a new mod_perl module
11466 $mod = CPAN::Shell->expand("Module","mod_perl");
11467 exit if $mod->uptodate;
11468 # new mod_perl arrived, let me know all update recommendations
11469 CPAN::Shell->r;
7d97ad34
SP		 11470
11471=back
11472
f20de9f0 11473=head2 Methods in the other Classes
7d97ad34 11474
f20de9f0 11475=over 4
7d97ad34 11476
f20de9f0 11477=item CPAN::Author::as_glimpse()
6d29edf5 11478
f20de9f0 11479Returns a one-line description of the author
da199366 11480
f20de9f0 11481=item CPAN::Author::as_string()
da199366 11482
f20de9f0 11483Returns a multi-line description of the author
10b2abe6 11484
f20de9f0 11485=item CPAN::Author::email()
2ccf00a7 11486
f20de9f0 11487Returns the author's email address
2ccf00a7 11488
f20de9f0 11489=item CPAN::Author::fullname()
2ccf00a7 11490
f20de9f0 11491Returns the author's name
2ccf00a7 11492
f20de9f0 11493=item CPAN::Author::name()
2ccf00a7 11494
f20de9f0 11495An alias for fullname
2ccf00a7 11496
f20de9f0 11497=item CPAN::Bundle::as_glimpse()
b72dd56f 11498
f20de9f0 11499Returns a one-line description of the bundle
b72dd56f 11500
f20de9f0 11501=item CPAN::Bundle::as_string()
2ccf00a7 11502
f20de9f0 11503Returns a multi-line description of the bundle
2ccf00a7 11504
f20de9f0 11505=item CPAN::Bundle::clean()
2ccf00a7 11506
f20de9f0 11507Recursively runs the C<clean> method on all items contained in the bundle.
5f05dabc 11508
f20de9f0 11509=item CPAN::Bundle::contains()
35576f8c 11510
f20de9f0
SP		 11511Returns a list of objects' IDs contained in a bundle. The associated
11512objects may be bundles, modules or distributions.
05bab18e 11513
f20de9f0 11514=item CPAN::Bundle::force($method,@args)
05bab18e 11515
f20de9f0
SP		 11516Forces CPAN to perform a task that it normally would have refused to
11517do. Force takes as arguments a method name to be called and any number
11518of additional arguments that should be passed to the called method.
11519The internals of the object get the needed changes so that CPAN.pm
11520does not refuse to take the action. The C<force> is passed recursively
11521to all contained objects. See also the section above on the C<force>
11522and the C<fforce> pragma.
05bab18e 11523
f20de9f0 11524=item CPAN::Bundle::get()
05bab18e 11525
f20de9f0 11526Recursively runs the C<get> method on all items contained in the bundle
05bab18e 11527
f20de9f0 11528=item CPAN::Bundle::inst_file()
05bab18e 11529
f20de9f0
SP		 11530Returns the highest installed version of the bundle in either @INC or
11531C<$CPAN::Config->{cpan_home}>. Note that this is different from
11532CPAN::Module::inst_file.
05bab18e 11533
f20de9f0 11534=item CPAN::Bundle::inst_version()
05bab18e 11535
f20de9f0 11536Like CPAN::Bundle::inst_file, but returns the $VERSION
05bab18e 11537
f20de9f0 11538=item CPAN::Bundle::uptodate()
05bab18e 11539
f20de9f0 11540Returns 1 if the bundle itself and all its members are uptodate.
05bab18e 11541
f20de9f0 11542=item CPAN::Bundle::install()
05bab18e 11543
f20de9f0 11544Recursively runs the C<install> method on all items contained in the bundle
05bab18e 11545
f20de9f0 11546=item CPAN::Bundle::make()
05bab18e 11547
f20de9f0 11548Recursively runs the C<make> method on all items contained in the bundle
05bab18e 11549
f20de9f0 11550=item CPAN::Bundle::readme()
05bab18e 11551
f20de9f0 11552Recursively runs the C<readme> method on all items contained in the bundle
05bab18e 11553
f20de9f0 11554=item CPAN::Bundle::test()
05bab18e 11555
f20de9f0 11556Recursively runs the C<test> method on all items contained in the bundle
05bab18e 11557
f20de9f0 11558=item CPAN::Distribution::as_glimpse()
05bab18e 11559
f20de9f0 11560Returns a one-line description of the distribution
05bab18e 11561
f20de9f0 11562=item CPAN::Distribution::as_string()
05bab18e 11563
f20de9f0 11564Returns a multi-line description of the distribution
05bab18e 11565
f20de9f0 11566=item CPAN::Distribution::author
05bab18e 11567
f20de9f0
SP		 11568Returns the CPAN::Author object of the maintainer who uploaded this
11569distribution
05bab18e 11570
f04ea8d1
SP		 11571=item CPAN::Distribution::pretty_id()
11572
11573Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
11574author's PAUSE ID and TARBALL is the distribution filename.
11575
11576=item CPAN::Distribution::base_id()
11577
11578Returns the distribution filename without any archive suffix. E.g
11579"Foo-Bar-0.01"
11580
f20de9f0 11581=item CPAN::Distribution::clean()
05bab18e 11582
f20de9f0
SP		 11583Changes to the directory where the distribution has been unpacked and
11584runs C<make clean> there.
05bab18e 11585
f20de9f0 11586=item CPAN::Distribution::containsmods()
05bab18e 11587
f20de9f0
SP		 11588Returns a list of IDs of modules contained in a distribution file.
11589Only works for distributions listed in the 02packages.details.txt.gz
11590file. This typically means that only the most recent version of a
11591distribution is covered.
05bab18e 11592
f20de9f0 11593=item CPAN::Distribution::cvs_import()
35576f8c 11594
f20de9f0
SP		 11595Changes to the directory where the distribution has been unpacked and
11596runs something like
5f05dabc 11597
f20de9f0 11598 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
05bab18e 11599
f20de9f0 11600there.
5f05dabc 11601
f20de9f0
SP		 11602=item CPAN::Distribution::dir()
11603
11604Returns the directory into which this distribution has been unpacked.
11605
11606=item CPAN::Distribution::force($method,@args)
11607
11608Forces CPAN to perform a task that it normally would have refused to
11609do. Force takes as arguments a method name to be called and any number
11610of additional arguments that should be passed to the called method.
11611The internals of the object get the needed changes so that CPAN.pm
11612does not refuse to take the action. See also the section above on the
11613C<force> and the C<fforce> pragma.
11614
11615=item CPAN::Distribution::get()
11616
11617Downloads the distribution from CPAN and unpacks it. Does nothing if
11618the distribution has already been downloaded and unpacked within the
11619current session.
11620
11621=item CPAN::Distribution::install()
11622
11623Changes to the directory where the distribution has been unpacked and
11624runs the external command C<make install> there. If C<make> has not
11625yet been run, it will be run first. A C<make test> will be issued in
11626any case and if this fails, the install will be canceled. The
11627cancellation can be avoided by letting C<force> run the C<install> for
11628you.
11629
11630This install method has only the power to install the distribution if
11631there are no dependencies in the way. To install an object and all of
11632its dependencies, use CPAN::Shell->install.
11633
11634Note that install() gives no meaningful return value. See uptodate().
11635
11636=item CPAN::Distribution::install_tested()
11637
11638Install all the distributions that have been tested sucessfully but
11639not yet installed. See also C<is_tested>.
11640
11641=item CPAN::Distribution::isa_perl()
11642
11643Returns 1 if this distribution file seems to be a perl distribution.
11644Normally this is derived from the file name only, but the index from
11645CPAN can contain a hint to achieve a return value of true for other
11646filenames too.
11647
11648=item CPAN::Distribution::is_tested()
11649
11650List all the distributions that have been tested sucessfully but not
11651yet installed. See also C<install_tested>.
11652
11653=item CPAN::Distribution::look()
11654
11655Changes to the directory where the distribution has been unpacked and
11656opens a subshell there. Exiting the subshell returns.
11657
11658=item CPAN::Distribution::make()
11659
11660First runs the C<get> method to make sure the distribution is
11661downloaded and unpacked. Changes to the directory where the
11662distribution has been unpacked and runs the external commands C<perl
11663Makefile.PL> or C<perl Build.PL> and C<make> there.
11664
11665=item CPAN::Distribution::perldoc()
11666
11667Downloads the pod documentation of the file associated with a
11668distribution (in html format) and runs it through the external
11669command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11670isn't available, it converts it to plain text with external
11671command html2text and runs it through the pager specified
11672in C<$CPAN::Config->{pager}>
11673
11674=item CPAN::Distribution::prefs()
11675
11676Returns the hash reference from the first matching YAML file that the
11677user has deposited in the C<prefs_dir/> directory. The first
11678succeeding match wins. The files in the C<prefs_dir/> are processed
11679alphabetically and the canonical distroname (e.g.
11680AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11681stored in the $root->{match}{distribution} attribute value.
11682Additionally all module names contained in a distribution are matched
11683agains the regular expressions in the $root->{match}{module} attribute
11684value. The two match values are ANDed together. Each of the two
11685attributes are optional.
11686
11687=item CPAN::Distribution::prereq_pm()
11688
11689Returns the hash reference that has been announced by a distribution
11690as the the C<requires> and C<build_requires> elements. These can be
11691declared either by the C<META.yml> (if authoritative) or can be
11692deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11693or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11694a comment in the produced C<Makefile>. I<Note>: this method only works
11695after an attempt has been made to C<make> the distribution. Returns
11696undef otherwise.
11697
11698=item CPAN::Distribution::readme()
11699
11700Downloads the README file associated with a distribution and runs it
11701through the pager specified in C<$CPAN::Config->{pager}>.
11702
dc053c64
SP		 11703=item CPAN::Distribution::reports()
11704
11705Downloads report data for this distribution from cpantesters.perl.org
11706and displays a subset of them.
11707
f20de9f0
SP		 11708=item CPAN::Distribution::read_yaml()
11709
11710Returns the content of the META.yml of this distro as a hashref. Note:
11711works only after an attempt has been made to C<make> the distribution.
11712Returns undef otherwise. Also returns undef if the content of META.yml
11713is not authoritative. (The rules about what exactly makes the content
11714authoritative are still in flux.)
11715
11716=item CPAN::Distribution::test()
11717
11718Changes to the directory where the distribution has been unpacked and
11719runs C<make test> there.
11720
11721=item CPAN::Distribution::uptodate()
11722
11723Returns 1 if all the modules contained in the distribution are
11724uptodate. Relies on containsmods.
11725
11726=item CPAN::Index::force_reload()
11727
11728Forces a reload of all indices.
11729
11730=item CPAN::Index::reload()
11731
11732Reloads all indices if they have not been read for more than
11733C<$CPAN::Config->{index_expire}> days.
11734
11735=item CPAN::InfoObj::dump()
11736
11737CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11738inherit this method. It prints the data structure associated with an
11739object. Useful for debugging. Note: the data structure is considered
11740internal and thus subject to change without notice.
11741
11742=item CPAN::Module::as_glimpse()
11743
11744Returns a one-line description of the module in four columns: The
11745first column contains the word C<Module>, the second column consists
11746of one character: an equals sign if this module is already installed
11747and uptodate, a less-than sign if this module is installed but can be
11748upgraded, and a space if the module is not installed. The third column
11749is the name of the module and the fourth column gives maintainer or
11750distribution information.
11751
11752=item CPAN::Module::as_string()
11753
11754Returns a multi-line description of the module
11755
11756=item CPAN::Module::clean()
11757
11758Runs a clean on the distribution associated with this module.
11759
11760=item CPAN::Module::cpan_file()
11761
11762Returns the filename on CPAN that is associated with the module.
11763
11764=item CPAN::Module::cpan_version()
11765
11766Returns the latest version of this module available on CPAN.
11767
11768=item CPAN::Module::cvs_import()
11769
11770Runs a cvs_import on the distribution associated with this module.
11771
11772=item CPAN::Module::description()
11773
11774Returns a 44 character description of this module. Only available for
11775modules listed in The Module List (CPAN/modules/00modlist.long.html
11776or 00modlist.long.txt.gz)
11777
11778=item CPAN::Module::distribution()
11779
11780Returns the CPAN::Distribution object that contains the current
11781version of this module.
11782
11783=item CPAN::Module::dslip_status()
11784
11785Returns a hash reference. The keys of the hash are the letters C<D>,
11786C<S>, C<L>, C<I>, and <P>, for development status, support level,
11787language, interface and public licence respectively. The data for the
11788DSLIP status are collected by pause.perl.org when authors register
11789their namespaces. The values of the 5 hash elements are one-character
11790words whose meaning is described in the table below. There are also 5
11791hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11792verbose value of the 5 status variables.
11793
11794Where the 'DSLIP' characters have the following meanings:
11795
11796 D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
11797 i - Idea, listed to gain consensus or as a placeholder
11798 c - under construction but pre-alpha (not yet released)
11799 a/b - Alpha/Beta testing
11800 R - Released
11801 M - Mature (no rigorous definition)
11802 S - Standard, supplied with Perl 5
11803
11804 S - Support Level:
11805 m - Mailing-list
11806 d - Developer
11807 u - Usenet newsgroup comp.lang.perl.modules
11808 n - None known, try comp.lang.perl.modules
11809 a - abandoned; volunteers welcome to take over maintainance
11810
11811 L - Language Used:
11812 p - Perl-only, no compiler needed, should be platform independent
11813 c - C and perl, a C compiler will be needed
11814 h - Hybrid, written in perl with optional C code, no compiler needed
11815 + - C++ and perl, a C++ compiler will be needed
11816 o - perl and another language other than C or C++
11817
11818 I - Interface Style
11819 f - plain Functions, no references used
11820 h - hybrid, object and function interfaces available
11821 n - no interface at all (huh?)
11822 r - some use of unblessed References or ties
11823 O - Object oriented using blessed references and/or inheritance
11824
11825 P - Public License
11826 p - Standard-Perl: user may choose between GPL and Artistic
11827 g - GPL: GNU General Public License
11828 l - LGPL: "GNU Lesser General Public License" (previously known as
11829 "GNU Library General Public License")
11830 b - BSD: The BSD License
11831 a - Artistic license alone
f04ea8d1 11832 2 - Artistic license 2.0 or later
f20de9f0
SP		 11833 o - open source: appoved by www.opensource.org
11834 d - allows distribution without restrictions
11835 r - restricted distribtion
11836 n - no license at all
11837
11838=item CPAN::Module::force($method,@args)
11839
11840Forces CPAN to perform a task that it normally would have refused to
11841do. Force takes as arguments a method name to be called and any number
11842of additional arguments that should be passed to the called method.
11843The internals of the object get the needed changes so that CPAN.pm
11844does not refuse to take the action. See also the section above on the
11845C<force> and the C<fforce> pragma.
11846
11847=item CPAN::Module::get()
11848
11849Runs a get on the distribution associated with this module.
11850
11851=item CPAN::Module::inst_file()
11852
11853Returns the filename of the module found in @INC. The first file found
11854is reported just like perl itself stops searching @INC when it finds a
11855module.
5f05dabc 11856
f20de9f0 11857=item CPAN::Module::available_file()
5f05dabc 11858
f20de9f0
SP		 11859Returns the filename of the module found in PERL5LIB or @INC. The
11860first file found is reported. The advantage of this method over
11861C<inst_file> is that modules that have been tested but not yet
11862installed are included because PERL5LIB keeps track of tested modules.
5f05dabc 11863
f20de9f0 11864=item CPAN::Module::inst_version()
5f05dabc 11865
f20de9f0 11866Returns the version number of the installed module in readable format.
5f05dabc 11867
f20de9f0 11868=item CPAN::Module::available_version()
5f05dabc 11869
f20de9f0 11870Returns the version number of the available module in readable format.
5f05dabc 11871
f20de9f0 11872=item CPAN::Module::install()
5f05dabc 11873
f20de9f0 11874Runs an C<install> on the distribution associated with this module.
5f05dabc 11875
f20de9f0 11876=item CPAN::Module::look()
5f05dabc 11877
f20de9f0
SP		 11878Changes to the directory where the distribution associated with this
11879module has been unpacked and opens a subshell there. Exiting the
11880subshell returns.
5f05dabc 11881
f20de9f0 11882=item CPAN::Module::make()
5f05dabc 11883
f20de9f0
SP		 11884Runs a C<make> on the distribution associated with this module.
11885
11886=item CPAN::Module::manpage_headline()
11887
11888If module is installed, peeks into the module's manpage, reads the
11889headline and returns it. Moreover, if the module has been downloaded
11890within this session, does the equivalent on the downloaded module even
11891if it is not installed.
11892
11893=item CPAN::Module::perldoc()
11894
11895Runs a C<perldoc> on this module.
11896
11897=item CPAN::Module::readme()
11898
11899Runs a C<readme> on the distribution associated with this module.
11900
dc053c64
SP		 11901=item CPAN::Module::reports()
11902
11903Calls the reports() method on the associated distribution object.
11904
f20de9f0
SP		 11905=item CPAN::Module::test()
11906
11907Runs a C<test> on the distribution associated with this module.
11908
11909=item CPAN::Module::uptodate()
11910
11911Returns 1 if the module is installed and up-to-date.
11912
11913=item CPAN::Module::userid()
11914
11915Returns the author's ID of the module.
5f05dabc 11916
11917=back
11918
f20de9f0 11919=head2 Cache Manager
ca79d794 11920
f20de9f0
SP		 11921Currently the cache manager only keeps track of the build directory
11922($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11923deletes complete directories below C<build_dir> as soon as the size of
11924all directories there gets bigger than $CPAN::Config->{build_cache}
11925(in MB). The contents of this cache may be used for later
11926re-installations that you intend to do manually, but will never be
11927trusted by CPAN itself. This is due to the fact that the user might
11928use these directories for building modules on different architectures.
11929
11930There is another directory ($CPAN::Config->{keep_source_where}) where
11931the original distribution files are kept. This directory is not
11932covered by the cache manager and must be controlled by the user. If
11933you choose to have the same directory as build_dir and as
11934keep_source_where directory, then your sources will be deleted with
11935the same fifo mechanism.
11936
11937=head2 Bundles
11938
11939A bundle is just a perl module in the namespace Bundle:: that does not
11940define any functions or methods. It usually only contains documentation.
11941
11942It starts like a perl module with a package declaration and a $VERSION
11943variable. After that the pod section looks like any other pod with the
11944only difference being that I<one special pod section> exists starting with
11945(verbatim):
11946
f04ea8d1 11947 =head1 CONTENTS
f20de9f0
SP		 11948
11949In this pod section each line obeys the format
11950
11951 Module_Name [Version_String] [- optional text]
11952
11953The only required part is the first field, the name of a module
11954(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11955of the line is optional. The comment part is delimited by a dash just
11956as in the man page header.
11957
11958The distribution of a bundle should follow the same convention as
11959other distributions.
11960
11961Bundles are treated specially in the CPAN package. If you say 'install
11962Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11963the modules in the CONTENTS section of the pod. You can install your
11964own Bundles locally by placing a conformant Bundle file somewhere into
11965your @INC path. The autobundle() command which is available in the
11966shell interface does that for you by including all currently installed
11967modules in a snapshot bundle file.
11968
11969=head1 PREREQUISITES
11970
11971If you have a local mirror of CPAN and can access all files with
11972"file:" URLs, then you only need a perl better than perl5.003 to run
11973this module. Otherwise Net::FTP is strongly recommended. LWP may be
11974required for non-UNIX systems or if your nearest CPAN site is
11975associated with a URL that is not C<ftp:>.
11976
11977If you have neither Net::FTP nor LWP, there is a fallback mechanism
11978implemented for an external ftp command or for an external lynx
11979command.
11980
11981=head1 UTILITIES
11982
11983=head2 Finding packages and VERSION
11984
11985This module presumes that all packages on CPAN
ca79d794 11986
2ccf00a7
SP		 11987=over 2
11988
f20de9f0 11989=item *
2ccf00a7 11990
f20de9f0
SP		 11991declare their $VERSION variable in an easy to parse manner. This
11992prerequisite can hardly be relaxed because it consumes far too much
11993memory to load all packages into the running program just to determine
11994the $VERSION variable. Currently all programs that are dealing with
11995version use something like this
2ccf00a7 11996
f20de9f0
SP		 11997 perl -MExtUtils::MakeMaker -le \
11998 'print MM->parse_version(shift)' filename
2ccf00a7 11999
f20de9f0
SP		 12000If you are author of a package and wonder if your $VERSION can be
12001parsed, please try the above method.
2ccf00a7 12002
f20de9f0 12003=item *
2ccf00a7 12004
f20de9f0
SP		 12005come as compressed or gzipped tarfiles or as zip files and contain a
12006C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12007without much enthusiasm).
2ccf00a7 12008
f20de9f0 12009=back
2ccf00a7 12010
f20de9f0
SP		 12011=head2 Debugging
12012
12013The debugging of this module is a bit complex, because we have
12014interferences of the software producing the indices on CPAN, of the
12015mirroring process on CPAN, of packaging, of configuration, of
12016synchronicity, and of bugs within CPAN.pm.
12017
12018For debugging the code of CPAN.pm itself in interactive mode some more
12019or less useful debugging aid can be turned on for most packages within
12020CPAN.pm with one of
12021
12022=over 2
12023
12024=item o debug package...
12025
12026sets debug mode for packages.
12027
12028=item o debug -package...
12029
12030unsets debug mode for packages.
12031
12032=item o debug all
12033
12034turns debugging on for all packages.
12035
12036=item o debug number
2ccf00a7
SP		 12037
12038=back
ca79d794 12039
f20de9f0
SP		 12040which sets the debugging packages directly. Note that C<o debug 0>
12041turns debugging off.
36263cb3 12042
f20de9f0
SP		 12043What seems quite a successful strategy is the combination of C<reload
12044cpan> and the debugging switches. Add a new debug statement while
12045running in the shell and then issue a C<reload cpan> and see the new
12046debugging messages immediately without losing the current context.
36263cb3 12047
f20de9f0
SP		 12048C<o debug> without an argument lists the valid package names and the
12049current set of packages in debugging mode. C<o debug> has built-in
12050completion support.
36263cb3 12051
f20de9f0
SP		 12052For debugging of CPAN data there is the C<dump> command which takes
12053the same arguments as make/test/install and outputs each object's
12054Data::Dumper dump. If an argument looks like a perl variable and
12055contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12056Data::Dumper directly.
36263cb3 12057
f20de9f0 12058=head2 Floppy, Zip, Offline Mode
36263cb3 12059
f20de9f0
SP		 12060CPAN.pm works nicely without network too. If you maintain machines
12061that are not networked at all, you should consider working with file:
12062URLs. Of course, you have to collect your modules somewhere first. So
12063you might use CPAN.pm to put together all you need on a networked
12064machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12065$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12066of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12067with this floppy. See also below the paragraph about CD-ROM support.
c356248b 12068
f20de9f0 12069=head2 Basic Utilities for Programmers
c356248b 12070
f20de9f0 12071=over 2
c356248b 12072
f20de9f0 12073=item has_inst($module)
c356248b 12074
f20de9f0
SP		 12075Returns true if the module is installed. Used to load all modules into
12076the running CPAN.pm which are considered optional. The config variable
12077C<dontload_list> can be used to intercept the C<has_inst()> call such
12078that an optional module is not loaded despite being available. For
12079example the following command will prevent that C<YAML.pm> is being
12080loaded:
2e2b7522 12081
f20de9f0 12082 cpan> o conf dontload_list push YAML
05bab18e 12083
f20de9f0 12084See the source for details.
05bab18e 12085
f20de9f0
SP		 12086=item has_usable($module)
12087
12088Returns true if the module is installed and is in a usable state. Only
12089useful for a handful of modules that are used internally. See the
12090source for details.
05bab18e 12091
f20de9f0 12092=item instance($module)
1e8f9a0a 12093
f20de9f0
SP		 12094The constructor for all the singletons used to represent modules,
12095distributions, authors and bundles. If the object already exists, this
12096method returns the object, otherwise it calls the constructor.
12097
12098=back
1e8f9a0a 12099
5f05dabc 12100=head1 SECURITY
12101
12102There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12103install foreign, unmasked, unsigned code on your machine. We compare
12104to a checksum that comes from the net just as the distribution file
0cf35e6a
SP		 12105itself. But we try to make it easy to add security on demand:
12106
12107=head2 Cryptographically signed modules
12108
12109Since release 1.77 CPAN.pm has been able to verify cryptographically
12110signed module distributions using Module::Signature. The CPAN modules
12111can be signed by their authors, thus giving more security. The simple
12112unsigned MD5 checksums that were used before by CPAN protect mainly
12113against accidental file corruption.
12114
12115You will need to have Module::Signature installed, which in turn
12116requires that you have at least one of Crypt::OpenPGP module or the
12117command-line F<gpg> tool installed.
12118
12119You will also need to be able to connect over the Internet to the public
12120keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
5f05dabc 12121
ed84aac9
A		 12122The configuration parameter check_sigs is there to turn signature
12123checking on or off.
12124
5f05dabc 12125=head1 EXPORT
12126
12127Most functions in package CPAN are exported per default. The reason
12128for this is that the primary use is intended for the cpan shell or for
d1be9408 12129one-liners.
5f05dabc 12130
9ddc4ed0
A		 12131=head1 ENVIRONMENT
12132
12133When the CPAN shell enters a subshell via the look command, it sets
12134the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12135already set.
12136
f04ea8d1
SP		 12137When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12138to the ID of the running process. It also sets
12139PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12140happen with older versions of Module::Install.
12141
12142When running C<perl Makefile.PL>, the environment variable
12143C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12144C<Makefile.PL> that is being executed. This prevents runaway processes
12145with newer versions of Module::Install.
be34b10d 12146
44d21104
A		 12147When the config variable ftp_passive is set, all downloads will be run
12148with the environment variable FTP_PASSIVE set to this value. This is
4d1321a7
A		 12149in general a good idea as it influences both Net::FTP and LWP based
12150connections. The same effect can be achieved by starting the cpan
12151shell with this environment variable set. For Net::FTP alone, one can
12152also always set passive mode by running libnetcfg.
44d21104 12153
f610777f
A		 12154=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12155
d8773709 12156Populating a freshly installed perl with my favorite modules is pretty
8b3ad137 12157easy if you maintain a private bundle definition file. To get a useful
f610777f
A		 12158blueprint of a bundle definition file, the command autobundle can be used
12159on the CPAN shell command line. This command writes a bundle definition
36263cb3 12160file for all modules that are installed for the currently running perl
f610777f
A		 12161interpreter. It's recommended to run this command only once and from then
12162on maintain the file manually under a private name, say
12163Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12164
12165 cpan> install Bundle::my_bundle
12166
36263cb3 12167then answer a few questions and then go out for a coffee.
f610777f 12168
8b3ad137 12169Maintaining a bundle definition file means keeping track of two
36263cb3
GS		 12170things: dependencies and interactivity. CPAN.pm sometimes fails on
12171calculating dependencies because not all modules define all MakeMaker
12172attributes correctly, so a bundle definition file should specify
12173prerequisites as early as possible. On the other hand, it's a bit
12174annoying that many distributions need some interactive configuring. So
12175what I try to accomplish in my private bundle file is to have the
12176packages that need to be configured early in the file and the gentle
12177ones later, so I can go out after a few minutes and leave CPAN.pm
8b3ad137 12178untended.
f610777f
A		 12179
12180=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12181
36263cb3 12182Thanks to Graham Barr for contributing the following paragraphs about
de34a54b 12183the interaction between perl, and various firewall configurations. For
3c4b39be 12184further information on firewalls, it is recommended to consult the
de34a54b
JH		 12185documentation that comes with the ncftp program. If you are unable to
12186go through the firewall with a simple Perl setup, it is very likely
12187that you can configure ncftp so that it works for your firewall.
12188
12189=head2 Three basic types of firewalls
f610777f
A		 12190
12191Firewalls can be categorized into three basic types.
12192
bbc7dcd2 12193=over 4
f610777f
A		 12194
12195=item http firewall
12196
12197This is where the firewall machine runs a web server and to access the
12198outside world you must do it via the web server. If you set environment
12199variables like http_proxy or ftp_proxy to a values beginning with http://
12200or in your web browser you have to set proxy information then you know
d1be9408 12201you are running an http firewall.
f610777f
A		 12202
12203To access servers outside these types of firewalls with perl (even for
12204ftp) you will need to use LWP.
12205
12206=item ftp firewall
12207
d1be9408 12208This where the firewall machine runs an ftp server. This kind of
911a92db
GS		 12209firewall will only let you access ftp servers outside the firewall.
12210This is usually done by connecting to the firewall with ftp, then
12211entering a username like "user@outside.host.com"
f610777f
A		 12212
12213To access servers outside these type of firewalls with perl you
12214will need to use Net::FTP.
12215
12216=item One way visibility
12217
d1be9408 12218I say one way visibility as these firewalls try to make themselves look
f610777f
A		 12219invisible to the users inside the firewall. An FTP data connection is
12220normally created by sending the remote server your IP address and then
12221listening for the connection. But the remote server will not be able to
12222connect to you because of the firewall. So for these types of firewall
12223FTP connections need to be done in a passive mode.
12224
12225There are two that I can think off.
12226
bbc7dcd2 12227=over 4
f610777f
A		 12228
12229=item SOCKS
12230
12231If you are using a SOCKS firewall you will need to compile perl and link
c4d24d4c 12232it with the SOCKS library, this is what is normally called a 'socksified'
f610777f
A		 12233perl. With this executable you will be able to connect to servers outside
12234the firewall as if it is not there.
12235
12236=item IP Masquerade
12237
12238This is the firewall implemented in the Linux kernel, it allows you to
12239hide a complete network behind one IP address. With this firewall no
d8773709 12240special compiling is needed as you can access hosts directly.
f610777f 12241
4d1321a7
A		 12242For accessing ftp servers behind such firewalls you usually need to
12243set the environment variable C<FTP_PASSIVE> or the config variable
12244ftp_passive to a true value.
5fc0f0f6 12245
f610777f
A		 12246=back
12247
12248=back
12249
c4d24d4c 12250=head2 Configuring lynx or ncftp for going through a firewall
de34a54b
JH		 12251
12252If you can go through your firewall with e.g. lynx, presumably with a
12253command such as
12254
12255 /usr/local/bin/lynx -pscott:tiger
12256
12257then you would configure CPAN.pm with the command
12258
12259 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12260
12261That's all. Similarly for ncftp or ftp, you would configure something
12262like
12263
12264 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12265
d1be9408 12266Your mileage may vary...
de34a54b
JH		 12267
12268=head1 FAQ
12269
bbc7dcd2 12270=over 4
de34a54b 12271
551e1d92
RB		 12272=item 1)
12273
12274I installed a new version of module X but CPAN keeps saying,
12275I have the old version installed
de34a54b
JH		 12276
12277Most probably you B<do> have the old version installed. This can
12278happen if a module installs itself into a different directory in the
12279@INC path than it was previously installed. This is not really a
12280CPAN.pm problem, you would have the same problem when installing the
12281module manually. The easiest way to prevent this behaviour is to add
12282the argument C<UNINST=1> to the C<make install> call, and that is why
12283many people add this argument permanently by configuring
12284
12285 o conf make_install_arg UNINST=1
12286
551e1d92
RB		 12287=item 2)
12288
12289So why is UNINST=1 not the default?
de34a54b
JH		 12290
12291Because there are people who have their precise expectations about who
12292may install where in the @INC path and who uses which @INC array. In
12293fine tuned environments C<UNINST=1> can cause damage.
12294
551e1d92
RB		 12295=item 3)
12296
12297I want to clean up my mess, and install a new perl along with
12298all modules I have. How do I go about it?
9d61fa1d
A		 12299
12300Run the autobundle command for your old perl and optionally rename the
12301resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12302with the Configure option prefix, e.g.
12303
12304 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12305
12306Install the bundle file you produced in the first step with something like
12307
12308 cpan> install Bundle::mybundle
12309
12310and you're done.
12311
551e1d92
RB		 12312=item 4)
12313
12314When I install bundles or multiple modules with one command
12315there is too much output to keep track of.
de34a54b
JH		 12316
12317You may want to configure something like
12318
12319 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12320 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12321
12322so that STDOUT is captured in a file for later inspection.
12323
c4d24d4c 12324
551e1d92
RB		 12325=item 5)
12326
12327I am not root, how can I install a module in a personal directory?
c4d24d4c 12328
554a9ef5 12329First of all, you will want to use your own configuration, not the one
44d21104
A		 12330that your root user installed. If you do not have permission to write
12331in the cpan directory that root has configured, you will be asked if
12332you want to create your own config. Answering "yes" will bring you into
12333CPAN's configuration stage, using the system config for all defaults except
12334things that have to do with CPAN's work directory, saving your choices to
12335your MyConfig.pm file.
12336
12337You can also manually initiate this process with the following command:
12338
12339 % perl -MCPAN -e 'mkmyconfig'
554a9ef5 12340
44d21104 12341or by running
554a9ef5 12342
44d21104
A		 12343 mkmyconfig
12344
12345from the CPAN shell.
12346
12347You will most probably also want to configure something like this:
c4d24d4c
A		 12348
12349 o conf makepl_arg "LIB=~/myperl/lib \
12350 INSTALLMAN1DIR=~/myperl/man/man1 \
ed756621
SP		 12351 INSTALLMAN3DIR=~/myperl/man/man3 \
12352 INSTALLSCRIPT=~/myperl/bin \
12353 INSTALLBIN=~/myperl/bin"
12354
f04ea8d1
SP		 12355and then (oh joy) the equivalent command for Module::Build. That would
12356be
12357
12358 o conf mbuildpl_arg "--lib=~/myperl/lib \
12359 --installman1dir=~/myperl/man/man1 \
12360 --installman3dir=~/myperl/man/man3 \
12361 --installscript=~/myperl/bin \
12362 --installbin=~/myperl/bin"
c4d24d4c
A		 12363
12364You can make this setting permanent like all C<o conf> settings with
ed756621 12365C<o conf commit> or by setting C<auto_commit> beforehand.
c4d24d4c
A		 12366
12367You will have to add ~/myperl/man to the MANPATH environment variable
12368and also tell your perl programs to look into ~/myperl/lib, e.g. by
12369including
12370
12371 use lib "$ENV{HOME}/myperl/lib";
12372
12373or setting the PERL5LIB environment variable.
12374
87892b73
RGS		 12375While we're speaking about $ENV{HOME}, it might be worth mentioning,
12376that for Windows we use the File::HomeDir module that provides an
12377equivalent to the concept of the home directory on Unix.
12378
4d1321a7 12379Another thing you should bear in mind is that the UNINST parameter can
f04ea8d1 12380be dangerous when you are installing into a private area because you
4d1321a7
A		 12381might accidentally remove modules that other people depend on that are
12382not using the private area.
c4d24d4c 12383
551e1d92
RB		 12384=item 6)
12385
12386How to get a package, unwrap it, and make a change before building it?
c4d24d4c 12387
8962fc49 12388Have a look at the C<look> (!) command.
c4d24d4c 12389
551e1d92
RB		 12390=item 7)
12391
12392I installed a Bundle and had a couple of fails. When I
12393retried, everything resolved nicely. Can this be fixed to work
12394on first try?
c4d24d4c
A		 12395
12396The reason for this is that CPAN does not know the dependencies of all
12397modules when it starts out. To decide about the additional items to
44d21104
A		 12398install, it just uses data found in the META.yml file or the generated
12399Makefile. An undetected missing piece breaks the process. But it may
12400well be that your Bundle installs some prerequisite later than some
12401depending item and thus your second try is able to resolve everything.
12402Please note, CPAN.pm does not know the dependency tree in advance and
12403cannot sort the queue of things to install in a topologically correct
12404order. It resolves perfectly well IF all modules declare the
12405prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12406the C<requires> stanza of Module::Build. For bundles which fail and
12407you need to install often, it is recommended to sort the Bundle
12408definition file manually.
5a5fac02 12409
551e1d92
RB		 12410=item 8)
12411
12412In our intranet we have many modules for internal use. How
12413can I integrate these modules with CPAN.pm but without uploading
12414the modules to CPAN?
5a5fac02
JH		 12415
12416Have a look at the CPAN::Site module.
c4d24d4c 12417
551e1d92
RB		 12418=item 9)
12419
44d21104
A		 12420When I run CPAN's shell, I get an error message about things in my
12421/etc/inputrc (or ~/.inputrc) file.
9d61fa1d 12422
44d21104
A		 12423These are readline issues and can only be fixed by studying readline
12424configuration on your architecture and adjusting the referenced file
12425accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12426and edit them. Quite often harmless changes like uppercasing or
12427lowercasing some arguments solves the problem.
8d97e4a1 12428
551e1d92
RB		 12429=item 10)
12430
12431Some authors have strange characters in their names.
8d97e4a1
JH		 12432
12433Internally CPAN.pm uses the UTF-8 charset. If your terminal is
12434expecting ISO-8859-1 charset, a converter can be activated by setting
12435term_is_latin to a true value in your config file. One way of doing so
12436would be
12437
44d21104 12438 cpan> o conf term_is_latin 1
8d97e4a1 12439
44d21104
A		 12440If other charset support is needed, please file a bugreport against
12441CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
12442the support or maybe UTF-8 terminals become widely available.
9d61fa1d 12443
f04ea8d1
SP		 12444Note: this config variable is deprecated and will be removed in a
12445future version of CPAN.pm. It will be replaced with the conventions
12446around the family of $LANG and $LC_* environment variables.
12447
554a9ef5
SP		 12448=item 11)
12449
12450When an install fails for some reason and then I correct the error
12451condition and retry, CPAN.pm refuses to install the module, saying
12452C<Already tried without success>.
12453
12454Use the force pragma like so
12455
12456 force install Foo::Bar
12457
554a9ef5
SP		 12458Or you can use
12459
12460 look Foo::Bar
12461
12462and then 'make install' directly in the subshell.
12463
44d21104
A		 12464=item 12)
12465
12466How do I install a "DEVELOPER RELEASE" of a module?
12467
8962fc49
SP		 12468By default, CPAN will install the latest non-developer release of a
12469module. If you want to install a dev release, you have to specify the
12470partial path starting with the author id to the tarball you wish to
12471install, like so:
44d21104 12472
4d1321a7 12473 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
44d21104 12474
8962fc49
SP		 12475Note that you can use the C<ls> command to get this path listed.
12476
44d21104
A		 12477=item 13)
12478
4d1321a7 12479How do I install a module and all its dependencies from the commandline,
44d21104
A		 12480without being prompted for anything, despite my CPAN configuration
12481(or lack thereof)?
12482
4d1321a7 12483CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
44d21104
A		 12484if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
12485asked any questions at all (assuming the modules you are installing are
12486nice about obeying that variable as well):
12487
12488 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
12489
b96578bb
SP		 12490=item 14)
12491
05bab18e 12492How do I create a Module::Build based Build.PL derived from an
ed84aac9 12493ExtUtils::MakeMaker focused Makefile.PL?
b96578bb
SP		 12494
12495http://search.cpan.org/search?query=Module::Build::Convert
12496
ade94d80 12497http://www.refcnt.org/papers/module-build-convert
b96578bb 12498
05bab18e
SP		 12499=item 15)
12500
12501What's the best CPAN site for me?
12502
12503The urllist config parameter is yours. You can add and remove sites at
12504will. You should find out which sites have the best uptodateness,
12505bandwidth, reliability, etc. and are topologically close to you. Some
12506people prefer fast downloads, others uptodateness, others reliability.
12507You decide which to try in which order.
12508
12509Henk P. Penning maintains a site that collects data about CPAN sites:
12510
12511 http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
b96578bb 12512
f04ea8d1
SP		 12513=item 16)
12514
12515Why do I get asked the same questions every time I start the shell?
12516
12517You can make your configuration changes permanent by calling the
12518command C<o conf commit>. Alternatively set the C<auto_commit>
12519variable to true by running C<o conf init auto_commit> and answering
12520the following question with yes.
12521
de34a54b
JH		 12522=back
12523
b72dd56f 12524=head1 COMPATIBILITY
5f05dabc 12525
b72dd56f 12526=head2 OLD PERL VERSIONS
4d1321a7 12527
b72dd56f
SP		 12528CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
12529newer versions. It is getting more and more difficult to get the
12530minimal prerequisites working on older perls. It is close to
12531impossible to get the whole Bundle::CPAN working there. If you're in
12532the position to have only these old versions, be advised that CPAN is
12533designed to work fine without the Bundle::CPAN installed.
12534
12535To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
12536compatible with ancient perls and that File::Temp is listed as a
12537prerequisite but CPAN has reasonable workarounds if it is missing.
12538
12539=head2 CPANPLUS
12540
12541This module and its competitor, the CPANPLUS module, are both much
12542cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
12543more modular but it was never tried to make it compatible with CPAN.pm.
09d9d230 12544
ed84aac9
A		 12545=head1 SECURITY ADVICE
12546
12547This software enables you to upgrade software on your computer and so
12548is inherently dangerous because the newly installed software may
12549contain bugs and may alter the way your computer works or even make it
12550unusable. Please consider backing up your data before every upgrade.
12551
b72dd56f
SP		 12552=head1 BUGS
12553
b03f445c 12554Please report bugs via L<http://rt.cpan.org/>
b72dd56f
SP		 12555
12556Before submitting a bug, please make sure that the traditional method
12557of building a Perl module package from a shell by following the
12558installation instructions of that package still works in your
12559environment.
12560
5f05dabc 12561=head1 AUTHOR
12562
e82b9348 12563Andreas Koenig C<< <andk@cpan.org> >>
5f05dabc 12564
2ccf00a7
SP		 12565=head1 LICENSE
12566
12567This program is free software; you can redistribute it and/or
12568modify it under the same terms as Perl itself.
12569
12570See L<http://www.perl.com/perl/misc/Artistic.html>
12571
c049f953
JH		 12572=head1 TRANSLATIONS
12573
12574Kawai,Takanori provides a Japanese translation of this manpage at
b03f445c 12575L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
c049f953 12576
5f05dabc 12577=head1 SEE ALSO
12578
b03f445c 12579L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
5f05dabc 12580
12581=cut
810a0276
SP		 12582
12583
Unnamed repository; edit this file 'description' to name the repository.