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
Oops, change 34762 should have bumped the VERSION
[perl5.git] / lib / CPAN.pm
CommitLineData
44d21104 1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
5254b38e 2# vim: ts=4 sts=4 sw=4:
e82b9348 3use strict;
8962fc49 4package CPAN;
5254b38e
SP		 5$CPAN::VERSION = '1.9301';
6$CPAN::VERSION =~ s/_//;
5f05dabc 7
5254b38e
SP		 8# we need to run chdir all over and we would get at wrong libraries
9# there
10use File::Spec ();
11BEGIN {
12 if (File::Spec->can("rel2abs")) {
13 for my $inc (@INC) {
14 $inc = File::Spec->rel2abs($inc) unless ref $inc;
15 }
16 }
17}
e82b9348 18use CPAN::HandleConfig;
554a9ef5 19use CPAN::Version;
e82b9348 20use CPAN::Debug;
135a59c2 21use CPAN::Queue;
e82b9348 22use CPAN::Tarzip;
f04ea8d1 23use CPAN::DeferedCode;
5f05dabc 24use Carp ();
25use Config ();
5254b38e 26use Cwd qw(chdir);
0cf35e6a 27use DirHandle ();
5f05dabc 28use Exporter ();
b96578bb
SP		 29use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
30 # 5.005_04 does not work without
31 # this
5f05dabc 32use File::Basename ();
10b2abe6 33use File::Copy ();
5f05dabc 34use File::Find;
35use File::Path ();
da199366 36use FileHandle ();
05bab18e 37use Fcntl qw(:flock);
5f05dabc 38use Safe ();
0cf35e6a 39use Sys::Hostname qw(hostname);
10b2abe6 40use Text::ParseWords ();
0cf35e6a 41use Text::Wrap ();
8962fc49 42
5254b38e 43# protect against "called too early"
b03f445c 44sub find_perl ();
5254b38e 45sub anycwd ();
b03f445c 46
8962fc49 47no lib ".";
5f05dabc 48
be708cc0 49require Mac::BuildTools if $^O eq 'MacOS';
5254b38e
SP		 50if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
51 $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
52 my $rec = $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} .= ",$$";
53 my @rec = split /,/, $rec;
54 # warn "# Note: Recursive call of CPAN.pm detected\n";
55 my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
56 my %sleep = (
57 5 => 30,
58 6 => 60,
59 7 => 120,
60 );
61 my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
62 my $verbose = @rec >= 4;
63 while (@rec) {
64 $w .= sprintf " which has been called by process %d", pop @rec;
65 }
66 if ($sleep) {
67 $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
68 }
69 if ($verbose) {
70 warn $w;
71 }
72 local $| = 1;
73 while ($sleep > 0) {
74 printf "\r#%5d", --$sleep;
75 sleep 1;
76 }
77 print "\n";
78}
f04ea8d1
SP		 79$ENV{PERL5_CPAN_IS_RUNNING}=$$;
80$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
be708cc0 81
e82b9348
SP		 82END { $CPAN::End++; &cleanup; }
83
da199366 84$CPAN::Signal ||= 0;
c356248b 85$CPAN::Frontend ||= "CPAN::Shell";
f04ea8d1 86unless (@CPAN::Defaultsites) {
7fefbd44
RGS		 87 @CPAN::Defaultsites = map {
88 CPAN::URL->new(TEXT => $_, FROM => "DEF")
89 }
90 "http://www.perl.org/CPAN/",
91 "ftp://ftp.perl.org/pub/CPAN/";
92}
5254b38e
SP		 93# $CPAN::iCwd (i for initial)
94$CPAN::iCwd ||= CPAN::anycwd();
607a774b 95$CPAN::Perl ||= CPAN::find_perl();
554a9ef5 96$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
f04ea8d1
SP		 97$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
98$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
607a774b 99
05bab18e 100# our globals are getting a mess
6658a91b
SP		 101use vars qw(
102 $AUTOLOAD
135a59c2 103 $Be_Silent
6658a91b 104 $CONFIG_DIRTY
6658a91b 105 $Defaultdocs
2b3bde2a 106 $Echo_readline
6658a91b
SP		 107 $Frontend
108 $GOTOSHELL
109 $HAS_USABLE
110 $Have_warned
f20de9f0 111 $MAX_RECURSION
6658a91b 112 $META
05bab18e 113 $RUN_DEGRADED
6658a91b 114 $Signal
be34b10d 115 $SQLite
6658a91b
SP		 116 $Suppress_readline
117 $VERSION
135a59c2 118 $autoload_recursion
6658a91b
SP		 119 $term
120 @Defaultsites
121 @EXPORT
135a59c2 122 );
6d29edf5 123
f20de9f0
SP		 124$MAX_RECURSION = 32;
125
2e2b7522 126@CPAN::ISA = qw(CPAN::Debug Exporter);
5f05dabc 127
44d21104
A		 128# note that these functions live in CPAN::Shell and get executed via
129# AUTOLOAD when called directly
55e314ee 130@EXPORT = qw(
44d21104
A		 131 autobundle
132 bundle
133 clean
134 cvs_import
135 expand
136 force
b72dd56f 137 fforce
44d21104
A		 138 get
139 install
05bab18e 140 install_tested
f20de9f0 141 is_tested
44d21104
A		 142 make
143 mkmyconfig
144 notest
145 perldoc
146 readme
147 recent
148 recompile
8fc516fe 149 report
44d21104 150 shell
f04ea8d1 151 smoke
44d21104 152 test
ed84aac9 153 upgrade
f04ea8d1 154 );
5f05dabc 155
0cf35e6a
SP		 156sub soft_chdir_with_alternatives ($);
157
135a59c2
A		 158{
159 $autoload_recursion ||= 0;
160
161 #-> sub CPAN::AUTOLOAD ;
162 sub AUTOLOAD {
163 $autoload_recursion++;
164 my($l) = $AUTOLOAD;
165 $l =~ s/.*:://;
166 if ($CPAN::Signal) {
167 warn "Refusing to autoload '$l' while signal pending";
168 $autoload_recursion--;
169 return;
170 }
171 if ($autoload_recursion > 1) {
172 my $fullcommand = join " ", map { "'$_'" } $l, @_;
173 warn "Refusing to autoload $fullcommand in recursion\n";
174 $autoload_recursion--;
175 return;
176 }
177 my(%export);
178 @export{@EXPORT} = '';
179 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
f04ea8d1 180 if (exists $export{$l}) {
135a59c2
A		 181 CPAN::Shell->$l(@_);
182 } else {
183 die(qq{Unknown CPAN command "$AUTOLOAD". }.
184 qq{Type ? for help.\n});
185 }
186 $autoload_recursion--;
55e314ee
A		 187 }
188}
189
5254b38e
SP		 190{
191 my $x = *SAVEOUT; # avoid warning
192 open($x,">&STDOUT") or die "dup failed";
193 my $redir = 0;
194 sub _redirect(@) {
195 #die if $redir;
196 local $_;
197 push(@_,undef);
198 while(defined($_=shift)) {
199 if (s/^\s*>//){
200 my ($m) = s/^>// ? ">" : "";
201 s/\s+//;
202 $_=shift unless length;
203 die "no dest" unless defined;
204 open(STDOUT,">$m$_") or die "open:$_:$!\n";
205 $redir=1;
206 } elsif ( s/^\s*\|\s*// ) {
207 my $pipe="| $_";
208 while(defined($_[0])){
209 $pipe .= ' ' . shift;
210 }
211 open(STDOUT,$pipe) or die "open:$pipe:$!\n";
212 $redir=1;
213 } else {
214 push(@_,$_);
215 }
216 }
217 return @_;
218 }
219 sub _unredirect {
220 return unless $redir;
221 $redir = 0;
222 ## redirect: unredirect and propagate errors. explicit close to wait for pipe.
223 close(STDOUT);
224 open(STDOUT,">&SAVEOUT");
225 die "$@" if "$@";
226 ## redirect: done
227 }
228}
229
55e314ee
A		 230#-> sub CPAN::shell ;
231sub shell {
36263cb3 232 my($self) = @_;
911a92db 233 $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
e82b9348 234 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
55e314ee 235
9ddc4ed0 236 my $oprompt = shift || CPAN::Prompt->new;
9d61fa1d
A		 237 my $prompt = $oprompt;
238 my $commandline = shift || "";
9ddc4ed0 239 $CPAN::CurrentCommandId ||= 1;
5e05dca5 240
55e314ee
A		 241 local($^W) = 1;
242 unless ($Suppress_readline) {
f04ea8d1 243 require Term::ReadLine;
9d61fa1d
A		 244 if (! $term
245 or
246 $term->ReadLine eq "Term::ReadLine::Stub"
247 ) {
248 $term = Term::ReadLine->new('CPAN Monitor');
249 }
f04ea8d1
SP		 250 if ($term->ReadLine eq "Term::ReadLine::Gnu") {
251 my $attribs = $term->Attribs;
252 $attribs->{attempted_completion_function} = sub {
253 &CPAN::Complete::gnu_cpl;
254 }
255 } else {
256 $readline::rl_completion_function =
257 $readline::rl_completion_function = 'CPAN::Complete::cpl';
258 }
5fc0f0f6
JH		 259 if (my $histfile = $CPAN::Config->{'histfile'}) {{
260 unless ($term->can("AddHistory")) {
261 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
262 last;
263 }
f20de9f0 264 $META->readhist($term,$histfile);
5fc0f0f6 265 }}
8962fc49
SP		 266 for ($CPAN::Config->{term_ornaments}) { # alias
267 local $Term::ReadLine::termcap_nowarn = 1;
ed84aac9
A		 268 $term->ornaments($_) if defined;
269 }
f04ea8d1
SP		 270 # $term->OUT is autoflushed anyway
271 my $odef = select STDERR;
272 $| = 1;
273 select STDOUT;
274 $| = 1;
275 select $odef;
55e314ee
A		 276 }
277
55e314ee 278 $META->checklock();
135a59c2
A		 279 my @cwd = grep { defined $_ and length $_ }
280 CPAN::anycwd(),
281 File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
282 File::Spec->rootdir();
911a92db
GS		 283 my $try_detect_readline;
284 $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
f04ea8d1
SP		 285 unless ($CPAN::Config->{inhibit_startup_message}) {
286 my $rl_avail = $Suppress_readline ? "suppressed" :
287 ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
288 "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
8962fc49
SP		 289 $CPAN::Frontend->myprint(
290 sprintf qq{
554a9ef5 291cpan shell -- CPAN exploration and modules installation (v%s)
6d29edf5 292ReadLine support %s
55e314ee 293
6d29edf5 294},
8962fc49
SP		 295 $CPAN::VERSION,
296 $rl_avail
297 )
298 }
c356248b 299 my($continuation) = "";
8962fc49 300 my $last_term_ornaments;
8d97e4a1 301 SHELLCOMMAND: while () {
f04ea8d1 302 if ($Suppress_readline) {
2b3bde2a
SP		 303 if ($Echo_readline) {
304 $|=1;
305 }
f04ea8d1
SP		 306 print $prompt;
307 last SHELLCOMMAND unless defined ($_ = <> );
2b3bde2a
SP		 308 if ($Echo_readline) {
309 # backdoor: I could not find a way to record sessions
310 print $_;
311 }
f04ea8d1
SP		 312 chomp;
313 } else {
314 last SHELLCOMMAND unless
8d97e4a1 315 defined ($_ = $term->readline($prompt, $commandline));
f04ea8d1
SP		 316 }
317 $_ = "$continuation$_" if $continuation;
318 s/^\s+//;
319 next SHELLCOMMAND if /^$/;
320 s/^\s*\?\s*/help /;
321 if (/^(?:q(?:uit)?|bye|exit)$/i) {
322 last SHELLCOMMAND;
323 } elsif (s/\\$//s) {
324 chomp;
325 $continuation = $_;
326 $prompt = " > ";
327 } elsif (/^\!/) {
328 s/^\!//;
329 my($eval) = $_;
330 package CPAN::Eval;
e82b9348 331 use strict;
f04ea8d1
SP		 332 use vars qw($import_done);
333 CPAN->import(':DEFAULT') unless $import_done++;
334 CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
335 eval($eval);
336 warn $@ if $@;
337 $continuation = "";
338 $prompt = $oprompt;
339 } elsif (/./) {
340 my(@line);
6a935156
SP		 341 eval { @line = Text::ParseWords::shellwords($_) };
342 warn($@), next SHELLCOMMAND if $@;
343 warn("Text::Parsewords could not parse the line [$_]"),
344 next SHELLCOMMAND unless @line;
f04ea8d1
SP		 345 $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
346 my $command = shift @line;
5254b38e
SP		 347 eval {
348 local (*STDOUT)=*STDOUT;
349 @line = _redirect(@line);
350 CPAN::Shell->$command(@line)
351 };
352 _unredirect;
f04ea8d1
SP		 353 if ($@) {
354 my $err = "$@";
355 if ($err =~ /\S/) {
356 require Carp;
357 require Dumpvalue;
5254b38e 358 my $dv = Dumpvalue->new(tick => '"');
f04ea8d1
SP		 359 Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
360 }
361 }
362 if ($command =~ /^(
363 # classic commands
364 make
365 |test
366 |install
367 |clean
368
369 # pragmas for classic commands
370 |ff?orce
371 |notest
372
373 # compounds
374 |report
375 |smoke
376 |upgrade
377 )$/x) {
378 # only commands that tell us something about failed distros
9ddc4ed0
A		 379 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
380 }
0cf35e6a 381 soft_chdir_with_alternatives(\@cwd);
f04ea8d1
SP		 382 $CPAN::Frontend->myprint("\n");
383 $continuation = "";
9ddc4ed0 384 $CPAN::CurrentCommandId++;
f04ea8d1
SP		 385 $prompt = $oprompt;
386 }
55e314ee 387 } continue {
f04ea8d1
SP		 388 $commandline = ""; # I do want to be able to pass a default to
389 # shell, but on the second command I see no
390 # use in that
391 $Signal=0;
392 CPAN::Queue->nullify_queue;
393 if ($try_detect_readline) {
394 if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
395 ||
396 $CPAN::META->has_inst("Term::ReadLine::Perl")
397 ) {
398 delete $INC{"Term/ReadLine.pm"};
399 my $redef = 0;
400 local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
401 require Term::ReadLine;
402 $CPAN::Frontend->myprint("\n$redef subroutines in ".
403 "Term::ReadLine redefined\n");
404 $GOTOSHELL = 1;
405 }
406 }
407 if ($term and $term->can("ornaments")) {
408 for ($CPAN::Config->{term_ornaments}) { # alias
409 if (defined $_) {
410 if (not defined $last_term_ornaments
411 or $_ != $last_term_ornaments
412 ) {
413 local $Term::ReadLine::termcap_nowarn = 1;
414 $term->ornaments($_);
415 $last_term_ornaments = $_;
416 }
417 } else {
418 undef $last_term_ornaments;
419 }
420 }
421 }
422 for my $class (qw(Module Distribution)) {
423 # again unsafe meta access?
424 for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
425 next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
426 CPAN->debug("BUG: $class '$dm' was in command state, resetting");
427 delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
428 }
429 }
430 if ($GOTOSHELL) {
431 $GOTOSHELL = 0; # not too often
432 $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
433 @_ = ($oprompt,"");
434 goto &shell;
435 }
55e314ee 436 }
0cf35e6a 437 soft_chdir_with_alternatives(\@cwd);
55e314ee
A		 438}
439
ecc7fca0 440#-> CPAN::soft_chdir_with_alternatives ;
0cf35e6a
SP		 441sub soft_chdir_with_alternatives ($) {
442 my($cwd) = @_;
135a59c2
A		 443 unless (@$cwd) {
444 my $root = File::Spec->rootdir();
445 $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
446Trying '$root' as temporary haven.
0cf35e6a 447});
135a59c2
A		 448 push @$cwd, $root;
449 }
450 while () {
451 if (chdir $cwd->[0]) {
452 return;
0cf35e6a 453 } else {
135a59c2
A		 454 if (@$cwd>1) {
455 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
456Trying to chdir to "$cwd->[1]" instead.
457});
458 shift @$cwd;
459 } else {
460 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
461 }
0cf35e6a
SP		 462 }
463 }
464}
44d21104 465
f04ea8d1
SP		 466sub _flock {
467 my($fh,$mode) = @_;
5254b38e 468 if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) {
f04ea8d1
SP		 469 return flock $fh, $mode;
470 } elsif (!$Have_warned->{"d_flock"}++) {
5254b38e 471 $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n");
f04ea8d1
SP		 472 $CPAN::Frontend->mysleep(5);
473 return 1;
474 } else {
475 return 1;
476 }
477}
478
b72dd56f 479sub _yaml_module () {
05bab18e
SP		 480 my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
481 if (
482 $yaml_module ne "YAML"
483 &&
484 !$CPAN::META->has_inst($yaml_module)
485 ) {
486 # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
487 $yaml_module = "YAML";
488 }
ade94d80
SP		 489 if ($yaml_module eq "YAML"
490 &&
491 $CPAN::META->has_inst($yaml_module)
492 &&
493 $YAML::VERSION < 0.60
494 &&
495 !$Have_warned->{"YAML"}++
496 ) {
497 $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
498 "I'll continue but problems are *very* likely to happen.\n"
499 );
500 $CPAN::Frontend->mysleep(5);
501 }
05bab18e
SP		 502 return $yaml_module;
503}
504
1e8f9a0a
SP		 505# CPAN::_yaml_loadfile
506sub _yaml_loadfile {
507 my($self,$local_file) = @_;
05bab18e 508 return +[] unless -s $local_file;
b72dd56f 509 my $yaml_module = _yaml_module;
1e8f9a0a 510 if ($CPAN::META->has_inst($yaml_module)) {
f04ea8d1
SP		 511 # temporarly enable yaml code deserialisation
512 no strict 'refs';
513 # 5.6.2 could not do the local() with the reference
5254b38e
SP		 514 # so we do it manually instead
515 my $old_loadcode = ${"$yaml_module\::LoadCode"};
f04ea8d1
SP		 516 ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
517
5254b38e 518 my ($code, @yaml);
f20de9f0 519 if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
f20de9f0
SP		 520 eval { @yaml = $code->($local_file); };
521 if ($@) {
522 # this shall not be done by the frontend
523 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
524 }
f20de9f0
SP		 525 } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
526 local *FH;
527 open FH, $local_file or die "Could not open '$local_file': $!";
528 local $/;
529 my $ystream = <FH>;
f20de9f0
SP		 530 eval { @yaml = $code->($ystream); };
531 if ($@) {
532 # this shall not be done by the frontend
533 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
534 }
1e8f9a0a 535 }
5254b38e
SP		 536 ${"$yaml_module\::LoadCode"} = $old_loadcode;
537 return \@yaml;
1e8f9a0a 538 } else {
b72dd56f
SP		 539 # this shall not be done by the frontend
540 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
1e8f9a0a 541 }
6658a91b 542 return +[];
1e8f9a0a
SP		 543}
544
05bab18e
SP		 545# CPAN::_yaml_dumpfile
546sub _yaml_dumpfile {
b72dd56f
SP		 547 my($self,$local_file,@what) = @_;
548 my $yaml_module = _yaml_module;
05bab18e 549 if ($CPAN::META->has_inst($yaml_module)) {
f20de9f0 550 my $code;
b72dd56f 551 if (UNIVERSAL::isa($local_file, "FileHandle")) {
f20de9f0 552 $code = UNIVERSAL::can($yaml_module, "Dump");
b72dd56f 553 eval { print $local_file $code->(@what) };
f20de9f0 554 } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
b72dd56f 555 eval { $code->($local_file,@what); };
f20de9f0
SP		 556 } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
557 local *FH;
558 open FH, ">$local_file" or die "Could not open '$local_file': $!";
559 print FH $code->(@what);
05bab18e
SP		 560 }
561 if ($@) {
b72dd56f 562 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
05bab18e
SP		 563 }
564 } else {
b72dd56f 565 if (UNIVERSAL::isa($local_file, "FileHandle")) {
be34b10d
SP		 566 # I think this case does not justify a warning at all
567 } else {
b72dd56f 568 die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
be34b10d 569 }
05bab18e
SP		 570 }
571}
572
be34b10d 573sub _init_sqlite () {
810a0276 574 unless ($CPAN::META->has_inst("CPAN::SQLite")) {
b72dd56f 575 $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
810a0276 576 unless $Have_warned->{"CPAN::SQLite"}++;
be34b10d
SP		 577 return;
578 }
810a0276 579 require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
be34b10d
SP		 580 $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
581}
582
810a0276
SP		 583{
584 my $negative_cache = {};
585 sub _sqlite_running {
586 if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
587 # need to cache the result, otherwise too slow
588 return $negative_cache->{fact};
589 } else {
590 $negative_cache = {}; # reset
591 }
592 my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
593 return $ret if $ret; # fast anyway
594 $negative_cache->{time} = time;
595 return $negative_cache->{fact} = $ret;
596 }
597}
598
55e314ee 599package CPAN::CacheMgr;
e82b9348 600use strict;
c356248b 601@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
5254b38e 602use Cwd qw(chdir);
55e314ee
A		 603use File::Find;
604
55e314ee 605package CPAN::FTP;
e82b9348 606use strict;
05bab18e 607use Fcntl qw(:flock);
f04ea8d1 608use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
55e314ee
A		 609@CPAN::FTP::ISA = qw(CPAN::Debug);
610
c049f953 611package CPAN::LWP::UserAgent;
e82b9348 612use strict;
c049f953 613use vars qw(@ISA $USER $PASSWD $SETUPDONE);
3c4b39be 614# we delay requiring LWP::UserAgent and setting up inheritance until we need it
c049f953 615
55e314ee 616package CPAN::Complete;
e82b9348 617use strict;
55e314ee 618@CPAN::Complete::ISA = qw(CPAN::Debug);
05bab18e
SP		 619# Q: where is the "How do I add a new command" HOWTO?
620# A: svn diff -r 1048:1049 where andk added the report command
9d61fa1d 621@CPAN::Complete::COMMANDS = sort qw(
f04ea8d1 622 ? ! a b d h i m o q r u
0cf35e6a 623 autobundle
f04ea8d1 624 bye
0cf35e6a
SP		 625 clean
626 cvs_import
627 dump
f04ea8d1 628 exit
f20de9f0 629 failed
0cf35e6a 630 force
b72dd56f 631 fforce
05bab18e 632 hosts
0cf35e6a 633 install
05bab18e 634 install_tested
f20de9f0 635 is_tested
0cf35e6a
SP		 636 look
637 ls
44d21104
A		 638 make
639 mkmyconfig
0cf35e6a
SP		 640 notest
641 perldoc
f04ea8d1 642 quit
0cf35e6a
SP		 643 readme
644 recent
44d21104 645 recompile
0cf35e6a 646 reload
8fc516fe 647 report
dc053c64 648 reports
ed84aac9 649 scripts
f04ea8d1 650 smoke
44d21104 651 test
ed84aac9 652 upgrade
0cf35e6a 653);
55e314ee
A		 654
655package CPAN::Index;
e82b9348 656use strict;
05bab18e 657use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
55e314ee 658@CPAN::Index::ISA = qw(CPAN::Debug);
c049f953
JH		 659$LAST_TIME ||= 0;
660$DATE_OF_03 ||= 0;
6d29edf5
JH		 661# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
662sub PROTOCOL { 2.0 }
55e314ee
A		 663
664package CPAN::InfoObj;
e82b9348 665use strict;
55e314ee
A		 666@CPAN::InfoObj::ISA = qw(CPAN::Debug);
667
668package CPAN::Author;
e82b9348 669use strict;
55e314ee
A		 670@CPAN::Author::ISA = qw(CPAN::InfoObj);
671
672package CPAN::Distribution;
e82b9348 673use strict;
55e314ee
A		 674@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
675
676package CPAN::Bundle;
e82b9348 677use strict;
55e314ee
A		 678@CPAN::Bundle::ISA = qw(CPAN::Module);
679
680package CPAN::Module;
e82b9348 681use strict;
55e314ee 682@CPAN::Module::ISA = qw(CPAN::InfoObj);
10b2abe6 683
35576f8c 684package CPAN::Exception::RecursiveDependency;
e82b9348 685use strict;
35576f8c
A		 686use overload '""' => "as_string";
687
f20de9f0
SP		 688# a module sees its distribution (no version)
689# a distribution sees its prereqs (which are module names) (usually with versions)
690# a bundle sees its module names and/or its distributions (no version)
691
35576f8c
A		 692sub new {
693 my($class) = shift;
694 my($deps) = shift;
ade94d80
SP		 695 my (@deps,%seen,$loop_starts_with);
696 DCHAIN: for my $dep (@$deps) {
697 push @deps, {name => $dep, display_as => $dep};
f04ea8d1 698 if ($seen{$dep}++) {
ade94d80
SP		 699 $loop_starts_with = $dep;
700 last DCHAIN;
701 }
702 }
703 my $in_loop = 0;
704 for my $i (0..$#deps) {
705 my $x = $deps[$i]{name};
706 $in_loop ||= $x eq $loop_starts_with;
707 my $xo = CPAN::Shell->expandany($x) or next;
708 if ($xo->isa("CPAN::Module")) {
709 my $have = $xo->inst_version || "N/A";
710 my($want,$d,$want_type);
711 if ($i>0 and $d = $deps[$i-1]{name}) {
712 my $do = CPAN::Shell->expandany($d);
713 $want = $do->{prereq_pm}{requires}{$x};
714 if (defined $want) {
715 $want_type = "requires: ";
716 } else {
717 $want = $do->{prereq_pm}{build_requires}{$x};
718 if (defined $want) {
719 $want_type = "build_requires: ";
720 } else {
721 $want_type = "unknown status";
722 $want = "???";
723 }
724 }
725 } else {
726 $want = $xo->cpan_version;
727 $want_type = "want: ";
728 }
729 $deps[$i]{have} = $have;
730 $deps[$i]{want_type} = $want_type;
731 $deps[$i]{want} = $want;
732 $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
733 } elsif ($xo->isa("CPAN::Distribution")) {
734 $deps[$i]{display_as} = $xo->pretty_id;
735 if ($in_loop) {
736 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
737 } else {
738 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
739 }
740 $xo->store_persistent_state; # otherwise I will not reach
741 # all involved parties for
742 # the next session
743 }
35576f8c
A		 744 }
745 bless { deps => \@deps }, $class;
746}
747
748sub as_string {
749 my($self) = shift;
ade94d80
SP		 750 my $ret = "\nRecursive dependency detected:\n ";
751 $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
752 $ret .= ".\nCannot resolve.\n";
753 $ret;
35576f8c
A		 754}
755
b72dd56f
SP		 756package CPAN::Exception::yaml_not_installed;
757use strict;
758use overload '""' => "as_string";
759
760sub new {
761 my($class,$module,$file,$during) = @_;
762 bless { module => $module, file => $file, during => $during }, $class;
763}
764
765sub as_string {
766 my($self) = shift;
767 "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
768}
769
770package CPAN::Exception::yaml_process_error;
771use strict;
772use overload '""' => "as_string";
773
774sub new {
23a216b4 775 my($class,$module,$file,$during,$error) = @_;
5254b38e 776 # my $at = Carp::longmess(""); # XXX find something more beautiful
b72dd56f
SP		 777 bless { module => $module,
778 file => $file,
779 during => $during,
5254b38e
SP		 780 error => $error,
781 # at => $at,
782 }, $class;
b72dd56f
SP		 783}
784
785sub as_string {
786 my($self) = shift;
23a216b4
SP		 787 if ($self->{during}) {
788 if ($self->{file}) {
789 if ($self->{module}) {
790 if ($self->{error}) {
791 return "Alert: While trying to '$self->{during}' YAML file\n".
792 " '$self->{file}'\n".
793 "with '$self->{module}' the following error was encountered:\n".
794 " $self->{error}\n";
795 } else {
796 return "Alert: While trying to '$self->{during}' YAML file\n".
797 " '$self->{file}'\n".
798 "with '$self->{module}' some unknown error was encountered\n";
799 }
800 } else {
801 return "Alert: While trying to '$self->{during}' YAML file\n".
802 " '$self->{file}'\n".
803 "some unknown error was encountered\n";
804 }
805 } else {
806 return "Alert: While trying to '$self->{during}' some YAML file\n".
807 "some unknown error was encountered\n";
808 }
809 } else {
810 return "Alert: unknown error encountered\n";
811 }
b72dd56f
SP		 812}
813
9ddc4ed0 814package CPAN::Prompt; use overload '""' => "as_string";
4d1321a7
A		 815use vars qw($prompt);
816$prompt = "cpan> ";
9ddc4ed0 817$CPAN::CurrentCommandId ||= 0;
9ddc4ed0
A		 818sub new {
819 bless {}, shift;
820}
821sub as_string {
05bab18e
SP		 822 my $word = "cpan";
823 unless ($CPAN::META->{LOCK}) {
824 $word = "nolock_cpan";
825 }
9ddc4ed0 826 if ($CPAN::Config->{commandnumber_in_prompt}) {
05bab18e 827 sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
9ddc4ed0 828 } else {
05bab18e 829 "$word> ";
9ddc4ed0
A		 830 }
831}
832
7fefbd44
RGS		 833package CPAN::URL; use overload '""' => "as_string", fallback => 1;
834# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
835# planned are things like age or quality
836sub new {
837 my($class,%args) = @_;
838 bless {
839 %args
840 }, $class;
841}
842sub as_string {
843 my($self) = @_;
844 $self->text;
845}
846sub text {
847 my($self,$set) = @_;
848 if (defined $set) {
849 $self->{TEXT} = $set;
850 }
851 $self->{TEXT};
852}
853
9ddc4ed0
A		 854package CPAN::Distrostatus;
855use overload '""' => "as_string",
856 fallback => 1;
5254b38e 857use vars qw($something_has_failed_at);
9ddc4ed0
A		 858sub new {
859 my($class,$arg) = @_;
5254b38e
SP		 860 my $failed = substr($arg,0,2) eq "NO";
861 if ($failed) {
862 $something_has_failed_at = $CPAN::CurrentCommandId;
863 }
9ddc4ed0
A		 864 bless {
865 TEXT => $arg,
5254b38e 866 FAILED => $failed,
9ddc4ed0 867 COMMANDID => $CPAN::CurrentCommandId,
be34b10d 868 TIME => time,
9ddc4ed0
A		 869 }, $class;
870}
5254b38e
SP		 871sub something_has_just_failed () {
872 defined $something_has_failed_at &&
873 $something_has_failed_at == $CPAN::CurrentCommandId;
874}
9ddc4ed0
A		 875sub commandid { shift->{COMMANDID} }
876sub failed { shift->{FAILED} }
877sub text {
878 my($self,$set) = @_;
879 if (defined $set) {
880 $self->{TEXT} = $set;
881 }
882 $self->{TEXT};
883}
884sub as_string {
885 my($self) = @_;
4d1321a7 886 $self->text;
9ddc4ed0
A		 887}
888
55e314ee 889package CPAN::Shell;
e82b9348 890use strict;
6a935156
SP		 891use vars qw(
892 $ADVANCED_QUERY
893 $AUTOLOAD
894 $COLOR_REGISTERED
f04ea8d1 895 $Help
135a59c2 896 $autoload_recursion
6a935156
SP		 897 $reload
898 @ISA
5254b38e 899 @relo
135a59c2 900 );
5254b38e
SP		 901@relo = (
902 "CPAN.pm",
903 "CPAN/Debug.pm",
904 "CPAN/Distroprefs.pm",
905 "CPAN/FirstTime.pm",
906 "CPAN/HandleConfig.pm",
907 "CPAN/Kwalify.pm",
908 "CPAN/Queue.pm",
909 "CPAN/Reporter/Config.pm",
910 "CPAN/Reporter/History.pm",
911 "CPAN/Reporter/PrereqCheck.pm",
912 "CPAN/Reporter.pm",
913 "CPAN/SQLite.pm",
914 "CPAN/Tarzip.pm",
915 "CPAN/Version.pm",
916 );
917# record the initial timestamp for reload.
918$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
55e314ee 919@CPAN::Shell::ISA = qw(CPAN::Debug);
5254b38e 920use Cwd qw(chdir);
9d61fa1d 921$COLOR_REGISTERED ||= 0;
f04ea8d1
SP		 922$Help = {
923 '?' => \"help",
924 '!' => "eval the rest of the line as perl",
925 a => "whois author",
926 autobundle => "wtite inventory into a bundle file",
927 b => "info about bundle",
928 bye => \"quit",
929 clean => "clean up a distribution's build directory",
930 # cvs_import
931 d => "info about a distribution",
932 # dump
933 exit => \"quit",
934 failed => "list all failed actions within current session",
935 fforce => "redo a command from scratch",
936 force => "redo a command",
937 h => \"help",
938 help => "overview over commands; 'help ...' explains specific commands",
939 hosts => "statistics about recently used hosts",
940 i => "info about authors/bundles/distributions/modules",
941 install => "install a distribution",
942 install_tested => "install all distributions tested OK",
943 is_tested => "list all distributions tested OK",
944 look => "open a subshell in a distribution's directory",
945 ls => "list distributions according to a glob",
946 m => "info about a module",
947 make => "make/build a distribution",
948 mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
949 notest => "run a (usually install) command but leave out the test phase",
950 o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
951 perldoc => "try to get a manpage for a module",
952 q => \"quit",
953 quit => "leave the cpan shell",
954 r => "review over upgradeable modules",
955 readme => "display the README of a distro woth a pager",
956 recent => "show recent uploads to the CPAN",
957 # recompile
958 reload => "'reload cpan' or 'reload index'",
959 report => "test a distribution and send a test report to cpantesters",
960 reports => "info about reported tests from cpantesters",
961 # scripts
962 # smoke
963 test => "test a distribution",
964 u => "display uninstalled modules",
965 upgrade => "combine 'r' command with immediate installation",
966 };
135a59c2 967{
135a59c2
A		 968 $autoload_recursion ||= 0;
969
970 #-> sub CPAN::Shell::AUTOLOAD ;
971 sub AUTOLOAD {
972 $autoload_recursion++;
973 my($l) = $AUTOLOAD;
974 my $class = shift(@_);
975 # warn "autoload[$l] class[$class]";
976 $l =~ s/.*:://;
977 if ($CPAN::Signal) {
978 warn "Refusing to autoload '$l' while signal pending";
979 $autoload_recursion--;
980 return;
981 }
982 if ($autoload_recursion > 1) {
983 my $fullcommand = join " ", map { "'$_'" } $l, @_;
984 warn "Refusing to autoload $fullcommand in recursion\n";
985 $autoload_recursion--;
986 return;
987 }
988 if ($l =~ /^w/) {
989 # XXX needs to be reconsidered
990 if ($CPAN::META->has_inst('CPAN::WAIT')) {
991 CPAN::WAIT->$l(@_);
992 } else {
993 $CPAN::Frontend->mywarn(qq{
55e314ee
A		 994Commands starting with "w" require CPAN::WAIT to be installed.
995Please consider installing CPAN::WAIT to use the fulltext index.
f610777f 996For this you just need to type
55e314ee 997 install CPAN::WAIT
c356248b 998});
6d29edf5 999 }
135a59c2
A		 1000 } else {
1001 $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
1002 qq{Type ? for help.
1003});
6d29edf5 1004 }
135a59c2 1005 $autoload_recursion--;
f610777f 1006 }
36263cb3
GS		 1007}
1008
55e314ee 1009package CPAN;
e82b9348 1010use strict;
55e314ee 1011
2e2b7522 1012$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
55e314ee 1013
6d29edf5
JH		 1014# from here on only subs.
1015################################################################################
55e314ee 1016
05bab18e
SP		 1017sub _perl_fingerprint {
1018 my($self,$other_fingerprint) = @_;
1019 my $dll = eval {OS2::DLLname()};
1020 my $mtime_dll = 0;
1021 if (defined $dll) {
1022 $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
1023 }
b03f445c 1024 my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
05bab18e 1025 my $this_fingerprint = {
b03f445c 1026 '$^X' => CPAN::find_perl,
05bab18e 1027 sitearchexp => $Config::Config{sitearchexp},
f20de9f0 1028 'mtime_$^X' => $mtime_perl,
05bab18e
SP		 1029 'mtime_dll' => $mtime_dll,
1030 };
1031 if ($other_fingerprint) {
1032 if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
1033 $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
1034 }
1035 # mandatory keys since 1.88_57
1036 for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
1037 return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
1038 }
1039 return 1;
1040 } else {
1041 return $this_fingerprint;
1042 }
1043}
1044
ed84aac9
A		 1045sub suggest_myconfig () {
1046 SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
1047 $CPAN::Frontend->myprint("You don't seem to have a user ".
1048 "configuration (MyConfig.pm) yet.\n");
8962fc49 1049 my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
ed84aac9
A		 1050 "user configuration now? (Y/n)",
1051 "yes");
1052 if($new =~ m{^y}i) {
1053 CPAN::Shell->mkmyconfig();
1054 return &checklock;
1055 } else {
1056 $CPAN::Frontend->mydie("OK, giving up.");
1057 }
1058 }
1059}
1060
6d29edf5 1061#-> sub CPAN::all_objects ;
36263cb3 1062sub all_objects {
5f05dabc 1063 my($mgr,$class) = @_;
e82b9348 1064 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
5f05dabc 1065 CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
1066 CPAN::Index->reload;
6d29edf5 1067 values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
5f05dabc 1068}
1069
c4d24d4c
A		 1070# Called by shell, not in batch mode. In batch mode I see no risk in
1071# having many processes updating something as installations are
1072# continually checked at runtime. In shell mode I suspect it is
1073# unintentional to open more than one shell at a time
1074
10b2abe6 1075#-> sub CPAN::checklock ;
5f05dabc 1076sub checklock {
1077 my($self) = @_;
5de3f0da 1078 my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
5f05dabc 1079 if (-f $lockfile && -M _ > 0) {
f04ea8d1 1080 my $fh = FileHandle->new($lockfile) or
9ddc4ed0 1081 $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
f04ea8d1
SP		 1082 my $otherpid = <$fh>;
1083 my $otherhost = <$fh>;
1084 $fh->close;
1085 if (defined $otherpid && $otherpid) {
1086 chomp $otherpid;
1087 }
1088 if (defined $otherhost && $otherhost) {
1089 chomp $otherhost;
1090 }
1091 my $thishost = hostname();
1092 if (defined $otherhost && defined $thishost &&
1093 $otherhost ne '' && $thishost ne '' &&
1094 $otherhost ne $thishost) {
9ddc4ed0 1095 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
c9869e1c
SP		 1096 "reports other host $otherhost and other ".
1097 "process $otherpid.\n".
0dfa0441 1098 "Cannot proceed.\n"));
f04ea8d1 1099 } elsif ($RUN_DEGRADED) {
05bab18e
SP		 1100 $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
1101 } elsif (defined $otherpid && $otherpid) {
f04ea8d1
SP		 1102 return if $$ == $otherpid; # should never happen
1103 $CPAN::Frontend->mywarn(
1104 qq{
0dfa0441 1105There seems to be running another CPAN process (pid $otherpid). Contacting...
c356248b 1106});
5254b38e 1107 if (kill 0, $otherpid or $!{EPERM}) {
f04ea8d1
SP		 1108 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
1109 my($ans) =
1110 CPAN::Shell::colorable_makemaker_prompt
1111 (qq{Shall I try to run in degraded }.
1112 qq{mode? (Y/n)},"y");
05bab18e
SP		 1113 if ($ans =~ /^y/i) {
1114 $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
1115Please report if something unexpected happens\n");
1116 $RUN_DEGRADED = 1;
1117 for ($CPAN::Config) {
be34b10d
SP		 1118 # XXX
1119 # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
1120 $_->{commandnumber_in_prompt} = 0; # visibility
1121 $_->{histfile} = ""; # who should win otherwise?
1122 $_->{cache_metadata} = 0; # better would be a lock?
b72dd56f 1123 $_->{use_sqlite} = 0; # better would be a write lock!
05bab18e
SP		 1124 }
1125 } else {
1126 $CPAN::Frontend->mydie("
1127You may want to kill the other job and delete the lockfile. On UNIX try:
0dfa0441 1128 kill $otherpid
c356248b 1129 rm $lockfile
05bab18e
SP		 1130");
1131 }
f04ea8d1
SP		 1132 } elsif (-w $lockfile) {
1133 my($ans) =
1134 CPAN::Shell::colorable_makemaker_prompt
1135 (qq{Other job not responding. Shall I overwrite }.
1136 qq{the lockfile '$lockfile'? (Y/n)},"y");
1137 $CPAN::Frontend->myexit("Ok, bye\n")
1138 unless $ans =~ /^y/i;
1139 } else {
1140 Carp::croak(
1141 qq{Lockfile '$lockfile' not writeable by you. }.
1142 qq{Cannot proceed.\n}.
1143 qq{ On UNIX try:\n}.
1144 qq{ rm '$lockfile'\n}.
1145 qq{ and then rerun us.\n}
1146 );
1147 }
1148 } else {
05bab18e
SP		 1149 $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
1150 "'$lockfile', please remove. Cannot proceed.\n"));
6d29edf5 1151 }
5f05dabc 1152 }
36263cb3
GS		 1153 my $dotcpan = $CPAN::Config->{cpan_home};
1154 eval { File::Path::mkpath($dotcpan);};
1155 if ($@) {
ed84aac9
A		 1156 # A special case at least for Jarkko.
1157 my $firsterror = $@;
1158 my $seconderror;
1159 my $symlinkcpan;
1160 if (-l $dotcpan) {
1161 $symlinkcpan = readlink $dotcpan;
1162 die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
1163 eval { File::Path::mkpath($symlinkcpan); };
1164 if ($@) {
1165 $seconderror = $@;
1166 } else {
1167 $CPAN::Frontend->mywarn(qq{
36263cb3
GS		 1168Working directory $symlinkcpan created.
1169});
ed84aac9
A		 1170 }
1171 }
1172 unless (-d $dotcpan) {
1173 my $mess = qq{
36263cb3
GS		 1174Your configuration suggests "$dotcpan" as your
1175CPAN.pm working directory. I could not create this directory due
1176to this error: $firsterror\n};
ed84aac9 1177 $mess .= qq{
36263cb3
GS		 1178As "$dotcpan" is a symlink to "$symlinkcpan",
1179I tried to create that, but I failed with this error: $seconderror
1180} if $seconderror;
ed84aac9 1181 $mess .= qq{
36263cb3
GS		 1182Please make sure the directory exists and is writable.
1183};
f04ea8d1 1184 $CPAN::Frontend->mywarn($mess);
ed84aac9
A		 1185 return suggest_myconfig;
1186 }
44d21104 1187 } # $@ after eval mkpath $dotcpan
05bab18e
SP		 1188 if (0) { # to test what happens when a race condition occurs
1189 for (reverse 1..10) {
1190 print $_, "\n";
1191 sleep 1;
1192 }
1193 }
1194 # locking
1195 if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
1196 my $fh;
1197 unless ($fh = FileHandle->new("+>>$lockfile")) {
1198 if ($! =~ /Permission/) {
f04ea8d1 1199 $CPAN::Frontend->mywarn(qq{
5f05dabc 1200
1201Your configuration suggests that CPAN.pm should use a working
1202directory of
1203 $CPAN::Config->{cpan_home}
1204Unfortunately we could not create the lock file
1205 $lockfile
1206due to permission problems.
1207
1208Please make sure that the configuration variable
1209 \$CPAN::Config->{cpan_home}
1210points to a directory where you can write a .lock file. You can set
87892b73
RGS		 1211this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1212\@INC path;
c356248b 1213});
05bab18e
SP		 1214 return suggest_myconfig;
1215 }
1216 }
1217 my $sleep = 1;
f04ea8d1 1218 while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
05bab18e
SP		 1219 if ($sleep>10) {
1220 $CPAN::Frontend->mydie("Giving up\n");
1221 }
1222 $CPAN::Frontend->mysleep($sleep++);
1223 $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1224 }
1225
1226 seek $fh, 0, 0;
1227 truncate $fh, 0;
b03f445c 1228 $fh->autoflush(1);
05bab18e
SP		 1229 $fh->print($$, "\n");
1230 $fh->print(hostname(), "\n");
1231 $self->{LOCK} = $lockfile;
1232 $self->{LOCKFH} = $fh;
5f05dabc 1233 }
6d29edf5 1234 $SIG{TERM} = sub {
135a59c2
A		 1235 my $sig = shift;
1236 &cleanup;
1237 $CPAN::Frontend->mydie("Got SIG$sig, leaving");
c356248b 1238 };
6d29edf5 1239 $SIG{INT} = sub {
09d9d230 1240 # no blocks!!!
135a59c2
A		 1241 my $sig = shift;
1242 &cleanup if $Signal;
1243 die "Got yet another signal" if $Signal > 1;
1244 $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1245 $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1246 $Signal++;
da199366 1247 };
911a92db
GS		 1248
1249# From: Larry Wall <larry@wall.org>
1250# Subject: Re: deprecating SIGDIE
1251# To: perl5-porters@perl.org
1252# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1253#
1254# The original intent of __DIE__ was only to allow you to substitute one
1255# kind of death for another on an application-wide basis without respect
1256# to whether you were in an eval or not. As a global backstop, it should
1257# not be used any more lightly (or any more heavily :-) than class
1258# UNIVERSAL. Any attempt to build a general exception model on it should
1259# be politely squashed. Any bug that causes every eval {} to have to be
1260# modified should be not so politely squashed.
1261#
1262# Those are my current opinions. It is also my optinion that polite
1263# arguments degenerate to personal arguments far too frequently, and that
1264# when they do, it's because both people wanted it to, or at least didn't
1265# sufficiently want it not to.
1266#
1267# Larry
1268
6d29edf5
JH		 1269 # global backstop to cleanup if we should really die
1270 $SIG{__DIE__} = \&cleanup;
e50380aa 1271 $self->debug("Signal handler set.") if $CPAN::DEBUG;
5f05dabc 1272}
1273
10b2abe6 1274#-> sub CPAN::DESTROY ;
5f05dabc 1275sub DESTROY {
1276 &cleanup; # need an eval?
1277}
1278
9d61fa1d
A		 1279#-> sub CPAN::anycwd ;
1280sub anycwd () {
1281 my $getcwd;
1282 $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1283 CPAN->$getcwd();
1284}
1285
55e314ee
A		 1286#-> sub CPAN::cwd ;
1287sub cwd {Cwd::cwd();}
1288
1289#-> sub CPAN::getcwd ;
1290sub getcwd {Cwd::getcwd();}
1291
ca79d794
SP		 1292#-> sub CPAN::fastcwd ;
1293sub fastcwd {Cwd::fastcwd();}
1294
1295#-> sub CPAN::backtickcwd ;
1296sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1297
607a774b 1298#-> sub CPAN::find_perl ;
b03f445c 1299sub find_perl () {
607a774b 1300 my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
5254b38e
SP		 1301 unless ($perl) {
1302 my $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
1303 $^X = $perl = $candidate if MM->maybe_command($candidate);
1304 }
607a774b 1305 unless ($perl) {
f04ea8d1 1306 my ($component,$perl_name);
607a774b 1307 DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
f04ea8d1
SP		 1308 PATH_COMPONENT: foreach $component (File::Spec->path(),
1309 $Config::Config{'binexp'}) {
1310 next unless defined($component) && $component;
1311 my($abs) = File::Spec->catfile($component,$perl_name);
1312 if (MM->maybe_command($abs)) {
5254b38e 1313 $^X = $perl = $abs;
f04ea8d1
SP		 1314 last DIST_PERLNAME;
1315 }
1316 }
1317 }
607a774b 1318 }
607a774b
MS		 1319 return $perl;
1320}
1321
1322
10b2abe6 1323#-> sub CPAN::exists ;
5f05dabc 1324sub exists {
1325 my($mgr,$class,$id) = @_;
e82b9348 1326 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
5f05dabc 1327 CPAN::Index->reload;
e50380aa 1328 ### Carp::croak "exists called without class argument" unless $class;
5f05dabc 1329 $id ||= "";
e82b9348 1330 $id =~ s/:+/::/g if $class eq "CPAN::Module";
810a0276
SP		 1331 my $exists;
1332 if (CPAN::_sqlite_running) {
1333 $exists = (exists $META->{readonly}{$class}{$id} or
1334 $CPAN::SQLite->set($class, $id));
be34b10d 1335 } else {
810a0276 1336 $exists = exists $META->{readonly}{$class}{$id};
be34b10d 1337 }
810a0276 1338 $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
5f05dabc 1339}
1340
09d9d230
A		 1341#-> sub CPAN::delete ;
1342sub delete {
1343 my($mgr,$class,$id) = @_;
6d29edf5
JH		 1344 delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1345 delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
09d9d230
A		 1346}
1347
de34a54b
JH		 1348#-> sub CPAN::has_usable
1349# has_inst is sometimes too optimistic, we should replace it with this
1350# has_usable whenever a case is given
1351sub has_usable {
1352 my($self,$mod,$message) = @_;
1353 return 1 if $HAS_USABLE->{$mod};
1354 my $has_inst = $self->has_inst($mod,$message);
1355 return unless $has_inst;
6d29edf5
JH		 1356 my $usable;
1357 $usable = {
1358 LWP => [ # we frequently had "Can't locate object
1359 # method "new" via package "LWP::UserAgent" at
1360 # (eval 69) line 2006
1361 sub {require LWP},
1362 sub {require LWP::UserAgent},
1363 sub {require HTTP::Request},
1364 sub {require URI::URL},
1365 ],
ec5fee46 1366 'Net::FTP' => [
6d29edf5
JH		 1367 sub {require Net::FTP},
1368 sub {require Net::Config},
87892b73
RGS		 1369 ],
1370 'File::HomeDir' => [
1371 sub {require File::HomeDir;
b03f445c 1372 unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
87892b73 1373 for ("Will not use File::HomeDir, need 0.52\n") {
ed84aac9 1374 $CPAN::Frontend->mywarn($_);
87892b73
RGS		 1375 die $_;
1376 }
1377 }
1378 },
1379 ],
f20de9f0
SP		 1380 'Archive::Tar' => [
1381 sub {require Archive::Tar;
b03f445c 1382 unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.00)) {
f20de9f0
SP		 1383 for ("Will not use Archive::Tar, need 1.00\n") {
1384 $CPAN::Frontend->mywarn($_);
1385 die $_;
1386 }
1387 }
1388 },
1389 ],
b03f445c
RGS		 1390 'File::Temp' => [
1391 # XXX we should probably delete from
1392 # %INC too so we can load after we
1393 # installed a new enough version --
1394 # I'm not sure.
1395 sub {require File::Temp;
1396 unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
1397 for ("Will not use File::Temp, need 0.16\n") {
1398 $CPAN::Frontend->mywarn($_);
1399 die $_;
1400 }
1401 }
1402 },
1403 ]
6d29edf5
JH		 1404 };
1405 if ($usable->{$mod}) {
87892b73
RGS		 1406 for my $c (0..$#{$usable->{$mod}}) {
1407 my $code = $usable->{$mod}[$c];
1408 my $ret = eval { &$code() };
1409 $ret = "" unless defined $ret;
1410 if ($@) {
1411 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1412 return;
1413 }
de34a54b 1414 }
de34a54b
JH		 1415 }
1416 return $HAS_USABLE->{$mod} = 1;
1417}
1418
55e314ee
A		 1419#-> sub CPAN::has_inst
1420sub has_inst {
1421 my($self,$mod,$message) = @_;
1422 Carp::croak("CPAN->has_inst() called without an argument")
f04ea8d1 1423 unless defined $mod;
4d1321a7
A		 1424 my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1425 keys %{$CPAN::Config->{dontload_hash}||{}},
1426 @{$CPAN::Config->{dontload_list}||[]};
1427 if (defined $message && $message eq "no" # afair only used by Nox
de34a54b 1428 ||
4d1321a7 1429 $dont{$mod}
de34a54b 1430 ) {
6d29edf5 1431 $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
de34a54b 1432 return 0;
55e314ee
A		 1433 }
1434 my $file = $mod;
c356248b 1435 my $obj;
55e314ee 1436 $file =~ s|::|/|g;
55e314ee 1437 $file .= ".pm";
c356248b 1438 if ($INC{$file}) {
f04ea8d1
SP		 1439 # checking %INC is wrong, because $INC{LWP} may be true
1440 # although $INC{"URI/URL.pm"} may have failed. But as
1441 # I really want to say "bla loaded OK", I have to somehow
1442 # cache results.
1443 ### warn "$file in %INC"; #debug
1444 return 1;
55e314ee 1445 } elsif (eval { require $file }) {
f04ea8d1
SP		 1446 # eval is good: if we haven't yet read the database it's
1447 # perfect and if we have installed the module in the meantime,
1448 # it tries again. The second require is only a NOOP returning
1449 # 1 if we had success, otherwise it's retrying
1450
1451 my $mtime = (stat $INC{$file})[9];
1452 # privileged files loaded by has_inst; Note: we use $mtime
1453 # as a proxy for a checksum.
1454 $CPAN::Shell::reload->{$file} = $mtime;
6a935156
SP		 1455 my $v = eval "\$$mod\::VERSION";
1456 $v = $v ? " (v$v)" : "";
f04ea8d1
SP		 1457 CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
1458 if ($mod eq "CPAN::WAIT") {
1459 push @CPAN::Shell::ISA, 'CPAN::WAIT';
1460 }
1461 return 1;
55e314ee 1462 } elsif ($mod eq "Net::FTP") {
f04ea8d1 1463 $CPAN::Frontend->mywarn(qq{
55e314ee
A		 1464 Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1465 if you just type
1466 install Bundle::libnet
5f05dabc 1467
5a5fac02 1468}) unless $Have_warned->{"Net::FTP"}++;
f04ea8d1
SP		 1469 $CPAN::Frontend->mysleep(3);
1470 } elsif ($mod eq "Digest::SHA") {
4d1321a7 1471 if ($Have_warned->{"Digest::SHA"}++) {
f04ea8d1 1472 $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
4d1321a7
A		 1473 qq{because Digest::SHA not installed.\n});
1474 } else {
8962fc49 1475 $CPAN::Frontend->mywarn(qq{
e82b9348
SP		 1476 CPAN: checksum security checks disabled because Digest::SHA not installed.
1477 Please consider installing the Digest::SHA module.
c356248b
A		 1478
1479});
8962fc49 1480 $CPAN::Frontend->mysleep(2);
4d1321a7 1481 }
f04ea8d1 1482 } elsif ($mod eq "Module::Signature") {
be34b10d
SP		 1483 # NOT prefs_lookup, we are not a distro
1484 my $check_sigs = $CPAN::Config->{check_sigs};
1485 if (not $check_sigs) {
ed84aac9
A		 1486 # they do not want us:-(
1487 } elsif (not $Have_warned->{"Module::Signature"}++) {
f04ea8d1
SP		 1488 # No point in complaining unless the user can
1489 # reasonably install and use it.
1490 if (eval { require Crypt::OpenPGP; 1 } ||
1491 (
ed84aac9
A		 1492 defined $CPAN::Config->{'gpg'}
1493 &&
1494 $CPAN::Config->{'gpg'} =~ /\S/
1495 )
1496 ) {
f04ea8d1 1497 $CPAN::Frontend->mywarn(qq{
554a9ef5
SP		 1498 CPAN: Module::Signature security checks disabled because Module::Signature
1499 not installed. Please consider installing the Module::Signature module.
1500 You may also need to be able to connect over the Internet to the public
1501 keyservers like pgp.mit.edu (port 11371).
1502
1503});
f04ea8d1
SP		 1504 $CPAN::Frontend->mysleep(2);
1505 }
1506 }
f14b5cec 1507 } else {
f04ea8d1 1508 delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
05454584 1509 }
55e314ee 1510 return 0;
05454584
A		 1511}
1512
10b2abe6 1513#-> sub CPAN::instance ;
5f05dabc 1514sub instance {
1515 my($mgr,$class,$id) = @_;
1516 CPAN::Index->reload;
5f05dabc 1517 $id ||= "";
6d29edf5
JH		 1518 # unsafe meta access, ok?
1519 return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1520 $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
5f05dabc 1521}
1522
10b2abe6 1523#-> sub CPAN::new ;
5f05dabc 1524sub new {
1525 bless {}, shift;
1526}
1527
10b2abe6 1528#-> sub CPAN::cleanup ;
5f05dabc 1529sub cleanup {
e82b9348 1530 # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
2e2b7522
GS		 1531 local $SIG{__DIE__} = '';
1532 my($message) = @_;
1533 my $i = 0;
1534 my $ineval = 0;
5fc0f0f6
JH		 1535 my($subroutine);
1536 while ((undef,undef,undef,$subroutine) = caller(++$i)) {
2e2b7522 1537 $ineval = 1, last if
f04ea8d1 1538 $subroutine eq '(eval)';
2e2b7522 1539 }
e82b9348 1540 return if $ineval && !$CPAN::End;
5fc0f0f6
JH		 1541 return unless defined $META->{LOCK};
1542 return unless -f $META->{LOCK};
1543 $META->savehist;
b72dd56f 1544 close $META->{LOCKFH};
5fc0f0f6 1545 unlink $META->{LOCK};
2e2b7522
GS		 1546 # require Carp;
1547 # Carp::cluck("DEBUGGING");
6658a91b
SP		 1548 if ( $CPAN::CONFIG_DIRTY ) {
1549 $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1550 }
8962fc49 1551 $CPAN::Frontend->myprint("Lockfile removed.\n");
5f05dabc 1552}
1553
f20de9f0
SP		 1554#-> sub CPAN::readhist
1555sub readhist {
1556 my($self,$term,$histfile) = @_;
5254b38e
SP		 1557 my $histsize = $CPAN::Config->{'histsize'} || 100;
1558 $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
f20de9f0 1559 my($fh) = FileHandle->new;
5254b38e 1560 open $fh, "<$histfile" or return;
f20de9f0
SP		 1561 local $/ = "\n";
1562 while (<$fh>) {
1563 chomp;
1564 $term->AddHistory($_);
1565 }
1566 close $fh;
1567}
1568
5fc0f0f6
JH		 1569#-> sub CPAN::savehist
1570sub savehist {
1571 my($self) = @_;
1572 my($histfile,$histsize);
f04ea8d1 1573 unless ($histfile = $CPAN::Config->{'histfile'}) {
5fc0f0f6
JH		 1574 $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1575 return;
1576 }
1577 $histsize = $CPAN::Config->{'histsize'} || 100;
f04ea8d1 1578 if ($CPAN::term) {
35576f8c
A		 1579 unless ($CPAN::term->can("GetHistory")) {
1580 $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1581 return;
1582 }
1583 } else {
5fc0f0f6
JH		 1584 return;
1585 }
1586 my @h = $CPAN::term->GetHistory;
1587 splice @h, 0, @h-$histsize if @h>$histsize;
1588 my($fh) = FileHandle->new;
35576f8c 1589 open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
5fc0f0f6
JH		 1590 local $\ = local $, = "\n";
1591 print $fh @h;
1592 close $fh;
1593}
1594
6658a91b 1595#-> sub CPAN::is_tested
4c070e31 1596sub is_tested {
b72dd56f
SP		 1597 my($self,$what,$when) = @_;
1598 unless ($what) {
1599 Carp::cluck("DEBUG: empty what");
1600 return;
1601 }
1602 $self->{is_tested}{$what} = $when;
4c070e31
IZ		 1603}
1604
5254b38e
SP		 1605#-> sub CPAN::reset_tested
1606# forget all distributions tested -- resets what gets included in PERL5LIB
1607sub reset_tested {
1608 my ($self) = @_;
1609 $self->{is_tested} = {};
1610}
1611
6658a91b 1612#-> sub CPAN::is_installed
135a59c2
A		 1613# unsets the is_tested flag: as soon as the thing is installed, it is
1614# not needed in set_perl5lib anymore
4c070e31
IZ		 1615sub is_installed {
1616 my($self,$what) = @_;
1617 delete $self->{is_tested}{$what};
1618}
1619
b72dd56f
SP		 1620sub _list_sorted_descending_is_tested {
1621 my($self) = @_;
1622 sort
1623 { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1624 keys %{$self->{is_tested}}
1625}
1626
6658a91b 1627#-> sub CPAN::set_perl5lib
5254b38e
SP		 1628# Notes on max environment variable length:
1629# - Win32 : XP or later, 8191; Win2000 or NT4, 2047
1630{
1631my $fh;
4c070e31 1632sub set_perl5lib {
6658a91b
SP		 1633 my($self,$for) = @_;
1634 unless ($for) {
1635 (undef,undef,undef,$for) = caller(1);
1636 $for =~ s/.*://;
1637 }
0362b508 1638 $self->{is_tested} ||= {};
4c070e31
IZ		 1639 return unless %{$self->{is_tested}};
1640 my $env = $ENV{PERL5LIB};
1641 $env = $ENV{PERLLIB} unless defined $env;
1642 my @env;
5254b38e 1643 push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
6658a91b
SP		 1644 #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1645 #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
b72dd56f
SP		 1646
1647 my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
5254b38e
SP		 1648 return if !@dirs;
1649
b72dd56f 1650 if (@dirs < 12) {
5254b38e
SP		 1651 $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
1652 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1653 } elsif (@dirs < 24 ) {
b72dd56f
SP		 1654 my @d = map {my $cp = $_;
1655 $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1656 $cp
1657 } @dirs;
5254b38e 1658 $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
b72dd56f
SP		 1659 "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1660 "for '$for'\n"
1661 );
5254b38e 1662 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
6658a91b 1663 } else {
b72dd56f 1664 my $cnt = keys %{$self->{is_tested}};
5254b38e 1665 $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
b72dd56f
SP		 1666 "$cnt build dirs to PERL5LIB; ".
1667 "for '$for'\n"
6658a91b 1668 );
5254b38e 1669 $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
6658a91b 1670 }
5254b38e 1671}}
4c070e31 1672
05454584 1673package CPAN::CacheMgr;
e82b9348 1674use strict;
5f05dabc 1675
05454584
A		 1676#-> sub CPAN::CacheMgr::as_string ;
1677sub as_string {
1678 eval { require Data::Dumper };
1679 if ($@) {
f04ea8d1 1680 return shift->SUPER::as_string;
5f05dabc 1681 } else {
f04ea8d1 1682 return Data::Dumper::Dumper(shift);
5f05dabc 1683 }
1684}
1685
05454584
A		 1686#-> sub CPAN::CacheMgr::cachesize ;
1687sub cachesize {
1688 shift->{DU};
5f05dabc 1689}
5f05dabc 1690
c4d24d4c 1691#-> sub CPAN::CacheMgr::tidyup ;
09d9d230
A		 1692sub tidyup {
1693 my($self) = @_;
be34b10d 1694 return unless $CPAN::META->{LOCK};
09d9d230 1695 return unless -d $self->{ID};
dc053c64
SP		 1696 my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1697 for my $current (0..$#toremove) {
1698 my $toremove = $toremove[$current];
1699 $CPAN::Frontend->myprint(sprintf(
1700 "DEL(%d/%d): %s \n",
1701 $current+1,
1702 scalar @toremove,
1703 $toremove,
1704 )
1705 );
09d9d230 1706 return if $CPAN::Signal;
810a0276 1707 $self->_clean_cache($toremove);
09d9d230
A		 1708 return if $CPAN::Signal;
1709 }
1710}
5f05dabc 1711
05454584
A		 1712#-> sub CPAN::CacheMgr::dir ;
1713sub dir {
1714 shift->{ID};
1715}
1716
1717#-> sub CPAN::CacheMgr::entries ;
1718sub entries {
1719 my($self,$dir) = @_;
55e314ee 1720 return unless defined $dir;
e50380aa 1721 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
05454584 1722 $dir ||= $self->{ID};
9d61fa1d 1723 my($cwd) = CPAN::anycwd();
05454584 1724 chdir $dir or Carp::croak("Can't chdir to $dir: $!");
f14b5cec
JH		 1725 my $dh = DirHandle->new(File::Spec->curdir)
1726 or Carp::croak("Couldn't opendir $dir: $!");
05454584
A		 1727 my(@entries);
1728 for ($dh->read) {
f04ea8d1
SP		 1729 next if $_ eq "." || $_ eq "..";
1730 if (-f $_) {
1731 push @entries, File::Spec->catfile($dir,$_);
1732 } elsif (-d _) {
1733 push @entries, File::Spec->catdir($dir,$_);
1734 } else {
1735 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1736 }
5f05dabc 1737 }
05454584 1738 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
dc053c64 1739 sort { -M $a <=> -M $b} @entries;
5f05dabc 1740}
1741
05454584
A		 1742#-> sub CPAN::CacheMgr::disk_usage ;
1743sub disk_usage {
dc053c64 1744 my($self,$dir,$fast) = @_;
09d9d230
A		 1745 return if exists $self->{SIZE}{$dir};
1746 return if $CPAN::Signal;
1747 my($Du) = 0;
c9869e1c 1748 if (-e $dir) {
2b3bde2a
SP		 1749 if (-d $dir) {
1750 unless (-x $dir) {
1751 unless (chmod 0755, $dir) {
1752 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1753 "permission to change the permission; cannot ".
1754 "estimate disk usage of '$dir'\n");
1755 $CPAN::Frontend->mysleep(5);
1756 return;
1757 }
c9869e1c 1758 }
2b3bde2a
SP		 1759 } elsif (-f $dir) {
1760 # nothing to say, no matter what the permissions
c9869e1c
SP		 1761 }
1762 } else {
2b3bde2a 1763 $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
0cf35e6a 1764 return;
0cf35e6a 1765 }
dc053c64
SP		 1766 if ($fast) {
1767 $Du = 0; # placeholder
1768 } else {
1769 find(
1770 sub {
0cf35e6a
SP		 1771 $File::Find::prune++ if $CPAN::Signal;
1772 return if -l $_;
1773 if ($^O eq 'MacOS') {
1774 require Mac::Files;
1775 my $cat = Mac::Files::FSpGetCatInfo($_);
1776 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1777 } else {
1778 if (-d _) {
1779 unless (-x _) {
1780 unless (chmod 0755, $_) {
1781 $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1782 "the permission to change the permission; ".
1783 "can only partially estimate disk usage ".
1784 "of '$_'\n");
8962fc49 1785 $CPAN::Frontend->mysleep(5);
0cf35e6a
SP		 1786 return;
1787 }
1788 }
1789 } else {
1790 $Du += (-s _);
1791 }
1792 }
1793 },
1794 $dir
dc053c64
SP		 1795 );
1796 }
09d9d230 1797 return if $CPAN::Signal;
05454584 1798 $self->{SIZE}{$dir} = $Du/1024/1024;
dc053c64 1799 unshift @{$self->{FIFO}}, $dir;
05454584
A		 1800 $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1801 $self->{DU} += $Du/1024/1024;
05454584 1802 $self->{DU};
5f05dabc 1803}
1804
810a0276
SP		 1805#-> sub CPAN::CacheMgr::_clean_cache ;
1806sub _clean_cache {
05454584 1807 my($self,$dir) = @_;
09d9d230 1808 return unless -e $dir;
810a0276 1809 unless (File::Spec->canonpath(File::Basename::dirname($dir))
f04ea8d1 1810 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
be34b10d
SP		 1811 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1812 "will not remove\n");
1813 $CPAN::Frontend->mysleep(5);
1814 return;
1815 }
05454584 1816 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
f04ea8d1 1817 if $CPAN::DEBUG;
05454584 1818 File::Path::rmtree($dir);
f20de9f0
SP		 1819 my $id_deleted = 0;
1820 if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1821 my $yaml_module = CPAN::_yaml_module;
1822 if ($CPAN::META->has_inst($yaml_module)) {
23a216b4
SP		 1823 my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1824 if ($@) {
1825 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1826 unlink "$dir.yml" or
1827 $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1828 return;
1829 } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
f20de9f0 1830 $CPAN::META->delete("CPAN::Distribution", $id);
23a216b4
SP		 1831
1832 # XXX we should restore the state NOW, otherise this
1833 # distro does not exist until we read an index. BUG ALERT(?)
1834
f20de9f0
SP		 1835 # $CPAN::Frontend->mywarn (" +++\n");
1836 $id_deleted++;
1837 }
1838 }
1839 unlink "$dir.yml"; # may fail
1840 unless ($id_deleted) {
1841 CPAN->debug("no distro found associated with '$dir'");
1842 }
1843 }
05454584
A		 1844 $self->{DU} -= $self->{SIZE}{$dir};
1845 delete $self->{SIZE}{$dir};
5f05dabc 1846}
1847
05454584
A		 1848#-> sub CPAN::CacheMgr::new ;
1849sub new {
1850 my $class = shift;
e50380aa
A		 1851 my $time = time;
1852 my($debug,$t2);
1853 $debug = "";
05454584 1854 my $self = {
f04ea8d1
SP		 1855 ID => $CPAN::Config->{build_dir},
1856 MAX => $CPAN::Config->{'build_cache'},
1857 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1858 DU => 0
1859 };
05454584
A		 1860 File::Path::mkpath($self->{ID});
1861 my $dh = DirHandle->new($self->{ID});
1862 bless $self, $class;
f610777f
A		 1863 $self->scan_cache;
1864 $t2 = time;
1865 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1866 $time = $t2;
1867 CPAN->debug($debug) if $CPAN::DEBUG;
1868 $self;
1869}
1870
1871#-> sub CPAN::CacheMgr::scan_cache ;
1872sub scan_cache {
1873 my $self = shift;
1874 return if $self->{SCAN} eq 'never';
1875 $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
f04ea8d1 1876 unless $self->{SCAN} eq 'atstart';
f20de9f0 1877 return unless $CPAN::META->{LOCK};
09d9d230 1878 $CPAN::Frontend->myprint(
f04ea8d1
SP		 1879 sprintf("Scanning cache %s for sizes\n",
1880 $self->{ID}));
f610777f 1881 my $e;
dc053c64 1882 my @entries = $self->entries($self->{ID});
b72dd56f
SP		 1883 my $i = 0;
1884 my $painted = 0;
1885 for $e (@entries) {
dc053c64
SP		 1886 my $symbol = ".";
1887 if ($self->{DU} > $self->{MAX}) {
1888 $symbol = "-";
1889 $self->disk_usage($e,1);
1890 } else {
1891 $self->disk_usage($e);
1892 }
b72dd56f
SP		 1893 $i++;
1894 while (($painted/76) < ($i/@entries)) {
dc053c64 1895 $CPAN::Frontend->myprint($symbol);
b72dd56f
SP		 1896 $painted++;
1897 }
f04ea8d1 1898 return if $CPAN::Signal;
5f05dabc 1899 }
b72dd56f 1900 $CPAN::Frontend->myprint("DONE\n");
09d9d230 1901 $self->tidyup;
5f05dabc 1902}
1903
05454584 1904package CPAN::Shell;
e82b9348 1905use strict;
5f05dabc 1906
05454584
A		 1907#-> sub CPAN::Shell::h ;
1908sub h {
1909 my($class,$about) = @_;
1910 if (defined $about) {
f04ea8d1
SP		 1911 my $help;
1912 if (exists $Help->{$about}) {
1913 if (ref $Help->{$about}) { # aliases
1914 $about = ${$Help->{$about}};
1915 }
1916 $help = $Help->{$about};
1917 } else {
1918 $help = "No help available";
1919 }
1920 $CPAN::Frontend->myprint("$about\: $help\n");
05454584 1921 } else {
9ddc4ed0 1922 my $filler = " " x (80 - 28 - length($CPAN::VERSION));
f04ea8d1 1923 $CPAN::Frontend->myprint(qq{
9ddc4ed0 1924Display Information $filler (ver $CPAN::VERSION)
c049f953
JH		 1925 command argument description
1926 a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
6a94b120 1927 i WORD or /REGEXP/ about any of the above
0cf35e6a 1928 ls AUTHOR or GLOB about files in the author's directory
ec5fee46
A		 1929 (with WORD being a module, bundle or author name or a distribution
1930 name of the form AUTHOR/DISTRIBUTION)
911a92db
GS		 1931
1932Download, Test, Make, Install...
ec5fee46
A		 1933 get download clean make clean
1934 make make (implies get) look open subshell in dist directory
1935 test make test (implies make) readme display these README files
1936 install make install (implies test) perldoc display POD documentation
1937
135a59c2
A		 1938Upgrade
1939 r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
1940 upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
1941
ec5fee46 1942Pragmas
b72dd56f 1943 force CMD try hard to do command fforce CMD try harder
810a0276 1944 notest CMD skip testing
911a92db
GS		 1945
1946Other
1947 h,? display this menu ! perl-code eval a perl command
1948 o conf [opt] set and query options q quit the cpan shell
1949 reload cpan load CPAN.pm again reload index load newer indices
ec5fee46 1950 autobundle Snapshot recent latest CPAN uploads});
135a59c2 1951}
05454584 1952}
da199366 1953
09d9d230
A		 1954*help = \&h;
1955
05454584 1956#-> sub CPAN::Shell::a ;
de34a54b
JH		 1957sub a {
1958 my($self,@arg) = @_;
1959 # authors are always UPPERCASE
1960 for (@arg) {
c049f953 1961 $_ = uc $_ unless /=/;
de34a54b
JH		 1962 }
1963 $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1964}
6d29edf5 1965
ca79d794
SP		 1966#-> sub CPAN::Shell::globls ;
1967sub globls {
1968 my($self,$s,$pragmas) = @_;
0cf35e6a
SP		 1969 # ls is really very different, but we had it once as an ordinary
1970 # command in the Shell (upto rev. 321) and we could not handle
1971 # force well then
e82b9348 1972 my(@accept,@preexpand);
0cf35e6a
SP		 1973 if ($s =~ /[\*\?\/]/) {
1974 if ($CPAN::META->has_inst("Text::Glob")) {
1975 if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1976 my $rau = Text::Glob::glob_to_regex(uc $au);
1977 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1978 if $CPAN::DEBUG;
1979 push @preexpand, map { $_->id . "/" . $pathglob }
1980 CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
e82b9348 1981 } else {
0cf35e6a
SP		 1982 my $rau = Text::Glob::glob_to_regex(uc $s);
1983 push @preexpand, map { $_->id }
1984 CPAN::Shell->expand_by_method('CPAN::Author',
1985 ['id'],
1986 "/$rau/");
e82b9348
SP		 1987 }
1988 } else {
0cf35e6a 1989 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
e82b9348 1990 }
0cf35e6a
SP		 1991 } else {
1992 push @preexpand, uc $s;
554a9ef5 1993 }
e82b9348
SP		 1994 for (@preexpand) {
1995 unless (/^[A-Z0-9\-]+(\/|$)/i) {
5fc0f0f6 1996 $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
c049f953
JH		 1997 next;
1998 }
e82b9348 1999 push @accept, $_;
8d97e4a1 2000 }
554a9ef5
SP		 2001 my $silent = @accept>1;
2002 my $last_alpha = "";
ca79d794 2003 my @results;
f04ea8d1 2004 for my $a (@accept) {
e82b9348
SP		 2005 my($author,$pathglob);
2006 if ($a =~ m|(.*?)/(.*)|) {
2007 my $a2 = $1;
2008 $pathglob = $2;
0cf35e6a
SP		 2009 $author = CPAN::Shell->expand_by_method('CPAN::Author',
2010 ['id'],
b72dd56f
SP		 2011 $a2)
2012 or $CPAN::Frontend->mydie("No author found for $a2\n");
e82b9348 2013 } else {
0cf35e6a
SP		 2014 $author = CPAN::Shell->expand_by_method('CPAN::Author',
2015 ['id'],
b72dd56f
SP		 2016 $a)
2017 or $CPAN::Frontend->mydie("No author found for $a\n");
e82b9348 2018 }
554a9ef5 2019 if ($silent) {
e82b9348 2020 my $alpha = substr $author->id, 0, 1;
554a9ef5 2021 my $ad;
e82b9348
SP		 2022 if ($alpha eq $last_alpha) {
2023 $ad = "";
554a9ef5 2024 } else {
e82b9348
SP		 2025 $ad = "[$alpha]";
2026 $last_alpha = $alpha;
554a9ef5
SP		 2027 }
2028 $CPAN::Frontend->myprint($ad);
2029 }
9ddc4ed0
A		 2030 for my $pragma (@$pragmas) {
2031 if ($author->can($pragma)) {
2032 $author->$pragma();
2033 }
2034 }
ca79d794
SP		 2035 push @results, $author->ls($pathglob,$silent); # silent if
2036 # more than one
2037 # author
9ddc4ed0 2038 for my $pragma (@$pragmas) {
05bab18e
SP		 2039 my $unpragma = "un$pragma";
2040 if ($author->can($unpragma)) {
2041 $author->$unpragma();
9ddc4ed0
A		 2042 }
2043 }
8d97e4a1 2044 }
ca79d794 2045 @results;
8d97e4a1 2046}
6d29edf5 2047
8d97e4a1 2048#-> sub CPAN::Shell::local_bundles ;
6d29edf5 2049sub local_bundles {
05454584 2050 my($self,@which) = @_;
55e314ee 2051 my($incdir,$bdir,$dh);
05454584 2052 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8d97e4a1
JH		 2053 my @bbase = "Bundle";
2054 while (my $bbase = shift @bbase) {
5de3f0da 2055 $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
8d97e4a1
JH		 2056 CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
2057 if ($dh = DirHandle->new($bdir)) { # may fail
2058 my($entry);
2059 for $entry ($dh->read) {
c049f953 2060 next if $entry =~ /^\./;
b96578bb 2061 next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
f04ea8d1 2062 if (-d File::Spec->catdir($bdir,$entry)) {
8d97e4a1
JH		 2063 push @bbase, "$bbase\::$entry";
2064 } else {
2065 next unless $entry =~ s/\.pm(?!\n)\Z//;
2066 $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
2067 }
2068 }
2069 }
2070 }
05454584 2071 }
6d29edf5
JH		 2072}
2073
2074#-> sub CPAN::Shell::b ;
2075sub b {
2076 my($self,@which) = @_;
2077 CPAN->debug("which[@which]") if $CPAN::DEBUG;
2078 $self->local_bundles;
c356248b 2079 $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
05454584 2080}
6d29edf5 2081
05454584 2082#-> sub CPAN::Shell::d ;
c356248b 2083sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
6d29edf5 2084
05454584 2085#-> sub CPAN::Shell::m ;
f610777f 2086sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
35576f8c
A		 2087 my $self = shift;
2088 $CPAN::Frontend->myprint($self->format_result('Module',@_));
f610777f 2089}
da199366 2090
05454584
A		 2091#-> sub CPAN::Shell::i ;
2092sub i {
2093 my($self) = shift;
2094 my(@args) = @_;
05454584
A		 2095 @args = '/./' unless @args;
2096 my(@result);
190aa835 2097 for my $type (qw/Bundle Distribution Module/) {
f04ea8d1 2098 push @result, $self->expand($type,@args);
05454584 2099 }
190aa835
MS		 2100 # Authors are always uppercase.
2101 push @result, $self->expand("Author", map { uc $_ } @args);
2102
8d97e4a1 2103 my $result = @result == 1 ?
f04ea8d1 2104 $result[0]->as_string :
8d97e4a1
JH		 2105 @result == 0 ?
2106 "No objects found of any type for argument @args\n" :
2107 join("",
2108 (map {$_->as_glimpse} @result),
2109 scalar @result, " items found\n",
2110 );
c356248b 2111 $CPAN::Frontend->myprint($result);
da199366 2112}
da199366 2113
05454584 2114#-> sub CPAN::Shell::o ;
5e05dca5 2115
8962fc49
SP		 2116# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
2117# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
135a59c2
A		 2118# probably have been called 'set' and 'o debug' maybe 'set debug' or
2119# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
05454584
A		 2120sub o {
2121 my($self,$o_type,@o_what) = @_;
2122 $o_type ||= "";
2123 CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
2124 if ($o_type eq 'conf') {
ecc7fca0
A		 2125 my($cfilter);
2126 ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
f04ea8d1
SP		 2127 if (!@o_what or $cfilter) { # print all things, "o conf"
2128 $cfilter ||= "";
2129 my $qrfilter = eval 'qr/$cfilter/';
2130 my($k,$v);
2131 $CPAN::Frontend->myprint("\$CPAN::Config options from ");
ed84aac9 2132 my @from;
f04ea8d1 2133 if (exists $INC{'CPAN/Config.pm'}) {
ed84aac9 2134 push @from, $INC{'CPAN/Config.pm'};
f04ea8d1
SP		 2135 }
2136 if (exists $INC{'CPAN/MyConfig.pm'}) {
ed84aac9 2137 push @from, $INC{'CPAN/MyConfig.pm'};
f04ea8d1 2138 }
ed84aac9 2139 $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
f04ea8d1
SP		 2140 $CPAN::Frontend->myprint(":\n");
2141 for $k (sort keys %CPAN::HandleConfig::can) {
2142 next unless $k =~ /$qrfilter/;
2143 $v = $CPAN::HandleConfig::can{$k};
2144 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
2145 }
2146 $CPAN::Frontend->myprint("\n");
2147 for $k (sort keys %CPAN::HandleConfig::keys) {
2148 next unless $k =~ /$qrfilter/;
e82b9348 2149 CPAN::HandleConfig->prettyprint($k);
f04ea8d1
SP		 2150 }
2151 $CPAN::Frontend->myprint("\n");
f20de9f0 2152 } else {
05bab18e 2153 if (CPAN::HandleConfig->edit(@o_what)) {
05bab18e
SP		 2154 } else {
2155 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
2156 qq{items\n\n});
2157 }
f04ea8d1 2158 }
05454584 2159 } elsif ($o_type eq 'debug') {
f04ea8d1
SP		 2160 my(%valid);
2161 @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
2162 if (@o_what) {
2163 while (@o_what) {
2164 my($what) = shift @o_what;
8d97e4a1
JH		 2165 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
2166 $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
2167 next;
2168 }
f04ea8d1
SP		 2169 if ( exists $CPAN::DEBUG{$what} ) {
2170 $CPAN::DEBUG |= $CPAN::DEBUG{$what};
2171 } elsif ($what =~ /^\d/) {
2172 $CPAN::DEBUG = $what;
2173 } elsif (lc $what eq 'all') {
2174 my($max) = 0;
2175 for (values %CPAN::DEBUG) {
2176 $max += $_;
2177 }
2178 $CPAN::DEBUG = $max;
2179 } else {
2180 my($known) = 0;
2181 for (keys %CPAN::DEBUG) {
2182 next unless lc($_) eq lc($what);
2183 $CPAN::DEBUG |= $CPAN::DEBUG{$_};
2184 $known = 1;
2185 }
2186 $CPAN::Frontend->myprint("unknown argument [$what]\n")
2187 unless $known;
2188 }
2189 }
2190 } else {
2191 my $raw = "Valid options for debug are ".
2192 join(", ",sort(keys %CPAN::DEBUG), 'all').
2193 qq{ or a number. Completion works on the options. }.
2194 qq{Case is ignored.};
2195 require Text::Wrap;
2196 $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
2197 $CPAN::Frontend->myprint("\n\n");
2198 }
2199 if ($CPAN::DEBUG) {
2200 $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
2201 my($k,$v);
2202 for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
2203 $v = $CPAN::DEBUG{$k};
2204 $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
05d2a450 2205 if $v & $CPAN::DEBUG;
f04ea8d1
SP		 2206 }
2207 } else {
2208 $CPAN::Frontend->myprint("Debugging turned off completely.\n");
2209 }
05454584 2210 } else {
f04ea8d1 2211 $CPAN::Frontend->myprint(qq{
05454584
A		 2212Known options:
2213 conf set or get configuration variables
2214 debug set or get debugging options
c356248b 2215});
5f05dabc 2216 }
5f05dabc 2217}
2218
6a935156 2219# CPAN::Shell::paintdots_onreload
6d29edf5 2220sub paintdots_onreload {
36263cb3
GS		 2221 my($ref) = shift;
2222 sub {
f04ea8d1
SP		 2223 if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
2224 my($subr) = $1;
2225 ++$$ref;
2226 local($|) = 1;
2227 # $CPAN::Frontend->myprint(".($subr)");
2228 $CPAN::Frontend->myprint(".");
6a935156
SP		 2229 if ($subr =~ /\bshell\b/i) {
2230 # warn "debug[$_[0]]";
2231
2232 # It would be nice if we could detect that a
2233 # subroutine has actually changed, but for now we
2234 # practically always set the GOTOSHELL global
2235
2236 $CPAN::GOTOSHELL=1;
2237 }
f04ea8d1
SP		 2238 return;
2239 }
2240 warn @_;
36263cb3
GS		 2241 };
2242}
2243
05bab18e
SP		 2244#-> sub CPAN::Shell::hosts ;
2245sub hosts {
2246 my($self) = @_;
2247 my $fullstats = CPAN::FTP->_ftp_statistics();
2248 my $history = $fullstats->{history} || [];
2249 my %S; # statistics
2250 while (my $last = pop @$history) {
2251 my $attempts = $last->{attempts} or next;
2252 my $start;
2253 if (@$attempts) {
2254 $start = $attempts->[-1]{start};
2255 if ($#$attempts > 0) {
2256 for my $i (0..$#$attempts-1) {
2257 my $url = $attempts->[$i]{url} or next;
2258 $S{no}{$url}++;
2259 }
2260 }
2261 } else {
2262 $start = $last->{start};
2263 }
2264 next unless $last->{thesiteurl}; # C-C? bad filenames?
2265 $S{start} = $start;
2266 $S{end} ||= $last->{end};
2267 my $dltime = $last->{end} - $start;
2268 my $dlsize = $last->{filesize} || 0;
f20de9f0 2269 my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
05bab18e
SP		 2270 my $s = $S{ok}{$url} ||= {};
2271 $s->{n}++;
2272 $s->{dlsize} ||= 0;
2273 $s->{dlsize} += $dlsize/1024;
2274 $s->{dltime} ||= 0;
2275 $s->{dltime} += $dltime;
2276 }
2277 my $res;
2278 for my $url (keys %{$S{ok}}) {
2279 next if $S{ok}{$url}{dltime} == 0; # div by zero
2280 push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2281 $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2282 $url,
2283 ];
2284 }
2285 for my $url (keys %{$S{no}}) {
2286 push @{$res->{no}}, [$S{no}{$url},
2287 $url,
2288 ];
2289 }
2290 my $R = ""; # report
b72dd56f
SP		 2291 if ($S{start} && $S{end}) {
2292 $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2293 $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
2294 }
05bab18e
SP		 2295 if ($res->{ok} && @{$res->{ok}}) {
2296 $R .= sprintf "\nSuccessful downloads:
2297 N kB secs kB/s url\n";
be34b10d 2298 my $i = 20;
05bab18e
SP		 2299 for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2300 $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
be34b10d 2301 last if --$i<=0;
05bab18e
SP		 2302 }
2303 }
2304 if ($res->{no} && @{$res->{no}}) {
2305 $R .= sprintf "\nUnsuccessful downloads:\n";
be34b10d 2306 my $i = 20;
05bab18e
SP		 2307 for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2308 $R .= sprintf "%4d %s\n", @$_;
be34b10d 2309 last if --$i<=0;
05bab18e
SP		 2310 }
2311 }
2312 $CPAN::Frontend->myprint($R);
2313}
2314
5254b38e 2315# here is where 'reload cpan' is done
05454584
A		 2316#-> sub CPAN::Shell::reload ;
2317sub reload {
d4fd5c69
A		 2318 my($self,$command,@arg) = @_;
2319 $command ||= "";
2320 $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
135a59c2 2321 if ($command =~ /^cpan$/i) {
e82b9348 2322 my $redef = 0;
0cf35e6a
SP		 2323 chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2324 my $failed;
8962fc49 2325 MFILE: for my $f (@relo) {
135a59c2
A		 2326 next unless exists $INC{$f};
2327 my $p = $f;
2328 $p =~ s/\.pm$//;
2329 $p =~ s|/|::|g;
2330 $CPAN::Frontend->myprint("($p");
5fc0f0f6 2331 local($SIG{__WARN__}) = paintdots_onreload(\$redef);
810a0276 2332 $self->_reload_this($f) or $failed++;
135a59c2
A		 2333 my $v = eval "$p\::->VERSION";
2334 $CPAN::Frontend->myprint("v$v)");
5fc0f0f6 2335 }
e82b9348 2336 $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
0cf35e6a 2337 if ($failed) {
135a59c2
A		 2338 my $errors = $failed == 1 ? "error" : "errors";
2339 $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
0cf35e6a
SP		 2340 "this session.\n");
2341 }
135a59c2 2342 } elsif ($command =~ /^index$/i) {
2e2b7522 2343 CPAN::Index->force_reload;
d4fd5c69 2344 } else {
135a59c2 2345 $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
f14b5cec 2346index re-reads the index files\n});
05454584
A		 2347 }
2348}
2349
2ccf00a7 2350# reload means only load again what we have loaded before
810a0276
SP		 2351#-> sub CPAN::Shell::_reload_this ;
2352sub _reload_this {
6a935156 2353 my($self,$f,$args) = @_;
7d97ad34 2354 CPAN->debug("f[$f]") if $CPAN::DEBUG;
2ccf00a7
SP		 2355 return 1 unless $INC{$f}; # we never loaded this, so we do not
2356 # reload but say OK
c9869e1c 2357 my $pwd = CPAN::anycwd();
7d97ad34
SP		 2358 CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2359 my($file);
c9869e1c 2360 for my $inc (@INC) {
7d97ad34
SP		 2361 $file = File::Spec->catfile($inc,split /\//, $f);
2362 last if -f $file;
2363 $file = "";
2364 }
2365 CPAN->debug("file[$file]") if $CPAN::DEBUG;
2366 my @inc = @INC;
2367 unless ($file && -f $file) {
2368 # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2369 $file = $INC{$f};
6658a91b
SP		 2370 unless (CPAN->has_inst("File::Basename")) {
2371 @inc = File::Basename::dirname($file);
2372 } else {
2373 # do we ever need this?
2374 @inc = substr($file,0,-length($f)-1); # bring in back to me!
2375 }
7d97ad34
SP		 2376 }
2377 CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2378 unless (-f $file) {
c9869e1c
SP		 2379 $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2380 return;
2381 }
6a935156 2382 my $mtime = (stat $file)[9];
5254b38e 2383 $reload->{$f} ||= -1;
f04ea8d1 2384 my $must_reload = $mtime != $reload->{$f};
6a935156 2385 $args ||= {};
f04ea8d1 2386 $must_reload ||= $args->{reloforce}; # o conf defaults needs this
6a935156
SP		 2387 if ($must_reload) {
2388 my $fh = FileHandle->new($file) or
2389 $CPAN::Frontend->mydie("Could not open $file: $!");
2390 local($/);
2391 local $^W = 1;
2392 my $content = <$fh>;
2393 CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2394 if $CPAN::DEBUG;
2395 delete $INC{$f};
2396 local @INC = @inc;
2397 eval "require '$f'";
f04ea8d1 2398 if ($@) {
6a935156
SP		 2399 warn $@;
2400 return;
2401 }
f04ea8d1 2402 $reload->{$f} = $mtime;
6a935156
SP		 2403 } else {
2404 $CPAN::Frontend->myprint("__unchanged__");
c9869e1c
SP		 2405 }
2406 return 1;
2407}
2408
44d21104
A		 2409#-> sub CPAN::Shell::mkmyconfig ;
2410sub mkmyconfig {
2411 my($self, $cpanpm, %args) = @_;
2412 require CPAN::FirstTime;
87892b73
RGS		 2413 my $home = CPAN::HandleConfig::home;
2414 $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2415 File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
44d21104 2416 File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
87892b73 2417 CPAN::HandleConfig::require_myconfig_or_config;
44d21104
A		 2418 $CPAN::Config ||= {};
2419 $CPAN::Config = {
2420 %$CPAN::Config,
2421 build_dir => undef,
2422 cpan_home => undef,
2423 keep_source_where => undef,
2424 histfile => undef,
2425 };
2426 CPAN::FirstTime::init($cpanpm, %args);
2427}
2428
05454584
A		 2429#-> sub CPAN::Shell::_binary_extensions ;
2430sub _binary_extensions {
2431 my($self) = shift @_;
2432 my(@result,$module,%seen,%need,$headerdone);
2433 for $module ($self->expand('Module','/./')) {
f04ea8d1
SP		 2434 my $file = $module->cpan_file;
2435 next if $file eq "N/A";
2436 next if $file =~ /^Contact Author/;
05d2a450 2437 my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
f04ea8d1
SP		 2438 next if $dist->isa_perl;
2439 next unless $module->xs_file;
2440 local($|) = 1;
2441 $CPAN::Frontend->myprint(".");
2442 push @result, $module;
05454584
A		 2443 }
2444# print join " | ", @result;
c356248b 2445 $CPAN::Frontend->myprint("\n");
05454584
A		 2446 return @result;
2447}
2448
2449#-> sub CPAN::Shell::recompile ;
2450sub recompile {
2451 my($self) = shift @_;
2452 my($module,@module,$cpan_file,%dist);
2453 @module = $self->_binary_extensions();
f04ea8d1 2454 for $module (@module) { # we force now and compile later, so we
c356248b 2455 # don't do it twice
f04ea8d1
SP		 2456 $cpan_file = $module->cpan_file;
2457 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2458 $pack->force;
2459 $dist{$cpan_file}++;
05454584
A		 2460 }
2461 for $cpan_file (sort keys %dist) {
f04ea8d1
SP		 2462 $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
2463 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2464 $pack->install;
2465 $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
05454584
A		 2466 # stop a package from recompiling,
2467 # e.g. IO-1.12 when we have perl5.003_10
2468 }
2469}
2470
ed84aac9
A		 2471#-> sub CPAN::Shell::scripts ;
2472sub scripts {
2473 my($self, $arg) = @_;
2474 $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2475
8962fc49
SP		 2476 for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2477 unless ($CPAN::META->has_inst($req)) {
2478 $CPAN::Frontend->mywarn(" $req not available\n");
2479 }
2480 }
ed84aac9
A		 2481 my $p = HTML::LinkExtor->new();
2482 my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2483 unless (-f $indexfile) {
2484 $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2485 }
2486 $p->parse_file($indexfile);
2487 my @hrefs;
2488 my $qrarg;
2489 if ($arg =~ s|^/(.+)/$|$1|) {
8962fc49 2490 $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
ed84aac9
A		 2491 }
2492 for my $l ($p->links) {
2493 my $tag = shift @$l;
2494 next unless $tag eq "a";
2495 my %att = @$l;
2496 my $href = $att{href};
2497 next unless $href =~ s|^\.\./authors/id/./../||;
2498 if ($arg) {
2499 if ($qrarg) {
2500 if ($href =~ $qrarg) {
2501 push @hrefs, $href;
2502 }
2503 } else {
2504 if ($href =~ /\Q$arg\E/) {
2505 push @hrefs, $href;
2506 }
2507 }
2508 } else {
2509 push @hrefs, $href;
2510 }
2511 }
2512 # now filter for the latest version if there is more than one of a name
2513 my %stems;
2514 for (sort @hrefs) {
2515 my $href = $_;
2516 s/-v?\d.*//;
2517 my $stem = $_;
2518 $stems{$stem} ||= [];
2519 push @{$stems{$stem}}, $href;
2520 }
2521 for (sort keys %stems) {
2522 my $highest;
2523 if (@{$stems{$_}} > 1) {
2524 $highest = List::Util::reduce {
2525 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2526 } @{$stems{$_}};
2527 } else {
2528 $highest = $stems{$_}[0];
2529 }
2530 $CPAN::Frontend->myprint("$highest\n");
2531 }
2532}
2533
8fc516fe
SP		 2534#-> sub CPAN::Shell::report ;
2535sub report {
2536 my($self,@args) = @_;
2537 unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2538 $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2539 }
2540 local $CPAN::Config->{test_report} = 1;
6658a91b
SP		 2541 $self->force("test",@args); # force is there so that the test be
2542 # re-run (as documented)
8fc516fe
SP		 2543}
2544
f20de9f0 2545# compare with is_tested
05bab18e
SP		 2546#-> sub CPAN::Shell::install_tested
2547sub install_tested {
2548 my($self,@some) = @_;
b72dd56f 2549 $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
05bab18e
SP		 2550 return if @some;
2551 CPAN::Index->reload;
2552
b72dd56f
SP		 2553 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2554 my $yaml = "$b.yml";
f04ea8d1 2555 unless (-f $yaml) {
b72dd56f
SP		 2556 $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2557 next;
2558 }
f20de9f0
SP		 2559 my $yaml_content = CPAN->_yaml_loadfile($yaml);
2560 my $id = $yaml_content->[0]{distribution}{ID};
f04ea8d1 2561 unless ($id) {
b72dd56f
SP		 2562 $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2563 next;
2564 }
2565 my $do = CPAN::Shell->expandany($id);
f04ea8d1 2566 unless ($do) {
b72dd56f
SP		 2567 $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2568 next;
2569 }
2570 unless ($do->{build_dir}) {
2571 $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2572 next;
2573 }
2574 unless ($do->{build_dir} eq $b) {
2575 $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2576 next;
2577 }
05bab18e
SP		 2578 push @some, $do;
2579 }
2580
2581 $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2582 return unless @some;
2583
2584 @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2585 $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2586 return unless @some;
2587
b72dd56f
SP		 2588 # @some = grep { not $_->uptodate } @some;
2589 # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2590 # return unless @some;
05bab18e
SP		 2591
2592 CPAN->debug("some[@some]");
2593 for my $d (@some) {
2594 my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2595 $CPAN::Frontend->myprint("install_tested: Running for $id\n");
b72dd56f 2596 $CPAN::Frontend->mysleep(1);
05bab18e
SP		 2597 $self->install($d);
2598 }
2599}
2600
ed84aac9
A		 2601#-> sub CPAN::Shell::upgrade ;
2602sub upgrade {
135a59c2
A		 2603 my($self,@args) = @_;
2604 $self->install($self->r(@args));
ed84aac9
A		 2605}
2606
05454584
A		 2607#-> sub CPAN::Shell::_u_r_common ;
2608sub _u_r_common {
2609 my($self) = shift @_;
2610 my($what) = shift @_;
2611 CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
c4d24d4c
A		 2612 Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2613 $what && $what =~ /^[aru]$/;
05454584
A		 2614 my(@args) = @_;
2615 @args = '/./' unless @args;
c356248b 2616 my(@result,$module,%seen,%need,$headerdone,
f04ea8d1
SP		 2617 $version_undefs,$version_zeroes,
2618 @version_undefs,@version_zeroes);
c356248b 2619 $version_undefs = $version_zeroes = 0;
9d61fa1d 2620 my $sprintf = "%s%-25s%s %9s %9s %s\n";
6d29edf5 2621 my @expand = $self->expand('Module',@args);
5254b38e 2622 if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
6d29edf5 2623 # for metadata cache
5254b38e
SP		 2624 my $expand = scalar @expand;
2625 $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
2626 }
2627 my @sexpand;
2628 if ($] < 5.008) {
2629 # hard to believe that the more complex sorting can lead to
2630 # stack curruptions on older perl
2631 @sexpand = sort {$a->id cmp $b->id} @expand;
2632 } else {
2633 @sexpand = map {
2634 $_->[1]
2635 } sort {
2636 $b->[0] <=> $a->[0]
2637 ||
2638 $a->[1]{ID} cmp $b->[1]{ID},
2639 } map {
2640 [$_->_is_representative_module,
2641 $_
2642 ]
2643 } @expand;
2644 }
2645 if ($CPAN::DEBUG) {
2646 $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
2647 sleep 1;
2648 }
2649 MODULE: for $module (@sexpand) {
f04ea8d1
SP		 2650 my $file = $module->cpan_file;
2651 next MODULE unless defined $file; # ??
2652 $file =~ s!^./../!!;
2653 my($latest) = $module->cpan_version;
2654 my($inst_file) = $module->inst_file;
5254b38e 2655 CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
f04ea8d1
SP		 2656 my($have);
2657 return if $CPAN::Signal;
5254b38e
SP		 2658 my($next_MODULE);
2659 eval { # version.pm involved!
2660 if ($inst_file) {
2661 if ($what eq "a") {
2662 $have = $module->inst_version;
2663 } elsif ($what eq "r") {
2664 $have = $module->inst_version;
2665 local($^W) = 0;
2666 if ($have eq "undef") {
2667 $version_undefs++;
2668 push @version_undefs, $module->as_glimpse;
2669 } elsif (CPAN::Version->vcmp($have,0)==0) {
2670 $version_zeroes++;
2671 push @version_zeroes, $module->as_glimpse;
2672 }
2673 ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
2674 # to be pedantic we should probably say:
2675 # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2676 # to catch the case where CPAN has a version 0 and we have a version undef
2677 } elsif ($what eq "u") {
2678 ++$next_MODULE;
2679 }
2680 } else {
2681 if ($what eq "a") {
2682 ++$next_MODULE;
2683 } elsif ($what eq "r") {
2684 ++$next_MODULE;
2685 } elsif ($what eq "u") {
2686 $have = "-";
f04ea8d1 2687 }
f04ea8d1 2688 }
5254b38e
SP		 2689 };
2690 next MODULE if $next_MODULE;
2691 if ($@) {
2692 $CPAN::Frontend->mywarn
2693 (sprintf("Error while comparing cpan/installed versions of '%s':
2694INST_FILE: %s
2695INST_VERSION: %s %s
2696CPAN_VERSION: %s %s
2697",
2698 $module->id,
2699 $inst_file || "",
2700 (defined $have ? $have : "[UNDEFINED]"),
2701 (ref $have ? ref $have : ""),
2702 $latest,
2703 (ref $latest ? ref $latest : ""),
2704 ));
2705 next MODULE;
f04ea8d1
SP		 2706 }
2707 return if $CPAN::Signal; # this is sometimes lengthy
2708 $seen{$file} ||= 0;
2709 if ($what eq "a") {
2710 push @result, sprintf "%s %s\n", $module->id, $have;
2711 } elsif ($what eq "r") {
2712 push @result, $module->id;
2713 next MODULE if $seen{$file}++;
2714 } elsif ($what eq "u") {
2715 push @result, $module->id;
2716 next MODULE if $seen{$file}++;
2717 next MODULE if $file =~ /^Contact/;
2718 }
2719 unless ($headerdone++) {
2720 $CPAN::Frontend->myprint("\n");
2721 $CPAN::Frontend->myprint(sprintf(
9d61fa1d
A		 2722 $sprintf,
2723 "",
2724 "Package namespace",
2725 "",
2726 "installed",
2727 "latest",
2728 "in CPAN file"
2729 ));
f04ea8d1 2730 }
9d61fa1d
A		 2731 my $color_on = "";
2732 my $color_off = "";
2733 if (
2734 $COLOR_REGISTERED
2735 &&
2736 $CPAN::META->has_inst("Term::ANSIColor")
2737 &&
0cf35e6a 2738 $module->description
9d61fa1d
A		 2739 ) {
2740 $color_on = Term::ANSIColor::color("green");
2741 $color_off = Term::ANSIColor::color("reset");
2742 }
f04ea8d1 2743 $CPAN::Frontend->myprint(sprintf $sprintf,
9d61fa1d 2744 $color_on,
05d2a450 2745 $module->id,
9d61fa1d 2746 $color_off,
05d2a450
A		 2747 $have,
2748 $latest,
2749 $file);
f04ea8d1 2750 $need{$module->id}++;
05454584
A		 2751 }
2752 unless (%need) {
f04ea8d1
SP		 2753 if ($what eq "u") {
2754 $CPAN::Frontend->myprint("No modules found for @args\n");
2755 } elsif ($what eq "r") {
2756 $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2757 }
05454584 2758 }
c356248b 2759 if ($what eq "r") {
f04ea8d1
SP		 2760 if ($version_zeroes) {
2761 my $s_has = $version_zeroes > 1 ? "s have" : " has";
2762 $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2763 qq{a version number of 0\n});
2764 if ($CPAN::Config->{show_zero_versions}) {
2765 local $" = "\t";
2766 $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
2767 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
2768 qq{to hide them)\n});
2769 } else {
2770 $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
2771 qq{to show them)\n});
2772 }
2773 }
2774 if ($version_undefs) {
2775 my $s_has = $version_undefs > 1 ? "s have" : " has";
2776 $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2777 qq{parseable version number\n});
2778 if ($CPAN::Config->{show_unparsable_versions}) {
2779 local $" = "\t";
2780 $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
2781 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
2782 qq{to hide them)\n});
2783 } else {
2784 $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
2785 qq{to show them)\n});
2786 }
2787 }
05454584
A		 2788 }
2789 @result;
2790}
2791
2792#-> sub CPAN::Shell::r ;
2793sub r {
2794 shift->_u_r_common("r",@_);
2795}
2796
2797#-> sub CPAN::Shell::u ;
2798sub u {
2799 shift->_u_r_common("u",@_);
2800}
2801
0cf35e6a
SP		 2802#-> sub CPAN::Shell::failed ;
2803sub failed {
9ddc4ed0 2804 my($self,$only_id,$silent) = @_;
c9869e1c 2805 my @failed;
0cf35e6a
SP		 2806 DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2807 my $failed = "";
810a0276 2808 NAY: for my $nosayer ( # order matters!
6658a91b 2809 "unwrapped",
87892b73
RGS		 2810 "writemakefile",
2811 "signature_verify",
2812 "make",
2813 "make_test",
2814 "install",
2815 "make_clean",
2816 ) {
0cf35e6a 2817 next unless exists $d->{$nosayer};
be34b10d 2818 next unless defined $d->{$nosayer};
44d21104 2819 next unless (
be34b10d 2820 UNIVERSAL::can($d->{$nosayer},"failed") ?
44d21104
A		 2821 $d->{$nosayer}->failed :
2822 $d->{$nosayer} =~ /^NO/
2823 );
87892b73 2824 next NAY if $only_id && $only_id != (
be34b10d 2825 UNIVERSAL::can($d->{$nosayer},"commandid")
87892b73
RGS		 2826 ?
2827 $d->{$nosayer}->commandid
2828 :
2829 $CPAN::CurrentCommandId
2830 );
0cf35e6a
SP		 2831 $failed = $nosayer;
2832 last;
2833 }
2834 next DIST unless $failed;
2835 my $id = $d->id;
2836 $id =~ s|^./../||;
c9869e1c
SP		 2837 #$print .= sprintf(
2838 # " %-45s: %s %s\n",
44d21104
A		 2839 push @failed,
2840 (
be34b10d 2841 UNIVERSAL::can($d->{$failed},"failed") ?
44d21104
A		 2842 [
2843 $d->{$failed}->commandid,
2844 $id,
2845 $failed,
2846 $d->{$failed}->text,
be34b10d 2847 $d->{$failed}{TIME}||0,
44d21104
A		 2848 ] :
2849 [
2850 1,
2851 $id,
2852 $failed,
2853 $d->{$failed},
be34b10d 2854 0,
44d21104
A		 2855 ]
2856 );
0cf35e6a 2857 }
be34b10d
SP		 2858 my $scope;
2859 if ($only_id) {
2860 $scope = "this command";
2861 } elsif ($CPAN::Index::HAVE_REANIMATED) {
2862 $scope = "this or a previous session";
2863 # it might be nice to have a section for previous session and
2864 # a second for this
2865 } else {
2866 $scope = "this session";
2867 }
c9869e1c 2868 if (@failed) {
be34b10d
SP		 2869 my $print;
2870 my $debug = 0;
2871 if ($debug) {
2872 $print = join "",
2873 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2874 sort { $a->[0] <=> $b->[0] } @failed;
2875 } else {
2876 $print = join "",
2877 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2878 sort {
2879 $a->[0] <=> $b->[0]
2880 ||
2881 $a->[4] <=> $b->[4]
2882 } @failed;
2883 }
2884 $CPAN::Frontend->myprint("Failed during $scope:\n$print");
9ddc4ed0 2885 } elsif (!$only_id || !$silent) {
be34b10d 2886 $CPAN::Frontend->myprint("Nothing failed in $scope\n");
0cf35e6a
SP		 2887 }
2888}
2889
c9869e1c
SP		 2890# XXX intentionally undocumented because completely bogus, unportable,
2891# useless, etc.
2892
0cf35e6a
SP		 2893#-> sub CPAN::Shell::status ;
2894sub status {
2895 my($self) = @_;
2896 require Devel::Size;
2897 my $ps = FileHandle->new;
2898 open $ps, "/proc/$$/status";
2899 my $vm = 0;
2900 while (<$ps>) {
2901 next unless /VmSize:\s+(\d+)/;
2902 $vm = $1;
2903 last;
2904 }
2905 $CPAN::Frontend->mywarn(sprintf(
2906 "%-27s %6d\n%-27s %6d\n",
2907 "vm",
2908 $vm,
2909 "CPAN::META",
2910 Devel::Size::total_size($CPAN::META)/1024,
2911 ));
2912 for my $k (sort keys %$CPAN::META) {
2913 next unless substr($k,0,4) eq "read";
2914 warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2915 for my $k2 (sort keys %{$CPAN::META->{$k}}) {
7d97ad34 2916 warn sprintf " %-25s %6d (keys: %6d)\n",
0cf35e6a
SP		 2917 $k2,
2918 Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2919 scalar keys %{$CPAN::META->{$k}{$k2}};
2920 }
2921 }
2922}
2923
f20de9f0 2924# compare with install_tested
b72dd56f 2925#-> sub CPAN::Shell::is_tested
f20de9f0 2926sub is_tested {
b72dd56f 2927 my($self) = @_;
f20de9f0 2928 CPAN::Index->reload;
b72dd56f
SP		 2929 for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2930 my $time;
2931 if ($CPAN::META->{is_tested}{$b}) {
2932 $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2933 } else {
2934 $time = scalar localtime;
2935 $time =~ s/\S/?/g;
2936 }
2937 $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2938 }
2939}
2940
05454584
A		 2941#-> sub CPAN::Shell::autobundle ;
2942sub autobundle {
2943 my($self) = shift;
e82b9348 2944 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
05454584 2945 my(@bundle) = $self->_u_r_common("a",@_);
5de3f0da 2946 my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
05454584
A		 2947 File::Path::mkpath($todir);
2948 unless (-d $todir) {
f04ea8d1
SP		 2949 $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2950 return;
05454584
A		 2951 }
2952 my($y,$m,$d) = (localtime)[5,4,3];
2953 $y+=1900;
2954 $m++;
2955 my($c) = 0;
2956 my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
5de3f0da 2957 my($to) = File::Spec->catfile($todir,"$me.pm");
05454584 2958 while (-f $to) {
f04ea8d1
SP		 2959 $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2960 $to = File::Spec->catfile($todir,"$me.pm");
05454584
A		 2961 }
2962 my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2963 $fh->print(
f04ea8d1
SP		 2964 "package Bundle::$me;\n\n",
2965 "\$VERSION = '0.01';\n\n",
2966 "1;\n\n",
2967 "__END__\n\n",
2968 "=head1 NAME\n\n",
2969 "Bundle::$me - Snapshot of installation on ",
2970 $Config::Config{'myhostname'},
2971 " on ",
2972 scalar(localtime),
2973 "\n\n=head1 SYNOPSIS\n\n",
2974 "perl -MCPAN -e 'install Bundle::$me'\n\n",
2975 "=head1 CONTENTS\n\n",
2976 join("\n", @bundle),
2977 "\n\n=head1 CONFIGURATION\n\n",
2978 Config->myconfig,
2979 "\n\n=head1 AUTHOR\n\n",
2980 "This Bundle has been generated automatically ",
2981 "by the autobundle routine in CPAN.pm.\n",
2982 );
05454584 2983 $fh->close;
c356248b
A		 2984 $CPAN::Frontend->myprint("\nWrote bundle file
2985 $to\n\n");
05454584
A		 2986}
2987
6d29edf5
JH		 2988#-> sub CPAN::Shell::expandany ;
2989sub expandany {
2990 my($self,$s) = @_;
2991 CPAN->debug("s[$s]") if $CPAN::DEBUG;
8fc516fe 2992 if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
8d97e4a1 2993 $s = CPAN::Distribution->normalize($s);
6d29edf5
JH		 2994 return $CPAN::META->instance('CPAN::Distribution',$s);
2995 # Distributions spring into existence, not expand
2996 } elsif ($s =~ m|^Bundle::|) {
2997 $self->local_bundles; # scanning so late for bundles seems
2998 # both attractive and crumpy: always
2999 # current state but easy to forget
3000 # somewhere
3001 return $self->expand('Bundle',$s);
3002 } else {
3003 return $self->expand('Module',$s)
3004 if $CPAN::META->exists('CPAN::Module',$s);
3005 }
3006 return;
3007}
3008
05454584
A		 3009#-> sub CPAN::Shell::expand ;
3010sub expand {
e82b9348 3011 my $self = shift;
05454584 3012 my($type,@args) = @_;
8d97e4a1 3013 CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
e82b9348
SP		 3014 my $class = "CPAN::$type";
3015 my $methods = ['id'];
3016 for my $meth (qw(name)) {
e82b9348
SP		 3017 next unless $class->can($meth);
3018 push @$methods, $meth;
3019 }
3020 $self->expand_by_method($class,$methods,@args);
3021}
3022
05bab18e 3023#-> sub CPAN::Shell::expand_by_method ;
e82b9348
SP		 3024sub expand_by_method {
3025 my $self = shift;
3026 my($class,$methods,@args) = @_;
3027 my($arg,@m);
05454584 3028 for $arg (@args) {
f04ea8d1
SP		 3029 my($regex,$command);
3030 if ($arg =~ m|^/(.*)/$|) {
3031 $regex = $1;
b03f445c
RGS		 3032# FIXME: there seem to be some ='s in the author data, which trigger
3033# a failure here. This needs to be contemplated.
3034# } elsif ($arg =~ m/=/) {
3035# $command = 1;
6d29edf5 3036 }
f04ea8d1 3037 my $obj;
8d97e4a1
JH		 3038 CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
3039 $class,
3040 defined $regex ? $regex : "UNDEFINED",
e82b9348 3041 defined $command ? $command : "UNDEFINED",
8d97e4a1 3042 ) if $CPAN::DEBUG;
f04ea8d1 3043 if (defined $regex) {
810a0276 3044 if (CPAN::_sqlite_running) {
5254b38e 3045 CPAN::Index->reload;
be34b10d
SP		 3046 $CPAN::SQLite->search($class, $regex);
3047 }
6d29edf5 3048 for $obj (
6d29edf5
JH		 3049 $CPAN::META->all_objects($class)
3050 ) {
f04ea8d1 3051 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
6d29edf5 3052 # BUG, we got an empty object somewhere
8d97e4a1 3053 require Data::Dumper;
6d29edf5 3054 CPAN->debug(sprintf(
8d97e4a1 3055 "Bug in CPAN: Empty id on obj[%s][%s]",
6d29edf5 3056 $obj,
8d97e4a1 3057 Data::Dumper::Dumper($obj)
6d29edf5
JH		 3058 )) if $CPAN::DEBUG;
3059 next;
3060 }
e82b9348 3061 for my $method (@$methods) {
135a59c2
A		 3062 my $match = eval {$obj->$method() =~ /$regex/i};
3063 if ($@) {
3064 my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
3065 $err ||= $@; # if we were too restrictive above
3066 $CPAN::Frontend->mydie("$err\n");
3067 } elsif ($match) {
e82b9348
SP		 3068 push @m, $obj;
3069 last;
3070 }
3071 }
6d29edf5
JH		 3072 }
3073 } elsif ($command) {
8d97e4a1
JH		 3074 die "equal sign in command disabled (immature interface), ".
3075 "you can set
3076 ! \$CPAN::Shell::ADVANCED_QUERY=1
3077to enable it. But please note, this is HIGHLY EXPERIMENTAL code
3078that may go away anytime.\n"
3079 unless $ADVANCED_QUERY;
3080 my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
3081 my($matchcrit) = $criterion =~ m/^~(.+)/;
6d29edf5
JH		 3082 for my $self (
3083 sort
3084 {$a->id cmp $b->id}
3085 $CPAN::META->all_objects($class)
3086 ) {
8d97e4a1
JH		 3087 my $lhs = $self->$method() or next; # () for 5.00503
3088 if ($matchcrit) {
3089 push @m, $self if $lhs =~ m/$matchcrit/;
3090 } else {
3091 push @m, $self if $lhs eq $criterion;
3092 }
6d29edf5 3093 }
f04ea8d1
SP		 3094 } else {
3095 my($xarg) = $arg;
3096 if ( $class eq 'CPAN::Bundle' ) {
3097 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
3098 } elsif ($class eq "CPAN::Distribution") {
8d97e4a1 3099 $xarg = CPAN::Distribution->normalize($arg);
e82b9348
SP		 3100 } else {
3101 $xarg =~ s/:+/::/g;
8d97e4a1 3102 }
f04ea8d1
SP		 3103 if ($CPAN::META->exists($class,$xarg)) {
3104 $obj = $CPAN::META->instance($class,$xarg);
3105 } elsif ($CPAN::META->exists($class,$arg)) {
3106 $obj = $CPAN::META->instance($class,$arg);
3107 } else {
3108 next;
3109 }
3110 push @m, $obj;
3111 }
05454584 3112 }
ecc7fca0 3113 @m = sort {$a->id cmp $b->id} @m;
e82b9348
SP		 3114 if ( $CPAN::DEBUG ) {
3115 my $wantarray = wantarray;
3116 my $join_m = join ",", map {$_->id} @m;
5254b38e
SP		 3117 # $self->debug("wantarray[$wantarray]join_m[$join_m]");
3118 my $count = scalar @m;
3119 $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
e82b9348 3120 }
e50380aa 3121 return wantarray ? @m : $m[0];
05454584
A		 3122}
3123
3124#-> sub CPAN::Shell::format_result ;
3125sub format_result {
3126 my($self) = shift;
3127 my($type,@args) = @_;
3128 @args = '/./' unless @args;
3129 my(@result) = $self->expand($type,@args);
8d97e4a1 3130 my $result = @result == 1 ?
f04ea8d1 3131 $result[0]->as_string :
8d97e4a1
JH		 3132 @result == 0 ?
3133 "No objects of type $type found for argument @args\n" :
3134 join("",
3135 (map {$_->as_glimpse} @result),
3136 scalar @result, " items found\n",
3137 );
05454584
A		 3138 $result;
3139}
3140
554a9ef5
SP		 3141#-> sub CPAN::Shell::report_fh ;
3142{
3143 my $installation_report_fh;
3144 my $previously_noticed = 0;
3145
3146 sub report_fh {
3147 return $installation_report_fh if $installation_report_fh;
b03f445c 3148 if ($CPAN::META->has_usable("File::Temp")) {
4d1321a7
A		 3149 $installation_report_fh
3150 = File::Temp->new(
917f1700 3151 dir => File::Spec->tmpdir,
4d1321a7
A		 3152 template => 'cpan_install_XXXX',
3153 suffix => '.txt',
3154 unlink => 0,
3155 );
3156 }
554a9ef5
SP		 3157 unless ( $installation_report_fh ) {
3158 warn("Couldn't open installation report file; " .
3159 "no report file will be generated."
3160 ) unless $previously_noticed++;
3161 }
3162 }
3163}
3164
3165
c356248b
A		 3166# The only reason for this method is currently to have a reliable
3167# debugging utility that reveals which output is going through which
3168# channel. No, I don't like the colors ;-)
8d97e4a1 3169
8962fc49
SP		 3170# to turn colordebugging on, write
3171# cpan> o conf colorize_output 1
3172
5254b38e 3173#-> sub CPAN::Shell::colorize_output ;
8962fc49
SP		 3174{
3175 my $print_ornamented_have_warned = 0;
3176 sub colorize_output {
3177 my $colorize_output = $CPAN::Config->{colorize_output};
3178 if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
3179 unless ($print_ornamented_have_warned++) {
3180 # no myprint/mywarn within myprint/mywarn!
3181 warn "Colorize_output is set to true but Term::ANSIColor is not
3182installed. To activate colorized output, please install Term::ANSIColor.\n\n";
3183 }
3184 $colorize_output = 0;
3185 }
3186 return $colorize_output;
3187 }
3188}
3189
3190
05bab18e 3191#-> sub CPAN::Shell::print_ornamented ;
c356248b
A		 3192sub print_ornamented {
3193 my($self,$what,$ornament) = @_;
8d97e4a1 3194 return unless defined $what;
c356248b 3195
554a9ef5
SP		 3196 local $| = 1; # Flush immediately
3197 if ( $CPAN::Be_Silent ) {
3198 print {report_fh()} $what;
3199 return;
3200 }
8962fc49 3201 my $swhat = "$what"; # stringify if it is an object
f04ea8d1
SP		 3202 if ($CPAN::Config->{term_is_latin}) {
3203 # note: deprecated, need to switch to $LANG and $LC_*
8d97e4a1 3204 # courtesy jhi:
8962fc49 3205 $swhat
8d97e4a1
JH		 3206 =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
3207 }
8962fc49 3208 if ($self->colorize_output) {
135a59c2
A		 3209 if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
3210 # if you want to have this configurable, please file a bugreport
b72dd56f 3211 $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
135a59c2 3212 }
8962fc49
SP		 3213 my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
3214 if ($@) {
3215 print "Term::ANSIColor rejects color[$ornament]: $@\n
f20de9f0 3216Please choose a different color (Hint: try 'o conf init /color/')\n";
8962fc49 3217 }
5254b38e 3218 # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
f04ea8d1
SP		 3219 # $trailer construct. We want the newline be the last thing if
3220 # there is a newline at the end ensuring that the next line is
3221 # empty for other players
3222 my $trailer = "";
3223 $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
135a59c2
A		 3224 print $color_on,
3225 $swhat,
f04ea8d1
SP		 3226 Term::ANSIColor::color("reset"),
3227 $trailer;
c356248b 3228 } else {
8962fc49 3229 print $swhat;
c356248b
A		 3230 }
3231}
3232
05bab18e
SP		 3233#-> sub CPAN::Shell::myprint ;
3234
f04ea8d1
SP		 3235# where is myprint/mywarn/Frontend/etc. documented? Where to use what?
3236# I think, we send everything to STDOUT and use print for normal/good
3237# news and warn for news that need more attention. Yes, this is our
3238# working contract for now.
c356248b
A		 3239sub myprint {
3240 my($self,$what) = @_;
f04ea8d1
SP		 3241 $self->print_ornamented($what,
3242 $CPAN::Config->{colorize_print}||'bold blue on_white',
3243 );
3244}
8d97e4a1 3245
f04ea8d1
SP		 3246sub optprint {
3247 my($self,$category,$what) = @_;
3248 my $vname = $category . "_verbosity";
3249 CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
3250 if (!$CPAN::Config->{$vname}
3251 || $CPAN::Config->{$vname} =~ /^v/
3252 ) {
3253 $CPAN::Frontend->myprint($what);
3254 }
c356248b
A		 3255}
3256
05bab18e 3257#-> sub CPAN::Shell::myexit ;
c356248b
A		 3258sub myexit {
3259 my($self,$what) = @_;
3260 $self->myprint($what);
3261 exit;
3262}
3263
05bab18e 3264#-> sub CPAN::Shell::mywarn ;
c356248b
A		 3265sub mywarn {
3266 my($self,$what) = @_;
2ccf00a7 3267 $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
c356248b
A		 3268}
3269
b96578bb 3270# only to be used for shell commands
05bab18e 3271#-> sub CPAN::Shell::mydie ;
c356248b
A		 3272sub mydie {
3273 my($self,$what) = @_;
dc053c64 3274 $self->mywarn($what);
b96578bb 3275
dc053c64 3276 # If it is the shell, we want the following die to be silent,
b96578bb
SP		 3277 # but if it is not the shell, we would need a 'die $what'. We need
3278 # to take care that only shell commands use mydie. Is this
3279 # possible?
3280
c356248b
A		 3281 die "\n";
3282}
3283
05bab18e 3284# sub CPAN::Shell::colorable_makemaker_prompt ;
8962fc49
SP		 3285sub colorable_makemaker_prompt {
3286 my($foo,$bar) = @_;
3287 if (CPAN::Shell->colorize_output) {
2ccf00a7 3288 my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
8962fc49
SP		 3289 my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
3290 print $color_on;
3291 }
3292 my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
3293 if (CPAN::Shell->colorize_output) {
3294 print Term::ANSIColor::color('reset');
3295 }
3296 return $ans;
3297}
3298
c9869e1c 3299# use this only for unrecoverable errors!
05bab18e 3300#-> sub CPAN::Shell::unrecoverable_error ;
c9869e1c
SP		 3301sub unrecoverable_error {
3302 my($self,$what) = @_;
3303 my @lines = split /\n/, $what;
3304 my $longest = 0;
3305 for my $l (@lines) {
3306 $longest = length $l if length $l > $longest;
3307 }
3308 $longest = 62 if $longest > 62;
3309 for my $l (@lines) {
f04ea8d1 3310 if ($l =~ /^\s*$/) {
c9869e1c
SP		 3311 $l = "\n";
3312 next;
3313 }
3314 $l = "==> $l";
3315 if (length $l < 66) {
3316 $l = pack "A66 A*", $l, "<==";
3317 }
3318 $l .= "\n";
3319 }
3320 unshift @lines, "\n";
3321 $self->mydie(join "", @lines);
c9869e1c
SP		 3322}
3323
05bab18e 3324#-> sub CPAN::Shell::mysleep ;
9ddc4ed0
A		 3325sub mysleep {
3326 my($self, $sleep) = @_;
dc053c64
SP		 3327 if (CPAN->has_inst("Time::HiRes")) {
3328 Time::HiRes::sleep($sleep);
3329 } else {
3330 sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3331 }
9ddc4ed0
A		 3332}
3333
05bab18e 3334#-> sub CPAN::Shell::setup_output ;
911a92db
GS		 3335sub setup_output {
3336 return if -t STDOUT;
3337 my $odef = select STDERR;
3338 $| = 1;
3339 select STDOUT;
3340 $| = 1;
3341 select $odef;
3342}
3343
05454584 3344#-> sub CPAN::Shell::rematein ;
810a0276 3345# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
05454584 3346sub rematein {
0cf35e6a 3347 my $self = shift;
05454584 3348 my($meth,@some) = @_;
554a9ef5 3349 my @pragma;
b72dd56f 3350 while($meth =~ /^(ff?orce|notest)$/) {
f04ea8d1
SP		 3351 push @pragma, $meth;
3352 $meth = shift @some or
0cf35e6a
SP		 3353 $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3354 "cannot continue");
05454584 3355 }
911a92db 3356 setup_output();
554a9ef5 3357 CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
6d29edf5
JH		 3358
3359 # Here is the place to set "test_count" on all involved parties to
3360 # 0. We then can pass this counter on to the involved
3361 # distributions and those can refuse to test if test_count > X. In
3362 # the first stab at it we could use a 1 for "X".
3363
3364 # But when do I reset the distributions to start with 0 again?
3365 # Jost suggested to have a random or cycling interaction ID that
3366 # we pass through. But the ID is something that is just left lying
3367 # around in addition to the counter, so I'd prefer to set the
3368 # counter to 0 now, and repeat at the end of the loop. But what
3369 # about dependencies? They appear later and are not reset, they
3370 # enter the queue but not its copy. How do they get a sensible
3371 # test_count?
3372
f04ea8d1
SP		 3373 # With configure_requires, "get" is vulnerable in recursion.
3374
3375 my $needs_recursion_protection = "get|make|test|install";
f20de9f0 3376
6d29edf5
JH		 3377 # construct the queue
3378 my($s,@s,@qcopy);
0cf35e6a 3379 STHING: foreach $s (@some) {
f04ea8d1
SP		 3380 my $obj;
3381 if (ref $s) {
6d29edf5 3382 CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
f04ea8d1
SP		 3383 $obj = $s;
3384 } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3385 } elsif ($s =~ m|^/|) { # looks like a regexp
8fc516fe
SP		 3386 if (substr($s,-1,1) eq ".") {
3387 $obj = CPAN::Shell->expandany($s);
3388 } else {
3389 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3390 "not supported.\nRejecting argument '$s'\n");
3391 $CPAN::Frontend->mysleep(2);
3392 next;
3393 }
f04ea8d1 3394 } elsif ($meth eq "ls") {
ca79d794 3395 $self->globls($s,\@pragma);
0cf35e6a
SP		 3396 next STHING;
3397 } else {
6d29edf5 3398 CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
f04ea8d1
SP		 3399 $obj = CPAN::Shell->expandany($s);
3400 }
3401 if (0) {
7d97ad34 3402 } elsif (ref $obj) {
f20de9f0 3403 if ($meth =~ /^($needs_recursion_protection)$/) {
ade94d80
SP		 3404 # it would be silly to check for recursion for look or dump
3405 # (we are in CPAN::Shell::rematein)
3406 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3407 eval { $obj->color_cmd_tmps(0,1); };
f04ea8d1 3408 if ($@) {
ade94d80
SP		 3409 if (ref $@
3410 and $@->isa("CPAN::Exception::RecursiveDependency")) {
3411 $CPAN::Frontend->mywarn($@);
3412 } else {
3413 if (0) {
3414 require Carp;
3415 Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3416 }
3417 die;
3418 }
3419 }
f20de9f0 3420 }
f04ea8d1 3421 CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
6d29edf5 3422 push @qcopy, $obj;
f04ea8d1
SP		 3423 } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3424 $obj = $CPAN::META->instance('CPAN::Author',uc($s));
dc053c64 3425 if ($meth =~ /^(dump|ls|reports)$/) {
5fc0f0f6 3426 $obj->$meth();
8d97e4a1 3427 } else {
8962fc49
SP		 3428 $CPAN::Frontend->mywarn(
3429 join "",
3430 "Don't be silly, you can't $meth ",
3431 $obj->fullname,
3432 " ;-)\n"
3433 );
3434 $CPAN::Frontend->mysleep(2);
8d97e4a1 3435 }
f04ea8d1 3436 } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
135a59c2
A		 3437 CPAN::InfoObj->dump($s);
3438 } else {
f04ea8d1
SP		 3439 $CPAN::Frontend
3440 ->mywarn(qq{Warning: Cannot $meth $s, }.
3441 qq{don't know what it is.
e50380aa
A		 3442Try the command
3443
3444 i /$s/
3445
6d29edf5 3446to find objects with matching identifiers.
c356248b 3447});
8962fc49 3448 $CPAN::Frontend->mysleep(2);
f04ea8d1 3449 }
6d29edf5
JH		 3450 }
3451
3452 # queuerunner (please be warned: when I started to change the
3453 # queue to hold objects instead of names, I made one or two
3454 # mistakes and never found which. I reverted back instead)
5254b38e 3455 QITEM: while (my $q = CPAN::Queue->first) {
6d29edf5 3456 my $obj;
135a59c2
A		 3457 my $s = $q->as_string;
3458 my $reqtype = $q->reqtype || "";
3459 $obj = CPAN::Shell->expandany($s);
f20de9f0
SP		 3460 unless ($obj) {
3461 # don't know how this can happen, maybe we should panic,
3462 # but maybe we get a solution from the first user who hits
3463 # this unfortunate exception?
3464 $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
2b3bde2a 3465 "to an object. Skipping.\n");
f20de9f0 3466 $CPAN::Frontend->mysleep(5);
2b3bde2a 3467 CPAN::Queue->delete_first($s);
5254b38e 3468 next QITEM;
f20de9f0 3469 }
135a59c2 3470 $obj->{reqtype} ||= "";
810a0276
SP		 3471 {
3472 # force debugging because CPAN::SQLite somehow delivers us
3473 # an empty object;
3474
3475 # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3476
3477 CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3478 "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3479 }
135a59c2
A		 3480 if ($obj->{reqtype}) {
3481 if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3482 $obj->{reqtype} = $reqtype;
3483 if (
3484 exists $obj->{install}
3485 &&
3486 (
be34b10d 3487 UNIVERSAL::can($obj->{install},"failed") ?
135a59c2
A		 3488 $obj->{install}->failed :
3489 $obj->{install} =~ /^NO/
3490 )
3491 ) {
3492 delete $obj->{install};
3493 $CPAN::Frontend->mywarn
3494 ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3495 }
3496 }
3497 } else {
3498 $obj->{reqtype} = $reqtype;
3499 }
3500
f04ea8d1
SP		 3501 for my $pragma (@pragma) {
3502 if ($pragma
3503 &&
3504 $obj->can($pragma)) {
3505 $obj->$pragma($meth);
3506 }
6d29edf5 3507 }
810a0276 3508 if (UNIVERSAL::can($obj, 'called_for')) {
6d29edf5
JH		 3509 $obj->called_for($s);
3510 }
135a59c2
A		 3511 CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3512 qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
6d29edf5 3513
6a935156 3514 push @qcopy, $obj;
f04ea8d1
SP		 3515 if ($meth =~ /^(report)$/) { # they came here with a pragma?
3516 $self->$meth($obj);
3517 } elsif (! UNIVERSAL::can($obj,$meth)) {
810a0276
SP		 3518 # Must never happen
3519 my $serialized = "";
3520 if (0) {
3521 } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3522 $serialized = YAML::Syck::Dump($obj);
3523 } elsif ($CPAN::META->has_inst("YAML")) {
3524 $serialized = YAML::Dump($obj);
3525 } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3526 $serialized = Data::Dumper::Dumper($obj);
3527 } else {
3528 require overload;
3529 $serialized = overload::StrVal($obj);
3530 }
23a216b4 3531 CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
810a0276 3532 $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
f04ea8d1 3533 } elsif ($obj->$meth()) {
6d29edf5 3534 CPAN::Queue->delete($s);
23a216b4 3535 CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
6d29edf5 3536 } else {
23a216b4 3537 CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
6d29edf5
JH		 3538 }
3539
3540 $obj->undelay;
f04ea8d1 3541 for my $pragma (@pragma) {
05bab18e 3542 my $unpragma = "un$pragma";
f04ea8d1
SP		 3543 if ($obj->can($unpragma)) {
3544 $obj->$unpragma();
3545 }
05bab18e 3546 }
5254b38e
SP		 3547 if ($CPAN::Config->{halt_on_failure}
3548 &&
3549 CPAN::Distrostatus::something_has_just_failed()
3550 ) {
3551 $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
3552 CPAN::Queue->nullify_queue;
3553 last QITEM;
3554 }
f04ea8d1 3555 CPAN::Queue->delete_first($s);
05454584 3556 }
f20de9f0
SP		 3557 if ($meth =~ /^($needs_recursion_protection)$/) {
3558 for my $obj (@qcopy) {
3559 $obj->color_cmd_tmps(0,0);
3560 }
6d29edf5 3561 }
05454584
A		 3562}
3563
554a9ef5
SP		 3564#-> sub CPAN::Shell::recent ;
3565sub recent {
f3fe0ae6 3566 my($self) = @_;
f04ea8d1
SP		 3567 if ($CPAN::META->has_inst("XML::LibXML")) {
3568 my $url = $CPAN::Defaultrecent;
3569 $CPAN::Frontend->myprint("Going to fetch '$url'\n");
3570 unless ($CPAN::META->has_usable("LWP")) {
3571 $CPAN::Frontend->mydie("LWP not installed; cannot continue");
3572 }
3573 CPAN::LWP::UserAgent->config;
3574 my $Ua;
3575 eval { $Ua = CPAN::LWP::UserAgent->new; };
3576 if ($@) {
3577 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
3578 }
3579 my $resp = $Ua->get($url);
3580 unless ($resp->is_success) {
3581 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
3582 }
3583 $CPAN::Frontend->myprint("DONE\n\n");
3584 my $xml = XML::LibXML->new->parse_string($resp->content);
3585 if (0) {
3586 my $s = $xml->serialize(2);
3587 $s =~ s/\n\s*\n/\n/g;
3588 $CPAN::Frontend->myprint($s);
3589 return;
3590 }
3591 my @distros;
3592 if ($url =~ /winnipeg/) {
3593 my $pubdate = $xml->findvalue("/rss/channel/pubDate");
3594 $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
3595 for my $eitem ($xml->findnodes("/rss/channel/item")) {
3596 my $distro = $eitem->findvalue("enclosure/\@url");
3597 $distro =~ s|.*?/authors/id/./../||;
3598 my $size = $eitem->findvalue("enclosure/\@length");
3599 my $desc = $eitem->findvalue("description");
5254b38e 3600 $desc =~ s/.+? - //;
f04ea8d1
SP		 3601 $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
3602 push @distros, $distro;
3603 }
3604 } elsif ($url =~ /search.*uploads.rdf/) {
3605 # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
3606 # xmlns="http://purl.org/rss/1.0/"
3607 # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
3608 # xmlns:dc="http://purl.org/dc/elements/1.1/"
3609 # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
3610 # xmlns:admin="http://webns.net/mvcb/"
3611
3612
3613 my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
3614 $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
3615 my $finish_eitem = 0;
3616 local $SIG{INT} = sub { $finish_eitem = 1 };
3617 EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
3618 my $distro = $eitem->findvalue("\@rdf:about");
3619 $distro =~ s|.*~||; # remove up to the tilde before the name
3620 $distro =~ s|/$||; # remove trailing slash
3621 $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
3622 my $author = uc $1 or die "distro[$distro] without author, cannot continue";
3623 my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
3624 my $i = 0;
3625 SUBDIRTEST: while () {
3626 last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
3627 if (my @ret = $self->globls("$distro*")) {
3628 @ret = grep {$_->[2] !~ /meta/} @ret;
3629 @ret = grep {length $_->[2]} @ret;
3630 if (@ret) {
3631 $distro = "$author/$ret[0][2]";
3632 last SUBDIRTEST;
3633 }
3634 }
3635 $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
3636 }
3637
3638 next EITEM if $distro =~ m|\*|; # did not find the thing
3639 $CPAN::Frontend->myprint("____$desc\n");
3640 push @distros, $distro;
3641 last EITEM if $finish_eitem;
3642 }
3643 }
3644 return \@distros;
3645 } else {
3646 # deprecated old version
3647 $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
3648 }
3649}
554a9ef5 3650
f04ea8d1
SP		 3651#-> sub CPAN::Shell::smoke ;
3652sub smoke {
3653 my($self) = @_;
3654 my $distros = $self->recent;
3655 DISTRO: for my $distro (@$distros) {
5254b38e 3656 next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
f04ea8d1
SP		 3657 $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
3658 {
3659 my $skip = 0;
3660 local $SIG{INT} = sub { $skip = 1 };
3661 for (0..9) {
3662 $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
3663 sleep 1;
3664 if ($skip) {
3665 $CPAN::Frontend->myprint(" skipped\n");
3666 next DISTRO;
3667 }
3668 }
3669 }
3670 $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
3671 $self->test($distro);
3672 }
554a9ef5
SP		 3673}
3674
3675{
3676 # set up the dispatching methods
3677 no strict "refs";
3678 for my $command (qw(
0cf35e6a
SP		 3679 clean
3680 cvs_import
3681 dump
3682 force
b72dd56f 3683 fforce
0cf35e6a
SP		 3684 get
3685 install
3686 look
3687 ls
3688 make
3689 notest
3690 perldoc
3691 readme
dc053c64 3692 reports
0cf35e6a 3693 test
554a9ef5
SP		 3694 )) {
3695 *$command = sub { shift->rematein($command, @_); };
3696 }
3697}
05454584 3698
c049f953 3699package CPAN::LWP::UserAgent;
e82b9348 3700use strict;
c049f953
JH		 3701
3702sub config {
3703 return if $SETUPDONE;
3704 if ($CPAN::META->has_usable('LWP::UserAgent')) {
3705 require LWP::UserAgent;
3706 @ISA = qw(Exporter LWP::UserAgent);
3707 $SETUPDONE++;
3708 } else {
8962fc49 3709 $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
c049f953
JH		 3710 }
3711}
3712
3713sub get_basic_credentials {
3714 my($self, $realm, $uri, $proxy) = @_;
c049f953 3715 if ($USER && $PASSWD) {
ed84aac9
A		 3716 return ($USER, $PASSWD);
3717 }
3718 if ( $proxy ) {
3719 ($USER,$PASSWD) = $self->get_proxy_credentials();
c049f953 3720 } else {
ed84aac9
A		 3721 ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3722 }
3723 return($USER,$PASSWD);
3724}
3725
3726sub get_proxy_credentials {
3727 my $self = shift;
3728 my ($user, $password);
5254b38e 3729 if ( defined $CPAN::Config->{proxy_user} ) {
ed84aac9 3730 $user = $CPAN::Config->{proxy_user};
5254b38e 3731 $password = $CPAN::Config->{proxy_pass} || "";
ed84aac9
A		 3732 return ($user, $password);
3733 }
3734 my $username_prompt = "\nProxy authentication needed!
c049f953
JH		 3735 (Note: to permanently configure username and password run
3736 o conf proxy_user your_username
3737 o conf proxy_pass your_password
ed84aac9
A		 3738 )\nUsername:";
3739 ($user, $password) =
3740 _get_username_and_password_from_user($username_prompt);
3741 return ($user,$password);
3742}
3743
3744sub get_non_proxy_credentials {
3745 my $self = shift;
3746 my ($user,$password);
5254b38e 3747 if ( defined $CPAN::Config->{username} ) {
ed84aac9 3748 $user = $CPAN::Config->{username};
5254b38e 3749 $password = $CPAN::Config->{password} || "";
ed84aac9
A		 3750 return ($user, $password);
3751 }
3752 my $username_prompt = "\nAuthentication needed!
3753 (Note: to permanently configure username and password run
3754 o conf username your_username
3755 o conf password your_password
3756 )\nUsername:";
8962fc49 3757
ed84aac9
A		 3758 ($user, $password) =
3759 _get_username_and_password_from_user($username_prompt);
3760 return ($user,$password);
3761}
3762
3763sub _get_username_and_password_from_user {
ed84aac9
A		 3764 my $username_message = shift;
3765 my ($username,$password);
3766
3767 ExtUtils::MakeMaker->import(qw(prompt));
3768 $username = prompt($username_message);
c049f953
JH		 3769 if ($CPAN::META->has_inst("Term::ReadKey")) {
3770 Term::ReadKey::ReadMode("noecho");
c049f953 3771 }
ed84aac9
A		 3772 else {
3773 $CPAN::Frontend->mywarn(
3774 "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3775 );
3776 }
3777 $password = prompt("Password:");
3778
c049f953
JH		 3779 if ($CPAN::META->has_inst("Term::ReadKey")) {
3780 Term::ReadKey::ReadMode("restore");
3781 }
3782 $CPAN::Frontend->myprint("\n\n");
ed84aac9 3783 return ($username,$password);
c049f953
JH		 3784}
3785
1426a145
JH		 3786# mirror(): Its purpose is to deal with proxy authentication. When we
3787# call SUPER::mirror, we relly call the mirror method in
3788# LWP::UserAgent. LWP::UserAgent will then call
3789# $self->get_basic_credentials or some equivalent and this will be
3790# $self->dispatched to our own get_basic_credentials method.
3791
3792# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3793
3794# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3795# although we have gone through our get_basic_credentials, the proxy
3796# server refuses to connect. This could be a case where the username or
3797# password has changed in the meantime, so I'm trying once again without
3798# $USER and $PASSWD to give the get_basic_credentials routine another
3799# chance to set $USER and $PASSWD.
3800
554a9ef5
SP		 3801# mirror(): Its purpose is to deal with proxy authentication. When we
3802# call SUPER::mirror, we relly call the mirror method in
3803# LWP::UserAgent. LWP::UserAgent will then call
3804# $self->get_basic_credentials or some equivalent and this will be
3805# $self->dispatched to our own get_basic_credentials method.
3806
3807# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3808
3809# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3810# although we have gone through our get_basic_credentials, the proxy
3811# server refuses to connect. This could be a case where the username or
3812# password has changed in the meantime, so I'm trying once again without
3813# $USER and $PASSWD to give the get_basic_credentials routine another
3814# chance to set $USER and $PASSWD.
3815
c049f953
JH		 3816sub mirror {
3817 my($self,$url,$aslocal) = @_;
3818 my $result = $self->SUPER::mirror($url,$aslocal);
3819 if ($result->code == 407) {
3820 undef $USER;
3821 undef $PASSWD;
3822 $result = $self->SUPER::mirror($url,$aslocal);
3823 }
3824 $result;
3825}
3826
05454584 3827package CPAN::FTP;
e82b9348 3828use strict;
05454584 3829
05bab18e
SP		 3830#-> sub CPAN::FTP::ftp_statistics
3831# if they want to rewrite, they need to pass in a filehandle
3832sub _ftp_statistics {
3833 my($self,$fh) = @_;
3834 my $locktype = $fh ? LOCK_EX : LOCK_SH;
3835 $fh ||= FileHandle->new;
3836 my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3837 open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3838 my $sleep = 1;
810a0276 3839 my $waitstart;
f04ea8d1 3840 while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
810a0276 3841 $waitstart ||= localtime();
05bab18e 3842 if ($sleep>3) {
810a0276 3843 $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
be34b10d
SP		 3844 }
3845 $CPAN::Frontend->mysleep($sleep);
3846 if ($sleep <= 3) {
3847 $sleep+=0.33;
810a0276
SP		 3848 } elsif ($sleep <=6) {
3849 $sleep+=0.11;
05bab18e 3850 }
05bab18e 3851 }
b72dd56f
SP		 3852 my $stats = eval { CPAN->_yaml_loadfile($file); };
3853 if ($@) {
3854 if (ref $@) {
3855 if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3856 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3857 return;
3858 } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3859 $CPAN::Frontend->mydie($@);
3860 }
3861 } else {
3862 $CPAN::Frontend->mydie($@);
3863 }
3864 }
05bab18e
SP		 3865 return $stats->[0];
3866}
3867
810a0276 3868#-> sub CPAN::FTP::_mytime
05bab18e
SP		 3869sub _mytime () {
3870 if (CPAN->has_inst("Time::HiRes")) {
3871 return Time::HiRes::time();
3872 } else {
3873 return time;
3874 }
3875}
3876
810a0276 3877#-> sub CPAN::FTP::_new_stats
05bab18e
SP		 3878sub _new_stats {
3879 my($self,$file) = @_;
3880 my $ret = {
3881 file => $file,
3882 attempts => [],
3883 start => _mytime,
3884 };
3885 $ret;
3886}
3887
810a0276 3888#-> sub CPAN::FTP::_add_to_statistics
05bab18e
SP		 3889sub _add_to_statistics {
3890 my($self,$stats) = @_;
b72dd56f 3891 my $yaml_module = CPAN::_yaml_module;
f20de9f0 3892 $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
810a0276
SP		 3893 if ($CPAN::META->has_inst($yaml_module)) {
3894 $stats->{thesiteurl} = $ThesiteURL;
5254b38e 3895 $stats->{end} = CPAN::FTP::_mytime();
810a0276 3896 my $fh = FileHandle->new;
b72dd56f
SP		 3897 my $time = time;
3898 my $sdebug = 0;
3899 my @debug;
3900 @debug = $time if $sdebug;
810a0276 3901 my $fullstats = $self->_ftp_statistics($fh);
b72dd56f 3902 close $fh;
810a0276 3903 $fullstats->{history} ||= [];
b72dd56f
SP		 3904 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3905 push @debug, time if $sdebug;
810a0276 3906 push @{$fullstats->{history}}, $stats;
5254b38e 3907 # YAML.pm 0.62 is unacceptably slow with 999;
ed756621 3908 # YAML::Syck 0.82 has no noticable performance problem with 999;
5254b38e
SP		 3909 my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
3910 my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
b72dd56f 3911 while (
5254b38e
SP		 3912 @{$fullstats->{history}} > $ftpstats_size
3913 || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
b72dd56f
SP		 3914 ) {
3915 shift @{$fullstats->{history}}
3916 }
3917 push @debug, scalar @{$fullstats->{history}} if $sdebug;
3918 push @debug, time if $sdebug;
3919 push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3920 # need no eval because if this fails, it is serious
3921 my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3922 CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
ade94d80 3923 if ( $sdebug ) {
b72dd56f
SP		 3924 local $CPAN::DEBUG = 512; # FTP
3925 push @debug, time;
3926 CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3927 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
810a0276 3928 @debug,
b72dd56f 3929 ));
810a0276 3930 }
b72dd56f
SP		 3931 # Win32 cannot rename a file to an existing filename
3932 unlink($sfile) if ($^O eq 'MSWin32');
5254b38e 3933 _copy_stat($sfile, "$sfile.$$") if -e $sfile;
b72dd56f
SP		 3934 rename "$sfile.$$", $sfile
3935 or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
05bab18e 3936 }
05bab18e
SP		 3937}
3938
5254b38e
SP		 3939# Copy some stat information (owner, group, mode and) from one file to
3940# another.
3941# This is a utility function which might be moved to a utility repository.
3942#-> sub CPAN::FTP::_copy_stat
3943sub _copy_stat {
3944 my($src, $dest) = @_;
3945 my @stat = stat($src);
3946 if (!@stat) {
3947 $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
3948 return;
3949 }
3950
3951 eval {
3952 chmod $stat[2], $dest
3953 or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
3954 };
3955 warn $@ if $@;
3956 eval {
3957 chown $stat[4], $stat[5], $dest
3958 or do {
3959 my $save_err = $!; # otherwise it's lost in the get... calls
3960 $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
3961 (getpwuid($stat[4]))[0] . "/" .
3962 (getgrgid($stat[5]))[0] . ": $save_err\n"
3963 );
3964 };
3965 };
3966 warn $@ if $@;
3967}
3968
05bab18e
SP		 3969# if file is CHECKSUMS, suggest the place where we got the file to be
3970# checked from, maybe only for young files?
810a0276 3971#-> sub CPAN::FTP::_recommend_url_for
05bab18e
SP		 3972sub _recommend_url_for {
3973 my($self, $file) = @_;
3974 my $urllist = $self->_get_urllist;
3975 if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3976 my $fullstats = $self->_ftp_statistics();
3977 my $history = $fullstats->{history} || [];
3978 while (my $last = pop @$history) {
3979 last if $last->{end} - time > 3600; # only young results are interesting
be34b10d 3980 next unless $last->{file}; # dirname of nothing dies!
05bab18e
SP		 3981 next unless $file eq File::Basename::dirname($last->{file});
3982 return $last->{thesiteurl};
3983 }
3984 }
3985 if ($CPAN::Config->{randomize_urllist}
3986 &&
3987 rand(1) < $CPAN::Config->{randomize_urllist}
3988 ) {
3989 $urllist->[int rand scalar @$urllist];
3990 } else {
3991 return ();
3992 }
3993}
3994
810a0276 3995#-> sub CPAN::FTP::_get_urllist
05bab18e
SP		 3996sub _get_urllist {
3997 my($self) = @_;
3998 $CPAN::Config->{urllist} ||= [];
3999 unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
4000 $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
4001 $CPAN::Config->{urllist} = [];
4002 }
4003 my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
4004 for my $u (@urllist) {
4005 CPAN->debug("u[$u]") if $CPAN::DEBUG;
4006 if (UNIVERSAL::can($u,"text")) {
4007 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
4008 } else {
4009 $u .= "/" unless substr($u,-1) eq "/";
4010 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
4011 }
4012 }
4013 \@urllist;
4014}
4015
05454584
A		 4016#-> sub CPAN::FTP::ftp_get ;
4017sub ftp_get {
9ddc4ed0
A		 4018 my($class,$host,$dir,$file,$target) = @_;
4019 $class->debug(
4020 qq[Going to fetch file [$file] from dir [$dir]
5254b38e 4021 on host [$host] as local [$target]\n]
9ddc4ed0
A		 4022 ) if $CPAN::DEBUG;
4023 my $ftp = Net::FTP->new($host);
4024 unless ($ftp) {
4025 $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
4026 return;
4027 }
4028 return 0 unless defined $ftp;
4029 $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
4030 $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
f04ea8d1 4031 unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
9ddc4ed0
A		 4032 my $msg = $ftp->message;
4033 $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
4034 return;
4035 }
f04ea8d1 4036 unless ( $ftp->cwd($dir) ) {
9ddc4ed0
A		 4037 my $msg = $ftp->message;
4038 $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
4039 return;
4040 }
4041 $ftp->binary;
4042 $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
f04ea8d1 4043 unless ( $ftp->get($file,$target) ) {
9ddc4ed0
A		 4044 my $msg = $ftp->message;
4045 $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
4046 return;
4047 }
4048 $ftp->quit; # it's ok if this fails
4049 return 1;
05454584
A		 4050}
4051
09d9d230 4052# If more accuracy is wanted/needed, Chris Leach sent me this patch...
f610777f 4053
5254b38e
SP		 4054 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
4055 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
6d29edf5
JH		 4056 # > ***************
4057 # > *** 1562,1567 ****
4058 # > --- 1562,1580 ----
4059 # > return 1 if substr($url,0,4) eq "file";
4060 # > return 1 unless $url =~ m|://([^/]+)|;
4061 # > my $host = $1;
4062 # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
4063 # > + if ($proxy) {
4064 # > + $proxy =~ m|://([^/:]+)|;
4065 # > + $proxy = $1;
4066 # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
4067 # > + if ($noproxy) {
4068 # > + if ($host !~ /$noproxy$/) {
4069 # > + $host = $proxy;
4070 # > + }
4071 # > + } else {
4072 # > + $host = $proxy;
4073 # > + }
4074 # > + }
4075 # > require Net::Ping;
4076 # > return 1 unless $Net::Ping::VERSION >= 2;
4077 # > my $p;
09d9d230
A		 4078
4079
05454584
A		 4080#-> sub CPAN::FTP::localize ;
4081sub localize {
4082 my($self,$file,$aslocal,$force) = @_;
4083 $force ||= 0;
4084 Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
f04ea8d1 4085 unless defined $aslocal;
55e314ee 4086 $self->debug("file[$file] aslocal[$aslocal] force[$force]")
f04ea8d1 4087 if $CPAN::DEBUG;
05454584 4088
f14b5cec 4089 if ($^O eq 'MacOS') {
6d29edf5
JH		 4090 # Comment by AK on 2000-09-03: Uniq short filenames would be
4091 # available in CHECKSUMS file
f14b5cec
JH		 4092 my($name, $path) = File::Basename::fileparse($aslocal, '');
4093 if (length($name) > 31) {
6d29edf5
JH		 4094 $name =~ s/(
4095 \.(
4096 readme(\.(gz|Z))? |
4097 (tar\.)?(gz|Z) |
4098 tgz |
4099 zip |
4100 pm\.(gz|Z)
4101 )
4102 )$//x;
f14b5cec
JH		 4103 my $suf = $1;
4104 my $size = 31 - length($suf);
4105 while (length($name) > $size) {
4106 chop $name;
4107 }
4108 $name .= $suf;
4109 $aslocal = File::Spec->catfile($path, $name);
4110 }
4111 }
4112
f04ea8d1 4113 if (-f $aslocal && -r _ && !($force & 1)) {
b96578bb
SP		 4114 my $size;
4115 if ($size = -s $aslocal) {
4116 $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
4117 return $aslocal;
4118 } else {
4119 # empty file from a previous unsuccessful attempt to download it
4120 unlink $aslocal or
ed84aac9
A		 4121 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
4122 "could not remove.");
b96578bb 4123 }
0cf35e6a 4124 }
05bab18e 4125 my($maybe_restore) = 0;
f04ea8d1
SP		 4126 if (-f $aslocal) {
4127 rename $aslocal, "$aslocal.bak$$";
4128 $maybe_restore++;
55e314ee 4129 }
05454584
A		 4130
4131 my($aslocal_dir) = File::Basename::dirname($aslocal);
f04ea8d1 4132 $self->mymkpath($aslocal_dir); # too early for file URLs / RT #28438
05454584 4133 # Inheritance is not easier to manage than a few if/else branches
de34a54b 4134 if ($CPAN::META->has_usable('LWP::UserAgent')) {
f04ea8d1 4135 unless ($Ua) {
c049f953 4136 CPAN::LWP::UserAgent->config;
f04ea8d1 4137 eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
d8773709 4138 if ($@) {
5fc0f0f6 4139 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
d8773709
JH		 4140 if $CPAN::DEBUG;
4141 } else {
4142 my($var);
4143 $Ua->proxy('ftp', $var)
4144 if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
4145 $Ua->proxy('http', $var)
4146 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
4147 $Ua->no_proxy($var)
4148 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
4149 }
f04ea8d1 4150 }
05454584 4151 }
35576f8c
A		 4152 for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
4153 $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
4154 }
05454584
A		 4155
4156 # Try the list of urls for each single object. We keep a record
4157 # where we did get a file from
c356248b 4158 my(@reordered,$last);
05bab18e
SP		 4159 my $ccurllist = $self->_get_urllist;
4160 $last = $#$ccurllist;
c356248b 4161 if ($force & 2) { # local cpans probably out of date, don't reorder
f04ea8d1 4162 @reordered = (0..$last);
c356248b 4163 } else {
f04ea8d1
SP		 4164 @reordered =
4165 sort {
4166 (substr($ccurllist->[$b],0,4) eq "file")
4167 <=>
4168 (substr($ccurllist->[$a],0,4) eq "file")
4169 or
4170 defined($ThesiteURL)
4171 and
05bab18e 4172 ($ccurllist->[$b] eq $ThesiteURL)
f04ea8d1 4173 <=>
05bab18e 4174 ($ccurllist->[$a] eq $ThesiteURL)
f04ea8d1 4175 } 0..$last;
c356248b 4176 }
c4d24d4c 4177 my(@levels);
7fefbd44 4178 $Themethod ||= "";
05bab18e 4179 $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
f04ea8d1
SP		 4180 my @all_levels = (
4181 ["dleasy", "file"],
4182 ["dleasy"],
4183 ["dlhard"],
4184 ["dlhardest"],
4185 ["dleasy", "http","defaultsites"],
4186 ["dlhard", "http","defaultsites"],
4187 ["dleasy", "ftp", "defaultsites"],
4188 ["dlhard", "ftp", "defaultsites"],
4189 ["dlhardest","", "defaultsites"],
4190 );
c356248b 4191 if ($Themethod) {
f04ea8d1
SP		 4192 @levels = grep {$_->[0] eq $Themethod} @all_levels;
4193 push @levels, grep {$_->[0] ne $Themethod} @all_levels;
c356248b 4194 } else {
f04ea8d1 4195 @levels = @all_levels;
c356248b 4196 }
f04ea8d1 4197 @levels = qw/dleasy/ if $^O eq 'MacOS';
c4d24d4c 4198 my($levelno);
f04ea8d1 4199 local $ENV{FTP_PASSIVE} =
4d1321a7
A		 4200 exists $CPAN::Config->{ftp_passive} ?
4201 $CPAN::Config->{ftp_passive} : 1;
05bab18e
SP		 4202 my $ret;
4203 my $stats = $self->_new_stats($file);
5254b38e
SP		 4204 for ($CPAN::Config->{connect_to_internet_ok}) {
4205 $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
4206 }
05bab18e 4207 LEVEL: for $levelno (0..$#levels) {
f04ea8d1
SP		 4208 my $level_tuple = $levels[$levelno];
4209 my($level,$scheme,$sitetag) = @$level_tuple;
4210 my $defaultsites = $sitetag && $sitetag eq "defaultsites";
4211 my @urllist;
4212 if ($defaultsites) {
4213 unless (defined $connect_to_internet_ok) {
4214 $CPAN::Frontend->myprint(sprintf qq{
4215I would like to connect to one of the following sites to get '%s':
4216
4217%s
4218},
4219 $file,
4220 join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
4221 );
4222 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
4223 if ($answer =~ /^y/i) {
4224 $connect_to_internet_ok = 1;
4225 } else {
4226 $connect_to_internet_ok = 0;
4227 }
4228 }
4229 if ($connect_to_internet_ok) {
4230 @urllist = @CPAN::Defaultsites;
4231 } else {
4232 @urllist = ();
4233 }
4234 } else {
4235 my @host_seq = $level =~ /dleasy/ ?
4236 @reordered : 0..$last; # reordered has file and $Thesiteurl first
4237 @urllist = map { $ccurllist->[$_] } @host_seq;
ca79d794
SP		 4238 }
4239 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
05bab18e
SP		 4240 my $aslocal_tempfile = $aslocal . ".tmp" . $$;
4241 if (my $recommend = $self->_recommend_url_for($file)) {
4242 @urllist = grep { $_ ne $recommend } @urllist;
4243 unshift @urllist, $recommend;
4244 }
4245 $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
f04ea8d1
SP		 4246 $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
4247 if ($ret) {
05bab18e
SP		 4248 CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
4249 if ($ret eq $aslocal_tempfile) {
4250 # if we got it exactly as we asked for, only then we
4251 # want to rename
4252 rename $aslocal_tempfile, $aslocal
4253 or $CPAN::Frontend->mydie("Error while trying to rename ".
4254 "'$ret' to '$aslocal': $!");
4255 $ret = $aslocal;
4256 }
4257 $Themethod = $level;
4258 my $now = time;
4259 # utime $now, $now, $aslocal; # too bad, if we do that, we
4260 # might alter a local mirror
4261 $self->debug("level[$level]") if $CPAN::DEBUG;
4262 last LEVEL;
f04ea8d1 4263 } else {
05bab18e
SP		 4264 unlink $aslocal_tempfile;
4265 last if $CPAN::Signal; # need to cleanup
f04ea8d1 4266 }
c356248b 4267 }
05bab18e
SP		 4268 if ($ret) {
4269 $stats->{filesize} = -s $ret;
4270 }
f20de9f0 4271 $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
05bab18e 4272 $self->_add_to_statistics($stats);
f20de9f0 4273 $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
05bab18e 4274 if ($ret) {
be34b10d 4275 unlink "$aslocal.bak$$";
05bab18e
SP		 4276 return $ret;
4277 }
c4d24d4c
A		 4278 unless ($CPAN::Signal) {
4279 my(@mess);
8962fc49
SP		 4280 local $" = " ";
4281 if (@{$CPAN::Config->{urllist}}) {
4282 push @mess,
4283 qq{Please check, if the URLs I found in your configuration file \(}.
4284 join(", ", @{$CPAN::Config->{urllist}}).
4285 qq{\) are valid.};
4286 } else {
4287 push @mess, qq{Your urllist is empty!};
4288 }
4289 push @mess, qq{The urllist can be edited.},
4290 qq{E.g. with 'o conf urllist push ftp://myurl/'};
4291 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
4292 $CPAN::Frontend->mywarn("Could not fetch $file\n");
4293 $CPAN::Frontend->mysleep(2);
c4d24d4c 4294 }
05bab18e 4295 if ($maybe_restore) {
f04ea8d1
SP		 4296 rename "$aslocal.bak$$", $aslocal;
4297 $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
4298 $self->ls($aslocal));
4299 return $aslocal;
c356248b
A		 4300 }
4301 return;
4302}
4303
f04ea8d1
SP		 4304sub mymkpath {
4305 my($self, $aslocal_dir) = @_;
4306 File::Path::mkpath($aslocal_dir);
4307 $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
4308 qq{directory "$aslocal_dir".
4309 I\'ll continue, but if you encounter problems, they may be due
4310 to insufficient permissions.\n}) unless -w $aslocal_dir;
4311}
4312
4313sub hostdlxxx {
4314 my $self = shift;
4315 my $level = shift;
4316 my $scheme = shift;
4317 my $h = shift;
4318 $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
4319 my $method = "host$level";
4320 $self->$method($h, @_);
4321}
4322
05bab18e
SP		 4323sub _set_attempt {
4324 my($self,$stats,$method,$url) = @_;
4325 push @{$stats->{attempts}}, {
4326 method => $method,
4327 start => _mytime,
4328 url => $url,
4329 };
4330}
4331
ca79d794 4332# package CPAN::FTP;
f04ea8d1 4333sub hostdleasy {
05bab18e 4334 my($self,$host_seq,$file,$aslocal,$stats) = @_;
ca79d794
SP		 4335 my($ro_url);
4336 HOSTEASY: for $ro_url (@$host_seq) {
f04ea8d1
SP		 4337 $self->_set_attempt($stats,"dleasy",$ro_url);
4338 my $url .= "$ro_url$file";
4339 $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
4340 if ($url =~ /^file:/) {
4341 my $l;
4342 if ($CPAN::META->has_inst('URI::URL')) {
4343 my $u = URI::URL->new($url);
4344 $l = $u->path;
4345 } else { # works only on Unix, is poorly constructed, but
4346 # hopefully better than nothing.
4347 # RFC 1738 says fileurl BNF is
4348 # fileurl = "file://" [ host | "localhost" ] "/" fpath
4349 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
4350 # the code
4351 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
4352 $l =~ s|^file:||; # assume they
36263cb3
GS		 4353 # meant
4354 # file://localhost
f04ea8d1 4355 $l =~ s|^/||s
4d1321a7 4356 if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
f04ea8d1 4357 }
4d1321a7 4358 $self->debug("local file[$l]") if $CPAN::DEBUG;
f04ea8d1
SP		 4359 if ( -f $l && -r _) {
4360 $ThesiteURL = $ro_url;
4361 return $l;
4362 }
4d1321a7
A		 4363 if ($l =~ /(.+)\.gz$/) {
4364 my $ungz = $1;
4365 if ( -f $ungz && -r _) {
4366 $ThesiteURL = $ro_url;
4367 return $ungz;
4368 }
4369 }
f04ea8d1
SP		 4370 # Maybe mirror has compressed it?
4371 if (-f "$l.gz") {
4372 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
4373 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
4374 if ( -f $aslocal) {
4375 $ThesiteURL = $ro_url;
4376 return $aslocal;
4377 }
4378 }
4379 $CPAN::Frontend->mywarn("Could not find '$l'\n");
4380 }
4381 $self->debug("it was not a file URL") if $CPAN::DEBUG;
c4d24d4c 4382 if ($CPAN::META->has_usable('LWP')) {
7fefbd44 4383 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
A		 4384 $url
4385");
7fefbd44
RGS		 4386 unless ($Ua) {
4387 CPAN::LWP::UserAgent->config;
4388 eval { $Ua = CPAN::LWP::UserAgent->new; };
4389 if ($@) {
4390 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
4391 }
4392 }
4393 my $res = $Ua->mirror($url, $aslocal);
4394 if ($res->is_success) {
4395 $ThesiteURL = $ro_url;
4396 my $now = time;
4397 utime $now, $now, $aslocal; # download time is more
4398 # important than upload
4399 # time
4400 return $aslocal;
4401 } elsif ($url !~ /\.gz(?!\n)\Z/) {
4402 my $gzurl = "$url.gz";
4403 $CPAN::Frontend->myprint("Fetching with LWP:
c356248b
A		 4404 $gzurl
4405");
7fefbd44 4406 $res = $Ua->mirror($gzurl, "$aslocal.gz");
be34b10d
SP		 4407 if ($res->is_success) {
4408 if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
4409 $ThesiteURL = $ro_url;
4410 return $aslocal;
4411 }
7fefbd44
RGS		 4412 }
4413 } else {
4414 $CPAN::Frontend->myprint(sprintf(
4415 "LWP failed with code[%s] message[%s]\n",
4416 $res->code,
4417 $res->message,
4418 ));
4419 # Alan Burlison informed me that in firewall environments
4420 # Net::FTP can still succeed where LWP fails. So we do not
4421 # skip Net::FTP anymore when LWP is available.
4422 }
7fefbd44 4423 } else {
8962fc49 4424 $CPAN::Frontend->mywarn(" LWP not available\n");
f04ea8d1 4425 }
c4d24d4c 4426 return if $CPAN::Signal;
f04ea8d1
SP		 4427 if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4428 # that's the nice and easy way thanks to Graham
05bab18e 4429 $self->debug("recognized ftp") if $CPAN::DEBUG;
f04ea8d1
SP		 4430 my($host,$dir,$getfile) = ($1,$2,$3);
4431 if ($CPAN::META->has_usable('Net::FTP')) {
4432 $dir =~ s|/+|/|g;
4433 $CPAN::Frontend->myprint("Fetching with Net::FTP:
09d9d230 4434 $url
c356248b 4435");
f04ea8d1
SP		 4436 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
4437 "aslocal[$aslocal]") if $CPAN::DEBUG;
4438 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
4439 $ThesiteURL = $ro_url;
4440 return $aslocal;
4441 }
4442 if ($aslocal !~ /\.gz(?!\n)\Z/) {
4443 my $gz = "$aslocal.gz";
4444 $CPAN::Frontend->myprint("Fetching with Net::FTP
09d9d230 4445 $url.gz
c356248b 4446");
e82b9348
SP		 4447 if (CPAN::FTP->ftp_get($host,
4448 $dir,
4449 "$getfile.gz",
4450 $gz) &&
f04ea8d1
SP		 4451 eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
4452 ) {
4453 $ThesiteURL = $ro_url;
4454 return $aslocal;
4455 }
4456 }
4457 # next HOSTEASY;
4458 } else {
05bab18e
SP		 4459 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
4460 }
f04ea8d1 4461 }
05bab18e
SP		 4462 if (
4463 UNIVERSAL::can($ro_url,"text")
4464 and
4465 $ro_url->{FROM} eq "USER"
f04ea8d1 4466 ) {
05bab18e
SP		 4467 ##address #17973: default URLs should not try to override
4468 ##user-defined URLs just because LWP is not available
f04ea8d1 4469 my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
05bab18e
SP		 4470 return $ret if $ret;
4471 }
c4d24d4c 4472 return if $CPAN::Signal;
c356248b
A		 4473 }
4474}
05454584 4475
ca79d794 4476# package CPAN::FTP;
f04ea8d1
SP		 4477sub hostdlhard {
4478 my($self,$host_seq,$file,$aslocal,$stats) = @_;
4479
4480 # Came back if Net::FTP couldn't establish connection (or
4481 # failed otherwise) Maybe they are behind a firewall, but they
4482 # gave us a socksified (or other) ftp program...
4483
4484 my($ro_url);
4485 my($devnull) = $CPAN::Config->{devnull} || "";
4486 # < /dev/null ";
4487 my($aslocal_dir) = File::Basename::dirname($aslocal);
4488 File::Path::mkpath($aslocal_dir);
ca79d794 4489 HOSTHARD: for $ro_url (@$host_seq) {
f04ea8d1
SP		 4490 $self->_set_attempt($stats,"dlhard",$ro_url);
4491 my $url = "$ro_url$file";
4492 my($proto,$host,$dir,$getfile);
4493
4494 # Courtesy Mark Conty mark_conty@cargill.com change from
4495 # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4496 # to
4497 if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
4498 # proto not yet used
4499 ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
4500 } else {
4501 next HOSTHARD; # who said, we could ftp anything except ftp?
4502 }
5a5fac02
JH		 4503 next HOSTHARD if $proto eq "file"; # file URLs would have had
4504 # success above. Likely a bogus URL
911a92db 4505
f04ea8d1 4506 $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
73beb80c 4507
f04ea8d1 4508 # Try the most capable first and leave ncftp* for last as it only
73beb80c 4509 # does FTP.
5254b38e 4510 my $proxy_vars = $self->_proxy_vars($ro_url);
44d21104 4511 DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
f04ea8d1
SP		 4512 my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
4513 next unless defined $funkyftp;
4514 next if $funkyftp =~ /^\s*$/;
4515
4516 my($asl_ungz, $asl_gz);
4517 ($asl_ungz = $aslocal) =~ s/\.gz//;
4518 $asl_gz = "$asl_ungz.gz";
4519
4520 my($src_switch) = "";
4521 my($chdir) = "";
4522 my($stdout_redir) = " > $asl_ungz";
4523 if ($f eq "lynx") {
4524 $src_switch = " -source";
4525 } elsif ($f eq "ncftp") {
4526 $src_switch = " -c";
4527 } elsif ($f eq "wget") {
4528 $src_switch = " -O $asl_ungz";
4529 $stdout_redir = "";
4530 } elsif ($f eq 'curl') {
4531 $src_switch = ' -L -f -s -S --netrc-optional';
5254b38e
SP		 4532 if ($proxy_vars->{http_proxy}) {
4533 $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
4534 }
f04ea8d1
SP		 4535 }
4536
4537 if ($f eq "ncftpget") {
4538 $chdir = "cd $aslocal_dir && ";
4539 $stdout_redir = "";
4540 }
4541 $CPAN::Frontend->myprint(
4542 qq[
de34a54b 4543Trying with "$funkyftp$src_switch" to get
c356248b 4544 $url
2e2b7522 4545]);
f04ea8d1
SP		 4546 my($system) =
4547 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4548 $self->debug("system[$system]") if $CPAN::DEBUG;
4549 my($wstatus) = system($system);
4550 if ($f eq "lynx") {
4551 # lynx returns 0 when it fails somewhere
4552 if (-s $asl_ungz) {
4553 my $content = do { local *FH;
4554 open FH, $asl_ungz or die;
4555 local $/;
4556 <FH> };
4557 if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4558 $CPAN::Frontend->mywarn(qq{
4559No success, the file that lynx has downloaded looks like an error message:
44d21104
A		 4560$content
4561});
f04ea8d1
SP		 4562 $CPAN::Frontend->mysleep(1);
4563 next DLPRG;
4564 }
be34b10d 4565 } else {
f04ea8d1
SP		 4566 $CPAN::Frontend->myprint(qq{
4567No success, the file that lynx has downloaded is an empty file.
4568});
4569 next DLPRG;
4570 }
4571 }
4572 if ($wstatus == 0) {
4573 if (-s $aslocal) {
4574 # Looks good
4575 } elsif ($asl_ungz ne $aslocal) {
4576 # test gzip integrity
4577 if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4578 # e.g. foo.tar is gzipped --> foo.tar.gz
4579 rename $asl_ungz, $aslocal;
4580 } else {
4581 eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4582 }
be34b10d
SP		 4583 }
4584 $ThesiteURL = $ro_url;
4585 return $aslocal;
f04ea8d1
SP		 4586 } elsif ($url !~ /\.gz(?!\n)\Z/) {
4587 unlink $asl_ungz if
4588 -f $asl_ungz && -s _ == 0;
4589 my $gz = "$aslocal.gz";
4590 my $gzurl = "$url.gz";
4591 $CPAN::Frontend->myprint(
4592 qq[
4593 Trying with "$funkyftp$src_switch" to get
4594 $url.gz
4595 ]);
4596 my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4597 $self->debug("system[$system]") if $CPAN::DEBUG;
4598 my($wstatus);
4599 if (($wstatus = system($system)) == 0
4600 &&
4601 -s $asl_gz
4602 ) {
4603 # test gzip integrity
4604 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4605 if ($ct && $ct->gtest) {
4606 $ct->gunzip($aslocal);
4607 } else {
4608 # somebody uncompressed file for us?
4609 rename $asl_ungz, $aslocal;
4610 }
4611 $ThesiteURL = $ro_url;
4612 return $aslocal;
4613 } else {
4614 unlink $asl_gz if -f $asl_gz;
4615 }
4616 } else {
4617 my $estatus = $wstatus >> 8;
4618 my $size = -f $aslocal ?
4619 ", left\n$aslocal with size ".-s _ :
4620 "\nWarning: expected file [$aslocal] doesn't exist";
4621 $CPAN::Frontend->myprint(qq{
4622 System call "$system"
4623 returned status $estatus (wstat $wstatus)$size
4624 });
4625 }
4626 return if $CPAN::Signal;
4627 } # transfer programs
c4d24d4c 4628 } # host
c356248b 4629}
05454584 4630
5254b38e
SP		 4631#-> CPAN::FTP::_proxy_vars
4632sub _proxy_vars {
4633 my($self,$url) = @_;
4634 my $ret = +{};
4635 my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
4636 if ($http_proxy) {
4637 my($host) = $url =~ m|://([^/:]+)|;
4638 my $want_proxy = 1;
4639 my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
4640 my @noproxy = split /\s*,\s*/, $noproxy;
4641 if ($host) {
4642 DOMAIN: for my $domain (@noproxy) {
4643 if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
4644 $want_proxy = 0;
4645 last DOMAIN;
4646 }
4647 }
4648 } else {
4649 $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n");
4650 }
4651 if ($want_proxy) {
4652 my($user, $pass) =
4653 &CPAN::LWP::UserAgent::get_proxy_credentials();
4654 $ret = {
4655 proxy_user => $user,
4656 proxy_pass => $pass,
4657 http_proxy => $http_proxy
4658 };
4659 }
4660 }
4661 return $ret;
4662}
4663
ca79d794 4664# package CPAN::FTP;
f04ea8d1 4665sub hostdlhardest {
05bab18e 4666 my($self,$host_seq,$file,$aslocal,$stats) = @_;
c356248b 4667
f04ea8d1 4668 return unless @$host_seq;
ca79d794 4669 my($ro_url);
c356248b
A		 4670 my($aslocal_dir) = File::Basename::dirname($aslocal);
4671 File::Path::mkpath($aslocal_dir);
35576f8c 4672 my $ftpbin = $CPAN::Config->{ftp};
8fc516fe 4673 unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
ca79d794
SP		 4674 $CPAN::Frontend->myprint("No external ftp command available\n\n");
4675 return;
4676 }
8962fc49 4677 $CPAN::Frontend->mywarn(qq{
ca79d794
SP		 4678As a last ressort we now switch to the external ftp command '$ftpbin'
4679to get '$aslocal'.
4680
8962fc49 4681Doing so often leads to problems that are hard to diagnose.
ca79d794
SP		 4682
4683If you're victim of such problems, please consider unsetting the ftp
4684config variable with
4685
4686 o conf ftp ""
4687 o conf commit
4688
4689});
8962fc49 4690 $CPAN::Frontend->mysleep(2);
ca79d794 4691 HOSTHARDEST: for $ro_url (@$host_seq) {
f04ea8d1
SP		 4692 $self->_set_attempt($stats,"dlhardest",$ro_url);
4693 my $url = "$ro_url$file";
4694 $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4695 unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4696 next;
4697 }
4698 my($host,$dir,$getfile) = ($1,$2,$3);
4699 my $timestamp = 0;
4700 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4701 $ctime,$blksize,$blocks) = stat($aslocal);
4702 $timestamp = $mtime ||= 0;
4703 my($netrc) = CPAN::FTP::netrc->new;
4704 my($netrcfile) = $netrc->netrc;
4705 my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4706 my $targetfile = File::Basename::basename($aslocal);
4707 my(@dialog);
4708 push(
4709 @dialog,
4710 "lcd $aslocal_dir",
4711 "cd /",
4712 map("cd $_", split /\//, $dir), # RFC 1738
4713 "bin",
4714 "get $getfile $targetfile",
4715 "quit"
4716 );
4717 if (! $netrcfile) {
4718 CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4719 } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4720 CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4721 $netrc->hasdefault,
4722 $netrc->contains($host))) if $CPAN::DEBUG;
4723 if ($netrc->protected) {
ca79d794
SP		 4724 my $dialog = join "", map { " $_\n" } @dialog;
4725 my $netrc_explain;
4726 if ($netrc->contains($host)) {
4727 $netrc_explain = "Relying that your .netrc entry for '$host' ".
4728 "manages the login";
4729 } else {
4730 $netrc_explain = "Relying that your default .netrc entry ".
4731 "manages the login";
4732 }
f04ea8d1 4733 $CPAN::Frontend->myprint(qq{
05454584
A		 4734 Trying with external ftp to get
4735 $url
ca79d794
SP		 4736 $netrc_explain
4737 Going to send the dialog
4738$dialog
05454584 4739}
f04ea8d1
SP		 4740 );
4741 $self->talk_ftp("$ftpbin$verbose $host",
4742 @dialog);
4743 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4744 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4745 $mtime ||= 0;
4746 if ($mtime > $timestamp) {
4747 $CPAN::Frontend->myprint("GOT $aslocal\n");
4748 $ThesiteURL = $ro_url;
4749 return $aslocal;
4750 } else {
4751 $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4752 }
4753 return if $CPAN::Signal;
4754 } else {
4755 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4756 qq{correctly protected.\n});
4757 }
4758 } else {
4759 $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
c356248b 4760 nor does it have a default entry\n");
f04ea8d1
SP		 4761 }
4762
4763 # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4764 # then and login manually to host, using e-mail as
4765 # password.
4766 $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4767 unshift(
4768 @dialog,
4769 "open $host",
4770 "user anonymous $Config::Config{'cf_email'}"
4771 );
ca79d794
SP		 4772 my $dialog = join "", map { " $_\n" } @dialog;
4773 $CPAN::Frontend->myprint(qq{
4774 Trying with external ftp to get
4775 $url
4776 Going to send the dialog
4777$dialog
4778}
f04ea8d1
SP		 4779 );
4780 $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4781 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4782 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4783 $mtime ||= 0;
4784 if ($mtime > $timestamp) {
4785 $CPAN::Frontend->myprint("GOT $aslocal\n");
4786 $ThesiteURL = $ro_url;
4787 return $aslocal;
4788 } else {
4789 $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4790 }
c4d24d4c 4791 return if $CPAN::Signal;
f04ea8d1
SP		 4792 $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4793 $CPAN::Frontend->mysleep(2);
c4d24d4c 4794 } # host
c356248b
A		 4795}
4796
ca79d794 4797# package CPAN::FTP;
c356248b
A		 4798sub talk_ftp {
4799 my($self,$command,@dialog) = @_;
4800 my $fh = FileHandle->new;
4801 $fh->open("|$command") or die "Couldn't open ftp: $!";
4802 foreach (@dialog) { $fh->print("$_\n") }
f04ea8d1 4803 $fh->close; # Wait for process to complete
c356248b
A		 4804 my $wstatus = $?;
4805 my $estatus = $wstatus >> 8;
4806 $CPAN::Frontend->myprint(qq{
4807Subprocess "|$command"
4808 returned status $estatus (wstat $wstatus)
4809}) if $wstatus;
05454584
A		 4810}
4811
e50380aa
A		 4812# find2perl needs modularization, too, all the following is stolen
4813# from there
09d9d230 4814# CPAN::FTP::ls
e50380aa
A		 4815sub ls {
4816 my($self,$name) = @_;
4817 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4818 $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4819
4820 my($perms,%user,%group);
4821 my $pname = $name;
4822
55e314ee 4823 if ($blocks) {
f04ea8d1 4824 $blocks = int(($blocks + 1) / 2);
e50380aa
A		 4825 }
4826 else {
f04ea8d1 4827 $blocks = int(($sizemm + 1023) / 1024);
e50380aa
A		 4828 }
4829
4830 if (-f _) { $perms = '-'; }
4831 elsif (-d _) { $perms = 'd'; }
4832 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4833 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4834 elsif (-p _) { $perms = 'p'; }
4835 elsif (-S _) { $perms = 's'; }
4836 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4837
4838 my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4839 my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4840 my $tmpmode = $mode;
4841 my $tmp = $rwx[$tmpmode & 7];
4842 $tmpmode >>= 3;
4843 $tmp = $rwx[$tmpmode & 7] . $tmp;
4844 $tmpmode >>= 3;
4845 $tmp = $rwx[$tmpmode & 7] . $tmp;
4846 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4847 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4848 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4849 $perms .= $tmp;
4850
4851 my $user = $user{$uid} || $uid; # too lazy to implement lookup
4852 my $group = $group{$gid} || $gid;
4853
4854 my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4855 my($timeyear);
4856 my($moname) = $moname[$mon];
4857 if (-M _ > 365.25 / 2) {
f04ea8d1 4858 $timeyear = $year + 1900;
e50380aa
A		 4859 }
4860 else {
f04ea8d1 4861 $timeyear = sprintf("%02d:%02d", $hour, $min);
e50380aa
A		 4862 }
4863
4864 sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
f04ea8d1
SP		 4865 $ino,
4866 $blocks,
4867 $perms,
4868 $nlink,
4869 $user,
4870 $group,
4871 $sizemm,
4872 $moname,
4873 $mday,
4874 $timeyear,
4875 $pname;
e50380aa
A		 4876}
4877
05454584 4878package CPAN::FTP::netrc;
e82b9348 4879use strict;
05454584 4880
ca79d794 4881# package CPAN::FTP::netrc;
05454584
A		 4882sub new {
4883 my($class) = @_;
87892b73
RGS		 4884 my $home = CPAN::HandleConfig::home;
4885 my $file = File::Spec->catfile($home,".netrc");
05454584
A		 4886
4887 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4888 $atime,$mtime,$ctime,$blksize,$blocks)
f04ea8d1 4889 = stat($file);
05454584
A		 4890 $mode ||= 0;
4891 my $protected = 0;
4892
42d3b621
A		 4893 my($fh,@machines,$hasdefault);
4894 $hasdefault = 0;
da199366
A		 4895 $fh = FileHandle->new or die "Could not create a filehandle";
4896
f04ea8d1
SP		 4897 if($fh->open($file)) {
4898 $protected = ($mode & 077) == 0;
4899 local($/) = "";
42d3b621 4900 NETRC: while (<$fh>) {
f04ea8d1
SP		 4901 my(@tokens) = split " ", $_;
4902 TOKEN: while (@tokens) {
4903 my($t) = shift @tokens;
4904 if ($t eq "default") {
4905 $hasdefault++;
4906 last NETRC;
4907 }
4908 last TOKEN if $t eq "macdef";
4909 if ($t eq "machine") {
4910 push @machines, shift @tokens;
4911 }
4912 }
4913 }
10b2abe6 4914 } else {
f04ea8d1 4915 $file = $hasdefault = $protected = "";
10b2abe6 4916 }
da199366 4917
10b2abe6 4918 bless {
f04ea8d1
SP		 4919 'mach' => [@machines],
4920 'netrc' => $file,
4921 'hasdefault' => $hasdefault,
4922 'protected' => $protected,
4923 }, $class;
10b2abe6
CS		 4924}
4925
ca79d794 4926# CPAN::FTP::netrc::hasdefault;
42d3b621 4927sub hasdefault { shift->{'hasdefault'} }
da199366
A		 4928sub netrc { shift->{'netrc'} }
4929sub protected { shift->{'protected'} }
10b2abe6
CS		 4930sub contains {
4931 my($self,$mach) = @_;
da199366 4932 for ( @{$self->{'mach'}} ) {
f04ea8d1 4933 return 1 if $_ eq $mach;
da199366
A		 4934 }
4935 return 0;
10b2abe6
CS		 4936}
4937
5f05dabc 4938package CPAN::Complete;
e82b9348 4939use strict;
5f05dabc 4940
36263cb3
GS		 4941sub gnu_cpl {
4942 my($text, $line, $start, $end) = @_;
4943 my(@perlret) = cpl($text, $line, $start);
4944 # find longest common match. Can anybody show me how to peruse
4945 # T::R::Gnu to have this done automatically? Seems expensive.
4946 return () unless @perlret;
4947 my($newtext) = $text;
4948 for (my $i = length($text)+1;;$i++) {
f04ea8d1
SP		 4949 last unless length($perlret[0]) && length($perlret[0]) >= $i;
4950 my $try = substr($perlret[0],0,$i);
4951 my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4952 # warn "try[$try]tries[@tries]";
4953 if (@tries == @perlret) {
4954 $newtext = $try;
4955 } else {
4956 last;
4957 }
36263cb3
GS		 4958 }
4959 ($newtext,@perlret);
4960}
4961
55e314ee
A		 4962#-> sub CPAN::Complete::cpl ;
4963sub cpl {
5f05dabc 4964 my($word,$line,$pos) = @_;
4965 $word ||= "";
4966 $line ||= "";
4967 $pos ||= 0;
4968 CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4969 $line =~ s/^\s*//;
f20de9f0 4970 if ($line =~ s/^((?:notest|f?force)\s*)//) {
f04ea8d1 4971 $pos -= length($1);
da199366 4972 }
5f05dabc 4973 my @return;
f04ea8d1
SP		 4974 if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
4975 @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
c049f953 4976 } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
f04ea8d1 4977 @return = ();
8d97e4a1 4978 } elsif ($line =~ /^(a|ls)\s/) {
f04ea8d1 4979 @return = cplx('CPAN::Author',uc($word));
5f05dabc 4980 } elsif ($line =~ /^b\s/) {
8d97e4a1 4981 CPAN::Shell->local_bundles;
f04ea8d1 4982 @return = cplx('CPAN::Bundle',$word);
5f05dabc 4983 } elsif ($line =~ /^d\s/) {
f04ea8d1 4984 @return = cplx('CPAN::Distribution',$word);
6d29edf5 4985 } elsif ($line =~ m/^(
554a9ef5 4986 [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
6d29edf5 4987 )\s/x ) {
d8773709
JH		 4988 if ($word =~ /^Bundle::/) {
4989 CPAN::Shell->local_bundles;
4990 }
f04ea8d1 4991 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 4992 } elsif ($line =~ /^i\s/) {
f04ea8d1 4993 @return = cpl_any($word);
5f05dabc 4994 } elsif ($line =~ /^reload\s/) {
f04ea8d1 4995 @return = cpl_reload($word,$line,$pos);
5f05dabc 4996 } elsif ($line =~ /^o\s/) {
f04ea8d1 4997 @return = cpl_option($word,$line,$pos);
9d61fa1d
A		 4998 } elsif ($line =~ m/^\S+\s/ ) {
4999 # fallback for future commands and what we have forgotten above
f04ea8d1 5000 @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
5f05dabc 5001 } else {
f04ea8d1 5002 @return = ();
5f05dabc 5003 }
5004 return @return;
5005}
5006
55e314ee
A		 5007#-> sub CPAN::Complete::cplx ;
5008sub cplx {
5f05dabc 5009 my($class, $word) = @_;
b72dd56f
SP		 5010 if (CPAN::_sqlite_running) {
5011 $CPAN::SQLite->search($class, "^\Q$word\E");
5012 }
de34a54b 5013 sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
5f05dabc 5014}
5015
55e314ee
A		 5016#-> sub CPAN::Complete::cpl_any ;
5017sub cpl_any {
5f05dabc 5018 my($word) = shift;
5019 return (
f04ea8d1
SP		 5020 cplx('CPAN::Author',$word),
5021 cplx('CPAN::Bundle',$word),
5022 cplx('CPAN::Distribution',$word),
5023 cplx('CPAN::Module',$word),
5024 );
5f05dabc 5025}
5026
55e314ee
A		 5027#-> sub CPAN::Complete::cpl_reload ;
5028sub cpl_reload {
5f05dabc 5029 my($word,$line,$pos) = @_;
5030 $word ||= "";
5031 my(@words) = split " ", $line;
5032 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
5033 my(@ok) = qw(cpan index);
e50380aa
A		 5034 return @ok if @words == 1;
5035 return grep /^\Q$word\E/, @ok if @words == 2 && $word;
5f05dabc 5036}
5037
55e314ee
A		 5038#-> sub CPAN::Complete::cpl_option ;
5039sub cpl_option {
5f05dabc 5040 my($word,$line,$pos) = @_;
5041 $word ||= "";
5042 my(@words) = split " ", $line;
5043 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
5044 my(@ok) = qw(conf debug);
e50380aa 5045 return @ok if @words == 1;
c356248b 5046 return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
5f05dabc 5047 if (0) {
5048 } elsif ($words[1] eq 'index') {
f04ea8d1 5049 return ();
5f05dabc 5050 } elsif ($words[1] eq 'conf') {
f04ea8d1 5051 return CPAN::HandleConfig::cpl(@_);
5f05dabc 5052 } elsif ($words[1] eq 'debug') {
f04ea8d1 5053 return sort grep /^\Q$word\E/i,
554a9ef5 5054 sort keys %CPAN::DEBUG, 'all';
5f05dabc 5055 }
5056}
5057
5058package CPAN::Index;
e82b9348 5059use strict;
5f05dabc 5060
10b2abe6 5061#-> sub CPAN::Index::force_reload ;
5f05dabc 5062sub force_reload {
5063 my($class) = @_;
c049f953 5064 $CPAN::Index::LAST_TIME = 0;
5f05dabc 5065 $class->reload(1);
5066}
5067
10b2abe6 5068#-> sub CPAN::Index::reload ;
5f05dabc 5069sub reload {
05bab18e 5070 my($self,$force) = @_;
5f05dabc 5071 my $time = time;
5072
c356248b
A		 5073 # XXX check if a newer one is available. (We currently read it
5074 # from time to time)
e50380aa 5075 for ($CPAN::Config->{index_expire}) {
f04ea8d1 5076 $_ = 0.001 unless $_ && $_ > 0.001;
e50380aa 5077 }
9d61fa1d
A		 5078 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
5079 # debug here when CPAN doesn't seem to read the Metadata
5080 require Carp;
5081 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
5082 }
5083 unless ($CPAN::META->{PROTOCOL}) {
05bab18e 5084 $self->read_metadata_cache;
9d61fa1d
A		 5085 $CPAN::META->{PROTOCOL} ||= "1.0";
5086 }
6d29edf5
JH		 5087 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
5088 # warn "Setting last_time to 0";
c049f953 5089 $LAST_TIME = 0; # No warning necessary
6d29edf5 5090 }
05bab18e 5091 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
f04ea8d1 5092 and ! $force) {
05bab18e
SP		 5093 # called too often
5094 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
5095 } elsif (0) {
6d29edf5
JH		 5096 # IFF we are developing, it helps to wipe out the memory
5097 # between reloads, otherwise it is not what a user expects.
5098 undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
5099 $CPAN::META = CPAN->new;
05bab18e 5100 } else {
6d29edf5 5101 my($debug,$t2);
c049f953 5102 local $LAST_TIME = $time;
6d29edf5
JH		 5103 local $CPAN::META->{PROTOCOL} = PROTOCOL;
5104
5105 my $needshort = $^O eq "dos";
5106
05bab18e 5107 $self->rd_authindex($self
6d29edf5
JH		 5108 ->reload_x(
5109 "authors/01mailrc.txt.gz",
5110 $needshort ?
5111 File::Spec->catfile('authors', '01mailrc.gz') :
5112 File::Spec->catfile('authors', '01mailrc.txt.gz'),
5113 $force));
5114 $t2 = time;
5115 $debug = "timing reading 01[".($t2 - $time)."]";
5116 $time = $t2;
5117 return if $CPAN::Signal; # this is sometimes lengthy
05bab18e 5118 $self->rd_modpacks($self
6d29edf5
JH		 5119 ->reload_x(
5120 "modules/02packages.details.txt.gz",
5121 $needshort ?
5122 File::Spec->catfile('modules', '02packag.gz') :
5123 File::Spec->catfile('modules', '02packages.details.txt.gz'),
5124 $force));
5125 $t2 = time;
5126 $debug .= "02[".($t2 - $time)."]";
5127 $time = $t2;
5128 return if $CPAN::Signal; # this is sometimes lengthy
05bab18e 5129 $self->rd_modlist($self
6d29edf5
JH		 5130 ->reload_x(
5131 "modules/03modlist.data.gz",
5132 $needshort ?
5133 File::Spec->catfile('modules', '03mlist.gz') :
5134 File::Spec->catfile('modules', '03modlist.data.gz'),
5135 $force));
05bab18e 5136 $self->write_metadata_cache;
6d29edf5
JH		 5137 $t2 = time;
5138 $debug .= "03[".($t2 - $time)."]";
5139 $time = $t2;
5140 CPAN->debug($debug) if $CPAN::DEBUG;
5141 }
05bab18e
SP		 5142 if ($CPAN::Config->{build_dir_reuse}) {
5143 $self->reanimate_build_dir;
5144 }
810a0276 5145 if (CPAN::_sqlite_running) {
be34b10d
SP		 5146 $CPAN::SQLite->reload(time => $time, force => $force)
5147 if not $LAST_TIME;
5148 }
c049f953 5149 $LAST_TIME = $time;
6d29edf5 5150 $CPAN::META->{PROTOCOL} = PROTOCOL;
5f05dabc 5151}
5152
05bab18e
SP		 5153#-> sub CPAN::Index::reanimate_build_dir ;
5154sub reanimate_build_dir {
5155 my($self) = @_;
5156 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
5157 return;
5158 }
5159 return if $HAVE_REANIMATED++;
5160 my $d = $CPAN::Config->{build_dir};
5161 my $dh = DirHandle->new;
5162 opendir $dh, $d or return; # does not exist
5163 my $dirent;
5164 my $i = 0;
5165 my $painted = 0;
5166 my $restored = 0;
be34b10d
SP		 5167 my @candidates = map { $_->[0] }
5168 sort { $b->[1] <=> $a->[1] }
5169 map { [ $_, -M File::Spec->catfile($d,$_) ] }
5170 grep {/\.yml$/} readdir $dh;
5254b38e
SP		 5171 unless (@candidates) {
5172 $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
5173 return;
5174 }
5175 $CPAN::Frontend->myprint
5176 (sprintf("Going to read %d yaml file%s from %s/\n",
5177 scalar @candidates,
5178 @candidates==1 ? "" : "s",
5179 $CPAN::Config->{build_dir}
5180 ));
5181 my $start = CPAN::FTP::_mytime;
23a216b4
SP		 5182 DISTRO: for $i (0..$#candidates) {
5183 my $dirent = $candidates[$i];
b72dd56f 5184 my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
23a216b4
SP		 5185 if ($@) {
5186 warn "Error while parsing file '$dirent'; error: '$@'";
5187 next DISTRO;
5188 }
b72dd56f 5189 my $c = $y->[0];
05bab18e
SP		 5190 if ($c && CPAN->_perl_fingerprint($c->{perl})) {
5191 my $key = $c->{distribution}{ID};
5192 for my $k (keys %{$c->{distribution}}) {
5193 if ($c->{distribution}{$k}
5194 && ref $c->{distribution}{$k}
5195 && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
be34b10d 5196 $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
05bab18e
SP		 5197 }
5198 }
5199
5200 #we tried to restore only if element already
5201 #exists; but then we do not work with metadata
5202 #turned off.
b72dd56f
SP		 5203 my $do
5204 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
5205 = $c->{distribution};
f04ea8d1
SP		 5206 for my $skipper (qw(
5207 badtestcnt
5208 configure_requires_later
5209 configure_requires_later_for
5210 force_update
5211 later
5212 later_for
5213 notest
5214 should_report
5215 sponsored_mods
5254b38e
SP		 5216 prefs
5217 negative_prefs_cache
f04ea8d1 5218 )) {
23a216b4
SP		 5219 delete $do->{$skipper};
5220 }
b72dd56f 5221 # $DB::single = 1;
5254b38e 5222 if ($do->tested_ok_but_not_installed) {
b72dd56f
SP		 5223 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
5224 }
05bab18e
SP		 5225 $restored++;
5226 }
5227 $i++;
5228 while (($painted/76) < ($i/@candidates)) {
5229 $CPAN::Frontend->myprint(".");
5230 $painted++;
5231 }
5232 }
5254b38e 5233 my $took = CPAN::FTP::_mytime - $start;
05bab18e 5234 $CPAN::Frontend->myprint(sprintf(
5254b38e 5235 "DONE\nRestored the state of %s (in %.4f secs)\n",
05bab18e 5236 $restored || "none",
5254b38e 5237 $took,
05bab18e
SP		 5238 ));
5239}
5240
5241
10b2abe6 5242#-> sub CPAN::Index::reload_x ;
5f05dabc 5243sub reload_x {
5244 my($cl,$wanted,$localname,$force) = @_;
c356248b 5245 $force |= 2; # means we're dealing with an index here
135a59c2
A		 5246 CPAN::HandleConfig->load; # we should guarantee loading wherever
5247 # we rely on Config XXX
c356248b 5248 $localname ||= $wanted;
5de3f0da 5249 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
f04ea8d1 5250 $localname);
e50380aa 5251 if (
f04ea8d1
SP		 5252 -f $abs_wanted &&
5253 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
5254 !($force & 1)
e50380aa 5255 ) {
f04ea8d1
SP		 5256 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
5257 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
5258 qq{day$s. I\'ll use that.});
5259 return $abs_wanted;
5f05dabc 5260 } else {
f04ea8d1 5261 $force |= 1; # means we're quite serious about it.
5f05dabc 5262 }
5263 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
5264}
5265
55e314ee
A		 5266#-> sub CPAN::Index::rd_authindex ;
5267sub rd_authindex {
f14b5cec 5268 my($cl, $index_target) = @_;
c356248b 5269 return unless defined $index_target;
810a0276
SP		 5270 return if CPAN::_sqlite_running;
5271 my @lines;
c356248b 5272 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 5273 local(*FH);
ec5fee46 5274 tie *FH, 'CPAN::Tarzip', $index_target;
52128c7b 5275 local($/) = "\n";
e82b9348 5276 local($_);
f14b5cec 5277 push @lines, split /\012/ while <FH>;
7d97ad34 5278 my $i = 0;
be34b10d 5279 my $painted = 0;
f14b5cec 5280 foreach (@lines) {
f04ea8d1
SP		 5281 my($userid,$fullname,$email) =
5282 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
8fc516fe 5283 $fullname ||= $email;
f04ea8d1 5284 if ($userid && $fullname && $email) {
8fc516fe
SP		 5285 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
5286 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
5287 } else {
5288 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
5289 }
be34b10d
SP		 5290 $i++;
5291 while (($painted/76) < ($i/@lines)) {
5292 $CPAN::Frontend->myprint(".");
5293 $painted++;
5294 }
f04ea8d1 5295 return if $CPAN::Signal;
5f05dabc 5296 }
7d97ad34 5297 $CPAN::Frontend->myprint("DONE\n");
09d9d230
A		 5298}
5299
5300sub userid {
5301 my($self,$dist) = @_;
5302 $dist = $self->{'id'} unless defined $dist;
5303 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
5304 $ret;
5f05dabc 5305}
5306
55e314ee
A		 5307#-> sub CPAN::Index::rd_modpacks ;
5308sub rd_modpacks {
05d2a450 5309 my($self, $index_target) = @_;
c356248b 5310 return unless defined $index_target;
810a0276 5311 return if CPAN::_sqlite_running;
c356248b 5312 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 5313 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
e82b9348 5314 local $_;
7d97ad34
SP		 5315 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
5316 my $slurp = "";
5317 my $chunk;
5318 while (my $bytes = $fh->READ(\$chunk,8192)) {
5319 $slurp.=$chunk;
5320 }
5321 my @lines = split /\012/, $slurp;
5322 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
5323 undef $fh;
de34a54b 5324 # read header
c049f953 5325 my($line_count,$last_updated);
f14b5cec 5326 while (@lines) {
f04ea8d1
SP		 5327 my $shift = shift(@lines);
5328 last if $shift =~ /^\s*$/;
5329 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
c049f953 5330 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
f14b5cec 5331 }
7d97ad34 5332 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
de34a54b 5333 if (not defined $line_count) {
05d2a450 5334
f04ea8d1 5335 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
05d2a450
A		 5336Please check the validity of the index file by comparing it to more
5337than one CPAN mirror. I'll continue but problems seem likely to
5338happen.\a
8962fc49 5339});
05d2a450 5340
f04ea8d1 5341 $CPAN::Frontend->mysleep(5);
de34a54b
JH		 5342 } elsif ($line_count != scalar @lines) {
5343
f04ea8d1 5344 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
de34a54b
JH		 5345contains a Line-Count header of %d but I see %d lines there. Please
5346check the validity of the index file by comparing it to more than one
5347CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
7fefbd44 5348$index_target, $line_count, scalar(@lines));
de34a54b
JH		 5349
5350 }
c049f953
JH		 5351 if (not defined $last_updated) {
5352
f04ea8d1 5353 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
c049f953
JH		 5354Please check the validity of the index file by comparing it to more
5355than one CPAN mirror. I'll continue but problems seem likely to
5356happen.\a
8962fc49 5357});
c049f953 5358
f04ea8d1 5359 $CPAN::Frontend->mysleep(5);
c049f953
JH		 5360 } else {
5361
f04ea8d1 5362 $CPAN::Frontend
c049f953
JH		 5363 ->myprint(sprintf qq{ Database was generated on %s\n},
5364 $last_updated);
5365 $DATE_OF_02 = $last_updated;
5366
9ddc4ed0 5367 my $age = time;
ec5fee46 5368 if ($CPAN::META->has_inst('HTTP::Date')) {
c049f953 5369 require HTTP::Date;
9ddc4ed0
A		 5370 $age -= HTTP::Date::str2time($last_updated);
5371 } else {
8962fc49 5372 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
9ddc4ed0
A		 5373 require Time::Local;
5374 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
5375 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
5376 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
5377 }
5378 $age /= 3600*24;
5379 if ($age > 30) {
c049f953 5380
9ddc4ed0
A		 5381 $CPAN::Frontend
5382 ->mywarn(sprintf
5383 qq{Warning: This index file is %d days old.
c049f953
JH		 5384 Please check the host you chose as your CPAN mirror for staleness.
5385 I'll continue but problems seem likely to happen.\a\n},
9ddc4ed0
A		 5386 $age);
5387
5388 } elsif ($age < -1) {
5389
5390 $CPAN::Frontend
5391 ->mywarn(sprintf
5392 qq{Warning: Your system date is %d days behind this index file!
5393 System time: %s
5394 Timestamp index file: %s
5395 Please fix your system time, problems with the make command expected.\n},
5396 -$age,
5397 scalar gmtime,
5398 $DATE_OF_02,
5399 );
c049f953 5400
c049f953
JH		 5401 }
5402 }
5403
5404
c4d24d4c
A		 5405 # A necessity since we have metadata_cache: delete what isn't
5406 # there anymore
5407 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
5408 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
5409 my(%exists);
7d97ad34 5410 my $i = 0;
be34b10d 5411 my $painted = 0;
f14b5cec 5412 foreach (@lines) {
05d2a450
A		 5413 # before 1.56 we split into 3 and discarded the rest. From
5414 # 1.57 we assign remaining text to $comment thus allowing to
5415 # influence isa_perl
f04ea8d1 5416 my($mod,$version,$dist,$comment) = split " ", $_, 4;
5254b38e
SP		 5417 unless ($mod && defined $version && $dist) {
5418 $CPAN::Frontend->mywarn("Could not split line[$_]\n");
5419 next;
5420 }
f04ea8d1
SP		 5421 my($bundle,$id,$userid);
5422
5423 if ($mod eq 'CPAN' &&
5424 ! (
5425 CPAN::Queue->exists('Bundle::CPAN') ||
5426 CPAN::Queue->exists('CPAN')
5427 )
5428 ) {
c4d24d4c 5429 local($^W)= 0;
f04ea8d1 5430 if ($version > $CPAN::VERSION) {
8962fc49 5431 $CPAN::Frontend->mywarn(qq{
ed84aac9
A		 5432 New CPAN.pm version (v$version) available.
5433 [Currently running version is v$CPAN::VERSION]
e50380aa 5434 You might want to try
b96578bb 5435 install CPAN
5f05dabc 5436 reload cpan
ed84aac9
A		 5437 to both upgrade CPAN.pm and run the new version without leaving
5438 the current session.
5439
c4d24d4c 5440}); #});
8962fc49 5441 $CPAN::Frontend->mysleep(2);
f04ea8d1
SP		 5442 $CPAN::Frontend->myprint(qq{\n});
5443 }
5444 last if $CPAN::Signal;
5445 } elsif ($mod =~ /^Bundle::(.*)/) {
5446 $bundle = $1;
5447 }
5448
5449 if ($bundle) {
5450 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
5451 # Let's make it a module too, because bundles have so much
5452 # in common with modules.
6d29edf5
JH		 5453
5454 # Changed in 1.57_63: seems like memory bloat now without
5455 # any value, so commented out
5456
f04ea8d1 5457 # $CPAN::META->instance('CPAN::Module',$mod);
c356248b 5458
f04ea8d1 5459 } else {
c356248b 5460
f04ea8d1
SP		 5461 # instantiate a module object
5462 $id = $CPAN::META->instance('CPAN::Module',$mod);
c4d24d4c 5463
f04ea8d1 5464 }
5f05dabc 5465
ec5fee46
A		 5466 # Although CPAN prohibits same name with different version the
5467 # indexer may have changed the version for the same distro
5468 # since the last time ("Force Reindexing" feature)
f04ea8d1 5469 if ($id->cpan_file ne $dist
ec5fee46
A		 5470 ||
5471 $id->cpan_version ne $version
f04ea8d1
SP		 5472 ) {
5473 $userid = $id->userid || $self->userid($dist);
5474 $id->set(
5475 'CPAN_USERID' => $userid,
5476 'CPAN_VERSION' => $version,
5477 'CPAN_FILE' => $dist,
5478 );
5479 }
5480
5481 # instantiate a distribution object
5482 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
5483 # we do not need CONTAINSMODS unless we do something with
5484 # this dist, so we better produce it on demand.
5485
5486 ## my $obj = $CPAN::META->instance(
5487 ## 'CPAN::Distribution' => $dist
5488 ## );
5489 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
5490 } else {
5491 $CPAN::META->instance(
5492 'CPAN::Distribution' => $dist
5493 )->set(
5494 'CPAN_USERID' => $userid,
5495 'CPAN_COMMENT' => $comment,
5496 );
5497 }
c4d24d4c
A		 5498 if ($secondtime) {
5499 for my $name ($mod,$dist) {
7d97ad34 5500 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
c4d24d4c
A		 5501 $exists{$name} = undef;
5502 }
5503 }
be34b10d
SP		 5504 $i++;
5505 while (($painted/76) < ($i/@lines)) {
5506 $CPAN::Frontend->myprint(".");
5507 $painted++;
5508 }
f04ea8d1 5509 return if $CPAN::Signal;
5f05dabc 5510 }
7d97ad34 5511 $CPAN::Frontend->myprint("DONE\n");
c4d24d4c
A		 5512 if ($secondtime) {
5513 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
5514 for my $o ($CPAN::META->all_objects($class)) {
5515 next if exists $exists{$o->{ID}};
5516 $CPAN::META->delete($class,$o->{ID});
7d97ad34
SP		 5517 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
5518 # if $CPAN::DEBUG;
c4d24d4c
A		 5519 }
5520 }
5521 }
5f05dabc 5522}
5523
55e314ee
A		 5524#-> sub CPAN::Index::rd_modlist ;
5525sub rd_modlist {
05454584 5526 my($cl,$index_target) = @_;
c356248b 5527 return unless defined $index_target;
810a0276 5528 return if CPAN::_sqlite_running;
c356248b 5529 $CPAN::Frontend->myprint("Going to read $index_target\n");
09d9d230 5530 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
e82b9348 5531 local $_;
7d97ad34
SP		 5532 my $slurp = "";
5533 my $chunk;
5534 while (my $bytes = $fh->READ(\$chunk,8192)) {
5535 $slurp.=$chunk;
5536 }
5537 my @eval2 = split /\012/, $slurp;
5538
5539 while (@eval2) {
f04ea8d1
SP		 5540 my $shift = shift(@eval2);
5541 if ($shift =~ /^Date:\s+(.*)/) {
5542 if ($DATE_OF_03 eq $1) {
7d97ad34
SP		 5543 $CPAN::Frontend->myprint("Unchanged.\n");
5544 return;
5545 }
f04ea8d1
SP		 5546 ($DATE_OF_03) = $1;
5547 }
5548 last if $shift =~ /^\s*$/;
05454584 5549 }
7d97ad34 5550 push @eval2, q{CPAN::Modulelist->data;};
05454584 5551 local($^W) = 0;
5254b38e 5552 my($compmt) = Safe->new("CPAN::Safe1");
7d97ad34
SP		 5553 my($eval2) = join("\n", @eval2);
5554 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
5254b38e 5555 my $ret = $compmt->reval($eval2);
05454584
A		 5556 Carp::confess($@) if $@;
5557 return if $CPAN::Signal;
7d97ad34 5558 my $i = 0;
be34b10d
SP		 5559 my $until = keys(%$ret);
5560 my $painted = 0;
7d97ad34 5561 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
05454584 5562 for (keys %$ret) {
f04ea8d1 5563 my $obj = $CPAN::META->instance("CPAN::Module",$_);
6d29edf5 5564 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
f04ea8d1 5565 $obj->set(%{$ret->{$_}});
be34b10d
SP		 5566 $i++;
5567 while (($painted/76) < ($i/$until)) {
5568 $CPAN::Frontend->myprint(".");
5569 $painted++;
5570 }
f04ea8d1 5571 return if $CPAN::Signal;
05454584 5572 }
7d97ad34 5573 $CPAN::Frontend->myprint("DONE\n");
05454584 5574}
5f05dabc 5575
5e05dca5
A		 5576#-> sub CPAN::Index::write_metadata_cache ;
5577sub write_metadata_cache {
5578 my($self) = @_;
5579 return unless $CPAN::Config->{'cache_metadata'};
810a0276 5580 return if CPAN::_sqlite_running;
5e05dca5
A		 5581 return unless $CPAN::META->has_usable("Storable");
5582 my $cache;
5583 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
f04ea8d1
SP		 5584 CPAN::Distribution)) {
5585 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5e05dca5 5586 }
5de3f0da 5587 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
c049f953
JH		 5588 $cache->{last_time} = $LAST_TIME;
5589 $cache->{DATE_OF_02} = $DATE_OF_02;
6d29edf5
JH		 5590 $cache->{PROTOCOL} = PROTOCOL;
5591 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
c4d24d4c 5592 eval { Storable::nstore($cache, $metadata_file) };
5fc0f0f6 5593 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5e05dca5
A		 5594}
5595
5596#-> sub CPAN::Index::read_metadata_cache ;
5597sub read_metadata_cache {
5598 my($self) = @_;
5599 return unless $CPAN::Config->{'cache_metadata'};
810a0276 5600 return if CPAN::_sqlite_running;
5e05dca5 5601 return unless $CPAN::META->has_usable("Storable");
5de3f0da 5602 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5e05dca5
A		 5603 return unless -r $metadata_file and -f $metadata_file;
5604 $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5605 my $cache;
5606 eval { $cache = Storable::retrieve($metadata_file) };
5fc0f0f6 5607 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
f04ea8d1 5608 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
c049f953 5609 $LAST_TIME = 0;
6d29edf5
JH		 5610 return;
5611 }
5612 if (exists $cache->{PROTOCOL}) {
5613 if (PROTOCOL > $cache->{PROTOCOL}) {
5614 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5fc0f0f6 5615 "with protocol v%s, requiring v%s\n",
6d29edf5
JH		 5616 $cache->{PROTOCOL},
5617 PROTOCOL)
5618 );
5619 return;
5620 }
5621 } else {
5622 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5fc0f0f6 5623 "with protocol v1.0\n");
6d29edf5
JH		 5624 return;
5625 }
5626 my $clcnt = 0;
5627 my $idcnt = 0;
5628 while(my($class,$v) = each %$cache) {
f04ea8d1
SP		 5629 next unless $class =~ /^CPAN::/;
5630 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
6d29edf5
JH		 5631 while (my($id,$ro) = each %$v) {
5632 $CPAN::META->{readwrite}{$class}{$id} ||=
5633 $class->new(ID=>$id, RO=>$ro);
5634 $idcnt++;
c4d24d4c 5635 }
6d29edf5 5636 $clcnt++;
5e05dca5 5637 }
6d29edf5
JH		 5638 unless ($clcnt) { # sanity check
5639 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5640 return;
5641 }
5642 if ($idcnt < 1000) {
5643 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5644 "in $metadata_file\n");
5645 return;
5646 }
5647 $CPAN::META->{PROTOCOL} ||=
5648 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5649 # does initialize to some protocol
c049f953
JH		 5650 $LAST_TIME = $cache->{last_time};
5651 $DATE_OF_02 = $cache->{DATE_OF_02};
d5a05a34 5652 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
f04ea8d1 5653 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
c049f953 5654 return;
5e05dca5
A		 5655}
5656
05454584 5657package CPAN::InfoObj;
e82b9348 5658use strict;
5254b38e 5659use Cwd qw(chdir);
5f05dabc 5660
0cf35e6a
SP		 5661sub ro {
5662 my $self = shift;
5663 exists $self->{RO} and return $self->{RO};
5664}
5665
6658a91b 5666#-> sub CPAN::InfoObj::cpan_userid
35576f8c
A		 5667sub cpan_userid {
5668 my $self = shift;
6658a91b
SP		 5669 my $ro = $self->ro;
5670 if ($ro) {
5671 return $ro->{CPAN_USERID} || "N/A";
5672 } else {
5673 $self->debug("ID[$self->{ID}]");
5674 # N/A for bundles found locally
5675 return "N/A";
5676 }
35576f8c
A		 5677}
5678
c049f953 5679sub id { shift->{ID}; }
6d29edf5 5680
05454584 5681#-> sub CPAN::InfoObj::new ;
6d29edf5
JH		 5682sub new {
5683 my $this = bless {}, shift;
5684 %$this = @_;
5685 $this
5686}
5687
5688# The set method may only be used by code that reads index data or
5689# otherwise "objective" data from the outside world. All session
5690# related material may do anything else with instance variables but
5691# must not touch the hash under the RO attribute. The reason is that
5692# the RO hash gets written to Metadata file and is thus persistent.
5f05dabc 5693
b96578bb
SP		 5694#-> sub CPAN::InfoObj::safe_chdir ;
5695sub safe_chdir {
5696 my($self,$todir) = @_;
5697 # we die if we cannot chdir and we are debuggable
5698 Carp::confess("safe_chdir called without todir argument")
5699 unless defined $todir and length $todir;
5700 if (chdir $todir) {
5701 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5702 if $CPAN::DEBUG;
5703 } else {
5704 if (-e $todir) {
5705 unless (-x $todir) {
5706 unless (chmod 0755, $todir) {
5707 my $cwd = CPAN::anycwd();
5708 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5709 "permission to change the permission; cannot ".
5710 "chdir to '$todir'\n");
5711 $CPAN::Frontend->mysleep(5);
5712 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5713 qq{to todir[$todir]: $!});
5714 }
5715 }
5716 } else {
5717 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5718 }
5719 if (chdir $todir) {
5720 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5721 if $CPAN::DEBUG;
5722 } else {
5723 my $cwd = CPAN::anycwd();
5724 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5725 qq{to todir[$todir] (a chmod has been issued): $!});
5726 }
5727 }
5728}
5729
05454584
A		 5730#-> sub CPAN::InfoObj::set ;
5731sub set {
5732 my($self,%att) = @_;
6d29edf5
JH		 5733 my $class = ref $self;
5734
5735 # This must be ||=, not ||, because only if we write an empty
5736 # reference, only then the set method will write into the readonly
5737 # area. But for Distributions that spring into existence, maybe
5738 # because of a typo, we do not like it that they are written into
5739 # the readonly area and made permanent (at least for a while) and
5740 # that is why we do not "allow" other places to call ->set.
8d97e4a1
JH		 5741 unless ($self->id) {
5742 CPAN->debug("Bug? Empty ID, rejecting");
5743 return;
5744 }
6d29edf5
JH		 5745 my $ro = $self->{RO} =
5746 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
da199366 5747
6d29edf5
JH		 5748 while (my($k,$v) = each %att) {
5749 $ro->{$k} = $v;
5750 }
5751}
5f05dabc 5752
05454584
A		 5753#-> sub CPAN::InfoObj::as_glimpse ;
5754sub as_glimpse {
5f05dabc 5755 my($self) = @_;
05454584
A		 5756 my(@m);
5757 my $class = ref($self);
5758 $class =~ s/^CPAN:://;
135a59c2
A		 5759 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5760 push @m, sprintf "%-15s %s\n", $class, $id;
05454584 5761 join "", @m;
5f05dabc 5762}
5763
05454584
A		 5764#-> sub CPAN::InfoObj::as_string ;
5765sub as_string {
5766 my($self) = @_;
5767 my(@m);
5768 my $class = ref($self);
5769 $class =~ s/^CPAN:://;
5770 push @m, $class, " id = $self->{ID}\n";
4d1321a7
A		 5771 my $ro;
5772 unless ($ro = $self->ro) {
8fc516fe
SP		 5773 if (substr($self->{ID},-1,1) eq ".") { # directory
5774 $ro = +{};
5775 } else {
f04ea8d1
SP		 5776 $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
5777 $CPAN::Frontend->mysleep(5);
5778 return;
8fc516fe 5779 }
4d1321a7 5780 }
0cf35e6a 5781 for (sort keys %$ro) {
f04ea8d1
SP		 5782 # next if m/^(ID|RO)$/;
5783 my $extra = "";
5784 if ($_ eq "CPAN_USERID") {
4d1321a7
A		 5785 $extra .= " (";
5786 $extra .= $self->fullname;
9d61fa1d
A		 5787 my $email; # old perls!
5788 if ($email = $CPAN::META->instance("CPAN::Author",
5789 $self->cpan_userid
5790 )->email) {
5791 $extra .= " <$email>";
5792 } else {
5793 $extra .= " <no email>";
5794 }
5795 $extra .= ")";
5796 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5797 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
5798 next;
5799 }
0cf35e6a
SP		 5800 next unless defined $ro->{$_};
5801 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
6d29edf5 5802 }
8fc516fe 5803 KEY: for (sort keys %$self) {
f04ea8d1 5804 next if m/^(ID|RO)$/;
8fc516fe
SP		 5805 unless (defined $self->{$_}) {
5806 delete $self->{$_};
5807 next KEY;
5808 }
f04ea8d1
SP		 5809 if (ref($self->{$_}) eq "ARRAY") {
5810 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
5811 } elsif (ref($self->{$_}) eq "HASH") {
8fc516fe
SP		 5812 my $value;
5813 if (/^CONTAINSMODS$/) {
5814 $value = join(" ",sort keys %{$self->{$_}});
5815 } elsif (/^prereq_pm$/) {
5816 my @value;
5817 my $v = $self->{$_};
5818 for my $x (sort keys %$v) {
5819 my @svalue;
5820 for my $y (sort keys %{$v->{$x}}) {
5821 push @svalue, "$y=>$v->{$x}{$y}";
5822 }
05bab18e 5823 push @value, "$x\:" . join ",", @svalue if @svalue;
8fc516fe
SP		 5824 }
5825 $value = join ";", @value;
5826 } else {
5827 $value = $self->{$_};
5828 }
f04ea8d1
SP		 5829 push @m, sprintf(
5830 " %-12s %s\n",
5831 $_,
5832 $value,
5833 );
5834 } else {
5835 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
5836 }
5f05dabc 5837 }
05454584 5838 join "", @m, "\n";
5f05dabc 5839}
5840
4d1321a7
A		 5841#-> sub CPAN::InfoObj::fullname ;
5842sub fullname {
05454584 5843 my($self) = @_;
9d61fa1d 5844 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5f05dabc 5845}
5846
6d29edf5 5847#-> sub CPAN::InfoObj::dump ;
36263cb3 5848sub dump {
f04ea8d1
SP		 5849 my($self, $what) = @_;
5850 unless ($CPAN::META->has_inst("Data::Dumper")) {
5851 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5852 }
5853 local $Data::Dumper::Sortkeys;
5854 $Data::Dumper::Sortkeys = 1;
5855 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5856 if (length $out > 100000) {
5857 my $fh_pager = FileHandle->new;
5858 local($SIG{PIPE}) = "IGNORE";
5859 my $pager = $CPAN::Config->{'pager'} || "cat";
5860 $fh_pager->open("|$pager")
5861 or die "Could not open pager $pager\: $!";
5862 $fh_pager->print($out);
5863 close $fh_pager;
5864 } else {
5865 $CPAN::Frontend->myprint($out);
5866 }
36263cb3
GS		 5867}
5868
05454584 5869package CPAN::Author;
e82b9348 5870use strict;
05454584 5871
9ddc4ed0
A		 5872#-> sub CPAN::Author::force
5873sub force {
5874 my $self = shift;
5875 $self->{force}++;
5876}
5877
5878#-> sub CPAN::Author::force
5879sub unforce {
5880 my $self = shift;
5881 delete $self->{force};
5882}
5883
c049f953
JH		 5884#-> sub CPAN::Author::id
5885sub id {
5886 my $self = shift;
5887 my $id = $self->{ID};
5888 $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5889 $id;
5890}
5891
05454584
A		 5892#-> sub CPAN::Author::as_glimpse ;
5893sub as_glimpse {
5f05dabc 5894 my($self) = @_;
05454584
A		 5895 my(@m);
5896 my $class = ref($self);
5897 $class =~ s/^CPAN:://;
c049f953
JH		 5898 push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5899 $class,
5900 $self->{ID},
5901 $self->fullname,
5902 $self->email);
05454584 5903 join "", @m;
5f05dabc 5904}
5905
05454584 5906#-> sub CPAN::Author::fullname ;
9d61fa1d 5907sub fullname {
0cf35e6a 5908 shift->ro->{FULLNAME};
9d61fa1d 5909}
05454584 5910*name = \&fullname;
36263cb3 5911
05454584 5912#-> sub CPAN::Author::email ;
0cf35e6a 5913sub email { shift->ro->{EMAIL}; }
8d97e4a1 5914
d8773709 5915#-> sub CPAN::Author::ls ;
8d97e4a1
JH		 5916sub ls {
5917 my $self = shift;
e82b9348 5918 my $glob = shift || "";
554a9ef5 5919 my $silent = shift || 0;
8d97e4a1
JH		 5920 my $id = $self->id;
5921
e82b9348 5922 # adapted from CPAN::Distribution::verifyCHECKSUM ;
c049f953
JH		 5923 my(@csf); # chksumfile
5924 @csf = $self->id =~ /(.)(.)(.*)/;
5925 $csf[1] = join "", @csf[0,1];
554a9ef5 5926 $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
c049f953 5927 my(@dl);
554a9ef5 5928 @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
c049f953 5929 unless (grep {$_->[2] eq $csf[1]} @dl) {
f3fe0ae6 5930 $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
c049f953
JH		 5931 return;
5932 }
554a9ef5 5933 @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
c049f953 5934 unless (grep {$_->[2] eq $csf[2]} @dl) {
f3fe0ae6 5935 $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
c049f953
JH		 5936 return;
5937 }
554a9ef5 5938 @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
e82b9348 5939 if ($glob) {
4d1321a7
A		 5940 if ($CPAN::META->has_inst("Text::Glob")) {
5941 my $rglob = Text::Glob::glob_to_regex($glob);
5942 @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5943 } else {
5944 $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5945 }
e82b9348 5946 }
f04ea8d1
SP		 5947 unless ($silent >= 2) {
5948 $CPAN::Frontend->myprint(join "", map {
5949 sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5950 } sort { $a->[2] cmp $b->[2] } @dl);
5951 }
ca79d794 5952 @dl;
8d97e4a1
JH		 5953}
5954
c049f953 5955# returns an array of arrays, the latter contain (size,mtime,filename)
d8773709 5956#-> sub CPAN::Author::dir_listing ;
8d97e4a1
JH		 5957sub dir_listing {
5958 my $self = shift;
5959 my $chksumfile = shift;
c049f953 5960 my $recursive = shift;
554a9ef5 5961 my $may_ftp = shift;
b96578bb 5962
8d97e4a1 5963 my $lc_want =
f04ea8d1
SP		 5964 File::Spec->catfile($CPAN::Config->{keep_source_where},
5965 "authors", "id", @$chksumfile);
f3fe0ae6 5966
554a9ef5
SP		 5967 my $fh;
5968
5969 # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5970 # hazard. (Without GPG installed they are not that much better,
5971 # though.)
5972 $fh = FileHandle->new;
5973 if (open($fh, $lc_want)) {
f04ea8d1
SP		 5974 my $line = <$fh>; close $fh;
5975 unlink($lc_want) unless $line =~ /PGP/;
554a9ef5 5976 }
f3fe0ae6 5977
8d97e4a1 5978 local($") = "/";
c049f953 5979 # connect "force" argument with "index_expire".
9ddc4ed0 5980 my $force = $self->{force};
c049f953 5981 if (my @stat = stat $lc_want) {
9ddc4ed0 5982 $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
c049f953 5983 }
554a9ef5
SP		 5984 my $lc_file;
5985 if ($may_ftp) {
5986 $lc_file = CPAN::FTP->localize(
5987 "authors/id/@$chksumfile",
5988 $lc_want,
5989 $force,
5990 );
5991 unless ($lc_file) {
5992 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5993 $chksumfile->[-1] .= ".gz";
5994 $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5995 "$lc_want.gz",1);
5996 if ($lc_file) {
5997 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
be34b10d 5998 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
554a9ef5
SP		 5999 } else {
6000 return;
6001 }
6002 }
6003 } else {
6004 $lc_file = $lc_want;
6005 # we *could* second-guess and if the user has a file: URL,
6006 # then we could look there. But on the other hand, if they do
6007 # have a file: URL, wy did they choose to set
6008 # $CPAN::Config->{show_upload_date} to false?
8d97e4a1
JH		 6009 }
6010
e82b9348 6011 # adapted from CPAN::Distribution::CHECKSUM_check_file ;
554a9ef5 6012 $fh = FileHandle->new;
8d97e4a1 6013 my($cksum);
f04ea8d1
SP		 6014 if (open $fh, $lc_file) {
6015 local($/);
6016 my $eval = <$fh>;
6017 $eval =~ s/\015?\012/\n/g;
6018 close $fh;
5254b38e
SP		 6019 my($compmt) = Safe->new();
6020 $cksum = $compmt->reval($eval);
f04ea8d1
SP		 6021 if ($@) {
6022 rename $lc_file, "$lc_file.bad";
6023 Carp::confess($@) if $@;
6024 }
554a9ef5 6025 } elsif ($may_ftp) {
f04ea8d1 6026 Carp::carp "Could not open '$lc_file' for reading.";
8d97e4a1 6027 } else {
554a9ef5 6028 # Maybe should warn: "You may want to set show_upload_date to a true value"
f04ea8d1 6029 return;
8d97e4a1
JH		 6030 }
6031 my(@result,$f);
6032 for $f (sort keys %$cksum) {
6033 if (exists $cksum->{$f}{isdir}) {
c049f953
JH		 6034 if ($recursive) {
6035 my(@dir) = @$chksumfile;
6036 pop @dir;
6037 push @dir, $f, "CHECKSUMS";
6038 push @result, map {
6039 [$_->[0], $_->[1], "$f/$_->[2]"]
554a9ef5 6040 } $self->dir_listing(\@dir,1,$may_ftp);
c049f953
JH		 6041 } else {
6042 push @result, [ 0, "-", $f ];
6043 }
8d97e4a1
JH		 6044 } else {
6045 push @result, [
6046 ($cksum->{$f}{"size"}||0),
6047 $cksum->{$f}{"mtime"}||"---",
6048 $f
6049 ];
6050 }
6051 }
6052 @result;
6053}
5f05dabc 6054
dc053c64
SP		 6055#-> sub CPAN::Author::reports
6056sub reports {
6057 $CPAN::Frontend->mywarn("reports on authors not implemented.
6058Please file a bugreport if you need this.\n");
6059}
6060
05454584 6061package CPAN::Distribution;
e82b9348 6062use strict;
5254b38e
SP		 6063use Cwd qw(chdir);
6064use CPAN::Distroprefs;
5f05dabc 6065
6d29edf5 6066# Accessors
e8a27a4e
A		 6067sub cpan_comment {
6068 my $self = shift;
6069 my $ro = $self->ro or return;
6070 $ro->{CPAN_COMMENT}
6071}
6d29edf5 6072
dc053c64 6073#-> CPAN::Distribution::undelay
6d29edf5
JH		 6074sub undelay {
6075 my $self = shift;
f04ea8d1
SP		 6076 for my $delayer (
6077 "configure_requires_later",
6078 "configure_requires_later_for",
6079 "later",
6080 "later_for",
6081 ) {
6082 delete $self->{$delayer};
6083 }
6d29edf5
JH		 6084}
6085
dc053c64
SP		 6086#-> CPAN::Distribution::is_dot_dist
6087sub is_dot_dist {
6088 my($self) = @_;
8ce4ea0b 6089 return substr($self->id,-1,1) eq ".";
dc053c64
SP		 6090}
6091
e8a27a4e 6092# add the A/AN/ stuff
dc053c64 6093#-> CPAN::Distribution::normalize
8d97e4a1
JH		 6094sub normalize {
6095 my($self,$s) = @_;
d8773709 6096 $s = $self->id unless defined $s;
8fc516fe 6097 if (substr($s,-1,1) eq ".") {
05bab18e
SP		 6098 # using a global because we are sometimes called as static method
6099 if (!$CPAN::META->{LOCK}
6100 && !$CPAN::Have_warned->{"$s is unlocked"}++
6101 ) {
6102 $CPAN::Frontend->mywarn("You are visiting the local directory
6103 '$s'
6104 without lock, take care that concurrent processes do not do likewise.\n");
6105 $CPAN::Frontend->mysleep(1);
6106 }
8fc516fe
SP		 6107 if ($s eq ".") {
6108 $s = "$CPAN::iCwd/.";
6109 } elsif (File::Spec->file_name_is_absolute($s)) {
6110 } elsif (File::Spec->can("rel2abs")) {
6111 $s = File::Spec->rel2abs($s);
6112 } else {
6113 $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
6114 }
6115 CPAN->debug("s[$s]") if $CPAN::DEBUG;
6116 unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
6117 for ($CPAN::META->instance("CPAN::Distribution", $s)) {
6118 $_->{build_dir} = $s;
6119 $_->{archived} = "local_directory";
6658a91b 6120 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
8fc516fe
SP		 6121 }
6122 }
6123 } elsif (
c049f953
JH		 6124 $s =~ tr|/|| == 1
6125 or
6126 $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
6127 ) {
6128 return $s if $s =~ m:^N/A|^Contact Author: ;
5254b38e 6129 $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
8d97e4a1
JH		 6130 CPAN->debug("s[$s]") if $CPAN::DEBUG;
6131 }
6132 $s;
6133}
6134
4d1321a7
A		 6135#-> sub CPAN::Distribution::author ;
6136sub author {
6137 my($self) = @_;
6658a91b
SP		 6138 my($authorid);
6139 if (substr($self->id,-1,1) eq ".") {
6140 $authorid = "LOCAL";
6141 } else {
6142 ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
6143 }
4d1321a7
A		 6144 CPAN::Shell->expand("Author",$authorid);
6145}
6146
6147# tries to get the yaml from CPAN instead of the distro itself:
6148# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
6149sub fast_yaml {
6150 my($self) = @_;
6151 my $meta = $self->pretty_id;
6152 $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
6153 my(@ls) = CPAN::Shell->globls($meta);
6154 my $norm = $self->normalize($meta);
6155
6156 my($local_file);
6157 my($local_wanted) =
6158 File::Spec->catfile(
f04ea8d1
SP		 6159 $CPAN::Config->{keep_source_where},
6160 "authors",
6161 "id",
6162 split(/\//,$norm)
6163 );
4d1321a7
A		 6164 $self->debug("Doing localize") if $CPAN::DEBUG;
6165 unless ($local_file =
6166 CPAN::FTP->localize("authors/id/$norm",
6167 $local_wanted)) {
6168 $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
6169 }
6658a91b
SP		 6170 my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
6171}
6172
6173#-> sub CPAN::Distribution::cpan_userid
6174sub cpan_userid {
6175 my $self = shift;
6176 if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
6177 return $1;
6178 }
6179 return $self->SUPER::cpan_userid;
4d1321a7
A		 6180}
6181
135a59c2 6182#-> sub CPAN::Distribution::pretty_id
e8a27a4e
A		 6183sub pretty_id {
6184 my $self = shift;
6185 my $id = $self->id;
6186 return $id unless $id =~ m|^./../|;
6187 substr($id,5);
6188}
6189
f04ea8d1
SP		 6190#-> sub CPAN::Distribution::base_id
6191sub base_id {
6192 my $self = shift;
6193 my $id = $self->pretty_id();
6194 my $base_id = File::Basename::basename($id);
6195 $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
6196 return $base_id;
6197}
6198
5254b38e
SP		 6199#-> sub CPAN::Distribution::tested_ok_but_not_installed
6200sub tested_ok_but_not_installed {
6201 my $self = shift;
6202 return (
6203 $self->{make_test}
6204 && $self->{build_dir}
6205 && (UNIVERSAL::can($self->{make_test},"failed") ?
6206 ! $self->{make_test}->failed :
6207 $self->{make_test} =~ /^YES/
6208 )
6209 && (
6210 !$self->{install}
6211 ||
6212 $self->{install}->failed
6213 )
6214 );
6215}
6216
6217
f20de9f0
SP		 6218# mark as dirty/clean for the sake of recursion detection. $color=1
6219# means "in use", $color=0 means "not in use anymore". $color=2 means
6220# we have determined prereqs now and thus insist on passing this
6221# through (at least) once again.
6222
6d29edf5
JH		 6223#-> sub CPAN::Distribution::color_cmd_tmps ;
6224sub color_cmd_tmps {
6225 my($self) = shift;
6226 my($depth) = shift || 0;
6227 my($color) = shift || 0;
35576f8c 6228 my($ancestors) = shift || [];
6d29edf5
JH		 6229 # a distribution needs to recurse into its prereq_pms
6230
6231 return if exists $self->{incommandcolor}
f20de9f0 6232 && $color==1
6d29edf5 6233 && $self->{incommandcolor}==$color;
f04ea8d1 6234 if ($depth>=$CPAN::MAX_RECURSION) {
ade94d80 6235 die(CPAN::Exception::RecursiveDependency->new($ancestors));
35576f8c
A		 6236 }
6237 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6d29edf5
JH		 6238 my $prereq_pm = $self->prereq_pm;
6239 if (defined $prereq_pm) {
135a59c2
A		 6240 PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
6241 keys %{$prereq_pm->{build_requires}||{}}) {
7d97ad34 6242 next PREREQ if $pre eq "perl";
44d21104
A		 6243 my $premo;
6244 unless ($premo = CPAN::Shell->expand("Module",$pre)) {
6245 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
6246 $CPAN::Frontend->mysleep(2);
6247 next PREREQ;
6248 }
35576f8c 6249 $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6d29edf5
JH		 6250 }
6251 }
6252 if ($color==0) {
6253 delete $self->{sponsored_mods};
b72dd56f
SP		 6254
6255 # as we are at the end of a command, we'll give up this
6256 # reminder of a broken test. Other commands may test this guy
6257 # again. Maybe 'badtestcnt' should be renamed to
f20de9f0 6258 # 'make_test_failed_within_command'?
6d29edf5
JH		 6259 delete $self->{badtestcnt};
6260 }
6261 $self->{incommandcolor} = $color;
6262}
6263
911a92db
GS		 6264#-> sub CPAN::Distribution::as_string ;
6265sub as_string {
f04ea8d1
SP		 6266 my $self = shift;
6267 $self->containsmods;
6268 $self->upload_date;
6269 $self->SUPER::as_string(@_);
911a92db
GS		 6270}
6271
6272#-> sub CPAN::Distribution::containsmods ;
6273sub containsmods {
f04ea8d1
SP		 6274 my $self = shift;
6275 return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
6276 my $dist_id = $self->{ID};
6277 for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
6278 my $mod_file = $mod->cpan_file or next;
6279 my $mod_id = $mod->{ID} or next;
6280 # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
6281 # sleep 1;
6282 if ($CPAN::Signal) {
6283 delete $self->{CONTAINSMODS};
6284 return;
6285 }
6286 $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
b72dd56f 6287 }
b03f445c 6288 keys %{$self->{CONTAINSMODS}||={}};
911a92db
GS		 6289}
6290
554a9ef5
SP		 6291#-> sub CPAN::Distribution::upload_date ;
6292sub upload_date {
f04ea8d1
SP		 6293 my $self = shift;
6294 return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
6295 my(@local_wanted) = split(/\//,$self->id);
6296 my $filename = pop @local_wanted;
6297 push @local_wanted, "CHECKSUMS";
6298 my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
6299 return unless $author;
6300 my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
6301 return unless @dl;
6302 my($dirent) = grep { $_->[2] eq $filename } @dl;
6303 # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
6304 return unless $dirent->[1];
6305 return $self->{UPLOAD_DATE} = $dirent->[1];
554a9ef5
SP		 6306}
6307
d8773709
JH		 6308#-> sub CPAN::Distribution::uptodate ;
6309sub uptodate {
6310 my($self) = @_;
6311 my $c;
6312 foreach $c ($self->containsmods) {
6313 my $obj = CPAN::Shell->expandany($c);
f04ea8d1 6314 unless ($obj->uptodate) {
8962fc49
SP		 6315 my $id = $self->pretty_id;
6316 $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
6317 return 0;
6318 }
d8773709
JH		 6319 }
6320 return 1;
6321}
6322
05454584
A		 6323#-> sub CPAN::Distribution::called_for ;
6324sub called_for {
6325 my($self,$id) = @_;
6d29edf5
JH		 6326 $self->{CALLED_FOR} = $id if defined $id;
6327 return $self->{CALLED_FOR};
5f05dabc 6328}
6329
05454584
A		 6330#-> sub CPAN::Distribution::get ;
6331sub get {
5f05dabc 6332 my($self) = @_;
b72dd56f 6333 $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
be34b10d
SP		 6334 if (my $goto = $self->prefs->{goto}) {
6335 $CPAN::Frontend->mywarn
6336 (sprintf(
6337 "delegating to '%s' as specified in prefs file '%s' doc %d\n",
6338 $goto,
6339 $self->{prefs_file},
6340 $self->{prefs_file_doc},
6341 ));
6342 return $self->goto($goto);
6343 }
6658a91b
SP		 6344 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6345 ? $ENV{PERL5LIB}
6346 : ($ENV{PERLLIB} || "");
5254b38e 6347 local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
6658a91b
SP		 6348 $CPAN::META->set_perl5lib;
6349 local $ENV{MAKEFLAGS}; # protect us from outer make calls
6350
da199366 6351 EXCUSE: {
f04ea8d1 6352 my @e;
8ce4ea0b 6353 my $goodbye_message;
b72dd56f 6354 $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5254b38e 6355 if ($self->prefs->{disabled} && ! $self->{force_update}) {
810a0276
SP		 6356 my $why = sprintf(
6357 "Disabled via prefs file '%s' doc %d",
6358 $self->{prefs_file},
6359 $self->{prefs_file_doc},
6360 );
6361 push @e, $why;
8ce4ea0b
SP		 6362 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
6363 $goodbye_message = "[disabled] -- NA $why";
810a0276
SP		 6364 # note: not intended to be persistent but at least visible
6365 # during this session
6366 } else {
dc053c64
SP		 6367 if (exists $self->{build_dir} && -d $self->{build_dir}
6368 && ($self->{modulebuild}||$self->{writemakefile})
6369 ) {
b72dd56f
SP		 6370 # this deserves print, not warn:
6371 $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
6372 "$self->{build_dir}\n"
6373 );
23a216b4 6374 return 1;
b72dd56f 6375 }
6658a91b 6376
b72dd56f
SP		 6377 # although we talk about 'force' we shall not test on
6378 # force directly. New model of force tries to refrain from
6379 # direct checking of force.
810a0276
SP		 6380 exists $self->{unwrapped} and (
6381 UNIVERSAL::can($self->{unwrapped},"failed") ?
6382 $self->{unwrapped}->failed :
6383 $self->{unwrapped} =~ /^NO/
6384 )
6385 and push @e, "Unwrapping had some problem, won't try again without force";
6386 }
8ce4ea0b
SP		 6387 if (@e) {
6388 $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
6389 if ($goodbye_message) {
6390 $self->goodbye($goodbye_message);
6391 }
6392 return;
6393 }
da199366 6394 }
f04ea8d1
SP		 6395 my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
6396
6397 my($local_file);
6398 unless ($self->{build_dir} && -d $self->{build_dir}) {
6399 $self->get_file_onto_local_disk;
6400 return if $CPAN::Signal;
6401 $self->check_integrity;
6402 return if $CPAN::Signal;
6403 (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
5254b38e
SP		 6404 if (exists $self->{writemakefile} && ref $self->{writemakefile}
6405 && $self->{writemakefile}->can("failed") &&
6406 $self->{writemakefile}->failed) {
6407 return;
6408 }
f04ea8d1
SP		 6409 $packagedir ||= $self->{build_dir};
6410 $self->{build_dir} = $packagedir;
6411 }
d8773709 6412
f04ea8d1 6413 if ($CPAN::Signal) {
dc053c64
SP		 6414 $self->safe_chdir($sub_wd);
6415 return;
6416 }
5254b38e 6417 return $self->choose_MM_or_MB($local_file);
dc053c64
SP		 6418}
6419
6420#-> CPAN::Distribution::get_file_onto_local_disk
6421sub get_file_onto_local_disk {
6422 my($self) = @_;
6423
6424 return if $self->is_dot_dist;
05454584
A		 6425 my($local_file);
6426 my($local_wanted) =
5de3f0da 6427 File::Spec->catfile(
f04ea8d1
SP		 6428 $CPAN::Config->{keep_source_where},
6429 "authors",
6430 "id",
6431 split(/\//,$self->id)
6432 );
05454584
A		 6433
6434 $self->debug("Doing localize") if $CPAN::DEBUG;
c049f953
JH		 6435 unless ($local_file =
6436 CPAN::FTP->localize("authors/id/$self->{ID}",
6437 $local_wanted)) {
6438 my $note = "";
6439 if ($CPAN::Index::DATE_OF_02) {
6440 $note = "Note: Current database in memory was generated ".
6441 "on $CPAN::Index::DATE_OF_02\n";
6442 }
6443 $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
6444 }
6658a91b
SP		 6445
6446 $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
05454584 6447 $self->{localfile} = $local_file;
dc053c64 6448}
05454584 6449
dc053c64
SP		 6450
6451#-> CPAN::Distribution::check_integrity
6452sub check_integrity {
6453 my($self) = @_;
6454
6455 return if $self->is_dot_dist;
e82b9348 6456 if ($CPAN::META->has_inst("Digest::SHA")) {
f04ea8d1
SP		 6457 $self->debug("Digest::SHA is installed, verifying");
6458 $self->verifyCHECKSUM;
55e314ee 6459 } else {
f04ea8d1 6460 $self->debug("Digest::SHA is NOT installed");
55e314ee 6461 }
dc053c64
SP		 6462}
6463
6464#-> CPAN::Distribution::run_preps_on_packagedir
6465sub run_preps_on_packagedir {
6466 my($self) = @_;
6467 return if $self->is_dot_dist;
d8773709 6468
d8773709
JH		 6469 $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
6470 my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
6471 $self->safe_chdir($builddir);
05bab18e
SP		 6472 $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
6473 File::Path::rmtree("tmp-$$");
6474 unless (mkdir "tmp-$$", 0755) {
c9869e1c 6475 $CPAN::Frontend->unrecoverable_error(<<EOF);
05bab18e 6476Couldn't mkdir '$builddir/tmp-$$': $!
c9869e1c
SP		 6477
6478Cannot continue: Please find the reason why I cannot make the
6479directory
05bab18e 6480$builddir/tmp-$$
c9869e1c
SP		 6481and fix the problem, then retry.
6482
6483EOF
6484 }
f04ea8d1 6485 if ($CPAN::Signal) {
d8773709
JH		 6486 return;
6487 }
05bab18e 6488 $self->safe_chdir("tmp-$$");
d8773709
JH		 6489
6490 #
6491 # Unpack the goods
6492 #
dc053c64 6493 my $local_file = $self->{localfile};
be34b10d
SP		 6494 my $ct = eval{CPAN::Tarzip->new($local_file)};
6495 unless ($ct) {
6496 $self->{unwrapped} = CPAN::Distrostatus->new("NO");
6497 delete $self->{build_dir};
6498 return;
6499 }
f04ea8d1 6500 if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
be34b10d 6501 $self->{was_uncompressed}++ unless eval{$ct->gtest()};
f04ea8d1 6502 $self->untar_me($ct);
05d2a450 6503 } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
f04ea8d1 6504 $self->unzip_me($ct);
55e314ee 6505 } else {
ed84aac9 6506 $self->{was_uncompressed}++ unless $ct->gtest();
f04ea8d1 6507 $local_file = $self->handle_singlefile($local_file);
5f05dabc 6508 }
d8773709
JH		 6509
6510 # we are still in the tmp directory!
6511 # Let's check if the package has its own directory.
6512 my $dh = DirHandle->new(File::Spec->curdir)
6513 or Carp::croak("Couldn't opendir .: $!");
6514 my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5254b38e
SP		 6515 if (grep { $_ eq "pax_global_header" } @readdir) {
6516 $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
6517from the tarball '$local_file'.
6518This is almost certainly an error. Please upgrade your tar.
6519I'll ignore this file for now.
6520See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
6521 $CPAN::Frontend->mysleep(5);
6522 @readdir = grep { $_ ne "pax_global_header" } @readdir;
6523 }
d8773709 6524 $dh->close;
05bab18e
SP		 6525 my ($packagedir);
6526 # XXX here we want in each branch File::Temp to protect all build_dir directories
b03f445c 6527 if (CPAN->has_usable("File::Temp")) {
05bab18e
SP		 6528 my $tdir_base;
6529 my $from_dir;
6530 my @dirents;
6531 if (@readdir == 1 && -d $readdir[0]) {
6532 $tdir_base = $readdir[0];
6533 $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5254b38e
SP		 6534 my $dh2;
6535 unless ($dh2 = DirHandle->new($from_dir)) {
6536 my($mode) = (stat $from_dir)[2];
6537 my $why = sprintf
6538 (
6539 "Couldn't opendir '%s', mode '%o': %s",
6540 $from_dir,
6541 $mode,
6542 $!,
6543 );
6544 $CPAN::Frontend->mywarn("$why\n");
6545 $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
6546 return;
6547 }
05bab18e
SP		 6548 @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
6549 } else {
6550 my $userid = $self->cpan_userid;
6551 CPAN->debug("userid[$userid]");
6552 if (!$userid or $userid eq "N/A") {
6553 $userid = "anon";
6554 }
6555 $tdir_base = $userid;
6556 $from_dir = File::Spec->curdir;
6557 @dirents = @readdir;
6558 }
6559 $packagedir = File::Temp::tempdir(
6560 "$tdir_base-XXXXXX",
6561 DIR => $builddir,
6562 CLEANUP => 0,
6563 );
6564 my $f;
6565 for $f (@dirents) { # is already without "." and ".."
6566 my $from = File::Spec->catdir($from_dir,$f);
6567 my $to = File::Spec->catdir($packagedir,$f);
810a0276
SP		 6568 unless (File::Copy::move($from,$to)) {
6569 my $err = $!;
6570 $from = File::Spec->rel2abs($from);
6571 Carp::confess("Couldn't move $from to $to: $err");
6572 }
05bab18e
SP		 6573 }
6574 } else { # older code below, still better than nothing when there is no File::Temp
6575 my($distdir);
6576 if (@readdir == 1 && -d $readdir[0]) {
6577 $distdir = $readdir[0];
6578 $packagedir = File::Spec->catdir($builddir,$distdir);
6579 $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
6580 if $CPAN::DEBUG;
6581 -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
6582 "$packagedir\n");
6583 File::Path::rmtree($packagedir);
6584 unless (File::Copy::move($distdir,$packagedir)) {
6585 $CPAN::Frontend->unrecoverable_error(<<EOF);
c9869e1c
SP		 6586Couldn't move '$distdir' to '$packagedir': $!
6587
6588Cannot continue: Please find the reason why I cannot move
05bab18e 6589$builddir/tmp-$$/$distdir
c9869e1c
SP		 6590to
6591$packagedir
6592and fix the problem, then retry
6593
6594EOF
05bab18e
SP		 6595 }
6596 $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
6597 $distdir,
6598 $packagedir,
6599 -e $packagedir,
6600 -d $packagedir,
6601 )) if $CPAN::DEBUG;
6602 } else {
6603 my $userid = $self->cpan_userid;
b72dd56f 6604 CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
05bab18e
SP		 6605 if (!$userid or $userid eq "N/A") {
6606 $userid = "anon";
6607 }
6608 my $pragmatic_dir = $userid . '000';
6609 $pragmatic_dir =~ s/\W_//g;
6610 $pragmatic_dir++ while -d "../$pragmatic_dir";
6611 $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
6612 $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
6613 File::Path::mkpath($packagedir);
6614 my($f);
6615 for $f (@readdir) { # is already without "." and ".."
6616 my $to = File::Spec->catdir($packagedir,$f);
6617 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
6618 }
9d61fa1d 6619 }
d8773709 6620 }
b72dd56f 6621 $self->{build_dir} = $packagedir;
6f14f089 6622 $self->safe_chdir($builddir);
05bab18e 6623 File::Path::rmtree("tmp-$$");
d8773709 6624
554a9ef5 6625 $self->safe_chdir($packagedir);
6658a91b 6626 $self->_signature_business();
554a9ef5 6627 $self->safe_chdir($builddir);
554a9ef5 6628
dc053c64
SP		 6629 return($packagedir,$local_file);
6630}
554a9ef5 6631
f04ea8d1
SP		 6632#-> sub CPAN::Distribution::parse_meta_yml ;
6633sub parse_meta_yml {
6634 my($self) = @_;
6635 my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
6636 my $yaml = File::Spec->catfile($build_dir,"META.yml");
6637 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
6638 return unless -f $yaml;
6639 my $early_yaml;
6640 eval {
6641 require Parse::Metayaml; # hypothetical
6642 $early_yaml = Parse::Metayaml::LoadFile($yaml)->[0];
6643 };
6644 unless ($early_yaml) {
6645 eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
6646 }
6647 unless ($early_yaml) {
6648 return;
6649 }
6650 return $early_yaml;
6651}
6652
5254b38e
SP		 6653#-> sub CPAN::Distribution::satisfy_requires ;
6654sub satisfy_requires {
6655 my ($self) = @_;
6656 if (my @prereq = $self->unsat_prereq("later")) {
6657 if ($prereq[0][0] eq "perl") {
6658 my $need = "requires perl '$prereq[0][1]'";
6659 my $id = $self->pretty_id;
6660 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6661 $self->{make} = CPAN::Distrostatus->new("NO $need");
6662 $self->store_persistent_state;
6663 die "[prereq] -- NOT OK\n";
6664 } else {
6665 my $follow = eval { $self->follow_prereqs("later",@prereq); };
6666 if (0) {
6667 } elsif ($follow) {
6668 # signal success to the queuerunner
6669 return 1;
6670 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6671 $CPAN::Frontend->mywarn($@);
6672 die "[depend] -- NOT OK\n";
6673 }
6674 }
6675 }
6676}
6677
f04ea8d1
SP		 6678#-> sub CPAN::Distribution::satisfy_configure_requires ;
6679sub satisfy_configure_requires {
6680 my($self) = @_;
6681 my $enable_configure_requires = 1;
6682 if (!$enable_configure_requires) {
6683 return 1;
6684 # if we return 1 here, everything is as before we introduced
6685 # configure_requires that means, things with
6686 # configure_requires simply fail, all others succeed
6687 }
6688 my @prereq = $self->unsat_prereq("configure_requires_later") or return 1;
6689 if ($self->{configure_requires_later}) {
6690 for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
6691 if ($self->{configure_requires_later_for}{$k}>1) {
6692 # we must not come here a second time
6693 $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
6694 require YAML::Syck;
6695 $CPAN::Frontend->mydie
6696 (
6697 YAML::Syck::Dump
6698 ({self=>$self, prereq=>\@prereq})
6699 );
6700 }
6701 }
6702 }
6703 if ($prereq[0][0] eq "perl") {
6704 my $need = "requires perl '$prereq[0][1]'";
6705 my $id = $self->pretty_id;
6706 $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6707 $self->{make} = CPAN::Distrostatus->new("NO $need");
6708 $self->store_persistent_state;
6709 return $self->goodbye("[prereq] -- NOT OK");
6710 } else {
6711 my $follow = eval {
6712 $self->follow_prereqs("configure_requires_later", @prereq);
6713 };
6714 if (0) {
6715 } elsif ($follow) {
6716 return;
6717 } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
6718 $CPAN::Frontend->mywarn($@);
6719 return $self->goodbye("[depend] -- NOT OK");
6720 }
6721 }
6722 die "never reached";
6723}
6724
5254b38e
SP		 6725#-> sub CPAN::Distribution::choose_MM_or_MB ;
6726sub choose_MM_or_MB {
f04ea8d1
SP		 6727 my($self,$local_file) = @_;
6728 $self->satisfy_configure_requires() or return;
6729 my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
d8773709
JH		 6730 my($mpl_exists) = -f $mpl;
6731 unless ($mpl_exists) {
c049f953
JH		 6732 # NFS has been reported to have racing problems after the
6733 # renaming of a directory in some environments.
6734 # This trick helps.
8962fc49 6735 $CPAN::Frontend->mysleep(1);
f04ea8d1
SP		 6736 my $mpldh = DirHandle->new($self->{build_dir})
6737 or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
c049f953
JH		 6738 $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
6739 $mpldh->close;
d8773709 6740 }
e82b9348 6741 my $prefer_installer = "eumm"; # eumm|mb
f04ea8d1 6742 if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
e82b9348 6743 if ($mpl_exists) { # they *can* choose
f20de9f0
SP		 6744 if ($CPAN::META->has_inst("Module::Build")) {
6745 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6746 q{prefer_installer});
6747 }
e82b9348
SP		 6748 } else {
6749 $prefer_installer = "mb";
6750 }
6751 }
6658a91b 6752 return unless $self->patch;
f04ea8d1
SP		 6753 if (lc($prefer_installer) eq "rand") {
6754 $prefer_installer = rand()<.5 ? "eumm" : "mb";
6755 }
e82b9348 6756 if (lc($prefer_installer) eq "mb") {
c9869e1c 6757 $self->{modulebuild} = 1;
2b3bde2a
SP		 6758 } elsif ($self->{archived} eq "patch") {
6759 # not an edge case, nothing to install for sure
6760 my $why = "A patch file cannot be installed";
6761 $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6762 $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
e82b9348 6763 } elsif (! $mpl_exists) {
f04ea8d1 6764 $self->_edge_cases($mpl,$local_file);
6658a91b 6765 }
05bab18e
SP		 6766 if ($self->{build_dir}
6767 &&
6768 $CPAN::Config->{build_dir_reuse}
6769 ) {
6770 $self->store_persistent_state;
6771 }
6658a91b
SP		 6772 return $self;
6773}
6774
05bab18e
SP		 6775#-> CPAN::Distribution::store_persistent_state
6776sub store_persistent_state {
6777 my($self) = @_;
be34b10d 6778 my $dir = $self->{build_dir};
810a0276 6779 unless (File::Spec->canonpath(File::Basename::dirname($dir))
f04ea8d1 6780 eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
be34b10d
SP		 6781 $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6782 "will not store persistent state\n");
6783 return;
6784 }
6785 my $file = sprintf "%s.yml", $dir;
b72dd56f
SP		 6786 my $yaml_module = CPAN::_yaml_module;
6787 if ($CPAN::META->has_inst($yaml_module)) {
6788 CPAN->_yaml_dumpfile(
6789 $file,
6790 {
6791 time => time,
6792 perl => CPAN::_perl_fingerprint,
6793 distribution => $self,
6794 }
6795 );
6796 } else {
6797 $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6798 "will not store persistent state\n");
6799 }
05bab18e
SP		 6800}
6801
b03f445c 6802#-> CPAN::Distribution::try_download
6658a91b
SP		 6803sub try_download {
6804 my($self,$patch) = @_;
6805 my $norm = $self->normalize($patch);
6806 my($local_wanted) =
6807 File::Spec->catfile(
6808 $CPAN::Config->{keep_source_where},
6809 "authors",
6810 "id",
6811 split(/\//,$norm),
f04ea8d1 6812 );
6658a91b
SP		 6813 $self->debug("Doing localize") if $CPAN::DEBUG;
6814 return CPAN::FTP->localize("authors/id/$norm",
6815 $local_wanted);
6816}
6817
8ce4ea0b
SP		 6818{
6819 my $stdpatchargs = "";
6820 #-> CPAN::Distribution::patch
6821 sub patch {
6822 my($self) = @_;
6823 $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6824 my $patches = $self->prefs->{patches};
6825 $patches ||= "";
6826 $self->debug("patches[$patches]") if $CPAN::DEBUG;
6827 if ($patches) {
6828 return unless @$patches;
6829 $self->safe_chdir($self->{build_dir});
6830 CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6831 my $patchbin = $CPAN::Config->{patch};
6832 unless ($patchbin && length $patchbin) {
6833 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6834 "Please run 'o conf init /patch/'\n\n");
6835 }
6836 unless (MM->maybe_command($patchbin)) {
6837 $CPAN::Frontend->mydie("No external patch command available\n\n".
6838 "Please run 'o conf init /patch/'\n\n");
6839 }
6840 $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6841 local $ENV{PATCH_GET} = 0; # formerly known as -g0
6842 unless ($stdpatchargs) {
6843 my $system = "$patchbin --version |";
6844 local *FH;
6845 open FH, $system or die "Could not fork '$system': $!";
6846 local $/ = "\n";
6847 my $pversion;
6848 PARSEVERSION: while (<FH>) {
6849 if (/^patch\s+([\d\.]+)/) {
6850 $pversion = $1;
6851 last PARSEVERSION;
6852 }
6853 }
6854 if ($pversion) {
6855 $stdpatchargs = "-N --fuzz=3";
6856 } else {
6857 $stdpatchargs = "-N";
6858 }
6859 }
6860 my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6861 $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6862 for my $patch (@$patches) {
6863 unless (-f $patch) {
6864 if (my $trydl = $self->try_download($patch)) {
6865 $patch = $trydl;
6866 } else {
6867 my $fail = "Could not find patch '$patch'";
6868 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6869 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6870 delete $self->{build_dir};
6871 return;
6872 }
6873 }
6874 $CPAN::Frontend->myprint(" $patch\n");
6875 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6876
6877 my $pcommand;
6878 my $ppp = $self->_patch_p_parameter($readfh);
6879 if ($ppp eq "applypatch") {
6880 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6658a91b 6881 } else {
8ce4ea0b
SP		 6882 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6883 $pcommand = "$patchbin $thispatchargs";
6884 }
6885
6886 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6887 my $writefh = FileHandle->new;
6888 $CPAN::Frontend->myprint(" $pcommand\n");
6889 unless (open $writefh, "|$pcommand") {
6890 my $fail = "Could not fork '$pcommand'";
6891 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6892 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6893 delete $self->{build_dir};
6894 return;
6895 }
6896 while (my $x = $readfh->READLINE) {
6897 print $writefh $x;
6898 }
6899 unless (close $writefh) {
6900 my $fail = "Could not apply patch '$patch'";
6658a91b
SP		 6901 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6902 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6903 delete $self->{build_dir};
6904 return;
6905 }
6906 }
8ce4ea0b 6907 $self->{patched}++;
6658a91b 6908 }
8ce4ea0b 6909 return 1;
6658a91b 6910 }
6658a91b
SP		 6911}
6912
05bab18e
SP		 6913sub _patch_p_parameter {
6914 my($self,$fh) = @_;
be34b10d
SP		 6915 my $cnt_files = 0;
6916 my $cnt_p0files = 0;
05bab18e
SP		 6917 local($_);
6918 while ($_ = $fh->READLINE) {
b72dd56f
SP		 6919 if (
6920 $CPAN::Config->{applypatch}
6921 &&
6922 /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6923 ) {
6924 return "applypatch"
6925 }
05bab18e
SP		 6926 next unless /^[\*\+]{3}\s(\S+)/;
6927 my $file = $1;
6928 $cnt_files++;
6929 $cnt_p0files++ if -f $file;
b72dd56f
SP		 6930 CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6931 if $CPAN::DEBUG;
05bab18e 6932 }
be34b10d 6933 return "-p1" unless $cnt_files;
05bab18e
SP		 6934 return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6935}
6936
6658a91b
SP		 6937#-> sub CPAN::Distribution::_edge_cases
6938# with "configure" or "Makefile" or single file scripts
6939sub _edge_cases {
f04ea8d1 6940 my($self,$mpl,$local_file) = @_;
6658a91b
SP		 6941 $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6942 $mpl,
6943 CPAN::anycwd(),
6944 )) if $CPAN::DEBUG;
f04ea8d1
SP		 6945 my $build_dir = $self->{build_dir};
6946 my($configure) = File::Spec->catfile($build_dir,"Configure");
6658a91b
SP		 6947 if (-f $configure) {
6948 # do we have anything to do?
6949 $self->{configure} = $configure;
f04ea8d1 6950 } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
6658a91b 6951 $CPAN::Frontend->mywarn(qq{
09d9d230
A		 6952Package comes with a Makefile and without a Makefile.PL.
6953We\'ll try to build it with that Makefile then.
6954});
6658a91b
SP		 6955 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6956 $CPAN::Frontend->mysleep(2);
6957 } else {
6958 my $cf = $self->called_for || "unknown";
6959 if ($cf =~ m|/|) {
6960 $cf =~ s|.*/||;
6961 $cf =~ s|\W.*||;
6962 }
6963 $cf =~ s|[/\\:]||g; # risk of filesystem damage
6964 $cf = "unknown" unless length($cf);
5254b38e
SP		 6965 if (my $crap = $self->_contains_crap($build_dir)) {
6966 my $why = qq{Package contains $crap; not recognized as a perl package, giving up};
6967 $CPAN::Frontend->mywarn("$why\n");
6968 $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
6969 return;
6970 }
6658a91b 6971 $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
d8773709
JH		 6972 (The test -f "$mpl" returned false.)
6973 Writing one on our own (setting NAME to $cf)\a\n});
6658a91b
SP		 6974 $self->{had_no_makefile_pl}++;
6975 $CPAN::Frontend->mysleep(3);
ed84aac9 6976
6658a91b
SP		 6977 # Writing our own Makefile.PL
6978
5254b38e 6979 my $exefile_stanza = "";
6658a91b 6980 if ($self->{archived} eq "maybe_pl") {
5254b38e
SP		 6981 $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
6982 }
6983
6984 my $fh = FileHandle->new;
6985 $fh->open(">$mpl")
6986 or Carp::croak("Could not open >$mpl: $!");
6987 $fh->print(
6988 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6989# because there was no Makefile.PL supplied.
6990# Autogenerated on: }.scalar localtime().qq{
6991
6992use ExtUtils::MakeMaker;
6993WriteMakefile(
6994 NAME => q[$cf],$exefile_stanza
6995 );
6996});
6997 $fh->close;
6998 }
6999}
7000
7001#-> CPAN;:Distribution::_contains_crap
7002sub _contains_crap {
7003 my($self,$dir) = @_;
7004 my(@dirs, $dh, @files);
7005 opendir $dh, $dir or return;
7006 my $dirent;
7007 for $dirent (readdir $dh) {
7008 next if $dirent =~ /^\.\.?$/;
7009 my $path = File::Spec->catdir($dir,$dirent);
7010 if (-d $path) {
7011 push @dirs, $dirent;
7012 } elsif (-f $path) {
7013 push @files, $dirent;
7014 }
7015 }
7016 if (@dirs && @files) {
7017 return "both files[@files] and directories[@dirs]";
7018 } elsif (@files > 2) {
7019 return "several files[@files] but no Makefile.PL or Build.PL";
7020 }
7021 return;
7022}
7023
7024#-> CPAN;:Distribution::_exefile_stanza
7025sub _exefile_stanza {
7026 my($self,$build_dir,$local_file) = @_;
7027
6658a91b 7028 my $fh = FileHandle->new;
f04ea8d1 7029 my $script_file = File::Spec->catfile($build_dir,$local_file);
6658a91b 7030 $fh->open($script_file)
dc053c64 7031 or Carp::croak("Could not open script '$script_file': $!");
6658a91b
SP		 7032 local $/ = "\n";
7033 # name parsen und prereq
7034 my($state) = "poddir";
7035 my($name, $prereq) = ("", "");
7036 while (<$fh>) {
7037 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
7038 if ($1 eq 'NAME') {
7039 $state = "name";
7040 } elsif ($1 eq 'PREREQUISITES') {
7041 $state = "prereq";
7042 }
7043 } elsif ($state =~ m{^(name|prereq)$}) {
7044 if (/^=/) {
7045 $state = "poddir";
7046 } elsif (/^\s*$/) {
7047 # nop
7048 } elsif ($state eq "name") {
7049 if ($name eq "") {
7050 ($name) = /^(\S+)/;
7051 $state = "poddir";
7052 }
7053 } elsif ($state eq "prereq") {
7054 $prereq .= $_;
ed84aac9 7055 }
6658a91b
SP		 7056 } elsif (/^=cut\b/) {
7057 last;
7058 }
7059 }
7060 $fh->close;
7061
7062 for ($name) {
7063 s{.*<}{}; # strip X<...>
7064 s{>.*}{};
7065 }
7066 chomp $prereq;
7067 $prereq = join " ", split /\s+/, $prereq;
7068 my($PREREQ_PM) = join("\n", map {
7069 s{.*<}{}; # strip X<...>
7070 s{>.*}{};
7071 if (/[\s\'\"]/) { # prose?
7072 } else {
7073 s/[^\w:]$//; # period?
7074 " "x28 . "'$_' => 0,";
7075 }
7076 } split /\s*,\s*/, $prereq);
ed84aac9 7077
6658a91b 7078 if ($name) {
f04ea8d1 7079 my $to_file = File::Spec->catfile($build_dir, $name);
6658a91b
SP		 7080 rename $script_file, $to_file
7081 or die "Can't rename $script_file to $to_file: $!";
7082 }
55e314ee 7083
5254b38e
SP		 7084 return "
7085 EXE_FILES => ['$name'],
7086 PREREQ_PM => {
7087$PREREQ_PM
7088 },
7089";
6658a91b 7090}
d8773709 7091
6658a91b
SP		 7092#-> CPAN::Distribution::_signature_business
7093sub _signature_business {
7094 my($self) = @_;
be34b10d
SP		 7095 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7096 q{check_sigs});
7097 if ($check_sigs) {
6658a91b
SP		 7098 if ($CPAN::META->has_inst("Module::Signature")) {
7099 if (-f "SIGNATURE") {
7100 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
7101 my $rv = Module::Signature::verify();
7102 if ($rv != Module::Signature::SIGNATURE_OK() and
7103 $rv != Module::Signature::SIGNATURE_MISSING()) {
05bab18e
SP		 7104 $CPAN::Frontend->mywarn(
7105 qq{\nSignature invalid for }.
7106 qq{distribution file. }.
7107 qq{Please investigate.\n\n}
7108 );
6658a91b
SP		 7109
7110 my $wrap =
23a216b4
SP		 7111 sprintf(qq{I'd recommend removing %s. Some error occured }.
7112 qq{while checking its signature, so it could }.
7113 qq{be invalid. Maybe you have configured }.
7114 qq{your 'urllist' with a bad URL. Please check this }.
7115 qq{array with 'o conf urllist' and retry. Or }.
7116 qq{examine the distribution in a subshell. Try
6658a91b 7117 look %s
23a216b4 7118and run
6658a91b
SP		 7119 cpansign -v
7120},
7121 $self->{localfile},
7122 $self->pretty_id,
7123 );
7124 $self->{signature_verify} = CPAN::Distrostatus->new("NO");
7125 $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
7126 $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
7127 } else {
7128 $self->{signature_verify} = CPAN::Distrostatus->new("YES");
7129 $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
7130 }
7131 } else {
7132 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
7133 }
7134 } else {
7135 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
7136 }
7137 }
5f05dabc 7138}
7139
6658a91b 7140#-> CPAN::Distribution::untar_me ;
55e314ee 7141sub untar_me {
e82b9348 7142 my($self,$ct) = @_;
55e314ee 7143 $self->{archived} = "tar";
5254b38e
SP		 7144 my $result = eval { $ct->untar() };
7145 if ($result) {
f04ea8d1 7146 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
55e314ee 7147 } else {
f04ea8d1 7148 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
55e314ee
A		 7149 }
7150}
7151
6d29edf5 7152# CPAN::Distribution::unzip_me ;
55e314ee 7153sub unzip_me {
e82b9348 7154 my($self,$ct) = @_;
05d2a450 7155 $self->{archived} = "zip";
e82b9348 7156 if ($ct->unzip()) {
f04ea8d1 7157 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
55e314ee 7158 } else {
f04ea8d1 7159 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
55e314ee 7160 }
c4d24d4c 7161 return;
55e314ee
A		 7162}
7163
ed84aac9 7164sub handle_singlefile {
55e314ee 7165 my($self,$local_file) = @_;
ed84aac9 7166
f04ea8d1
SP		 7167 if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
7168 $self->{archived} = "pm";
2b3bde2a 7169 } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
f04ea8d1 7170 $self->{archived} = "patch";
ed84aac9 7171 } else {
f04ea8d1 7172 $self->{archived} = "maybe_pl";
ed84aac9
A		 7173 }
7174
55e314ee 7175 my $to = File::Basename::basename($local_file);
554a9ef5 7176 if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
be34b10d 7177 if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6658a91b 7178 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
554a9ef5 7179 } else {
6658a91b 7180 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
554a9ef5 7181 }
55e314ee 7182 } else {
2b3bde2a
SP		 7183 if (File::Copy::cp($local_file,".")) {
7184 $self->{unwrapped} = CPAN::Distrostatus->new("YES");
7185 } else {
7186 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
7187 }
55e314ee 7188 }
ed84aac9 7189 return $to;
55e314ee
A		 7190}
7191
05454584
A		 7192#-> sub CPAN::Distribution::new ;
7193sub new {
7194 my($class,%att) = @_;
5f05dabc 7195
5e05dca5 7196 # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
5f05dabc 7197
05454584
A		 7198 my $this = { %att };
7199 return bless $this, $class;
5f05dabc 7200}
7201
05454584
A		 7202#-> sub CPAN::Distribution::look ;
7203sub look {
5f05dabc 7204 my($self) = @_;
36263cb3
GS		 7205
7206 if ($^O eq 'MacOS') {
be708cc0 7207 $self->Mac::BuildTools::look;
36263cb3
GS		 7208 return;
7209 }
7210
05454584 7211 if ( $CPAN::Config->{'shell'} ) {
f04ea8d1 7212 $CPAN::Frontend->myprint(qq{
05454584 7213Trying to open a subshell in the build directory...
c356248b 7214});
05454584 7215 } else {
f04ea8d1 7216 $CPAN::Frontend->myprint(qq{
05454584
A		 7217Your configuration does not define a value for subshells.
7218Please define it with "o conf shell <your shell>"
c356248b 7219});
f04ea8d1 7220 return;
5f05dabc 7221 }
05454584 7222 my $dist = $self->id;
c049f953
JH		 7223 my $dir;
7224 unless ($dir = $self->dir) {
7225 $self->get;
7226 }
7227 unless ($dir ||= $self->dir) {
f04ea8d1 7228 $CPAN::Frontend->mywarn(qq{
c049f953
JH		 7229Could not determine which directory to use for looking at $dist.
7230});
f04ea8d1 7231 return;
c049f953 7232 }
9d61fa1d 7233 my $pwd = CPAN::anycwd();
c049f953 7234 $self->safe_chdir($dir);
c356248b 7235 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
9ddc4ed0 7236 {
f04ea8d1 7237 local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
9ddc4ed0 7238 $ENV{CPAN_SHELL_LEVEL} += 1;
f04ea8d1 7239 my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
5254b38e
SP		 7240
7241 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7242 ? $ENV{PERL5LIB}
7243 : ($ENV{PERLLIB} || "");
7244
7245 local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
7246 $CPAN::META->set_perl5lib;
7247 local $ENV{MAKEFLAGS}; # protect us from outer make calls
7248
f04ea8d1
SP		 7249 unless (system($shell) == 0) {
7250 my $code = $? >> 8;
7251 $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
7252 }
35576f8c 7253 }
c049f953 7254 $self->safe_chdir($pwd);
5f05dabc 7255}
7256
6d29edf5 7257# CPAN::Distribution::cvs_import ;
911a92db
GS		 7258sub cvs_import {
7259 my($self) = @_;
7260 $self->get;
7261 my $dir = $self->dir;
7262
7263 my $package = $self->called_for;
7264 my $module = $CPAN::META->instance('CPAN::Module', $package);
6d29edf5 7265 my $version = $module->cpan_version;
911a92db 7266
6d29edf5 7267 my $userid = $self->cpan_userid;
911a92db 7268
5fc0f0f6 7269 my $cvs_dir = (split /\//, $dir)[-1];
05d2a450 7270 $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
f04ea8d1 7271 my $cvs_root =
911a92db 7272 $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
f04ea8d1 7273 my $cvs_site_perl =
911a92db
GS		 7274 $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
7275 if ($cvs_site_perl) {
f04ea8d1 7276 $cvs_dir = "$cvs_site_perl/$cvs_dir";
911a92db
GS		 7277 }
7278 my $cvs_log = qq{"imported $package $version sources"};
7279 $version =~ s/\./_/g;
135a59c2 7280 # XXX cvs: undocumented and unclear how it was meant to work
911a92db 7281 my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
f04ea8d1 7282 "$cvs_dir", $userid, "v$version");
911a92db 7283
9d61fa1d 7284 my $pwd = CPAN::anycwd();
05d2a450 7285 chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
911a92db
GS		 7286
7287 $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
7288
7289 $CPAN::Frontend->myprint(qq{@cmd\n});
de34a54b 7290 system(@cmd) == 0 or
ed84aac9 7291 # XXX cvs
f04ea8d1 7292 $CPAN::Frontend->mydie("cvs import failed");
05d2a450 7293 chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
911a92db
GS		 7294}
7295
05454584
A		 7296#-> sub CPAN::Distribution::readme ;
7297sub readme {
5f05dabc 7298 my($self) = @_;
05454584
A		 7299 my($dist) = $self->id;
7300 my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
7301 $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
7302 my($local_file);
7303 my($local_wanted) =
f04ea8d1
SP		 7304 File::Spec->catfile(
7305 $CPAN::Config->{keep_source_where},
7306 "authors",
7307 "id",
7308 split(/\//,"$sans.readme"),
7309 );
05454584 7310 $self->debug("Doing localize") if $CPAN::DEBUG;
c356248b 7311 $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
f04ea8d1
SP		 7312 $local_wanted)
7313 or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
f14b5cec
JH		 7314
7315 if ($^O eq 'MacOS') {
be708cc0 7316 Mac::BuildTools::launch_file($local_file);
f14b5cec
JH		 7317 return;
7318 }
7319
05454584 7320 my $fh_pager = FileHandle->new;
c356248b 7321 local($SIG{PIPE}) = "IGNORE";
ed84aac9
A		 7322 my $pager = $CPAN::Config->{'pager'} || "cat";
7323 $fh_pager->open("|$pager")
f04ea8d1 7324 or die "Could not open pager $pager\: $!";
05454584 7325 my $fh_readme = FileHandle->new;
c356248b 7326 $fh_readme->open($local_file)
f04ea8d1 7327 or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
c356248b
A		 7328 $CPAN::Frontend->myprint(qq{
7329Displaying file
7330 $local_file
ed84aac9 7331with pager "$pager"
c356248b 7332});
05454584 7333 $fh_pager->print(<$fh_readme>);
554a9ef5 7334 $fh_pager->close;
5f05dabc 7335}
7336
e82b9348
SP		 7337#-> sub CPAN::Distribution::verifyCHECKSUM ;
7338sub verifyCHECKSUM {
5f05dabc 7339 my($self) = @_;
05454584 7340 EXCUSE: {
f04ea8d1
SP		 7341 my @e;
7342 $self->{CHECKSUM_STATUS} ||= "";
7343 $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
7344 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 7345 }
55e314ee 7346 my($lc_want,$lc_file,@local,$basename);
5fc0f0f6 7347 @local = split(/\//,$self->id);
55e314ee 7348 pop @local;
05454584 7349 push @local, "CHECKSUMS";
55e314ee 7350 $lc_want =
f04ea8d1
SP		 7351 File::Spec->catfile($CPAN::Config->{keep_source_where},
7352 "authors", "id", @local);
05454584 7353 local($") = "/";
b96578bb
SP		 7354 if (my $size = -s $lc_want) {
7355 $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
7356 if ($self->CHECKSUM_check_file($lc_want,1)) {
7357 return $self->{CHECKSUM_STATUS} = "OK";
7358 }
05454584 7359 }
55e314ee 7360 $lc_file = CPAN::FTP->localize("authors/id/@local",
f04ea8d1 7361 $lc_want,1);
55e314ee 7362 unless ($lc_file) {
8d97e4a1 7363 $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
f04ea8d1
SP		 7364 $local[-1] .= ".gz";
7365 $lc_file = CPAN::FTP->localize("authors/id/@local",
7366 "$lc_want.gz",1);
7367 if ($lc_file) {
7368 $lc_file =~ s/\.gz(?!\n)\Z//;
7369 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
7370 } else {
7371 return;
7372 }
05454584 7373 }
b96578bb
SP		 7374 if ($self->CHECKSUM_check_file($lc_file)) {
7375 return $self->{CHECKSUM_STATUS} = "OK";
7376 }
5f05dabc 7377}
7378
4d1321a7 7379#-> sub CPAN::Distribution::SIG_check_file ;
554a9ef5
SP		 7380sub SIG_check_file {
7381 my($self,$chk_file) = @_;
7382 my $rv = eval { Module::Signature::_verify($chk_file) };
7383
7384 if ($rv == Module::Signature::SIGNATURE_OK()) {
f04ea8d1
SP		 7385 $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
7386 return $self->{SIG_STATUS} = "OK";
554a9ef5 7387 } else {
f04ea8d1
SP		 7388 $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
7389 qq{distribution file. }.
7390 qq{Please investigate.\n\n}.
7391 $self->as_string,
7392 $CPAN::META->instance(
7393 'CPAN::Author',
7394 $self->cpan_userid
7395 )->as_string);
7396
7397 my $wrap = qq{I\'d recommend removing $chk_file. Its signature
554a9ef5
SP		 7398is invalid. Maybe you have configured your 'urllist' with
7399a bad URL. Please check this array with 'o conf urllist', and
7400retry.};
7401
f04ea8d1 7402 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
554a9ef5
SP		 7403 }
7404}
7405
e82b9348 7406#-> sub CPAN::Distribution::CHECKSUM_check_file ;
b96578bb
SP		 7407
7408# sloppy is 1 when we have an old checksums file that maybe is good
7409# enough
7410
e82b9348 7411sub CHECKSUM_check_file {
b96578bb 7412 my($self,$chk_file,$sloppy) = @_;
55e314ee 7413 my($cksum,$file,$basename);
554a9ef5 7414
b96578bb
SP		 7415 $sloppy ||= 0;
7416 $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
be34b10d
SP		 7417 my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
7418 q{check_sigs});
7419 if ($check_sigs) {
6658a91b 7420 if ($CPAN::META->has_inst("Module::Signature")) {
b72dd56f 7421 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
ed84aac9
A		 7422 $self->SIG_check_file($chk_file);
7423 } else {
b72dd56f 7424 $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
ed84aac9 7425 }
554a9ef5
SP		 7426 }
7427
c356248b 7428 $file = $self->{localfile};
55e314ee
A		 7429 $basename = File::Basename::basename($file);
7430 my $fh = FileHandle->new;
f04ea8d1
SP		 7431 if (open $fh, $chk_file) {
7432 local($/);
7433 my $eval = <$fh>;
7434 $eval =~ s/\015?\012/\n/g;
7435 close $fh;
5254b38e
SP		 7436 my($compmt) = Safe->new();
7437 $cksum = $compmt->reval($eval);
f04ea8d1
SP		 7438 if ($@) {
7439 rename $chk_file, "$chk_file.bad";
7440 Carp::confess($@) if $@;
7441 }
55e314ee 7442 } else {
f04ea8d1 7443 Carp::carp "Could not open $chk_file for reading";
55e314ee 7444 }
09d9d230 7445
44d21104
A		 7446 if (! ref $cksum or ref $cksum ne "HASH") {
7447 $CPAN::Frontend->mywarn(qq{
7448Warning: checksum file '$chk_file' broken.
7449
7450When trying to read that file I expected to get a hash reference
7451for further processing, but got garbage instead.
7452});
8962fc49 7453 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
b96578bb
SP		 7454 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
7455 $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
44d21104
A		 7456 return;
7457 } elsif (exists $cksum->{$basename}{sha256}) {
f04ea8d1
SP		 7458 $self->debug("Found checksum for $basename:" .
7459 "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
7460
7461 open($fh, $file);
7462 binmode $fh;
7463 my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
7464 $fh->close;
7465 $fh = CPAN::Tarzip->TIEHANDLE($file);
7466
7467 unless ($eq) {
7468 my $dg = Digest::SHA->new(256);
7469 my($data,$ref);
7470 $ref = \$data;
7471 while ($fh->READ($ref, 4096) > 0) {
7472 $dg->add($data);
7473 }
7474 my $hexdigest = $dg->hexdigest;
7475 $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
7476 }
7477
7478 if ($eq) {
7479 $CPAN::Frontend->myprint("Checksum for $file ok\n");
7480 return $self->{CHECKSUM_STATUS} = "OK";
7481 } else {
7482 $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
7483 qq{distribution file. }.
7484 qq{Please investigate.\n\n}.
7485 $self->as_string,
7486 $CPAN::META->instance(
7487 'CPAN::Author',
7488 $self->cpan_userid
7489 )->as_string);
7490
7491 my $wrap = qq{I\'d recommend removing $file. Its
c4d24d4c
A		 7492checksum is incorrect. Maybe you have configured your 'urllist' with
7493a bad URL. Please check this array with 'o conf urllist', and
55e314ee 7494retry.};
de34a54b 7495
c4d24d4c
A		 7496 $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
7497
7498 # former versions just returned here but this seems a
7499 # serious threat that deserves a die
7500
f04ea8d1
SP		 7501 # $CPAN::Frontend->myprint("\n\n");
7502 # sleep 3;
7503 # return;
7504 }
7505 # close $fh if fileno($fh);
5f05dabc 7506 } else {
b96578bb 7507 return if $sloppy;
f04ea8d1
SP		 7508 unless ($self->{CHECKSUM_STATUS}) {
7509 $CPAN::Frontend->mywarn(qq{
e82b9348 7510Warning: No checksum for $basename in $chk_file.
5a5fac02
JH		 7511
7512The cause for this may be that the file is very new and the checksum
7513has not yet been calculated, but it may also be that something is
7514going awry right now.
c356248b 7515});
8962fc49 7516 my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
b96578bb 7517 $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
f04ea8d1 7518 }
b96578bb 7519 $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
f04ea8d1 7520 return;
5f05dabc 7521 }
7522}
7523
e82b9348
SP		 7524#-> sub CPAN::Distribution::eq_CHECKSUM ;
7525sub eq_CHECKSUM {
7526 my($self,$fh,$expect) = @_;
87892b73
RGS		 7527 if ($CPAN::META->has_inst("Digest::SHA")) {
7528 my $dg = Digest::SHA->new(256);
7529 my($data);
f04ea8d1 7530 while (read($fh, $data, 4096)) {
87892b73
RGS		 7531 $dg->add($data);
7532 }
7533 my $hexdigest = $dg->hexdigest;
7534 # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
7535 return $hexdigest eq $expect;
09d9d230 7536 }
87892b73 7537 return 1;
05454584 7538}
5f05dabc 7539
05454584 7540#-> sub CPAN::Distribution::force ;
c4d24d4c 7541
e82b9348
SP		 7542# Both CPAN::Modules and CPAN::Distributions know if "force" is in
7543# effect by autoinspection, not by inspecting a global variable. One
7544# of the reason why this was chosen to work that way was the treatment
7545# of dependencies. They should not automatically inherit the force
c4d24d4c
A		 7546# status. But this has the downside that ^C and die() will return to
7547# the prompt but will not be able to reset the force_update
7548# attributes. We try to correct for it currently in the read_metadata
7549# routine, and immediately before we check for a Signal. I hope this
7550# works out in one of v1.57_53ff
7551
4d1321a7
A		 7552# "Force get forgets previous error conditions"
7553
b72dd56f
SP		 7554#-> sub CPAN::Distribution::fforce ;
7555sub fforce {
7556 my($self, $method) = @_;
7557 $self->force($method,1);
7558}
7559
4d1321a7 7560#-> sub CPAN::Distribution::force ;
5f05dabc 7561sub force {
b72dd56f 7562 my($self, $method,$fforce) = @_;
810a0276
SP		 7563 my %phase_map = (
7564 get => [
7565 "unwrapped",
7566 "build_dir",
7567 "archived",
7568 "localfile",
7569 "CHECKSUM_STATUS",
7570 "signature_verify",
7571 "prefs",
7572 "prefs_file",
7573 "prefs_file_doc",
7574 ],
7575 make => [
7576 "writemakefile",
7577 "make",
7578 "modulebuild",
7579 "prereq_pm",
7580 "prereq_pm_detected",
7581 ],
7582 test => [
7583 "badtestcnt",
7584 "make_test",
7585 ],
7586 install => [
7587 "install",
7588 ],
7589 unknown => [
7590 "reqtype",
7591 "yaml_content",
7592 ],
7593 );
b72dd56f
SP		 7594 my $methodmatch = 0;
7595 my $ldebug = 0;
7596 PHASE: for my $phase (qw(unknown get make test install)) { # order matters
7597 $methodmatch = 1 if $fforce || $phase eq $method;
7598 next unless $methodmatch;
810a0276 7599 ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
b72dd56f
SP		 7600 if ($phase eq "get") {
7601 if (substr($self->id,-1,1) eq "."
7602 && $att =~ /(unwrapped|build_dir|archived)/ ) {
7603 # cannot be undone for local distros
7604 next ATTRIBUTE;
7605 }
7606 if ($att eq "build_dir"
7607 && $self->{build_dir}
7608 && $CPAN::META->{is_tested}
7609 ) {
7610 delete $CPAN::META->{is_tested}{$self->{build_dir}};
7611 }
7612 } elsif ($phase eq "test") {
7613 if ($att eq "make_test"
7614 && $self->{make_test}
7615 && $self->{make_test}{COMMANDID}
7616 && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
7617 ) {
7618 # endless loop too likely
7619 next ATTRIBUTE;
7620 }
810a0276
SP		 7621 }
7622 delete $self->{$att};
b72dd56f
SP		 7623 if ($ldebug || $CPAN::DEBUG) {
7624 # local $CPAN::DEBUG = 16; # Distribution
7625 CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
7626 }
810a0276 7627 }
f610777f 7628 }
9ddc4ed0 7629 if ($method && $method =~ /make|test|install/) {
b72dd56f 7630 $self->{force_update} = 1; # name should probably have been force_install
c4d24d4c
A		 7631 }
7632}
7633
05bab18e 7634#-> sub CPAN::Distribution::notest ;
554a9ef5 7635sub notest {
f3fe0ae6 7636 my($self, $method) = @_;
23a216b4 7637 # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
554a9ef5
SP		 7638 $self->{"notest"}++; # name should probably have been force_install
7639}
7640
05bab18e 7641#-> sub CPAN::Distribution::unnotest ;
554a9ef5 7642sub unnotest {
f3fe0ae6 7643 my($self) = @_;
554a9ef5 7644 # warn "XDEBUG: deleting notest";
23a216b4 7645 delete $self->{notest};
554a9ef5
SP		 7646}
7647
c4d24d4c
A		 7648#-> sub CPAN::Distribution::unforce ;
7649sub unforce {
7650 my($self) = @_;
b72dd56f 7651 delete $self->{force_update};
5f05dabc 7652}
7653
de34a54b 7654#-> sub CPAN::Distribution::isa_perl ;
09d9d230
A		 7655sub isa_perl {
7656 my($self) = @_;
7657 my $file = File::Basename::basename($self->id);
05d2a450
A		 7658 if ($file =~ m{ ^ perl
7659 -?
f04ea8d1
SP		 7660 (5)
7661 ([._-])
7662 (
05d2a450
A		 7663 \d{3}(_[0-4][0-9])?
7664 |
ed84aac9 7665 \d+\.\d+
05d2a450 7666 )
f04ea8d1
SP		 7667 \.tar[._-](?:gz|bz2)
7668 (?!\n)\Z
7669 }xs) {
05d2a450 7670 return "$1.$3";
6d29edf5
JH		 7671 } elsif ($self->cpan_comment
7672 &&
f04ea8d1 7673 $self->cpan_comment =~ /isa_perl\(.+?\)/) {
05d2a450
A		 7674 return $1;
7675 }
09d9d230
A		 7676}
7677
607a774b 7678
d4fd5c69
A		 7679#-> sub CPAN::Distribution::perl ;
7680sub perl {
ed84aac9
A		 7681 my ($self) = @_;
7682 if (! $self) {
7683 use Carp qw(carp);
7684 carp __PACKAGE__ . "::perl was called without parameters.";
7685 }
7686 return CPAN::HandleConfig->safe_quote($CPAN::Perl);
d4fd5c69
A		 7687}
7688
607a774b 7689
05454584
A		 7690#-> sub CPAN::Distribution::make ;
7691sub make {
7692 my($self) = @_;
be34b10d
SP		 7693 if (my $goto = $self->prefs->{goto}) {
7694 return $self->goto($goto);
7695 }
e82b9348 7696 my $make = $self->{modulebuild} ? "Build" : "make";
09d9d230
A		 7697 # Emergency brake if they said install Pippi and get newest perl
7698 if ($self->isa_perl) {
f04ea8d1
SP		 7699 if (
7700 $self->called_for ne $self->id &&
7701 ! $self->{force_update}
7702 ) {
7703 # if we die here, we break bundles
7704 $CPAN::Frontend
7705 ->mywarn(sprintf(
7706 qq{The most recent version "%s" of the module "%s"
6a935156
SP		 7707is part of the perl-%s distribution. To install that, you need to run
7708 force install %s --or--
7709 install %s
09d9d230 7710},
6a935156
SP		 7711 $CPAN::META->instance(
7712 'CPAN::Module',
7713 $self->called_for
7714 )->cpan_version,
7715 $self->called_for,
7716 $self->isa_perl,
7717 $self->called_for,
7718 $self->id,
7719 ));
f04ea8d1
SP		 7720 $self->{make} = CPAN::Distrostatus->new("NO isa perl");
7721 $CPAN::Frontend->mysleep(1);
7722 return;
7723 }
09d9d230 7724 }
6a935156 7725 $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
05454584 7726 $self->get;
5254b38e 7727 return if $self->prefs->{disabled} && ! $self->{force_update};
f04ea8d1
SP		 7728 if ($self->{configure_requires_later}) {
7729 return;
7730 }
6658a91b
SP		 7731 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7732 ? $ENV{PERL5LIB}
7733 : ($ENV{PERLLIB} || "");
5254b38e 7734 local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
6658a91b
SP		 7735 $CPAN::META->set_perl5lib;
7736 local $ENV{MAKEFLAGS}; # protect us from outer make calls
7737
f04ea8d1
SP		 7738 if ($CPAN::Signal) {
7739 delete $self->{force_update};
7740 return;
4d1321a7 7741 }
b72dd56f
SP		 7742
7743 my $builddir;
05454584 7744 EXCUSE: {
0cf35e6a 7745 my @e;
6658a91b
SP		 7746 if (!$self->{archived} || $self->{archived} eq "NO") {
7747 push @e, "Is neither a tar nor a zip archive.";
7748 }
5f05dabc 7749
6658a91b
SP		 7750 if (!$self->{unwrapped}
7751 || (
be34b10d 7752 UNIVERSAL::can($self->{unwrapped},"failed") ?
6658a91b
SP		 7753 $self->{unwrapped}->failed :
7754 $self->{unwrapped} =~ /^NO/
7755 )) {
7756 push @e, "Had problems unarchiving. Please build manually";
7757 }
9ddc4ed0
A		 7758
7759 unless ($self->{force_update}) {
be34b10d
SP		 7760 exists $self->{signature_verify} and
7761 (
7762 UNIVERSAL::can($self->{signature_verify},"failed") ?
7763 $self->{signature_verify}->failed :
7764 $self->{signature_verify} =~ /^NO/
7765 )
9ddc4ed0
A		 7766 and push @e, "Did not pass the signature test.";
7767 }
05454584 7768
4d1321a7
A		 7769 if (exists $self->{writemakefile} &&
7770 (
be34b10d 7771 UNIVERSAL::can($self->{writemakefile},"failed") ?
4d1321a7
A		 7772 $self->{writemakefile}->failed :
7773 $self->{writemakefile} =~ /^NO/
7774 )) {
7775 # XXX maybe a retry would be in order?
be34b10d 7776 my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
4d1321a7
A		 7777 $self->{writemakefile}->text :
7778 $self->{writemakefile};
5254b38e 7779 $err =~ s/^NO\s*(--\s+)?//;
4d1321a7
A		 7780 $err ||= "Had some problem writing Makefile";
7781 $err .= ", won't make";
7782 push @e, $err;
7783 }
05454584 7784
f04ea8d1 7785 if (defined $self->{make}) {
8ce4ea0b
SP		 7786 if (UNIVERSAL::can($self->{make},"failed") ?
7787 $self->{make}->failed :
7788 $self->{make} =~ /^NO/) {
ade94d80
SP		 7789 if ($self->{force_update}) {
7790 # Trying an already failed 'make' (unless somebody else blocks)
7791 } else {
7792 # introduced for turning recursion detection into a distrostatus
23a216b4
SP		 7793 my $error = length $self->{make}>3
7794 ? substr($self->{make},3) : "Unknown error";
7795 $CPAN::Frontend->mywarn("Could not make: $error\n");
ade94d80
SP		 7796 $self->store_persistent_state;
7797 return;
7798 }
7799 } else {
7800 push @e, "Has already been made";
5254b38e
SP		 7801 my $wait_for_prereqs = eval { $self->satisfy_requires };
7802 return 1 if $wait_for_prereqs; # tells queuerunner to continue
7803 return $self->goodbye($@) if $@; # tells queuerunner to stop
ade94d80
SP		 7804 }
7805 }
6d29edf5 7806
f04ea8d1
SP		 7807 my $later = $self->{later} || $self->{configure_requires_later};
7808 if ($later) { # see also undelay
7809 if ($later) {
7810 push @e, $later;
c9869e1c
SP		 7811 }
7812 }
05454584 7813
f04ea8d1 7814 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
b72dd56f
SP		 7815 $builddir = $self->dir or
7816 $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7817 unless (chdir $builddir) {
7818 push @e, "Couldn't chdir to '$builddir': $!";
7819 }
f04ea8d1 7820 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
5f05dabc 7821 }
f04ea8d1
SP		 7822 if ($CPAN::Signal) {
7823 delete $self->{force_update};
7824 return;
4d1321a7 7825 }
c356248b 7826 $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
05454584
A		 7827 $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7828
f14b5cec 7829 if ($^O eq 'MacOS') {
be708cc0 7830 Mac::BuildTools::make($self);
f14b5cec
JH		 7831 return;
7832 }
7833
810a0276
SP		 7834 my %env;
7835 while (my($k,$v) = each %ENV) {
7836 next unless defined $v;
7837 $env{$k} = $v;
7838 }
7839 local %ENV = %env;
05454584 7840 my $system;
5254b38e
SP		 7841 my $pl_commandline;
7842 if ($self->prefs->{pl}) {
7843 $pl_commandline = $self->prefs->{pl}{commandline};
7844 }
7845 if ($pl_commandline) {
7846 $system = $pl_commandline;
810a0276
SP		 7847 $ENV{PERL} = $^X;
7848 } elsif ($self->{'configure'}) {
e82b9348
SP		 7849 $system = $self->{'configure'};
7850 } elsif ($self->{modulebuild}) {
f04ea8d1 7851 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
e82b9348 7852 $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
5f05dabc 7853 } else {
f04ea8d1
SP		 7854 my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7855 my $switch = "";
d4fd5c69 7856# This needs a handler that can be turned on or off:
f04ea8d1
SP		 7857# $switch = "-MExtUtils::MakeMaker ".
7858# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7859# if $] > 5.00310;
5254b38e 7860 my $makepl_arg = $self->_make_phase_arg("pl");
f04ea8d1
SP		 7861 $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
7862 "Makefile.PL");
7863 $system = sprintf("%s%s Makefile.PL%s",
4d1321a7
A		 7864 $perl,
7865 $switch ? " $switch" : "",
1e8f9a0a 7866 $makepl_arg ? " $makepl_arg" : "",
4d1321a7 7867 );
d4fd5c69 7868 }
5254b38e
SP		 7869 my $pl_env;
7870 if ($self->prefs->{pl}) {
7871 $pl_env = $self->prefs->{pl}{env};
7872 }
7873 if ($pl_env) {
7874 for my $e (keys %$pl_env) {
7875 $ENV{$e} = $pl_env->{$e};
1e8f9a0a
SP		 7876 }
7877 }
7878 if (exists $self->{writemakefile}) {
7879 } else {
f04ea8d1
SP		 7880 local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7881 my($ret,$pid,$output);
7882 $@ = "";
2ccf00a7 7883 my $go_via_alarm;
f04ea8d1 7884 if ($CPAN::Config->{inactivity_timeout}) {
2ccf00a7
SP		 7885 require Config;
7886 if ($Config::Config{d_alarm}
7887 &&
7888 $Config::Config{d_alarm} eq "define"
7889 ) {
7890 $go_via_alarm++
7891 } else {
7892 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7893 "variable 'inactivity_timeout' to ".
7894 "'$CPAN::Config->{inactivity_timeout}'. But ".
7895 "on this machine the system call 'alarm' ".
7896 "isn't available. This means that we cannot ".
7897 "provide the feature of intercepting long ".
7898 "waiting code and will turn this feature off.\n"
7899 );
7900 $CPAN::Config->{inactivity_timeout} = 0;
7901 }
7902 }
7903 if ($go_via_alarm) {
f04ea8d1
SP		 7904 if ( $self->_should_report('pl') ) {
7905 ($output, $ret) = CPAN::Reporter::record_command(
7906 $system,
7907 $CPAN::Config->{inactivity_timeout},
7908 );
7909 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7910 }
7911 else {
7912 eval {
7913 alarm $CPAN::Config->{inactivity_timeout};
7914 local $SIG{CHLD}; # = sub { wait };
7915 if (defined($pid = fork)) {
7916 if ($pid) { #parent
7917 # wait;
7918 waitpid $pid, 0;
7919 } else { #child
7920 # note, this exec isn't necessary if
7921 # inactivity_timeout is 0. On the Mac I'd
7922 # suggest, we set it always to 0.
7923 exec $system;
7924 }
7925 } else {
7926 $CPAN::Frontend->myprint("Cannot fork: $!");
7927 return;
2ccf00a7 7928 }
f04ea8d1
SP		 7929 };
7930 alarm 0;
7931 if ($@) {
7932 kill 9, $pid;
7933 waitpid $pid, 0;
7934 my $err = "$@";
7935 $CPAN::Frontend->myprint($err);
7936 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7937 $@ = "";
7938 $self->store_persistent_state;
7939 return $self->goodbye("$system -- TIMED OUT");
2ccf00a7 7940 }
2ccf00a7 7941 }
f04ea8d1 7942 } else {
05bab18e 7943 if (my $expect_model = $self->_prefs_with_expect("pl")) {
f04ea8d1
SP		 7944 # XXX probably want to check _should_report here and warn
7945 # about not being able to use CPAN::Reporter with expect
5254b38e 7946 $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
05bab18e
SP		 7947 if (! defined $ret
7948 && $self->{writemakefile}
7949 && $self->{writemakefile}->failed) {
7950 # timeout
7951 return;
7952 }
f04ea8d1
SP		 7953 }
7954 elsif ( $self->_should_report('pl') ) {
7955 ($output, $ret) = CPAN::Reporter::record_command($system);
7956 CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
7957 }
7958 else {
1e8f9a0a
SP		 7959 $ret = system($system);
7960 }
7961 if ($ret != 0) {
7962 $self->{writemakefile} = CPAN::Distrostatus
7963 ->new("NO '$system' returned status $ret");
7964 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
05bab18e 7965 $self->store_persistent_state;
f04ea8d1
SP		 7966 return $self->goodbye("$system -- NOT OK");
7967 }
7968 }
7969 if (-f "Makefile" || -f "Build") {
7970 $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7971 delete $self->{make_clean}; # if cleaned before, enable next
7972 } else {
7973 my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
5254b38e
SP		 7974 my $why = "No '$makefile' created";
7975 $CPAN::Frontend->mywarn($why);
f04ea8d1 7976 $self->{writemakefile} = CPAN::Distrostatus
5254b38e 7977 ->new(qq{NO -- $why\n});
f04ea8d1 7978 $self->store_persistent_state;
5254b38e 7979 return $self->goodbye("$system -- NOT OK");
f04ea8d1
SP		 7980 }
7981 }
7982 if ($CPAN::Signal) {
7983 delete $self->{force_update};
7984 return;
c4d24d4c 7985 }
5254b38e
SP		 7986 my $wait_for_prereqs = eval { $self->satisfy_requires };
7987 return 1 if $wait_for_prereqs; # tells queuerunner to continue
7988 return $self->goodbye($@) if $@; # tells queuerunner to stop
f04ea8d1
SP		 7989 if ($CPAN::Signal) {
7990 delete $self->{force_update};
7991 return;
1e8f9a0a 7992 }
5254b38e
SP		 7993 my $make_commandline;
7994 if ($self->prefs->{make}) {
7995 $make_commandline = $self->prefs->{make}{commandline};
7996 }
7997 if ($make_commandline) {
7998 $system = $make_commandline;
b03f445c 7999 $ENV{PERL} = CPAN::find_perl;
e82b9348 8000 } else {
810a0276
SP		 8001 if ($self->{modulebuild}) {
8002 unless (-f "Build") {
8003 my $cwd = CPAN::anycwd();
8004 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
8ce4ea0b 8005 " in cwd[$cwd]. Danger, Will Robinson!\n");
810a0276
SP		 8006 $CPAN::Frontend->mysleep(5);
8007 }
b72dd56f 8008 $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
810a0276 8009 } else {
b72dd56f 8010 $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
810a0276 8011 }
b72dd56f 8012 $system =~ s/\s+$//;
5254b38e 8013 my $make_arg = $self->_make_phase_arg("make");
810a0276
SP		 8014 $system = sprintf("%s%s",
8015 $system,
8016 $make_arg ? " $make_arg" : "",
8017 );
e82b9348 8018 }
5254b38e
SP		 8019 my $make_env;
8020 if ($self->prefs->{make}) {
8021 $make_env = $self->prefs->{make}{env};
8022 }
8023 if ($make_env) { # overriding the local ENV of PL, not the outer
8024 # ENV, but unlikely to be a risk
8025 for my $e (keys %$make_env) {
8026 $ENV{$e} = $make_env->{$e};
1e8f9a0a
SP		 8027 }
8028 }
05bab18e
SP		 8029 my $expect_model = $self->_prefs_with_expect("make");
8030 my $want_expect = 0;
8031 if ( $expect_model && @{$expect_model->{talk}} ) {
8032 my $can_expect = $CPAN::META->has_inst("Expect");
8033 if ($can_expect) {
8034 $want_expect = 1;
8035 } else {
8036 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
be34b10d 8037 "system()\n");
05bab18e
SP		 8038 }
8039 }
8040 my $system_ok;
8041 if ($want_expect) {
f04ea8d1
SP		 8042 # XXX probably want to check _should_report here and
8043 # warn about not being able to use CPAN::Reporter with expect
5254b38e 8044 $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
f04ea8d1
SP		 8045 }
8046 elsif ( $self->_should_report('make') ) {
8047 my ($output, $ret) = CPAN::Reporter::record_command($system);
8048 CPAN::Reporter::grade_make( $self, $system, $output, $ret );
8049 $system_ok = ! $ret;
8050 }
8051 else {
05bab18e
SP		 8052 $system_ok = system($system) == 0;
8053 }
8054 $self->introduce_myself;
8055 if ( $system_ok ) {
f04ea8d1
SP		 8056 $CPAN::Frontend->myprint(" $system -- OK\n");
8057 $self->{make} = CPAN::Distrostatus->new("YES");
6d29edf5 8058 } else {
f04ea8d1
SP		 8059 $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
8060 $self->{make} = CPAN::Distrostatus->new("NO");
8061 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
6d29edf5 8062 }
05bab18e 8063 $self->store_persistent_state;
6d29edf5 8064}
f610777f 8065
8ce4ea0b
SP		 8066# CPAN::Distribution::goodbye ;
8067sub goodbye {
8068 my($self,$goodbye) = @_;
8069 my $id = $self->pretty_id;
f04ea8d1 8070 $CPAN::Frontend->mywarn(" $id\n $goodbye\n");
8ce4ea0b
SP		 8071 return;
8072}
8073
8074# CPAN::Distribution::_run_via_expect ;
6658a91b 8075sub _run_via_expect {
5254b38e 8076 my($self,$system,$phase,$expect_model) = @_;
05bab18e 8077 CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
1e8f9a0a 8078 if ($CPAN::META->has_inst("Expect")) {
05bab18e 8079 my $expo = Expect->new; # expo Expect object;
1e8f9a0a 8080 $expo->spawn($system);
810a0276
SP		 8081 $expect_model->{mode} ||= "deterministic";
8082 if ($expect_model->{mode} eq "deterministic") {
5254b38e 8083 return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
810a0276 8084 } elsif ($expect_model->{mode} eq "anyorder") {
5254b38e 8085 return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
05bab18e
SP		 8086 } else {
8087 die "Panic: Illegal expect mode: $expect_model->{mode}";
1e8f9a0a 8088 }
1e8f9a0a
SP		 8089 } else {
8090 $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
8091 return system($system);
8092 }
8093}
8094
05bab18e 8095sub _run_via_expect_anyorder {
5254b38e 8096 my($self,$expo,$phase,$expect_model) = @_;
810a0276 8097 my $timeout = $expect_model->{timeout} || 5;
f04ea8d1 8098 my $reuse = $expect_model->{reuse};
810a0276 8099 my @expectacopy = @{$expect_model->{talk}}; # we trash it!
05bab18e 8100 my $but = "";
5254b38e 8101 my $timeout_start = time;
05bab18e
SP		 8102 EXPECT: while () {
8103 my($eof,$ran_into_timeout);
5254b38e
SP		 8104 # XXX not up to the full power of expect. one could certainly
8105 # wrap all of the talk pairs into a single expect call and on
8106 # success tweak it and step ahead to the next question. The
8107 # current implementation unnecessarily limits itself to a
8108 # single match.
8109 my @match = $expo->expect(1,
05bab18e
SP		 8110 [ eof => sub {
8111 $eof++;
8112 } ],
8113 [ timeout => sub {
8114 $ran_into_timeout++;
8115 } ],
8116 -re => eval"qr{.}",
8117 );
8118 if ($match[2]) {
8119 $but .= $match[2];
8120 }
8121 $but .= $expo->clear_accum;
8122 if ($eof) {
8123 $expo->soft_close;
8124 return $expo->exitstatus();
8125 } elsif ($ran_into_timeout) {
8126 # warn "DEBUG: they are asking a question, but[$but]";
8127 for (my $i = 0; $i <= $#expectacopy; $i+=2) {
8128 my($next,$send) = @expectacopy[$i,$i+1];
8129 my $regex = eval "qr{$next}";
8130 # warn "DEBUG: will compare with regex[$regex].";
8131 if ($but =~ /$regex/) {
8132 # warn "DEBUG: will send send[$send]";
8133 $expo->send($send);
f04ea8d1
SP		 8134 # never allow reusing an QA pair unless they told us
8135 splice @expectacopy, $i, 2 unless $reuse;
05bab18e
SP		 8136 next EXPECT;
8137 }
8138 }
5254b38e
SP		 8139 my $have_waited = time - $timeout_start;
8140 if ($have_waited < $timeout) {
8141 # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
8142 next EXPECT;
8143 }
05bab18e
SP		 8144 my $why = "could not answer a question during the dialog";
8145 $CPAN::Frontend->mywarn("Failing: $why\n");
5254b38e 8146 $self->{$phase} =
05bab18e 8147 CPAN::Distrostatus->new("NO $why");
5254b38e 8148 return 0;
05bab18e
SP		 8149 }
8150 }
8151}
8152
8153sub _run_via_expect_deterministic {
5254b38e 8154 my($self,$expo,$phase,$expect_model) = @_;
05bab18e 8155 my $ran_into_timeout;
5254b38e 8156 my $ran_into_eof;
810a0276
SP		 8157 my $timeout = $expect_model->{timeout} || 15; # currently unsettable
8158 my $expecta = $expect_model->{talk};
05bab18e 8159 EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
810a0276 8160 my($re,$send) = @$expecta[$i,$i+1];
05bab18e
SP		 8161 CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
8162 my $regex = eval "qr{$re}";
8163 $expo->expect($timeout,
8164 [ eof => sub {
8165 my $but = $expo->clear_accum;
8166 $CPAN::Frontend->mywarn("EOF (maybe harmless)
8167expected[$regex]\nbut[$but]\n\n");
5254b38e 8168 $ran_into_eof++;
05bab18e
SP		 8169 } ],
8170 [ timeout => sub {
8171 my $but = $expo->clear_accum;
8172 $CPAN::Frontend->mywarn("TIMEOUT
8173expected[$regex]\nbut[$but]\n\n");
8174 $ran_into_timeout++;
8175 } ],
8176 -re => $regex);
f04ea8d1 8177 if ($ran_into_timeout) {
05bab18e 8178 # note that the caller expects 0 for success
5254b38e 8179 $self->{$phase} =
05bab18e 8180 CPAN::Distrostatus->new("NO timeout during expect dialog");
5254b38e
SP		 8181 return 0;
8182 } elsif ($ran_into_eof) {
8183 last EXPECT;
05bab18e
SP		 8184 }
8185 $expo->send($send);
8186 }
8187 $expo->soft_close;
8188 return $expo->exitstatus();
8189}
8190
b72dd56f 8191#-> CPAN::Distribution::_validate_distropref
810a0276
SP		 8192sub _validate_distropref {
8193 my($self,@args) = @_;
8194 if (
8195 $CPAN::META->has_inst("CPAN::Kwalify")
8196 &&
8197 $CPAN::META->has_inst("Kwalify")
8198 ) {
8199 eval {CPAN::Kwalify::_validate("distroprefs",@args);};
8200 if ($@) {
8201 $CPAN::Frontend->mywarn($@);
8202 }
8203 } else {
8204 CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
8205 }
8206}
8207
b72dd56f 8208#-> CPAN::Distribution::_find_prefs
1e8f9a0a 8209sub _find_prefs {
6658a91b
SP		 8210 my($self) = @_;
8211 my $distroid = $self->pretty_id;
b72dd56f 8212 #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
1e8f9a0a 8213 my $prefs_dir = $CPAN::Config->{prefs_dir};
b03f445c 8214 return if $prefs_dir =~ /^\s*$/;
1e8f9a0a
SP		 8215 eval { File::Path::mkpath($prefs_dir); };
8216 if ($@) {
8217 $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
8218 }
b72dd56f 8219 my $yaml_module = CPAN::_yaml_module;
5254b38e 8220 my $ext_map = {};
be34b10d 8221 my @extensions;
1e8f9a0a 8222 if ($CPAN::META->has_inst($yaml_module)) {
5254b38e 8223 $ext_map->{yml} = 'CPAN';
be34b10d
SP		 8224 } else {
8225 my @fallbacks;
8226 if ($CPAN::META->has_inst("Data::Dumper")) {
5254b38e 8227 push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
be34b10d
SP		 8228 }
8229 if ($CPAN::META->has_inst("Storable")) {
5254b38e 8230 push @fallbacks, $ext_map->{st} = 'Storable';
be34b10d
SP		 8231 }
8232 if (@fallbacks) {
8233 local $" = " and ";
8234 unless ($self->{have_complained_about_missing_yaml}++) {
8235 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
8236 "to @fallbacks to read prefs '$prefs_dir'\n");
8237 }
8238 } else {
8239 unless ($self->{have_complained_about_missing_yaml}++) {
8240 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
8241 "read prefs '$prefs_dir'\n");
8242 }
8243 }
8244 }
5254b38e
SP		 8245 my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
8246 DIRENT: while (my $result = $finder->next) {
8247 if ($result->is_warning) {
8248 $CPAN::Frontend->mywarn($result->as_string);
8249 $CPAN::Frontend->mysleep(1);
8250 next DIRENT;
8251 } elsif ($result->is_fatal) {
8252 $CPAN::Frontend->mydie($result->as_string);
8253 }
6658a91b 8254
5254b38e
SP		 8255 my @prefs = @{ $result->prefs };
8256
8257 ELEMENT: for my $y (0..$#prefs) {
8258 my $pref = $prefs[$y];
8259 $self->_validate_distropref($pref->data, $result->abs, $y);
8260
8261 # I don't know why we silently skip when there's no match, but
8262 # complain if there's an empty match hashref, and there's no
8263 # comment explaining why -- hdp, 2008-03-18
8264 unless ($pref->has_any_match) {
8265 next ELEMENT;
8266 }
8267
8268 unless ($pref->has_valid_subkeys) {
8269 $CPAN::Frontend->mydie(sprintf
8270 "Nonconforming .%s file '%s': " .
8271 "missing match/* subattribute. " .
8272 "Please remove, cannot continue.",
8273 $result->ext, $result->abs,
8274 );
8275 }
8276
8277 my $arg = {
8278 env => \%ENV,
8279 distribution => $distroid,
8280 perl => \&CPAN::find_perl,
8281 perlconfig => \%Config::Config,
8282 module => sub { [ $self->containsmods ] },
8283 };
8284
8285 if ($pref->matches($arg)) {
8286 return {
8287 prefs => $pref->data,
8288 prefs_file => $result->abs,
8289 prefs_file_doc => $y,
8290 };
1e8f9a0a 8291 }
5254b38e 8292
1e8f9a0a 8293 }
1e8f9a0a
SP		 8294 }
8295 return;
8296}
8297
8298# CPAN::Distribution::prefs
8299sub prefs {
8300 my($self) = @_;
f20de9f0
SP		 8301 if (exists $self->{negative_prefs_cache}
8302 &&
8303 $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
8304 ) {
8305 delete $self->{negative_prefs_cache};
8306 delete $self->{prefs};
8307 }
1e8f9a0a
SP		 8308 if (exists $self->{prefs}) {
8309 return $self->{prefs}; # XXX comment out during debugging
8310 }
8311 if ($CPAN::Config->{prefs_dir}) {
8312 CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
6658a91b 8313 my $prefs = $self->_find_prefs();
b72dd56f
SP		 8314 $prefs ||= ""; # avoid warning next line
8315 CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
1e8f9a0a 8316 if ($prefs) {
05bab18e 8317 for my $x (qw(prefs prefs_file prefs_file_doc)) {
1e8f9a0a
SP		 8318 $self->{$x} = $prefs->{$x};
8319 }
6658a91b
SP		 8320 my $bs = sprintf(
8321 "%s[%s]",
8322 File::Basename::basename($self->{prefs_file}),
05bab18e 8323 $self->{prefs_file_doc},
6658a91b 8324 );
1e8f9a0a 8325 my $filler1 = "_" x 22;
6658a91b 8326 my $filler2 = int(66 - length($bs))/2;
1e8f9a0a
SP		 8327 $filler2 = 0 if $filler2 < 0;
8328 $filler2 = " " x $filler2;
8329 $CPAN::Frontend->myprint("
8330$filler1 D i s t r o P r e f s $filler1
6658a91b 8331$filler2 $bs $filler2
1e8f9a0a
SP		 8332");
8333 $CPAN::Frontend->mysleep(1);
8334 return $self->{prefs};
8335 }
8336 }
f20de9f0
SP		 8337 $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
8338 return $self->{prefs} = +{};
1e8f9a0a
SP		 8339}
8340
5254b38e
SP		 8341# CPAN::Distribution::_make_phase_arg
8342sub _make_phase_arg {
8343 my($self, $phase) = @_;
8344 my $_make_phase_arg;
1e8f9a0a
SP		 8345 my $prefs = $self->prefs;
8346 if (
8347 $prefs
5254b38e
SP		 8348 && exists $prefs->{$phase}
8349 && exists $prefs->{$phase}{args}
8350 && $prefs->{$phase}{args}
1e8f9a0a 8351 ) {
5254b38e 8352 $_make_phase_arg = join(" ",
1e8f9a0a 8353 map {CPAN::HandleConfig
5254b38e 8354 ->safe_quote($_)} @{$prefs->{$phase}{args}},
1e8f9a0a
SP		 8355 );
8356 }
5254b38e
SP		 8357
8358# cpan[2]> o conf make[TAB]
8359# make make_install_make_command
8360# make_arg makepl_arg
8361# make_install_arg
8362# cpan[2]> o conf mbuild[TAB]
8363# mbuild_arg mbuild_install_build_command
8364# mbuild_install_arg mbuildpl_arg
8365
8366 my $mantra; # must switch make/mbuild here
8367 if ($self->{modulebuild}) {
8368 $mantra = "mbuild";
8369 } else {
8370 $mantra = "make";
8371 }
8372 my %map = (
8373 pl => "pl_arg",
8374 make => "_arg",
8375 test => "_test_arg", # does not really exist but maybe
8376 # will some day and now protects
8377 # us from unini warnings
8378 install => "_install_arg",
8379 );
8380 my $phase_underscore_meshup = $map{$phase};
8381 my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
8382
8383 $_make_phase_arg ||= $CPAN::Config->{$what};
8384 return $_make_phase_arg;
1e8f9a0a
SP		 8385}
8386
8387# CPAN::Distribution::_make_command
9ddc4ed0 8388sub _make_command {
ed84aac9
A		 8389 my ($self) = @_;
8390 if ($self) {
8391 return
1e8f9a0a 8392 CPAN::HandleConfig
ed84aac9 8393 ->safe_quote(
6658a91b
SP		 8394 CPAN::HandleConfig->prefs_lookup($self,
8395 q{make})
1e8f9a0a
SP		 8396 || $Config::Config{make}
8397 || 'make'
ed84aac9
A		 8398 );
8399 } else {
8400 # Old style call, without object. Deprecated
8401 Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
8402 return
1e8f9a0a 8403 safe_quote(undef,
6658a91b 8404 CPAN::HandleConfig->prefs_lookup($self,q{make})
1e8f9a0a
SP		 8405 || $CPAN::Config->{make}
8406 || $Config::Config{make}
8407 || 'make');
ed84aac9 8408 }
9ddc4ed0
A		 8409}
8410
c9869e1c 8411#-> sub CPAN::Distribution::follow_prereqs ;
6d29edf5
JH		 8412sub follow_prereqs {
8413 my($self) = shift;
f04ea8d1 8414 my($slot) = shift;
135a59c2
A		 8415 my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
8416 return unless @prereq_tuples;
5254b38e
SP		 8417 my(@good_prereq_tuples);
8418 for my $p (@prereq_tuples) {
8419 # XXX watch out for foul ones
8420 # $DB::single++;
8421 push @good_prereq_tuples, $p;
8422 }
6658a91b 8423 my $pretty_id = $self->pretty_id;
135a59c2
A		 8424 my %map = (
8425 b => "build_requires",
8426 r => "requires",
8427 c => "commandline",
8428 );
6658a91b
SP		 8429 my($filler1,$filler2,$filler3,$filler4);
8430 my $unsat = "Unsatisfied dependencies detected during";
8431 my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
8432 {
8433 my $r = int(($w - length($unsat))/2);
8434 my $l = $w - length($unsat) - $r;
8435 $filler1 = "-"x4 . " "x$l;
8436 $filler2 = " "x$r . "-"x4 . "\n";
8437 }
8438 {
8439 my $r = int(($w - length($pretty_id))/2);
8440 my $l = $w - length($pretty_id) - $r;
8441 $filler3 = "-"x4 . " "x$l;
8442 $filler4 = " "x$r . "-"x4 . "\n";
8443 }
135a59c2 8444 $CPAN::Frontend->
6658a91b
SP		 8445 myprint("$filler1 $unsat $filler2".
8446 "$filler3 $pretty_id $filler4".
5254b38e 8447 join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
135a59c2 8448 );
6d29edf5
JH		 8449 my $follow = 0;
8450 if ($CPAN::Config->{prerequisites_policy} eq "follow") {
f04ea8d1 8451 $follow = 1;
6d29edf5 8452 } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
f04ea8d1 8453 my $answer = CPAN::Shell::colorable_makemaker_prompt(
f610777f
A		 8454"Shall I follow them and prepend them to the queue
8455of modules we are processing right now?", "yes");
f04ea8d1 8456 $follow = $answer =~ /^\s*y/i;
6d29edf5 8457 } else {
5254b38e 8458 my @prereq = map { $_=>[0] } @good_prereq_tuples;
f04ea8d1
SP		 8459 local($") = ", ";
8460 $CPAN::Frontend->
de34a54b 8461 myprint(" Ignoring dependencies on modules @prereq\n");
f610777f 8462 }
6d29edf5 8463 if ($follow) {
6658a91b 8464 my $id = $self->id;
6d29edf5 8465 # color them as dirty
5254b38e 8466 for my $gp (@good_prereq_tuples) {
35576f8c 8467 # warn "calling color_cmd_tmps(0,1)";
5254b38e 8468 my $p = $gp->[0];
810a0276 8469 my $any = CPAN::Shell->expandany($p);
f04ea8d1 8470 $self->{$slot . "_for"}{$any->id}++;
810a0276 8471 if ($any) {
f20de9f0 8472 $any->color_cmd_tmps(0,2);
810a0276
SP		 8473 } else {
8474 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
8475 $CPAN::Frontend->mysleep(2);
8476 }
6d29edf5 8477 }
135a59c2 8478 # queue them and re-queue yourself
f04ea8d1 8479 CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
5254b38e 8480 map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
f04ea8d1 8481 $self->{$slot} = "Delayed until after prerequisites";
6d29edf5
JH		 8482 return 1; # signal success to the queuerunner
8483 }
f04ea8d1 8484 return;
6d29edf5
JH		 8485}
8486
5254b38e
SP		 8487sub _feature_depends {
8488 my($self) = @_;
8489 my $meta_yml = $self->parse_meta_yml();
8490 my $optf = $meta_yml->{optional_features} or return;
8491 if (!ref $optf or ref $optf ne "HASH"){
8492 $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
8493 $optf = {};
8494 }
8495 my $wantf = $self->prefs->{features} or return;
8496 if (!ref $wantf or ref $wantf ne "ARRAY"){
8497 $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
8498 $wantf = [];
8499 }
8500 my $dep = +{};
8501 for my $wf (@$wantf) {
8502 if (my $f = $optf->{$wf}) {
8503 $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
8504 "is accompanied by this description:\n".
8505 $f->{description}.
8506 "\n\n"
8507 );
8508 # configure_requires currently not in the spec, unlikely to be useful anyway
8509 for my $reqtype (qw(configure_requires build_requires requires)) {
8510 my $reqhash = $f->{$reqtype} or next;
8511 while (my($k,$v) = each %$reqhash) {
8512 $dep->{$reqtype}{$k} = $v;
8513 }
8514 }
8515 } else {
8516 $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
8517 "found in the META.yml file".
8518 "\n\n"
8519 );
8520 }
8521 }
8522 $dep;
8523}
8524
6d29edf5 8525#-> sub CPAN::Distribution::unsat_prereq ;
5254b38e 8526# return ([Foo,"r"],[Bar,"b"]) for normal modules
7d97ad34 8527# return ([perl=>5.008]) if we need a newer perl than we are running under
5254b38e 8528# (sorry for the inconsistency, it was an accident)
6d29edf5 8529sub unsat_prereq {
f04ea8d1
SP		 8530 my($self,$slot) = @_;
8531 my(%merged,$prereq_pm);
8532 my $prefs_depends = $self->prefs->{depends}||{};
5254b38e 8533 my $feature_depends = $self->_feature_depends();
f04ea8d1
SP		 8534 if ($slot eq "configure_requires_later") {
8535 my $meta_yml = $self->parse_meta_yml();
5254b38e
SP		 8536 if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
8537 $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
8538 $meta_yml = +{};
8539 }
8540 %merged = (
8541 %{$meta_yml->{configure_requires}||{}},
8542 %{$prefs_depends->{configure_requires}||{}},
8543 %{$feature_depends->{configure_requires}||{}},
8544 );
f04ea8d1
SP		 8545 $prereq_pm = {}; # configure_requires defined as "b"
8546 } elsif ($slot eq "later") {
8547 my $prereq_pm_0 = $self->prereq_pm || {};
8548 for my $reqtype (qw(requires build_requires)) {
8549 $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
5254b38e
SP		 8550 for my $dep ($prefs_depends,$feature_depends) {
8551 for my $k (keys %{$dep->{$reqtype}||{}}) {
8552 $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
8553 }
f04ea8d1
SP		 8554 }
8555 }
8556 %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
8557 } else {
8558 die "Panic: illegal slot '$slot'";
8559 }
6d29edf5 8560 my(@need);
f20de9f0
SP		 8561 my @merged = %merged;
8562 CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
135a59c2 8563 NEED: while (my($need_module, $need_version) = each %merged) {
f20de9f0 8564 my($available_version,$available_file,$nmo);
7d97ad34 8565 if ($need_module eq "perl") {
b72dd56f 8566 $available_version = $];
b03f445c 8567 $available_file = CPAN::find_perl;
7d97ad34 8568 } else {
f20de9f0 8569 $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7d97ad34 8570 next if $nmo->uptodate;
b72dd56f 8571 $available_file = $nmo->available_file;
7d97ad34
SP		 8572
8573 # if they have not specified a version, we accept any installed one
ade94d80
SP		 8574 if (defined $available_file
8575 and ( # a few quick shortcurcuits
8576 not defined $need_version
8577 or $need_version eq '0' # "==" would trigger warning when not numeric
8578 or $need_version eq "undef"
8579 )) {
8580 next NEED;
7d97ad34
SP		 8581 }
8582
b72dd56f 8583 $available_version = $nmo->available_version;
6d29edf5
JH		 8584 }
8585
8586 # We only want to install prereqs if either they're not installed
8587 # or if the installed version is too old. We cannot omit this
8588 # check, because if 'force' is in effect, nobody else will check.
b72dd56f 8589 if (defined $available_file) {
5254b38e
SP		 8590 my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
8591 ($need_module,$available_file,$available_version,$need_version);
8592 next NEED if $fulfills_all_version_rqs;
6d29edf5
JH		 8593 }
8594
7d97ad34
SP		 8595 if ($need_module eq "perl") {
8596 return ["perl", $need_version];
8597 }
f04ea8d1
SP		 8598 $self->{sponsored_mods}{$need_module} ||= 0;
8599 CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
5254b38e 8600 if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
6d29edf5 8601 # We have already sponsored it and for some reason it's still
f20de9f0
SP		 8602 # not available. So we do ... what??
8603
6d29edf5 8604 # if we push it again, we have a potential infinite loop
f20de9f0
SP		 8605
8606 # The following "next" was a very problematic construct.
23a216b4
SP		 8607 # It helped a lot but broke some day and had to be
8608 # replaced.
f20de9f0
SP		 8609
8610 # We must be able to deal with modules that come again and
8611 # again as a prereq and have themselves prereqs and the
8612 # queue becomes long but finally we would find the correct
8613 # order. The RecursiveDependency check should trigger a
8614 # die when it's becoming too weird. Unfortunately removing
8615 # this next breaks many other things.
8616
8617 # The bug that brought this up is described in Todo under
8618 # "5.8.9 cannot install Compress::Zlib"
8619
23a216b4 8620 # next; # this is the next that had to go away
f20de9f0
SP		 8621
8622 # The following "next NEED" are fine and the error message
8623 # explains well what is going on. For example when the DBI
8624 # fails and consequently DBD::SQLite fails and now we are
8625 # processing CPAN::SQLite. Then we must have a "next" for
8626 # DBD::SQLite. How can we get it and how can we identify
8627 # all other cases we must identify?
8628
8629 my $do = $nmo->distribution;
8630 next NEED unless $do; # not on CPAN
ecc7fca0 8631 if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
b03f445c
RGS		 8632 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8633 "'$need_module => $need_version' ".
8634 "for '$self->{ID}' seems ".
ecc7fca0 8635 "not available according to the indexes\n"
b03f445c
RGS		 8636 );
8637 next NEED;
8638 }
f20de9f0
SP		 8639 NOSAYER: for my $nosayer (
8640 "unwrapped",
8641 "writemakefile",
8642 "signature_verify",
8643 "make",
8644 "make_test",
8645 "install",
8646 "make_clean",
8647 ) {
23a216b4 8648 if ($do->{$nosayer}) {
5254b38e
SP		 8649 my $selfid = $self->pretty_id;
8650 my $did = $do->pretty_id;
23a216b4
SP		 8651 if (UNIVERSAL::can($do->{$nosayer},"failed") ?
8652 $do->{$nosayer}->failed :
8653 $do->{$nosayer} =~ /^NO/) {
8654 if ($nosayer eq "make_test"
8655 &&
8656 $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
8657 ) {
8658 next NOSAYER;
8659 }
8660 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8661 "'$need_module => $need_version' ".
5254b38e
SP		 8662 "for '$selfid' failed when ".
8663 "processing '$did' with ".
23a216b4
SP		 8664 "'$nosayer => $do->{$nosayer}'. Continuing, ".
8665 "but chances to succeed are limited.\n"
8666 );
5254b38e 8667 $CPAN::Frontend->mysleep($sponsoring/10);
23a216b4
SP		 8668 next NEED;
8669 } else { # the other guy succeeded
5254b38e 8670 if ($nosayer =~ /^(install|make_test)$/) {
23a216b4
SP		 8671 # we had this with
8672 # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
5254b38e
SP		 8673 # in 2007-03 for 'make install'
8674 # and 2008-04: #30464 (for 'make test')
23a216b4
SP		 8675 $CPAN::Frontend->mywarn("Warning: Prerequisite ".
8676 "'$need_module => $need_version' ".
5254b38e
SP		 8677 "for '$selfid' already built ".
8678 "but the result looks suspicious. ".
8679 "Skipping another build attempt, ".
23a216b4
SP		 8680 "to prevent looping endlessly.\n"
8681 );
8682 next NEED;
8683 }
f20de9f0 8684 }
f20de9f0
SP		 8685 }
8686 }
6d29edf5 8687 }
135a59c2
A		 8688 my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
8689 push @need, [$need_module,$needed_as];
5f05dabc 8690 }
f20de9f0
SP		 8691 my @unfolded = map { "[".join(",",@$_)."]" } @need;
8692 CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
6d29edf5 8693 @need;
5f05dabc 8694}
8695
5254b38e
SP		 8696sub _fulfills_all_version_rqs {
8697 my($self,$need_module,$available_file,$available_version,$need_version) = @_;
8698 my(@all_requirements) = split /\s*,\s*/, $need_version;
8699 local($^W) = 0;
8700 my $ok = 0;
8701 RQ: for my $rq (@all_requirements) {
8702 if ($rq =~ s|>=\s*||) {
8703 } elsif ($rq =~ s|>\s*||) {
8704 # 2005-12: one user
8705 if (CPAN::Version->vgt($available_version,$rq)) {
8706 $ok++;
8707 }
8708 next RQ;
8709 } elsif ($rq =~ s|!=\s*||) {
8710 # 2005-12: no user
8711 if (CPAN::Version->vcmp($available_version,$rq)) {
8712 $ok++;
8713 next RQ;
8714 } else {
8715 last RQ;
8716 }
8717 } elsif ($rq =~ m|<=?\s*|) {
8718 # 2005-12: no user
8719 $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
8720 $ok++;
8721 next RQ;
8722 }
8723 if (! CPAN::Version->vgt($rq, $available_version)) {
8724 $ok++;
8725 }
8726 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
8727 "available_version[%s]rq[%s]ok[%d]",
8728 $need_module,
8729 $available_file,
8730 $available_version,
8731 CPAN::Version->readable($rq),
8732 $ok,
8733 )) if $CPAN::DEBUG;
8734 }
8735 return $ok == @all_requirements;
8736}
8737
e82b9348
SP		 8738#-> sub CPAN::Distribution::read_yaml ;
8739sub read_yaml {
8740 my($self) = @_;
8741 return $self->{yaml_content} if exists $self->{yaml_content};
5254b38e
SP		 8742 my $build_dir;
8743 unless ($build_dir = $self->{build_dir}) {
8744 # maybe permission on build_dir was missing
8745 $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
8746 return;
8747 }
e82b9348 8748 my $yaml = File::Spec->catfile($build_dir,"META.yml");
44d21104 8749 $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
e82b9348 8750 return unless -f $yaml;
6658a91b 8751 eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
1e8f9a0a 8752 if ($@) {
b72dd56f 8753 $CPAN::Frontend->mywarn("Could not read ".
be34b10d
SP		 8754 "'$yaml'. Falling back to other ".
8755 "methods to determine prerequisites\n");
b72dd56f
SP		 8756 return $self->{yaml_content} = undef; # if we die, then we
8757 # cannot read YAML's own
8758 # META.yml
1e8f9a0a 8759 }
f20de9f0 8760 # not "authoritative"
5254b38e
SP		 8761 for ($self->{yaml_content}) {
8762 if (defined $_ && (! ref $_ || ref $_ ne "HASH")) {
8763 $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
8764 $self->{yaml_content} = +{};
8765 }
8766 }
1e8f9a0a
SP		 8767 if (not exists $self->{yaml_content}{dynamic_config}
8768 or $self->{yaml_content}{dynamic_config}
8769 ) {
8770 $self->{yaml_content} = undef;
e82b9348 8771 }
135a59c2
A		 8772 $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
8773 if $CPAN::DEBUG;
e82b9348
SP		 8774 return $self->{yaml_content};
8775}
8776
6d29edf5
JH		 8777#-> sub CPAN::Distribution::prereq_pm ;
8778sub prereq_pm {
e82b9348 8779 my($self) = @_;
be34b10d 8780 $self->{prereq_pm_detected} ||= 0;
f20de9f0 8781 CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
be34b10d 8782 return $self->{prereq_pm} if $self->{prereq_pm_detected};
e82b9348
SP		 8783 return unless $self->{writemakefile} # no need to have succeeded
8784 # but we must have run it
c9869e1c 8785 || $self->{modulebuild};
5254b38e
SP		 8786 unless ($self->{build_dir}) {
8787 return;
8788 }
be34b10d
SP		 8789 CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
8790 $self->{writemakefile}||"",
8791 $self->{modulebuild}||"",
8792 ) if $CPAN::DEBUG;
135a59c2
A		 8793 my($req,$breq);
8794 if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
8795 $req = $yaml->{requires} || {};
8796 $breq = $yaml->{build_requires} || {};
e82b9348
SP		 8797 undef $req unless ref $req eq "HASH" && %$req;
8798 if ($req) {
810a0276
SP		 8799 if ($yaml->{generated_by} &&
8800 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
e82b9348
SP		 8801 my $eummv = do { local $^W = 0; $1+0; };
8802 if ($eummv < 6.2501) {
8803 # thanks to Slaven for digging that out: MM before
8804 # that could be wrong because it could reflect a
8805 # previous release
8806 undef $req;
8807 }
8808 }
8809 my $areq;
8810 my $do_replace;
3ff97d55 8811 while (my($k,$v) = each %{$req||{}}) {
e82b9348
SP		 8812 if ($v =~ /\d/) {
8813 $areq->{$k} = $v;
8814 } elsif ($k =~ /[A-Za-z]/ &&
8815 $v =~ /[A-Za-z]/ &&
8816 $CPAN::META->exists("Module",$v)
8817 ) {
8818 $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
8819 "requires hash: $k => $v; I'll take both ".
8820 "key and value as a module name\n");
8962fc49 8821 $CPAN::Frontend->mysleep(1);
e82b9348
SP		 8822 $areq->{$k} = 0;
8823 $areq->{$v} = 0;
8824 $do_replace++;
8825 }
8826 }
8827 $req = $areq if $do_replace;
8828 }
e82b9348 8829 }
135a59c2 8830 unless ($req || $breq) {
5254b38e
SP		 8831 my $build_dir;
8832 unless ( $build_dir = $self->{build_dir} ) {
8833 return;
8834 }
e82b9348
SP		 8835 my $makefile = File::Spec->catfile($build_dir,"Makefile");
8836 my $fh;
8837 if (-f $makefile
8838 and
8839 $fh = FileHandle->new("<$makefile\0")) {
be34b10d 8840 CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
e82b9348
SP		 8841 local($/) = "\n";
8842 while (<$fh>) {
8843 last if /MakeMaker post_initialize section/;
8844 my($p) = m{^[\#]
8845 \s+PREREQ_PM\s+=>\s+(.+)
8846 }x;
8847 next unless $p;
8848 # warn "Found prereq expr[$p]";
8849
8850 # Regexp modified by A.Speer to remember actual version of file
8851 # PREREQ_PM hash key wants, then add to
f04ea8d1 8852 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
e82b9348
SP		 8853 # In case a prereq is mentioned twice, complain.
8854 if ( defined $req->{$1} ) {
8855 warn "Warning: PREREQ_PM mentions $1 more than once, ".
8856 "last mention wins";
8857 }
f20de9f0
SP		 8858 my($m,$n) = ($1,$2);
8859 if ($n =~ /^q\[(.*?)\]$/) {
8860 $n = $1;
8861 }
8862 $req->{$m} = $n;
e82b9348
SP		 8863 }
8864 last;
8865 }
be34b10d
SP		 8866 }
8867 }
8868 unless ($req || $breq) {
8869 my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
8870 my $buildfile = File::Spec->catfile($build_dir,"Build");
8871 if (-f $buildfile) {
8872 CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
8873 my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
8874 if (-f $build_prereqs) {
8875 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
8876 my $content = do { local *FH;
8877 open FH, $build_prereqs
8878 or $CPAN::Frontend->mydie("Could not open ".
8879 "'$build_prereqs': $!");
8880 local $/;
8881 <FH>;
8882 };
8883 my $bphash = eval $content;
6a935156 8884 if ($@) {
be34b10d
SP		 8885 } else {
8886 $req = $bphash->{requires} || +{};
8887 $breq = $bphash->{build_requires} || +{};
6a935156 8888 }
9ddc4ed0 8889 }
e82b9348
SP		 8890 }
8891 }
7d97ad34
SP		 8892 if (-f "Build.PL"
8893 && ! -f "Makefile.PL"
8894 && ! exists $req->{"Module::Build"}
8895 && ! $CPAN::META->has_inst("Module::Build")) {
c9869e1c
SP		 8896 $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ".
8897 "undeclared prerequisite.\n".
135a59c2 8898 " Adding it now as such.\n"
c9869e1c
SP		 8899 );
8900 $CPAN::Frontend->mysleep(5);
8901 $req->{"Module::Build"} = 0;
8902 delete $self->{writemakefile};
8903 }
be34b10d
SP		 8904 if ($req || $breq) {
8905 $self->{prereq_pm_detected}++;
8906 return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
8907 }
f610777f
A		 8908}
8909
05454584
A		 8910#-> sub CPAN::Distribution::test ;
8911sub test {
5f05dabc 8912 my($self) = @_;
be34b10d
SP		 8913 if (my $goto = $self->prefs->{goto}) {
8914 return $self->goto($goto);
8915 }
05454584 8916 $self->make;
5254b38e 8917 return if $self->prefs->{disabled} && ! $self->{force_update};
f04ea8d1 8918 if ($CPAN::Signal) {
c4d24d4c
A		 8919 delete $self->{force_update};
8920 return;
8921 }
554a9ef5
SP		 8922 # warn "XDEBUG: checking for notest: $self->{notest} $self";
8923 if ($self->{notest}) {
e82b9348
SP		 8924 $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8925 return 1;
554a9ef5
SP		 8926 }
8927
e82b9348 8928 my $make = $self->{modulebuild} ? "Build" : "make";
6658a91b
SP		 8929
8930 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8931 ? $ENV{PERL5LIB}
8932 : ($ENV{PERLLIB} || "");
8933
5254b38e 8934 local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
6658a91b
SP		 8935 $CPAN::META->set_perl5lib;
8936 local $ENV{MAKEFLAGS}; # protect us from outer make calls
8937
e82b9348 8938 $CPAN::Frontend->myprint("Running $make test\n");
f20de9f0 8939
05454584 8940 EXCUSE: {
f04ea8d1 8941 my @e;
23a216b4
SP		 8942 if ($self->{make} or $self->{later}) {
8943 # go ahead
8944 } else {
4d1321a7
A		 8945 push @e,
8946 "Make had some problems, won't test";
8947 }
05454584 8948
f04ea8d1
SP		 8949 exists $self->{make} and
8950 (
be34b10d 8951 UNIVERSAL::can($self->{make},"failed") ?
44d21104
A		 8952 $self->{make}->failed :
8953 $self->{make} =~ /^NO/
8954 ) and push @e, "Can't test without successful make";
6d29edf5 8955 $self->{badtestcnt} ||= 0;
f20de9f0
SP		 8956 if ($self->{badtestcnt} > 0) {
8957 require Data::Dumper;
8958 CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
6d29edf5 8959 push @e, "Won't repeat unsuccessful test during this command";
f20de9f0 8960 }
6d29edf5 8961
23a216b4 8962 push @e, $self->{later} if $self->{later};
f04ea8d1 8963 push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
6d29edf5 8964
6a935156 8965 if (exists $self->{build_dir}) {
23a216b4
SP		 8966 if (exists $self->{make_test}) {
8967 if (
8968 UNIVERSAL::can($self->{make_test},"failed") ?
8969 $self->{make_test}->failed :
8970 $self->{make_test} =~ /^NO/
8971 ) {
8972 if (
8973 UNIVERSAL::can($self->{make_test},"commandid")
8974 &&
8975 $self->{make_test}->commandid == $CPAN::CurrentCommandId
8976 ) {
8977 push @e, "Has already been tested within this command";
8978 }
8979 } else {
8980 push @e, "Has already been tested successfully";
5254b38e
SP		 8981 # if global "is_tested" has been cleared, we need to mark this to
8982 # be added to PERL5LIB if not already installed
8983 if ($self->tested_ok_but_not_installed) {
8984 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8985 }
23a216b4 8986 }
6a935156
SP		 8987 }
8988 } elsif (!@e) {
8989 push @e, "Has no own directory";
135a59c2 8990 }
f04ea8d1 8991 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
b72dd56f
SP		 8992 unless (chdir $self->{build_dir}) {
8993 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8994 }
f04ea8d1 8995 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
05454584 8996 }
b72dd56f 8997 $self->debug("Changed directory to $self->{build_dir}")
f04ea8d1 8998 if $CPAN::DEBUG;
f14b5cec
JH		 8999
9000 if ($^O eq 'MacOS') {
be708cc0 9001 Mac::BuildTools::make_test($self);
f14b5cec
JH		 9002 return;
9003 }
9004
7d97ad34 9005 if ($self->{modulebuild}) {
5254b38e
SP		 9006 my $thm = CPAN::Shell->expand("Module","Test::Harness");
9007 my $v = $thm->inst_version;
7d97ad34 9008 if (CPAN::Version->vlt($v,2.62)) {
5254b38e
SP		 9009 # XXX Eric Wilhelm reported this as a bug: klapperl:
9010 # Test::Harness 3.0 self-tests, so that should be 'unless
9011 # installing Test::Harness'
9012 unless ($self->id eq $thm->distribution->id) {
9013 $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7d97ad34 9014 '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
5254b38e
SP		 9015 $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
9016 return;
9017 }
9018 }
9019 }
9020
9021 if ( ! $self->{force_update} ) {
9022 # bypass actual tests if "trust_test_report_history" and have a report
9023 my $have_tested_fcn;
9024 if ( $CPAN::Config->{trust_test_report_history}
9025 && $CPAN::META->has_inst("CPAN::Reporter::History")
9026 && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
9027 if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
9028 # Do nothing if grade was DISCARD
9029 if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
9030 $self->{make_test} = CPAN::Distrostatus->new("YES");
9031 # if global "is_tested" has been cleared, we need to mark this to
9032 # be added to PERL5LIB if not already installed
9033 if ($self->tested_ok_but_not_installed) {
9034 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
9035 }
9036 $CPAN::Frontend->myprint("Found prior test report -- OK\n");
9037 return;
9038 }
9039 elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
9040 $self->{make_test} = CPAN::Distrostatus->new("NO");
9041 $self->{badtestcnt}++;
9042 $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
9043 return;
9044 }
9045 }
7d97ad34
SP		 9046 }
9047 }
9048
e82b9348 9049 my $system;
f04ea8d1
SP		 9050 my $prefs_test = $self->prefs->{test};
9051 if (my $commandline
9052 = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
810a0276 9053 $system = $commandline;
b03f445c 9054 $ENV{PERL} = CPAN::find_perl;
810a0276 9055 } elsif ($self->{modulebuild}) {
44d21104 9056 $system = sprintf "%s test", $self->_build_command();
5254b38e
SP		 9057 unless (-e "Build") {
9058 my $id = $self->pretty_id;
9059 $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
9060 }
e82b9348 9061 } else {
ed84aac9 9062 $system = join " ", $self->_make_command(), "test";
e82b9348 9063 }
5254b38e 9064 my $make_test_arg = $self->_make_phase_arg("test");
f20de9f0
SP		 9065 $system = sprintf("%s%s",
9066 $system,
9067 $make_test_arg ? " $make_test_arg" : "",
9068 );
1e8f9a0a 9069 my($tests_ok);
6658a91b
SP		 9070 my %env;
9071 while (my($k,$v) = each %ENV) {
9072 next unless defined $v;
9073 $env{$k} = $v;
9074 }
9075 local %ENV = %env;
5254b38e
SP		 9076 my $test_env;
9077 if ($self->prefs->{test}) {
9078 $test_env = $self->prefs->{test}{env};
9079 }
9080 if ($test_env) {
9081 for my $e (keys %$test_env) {
9082 $ENV{$e} = $test_env->{$e};
1e8f9a0a
SP		 9083 }
9084 }
05bab18e 9085 my $expect_model = $self->_prefs_with_expect("test");
6658a91b 9086 my $want_expect = 0;
05bab18e
SP		 9087 if ( $expect_model && @{$expect_model->{talk}} ) {
9088 my $can_expect = $CPAN::META->has_inst("Expect");
6658a91b
SP		 9089 if ($can_expect) {
9090 $want_expect = 1;
9091 } else {
9092 $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
9093 "testing without\n");
9094 }
9095 }
6658a91b 9096 if ($want_expect) {
f04ea8d1 9097 if ($self->_should_report('test')) {
6658a91b
SP		 9098 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
9099 "not supported when distroprefs specify ".
9100 "an interactive test\n");
9101 }
5254b38e 9102 $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
f04ea8d1 9103 } elsif ( $self->_should_report('test') ) {
6a935156 9104 $tests_ok = CPAN::Reporter::test($self, $system);
8962fc49 9105 } else {
6a935156 9106 $tests_ok = system($system) == 0;
8962fc49 9107 }
05bab18e 9108 $self->introduce_myself;
8962fc49 9109 if ( $tests_ok ) {
6a935156
SP		 9110 {
9111 my @prereq;
810a0276 9112
b72dd56f 9113 # local $CPAN::DEBUG = 16; # Distribution
6a935156 9114 for my $m (keys %{$self->{sponsored_mods}}) {
f04ea8d1 9115 next unless $self->{sponsored_mods}{$m} > 0;
f20de9f0 9116 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
810a0276
SP		 9117 # XXX we need available_version which reflects
9118 # $ENV{PERL5LIB} so that already tested but not yet
9119 # installed modules are counted.
9120 my $available_version = $m_obj->available_version;
b72dd56f 9121 my $available_file = $m_obj->available_file;
810a0276 9122 if ($available_version &&
b72dd56f 9123 !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
810a0276
SP		 9124 ) {
9125 CPAN->debug("m[$m] good enough available_version[$available_version]")
9126 if $CPAN::DEBUG;
b72dd56f
SP		 9127 } elsif ($available_file
9128 && (
9129 !$self->{prereq_pm}{$m}
9130 ||
9131 $self->{prereq_pm}{$m} == 0
9132 )
9133 ) {
9134 # lex Class::Accessor::Chained::Fast which has no $VERSION
9135 CPAN->debug("m[$m] have available_file[$available_file]")
9136 if $CPAN::DEBUG;
810a0276
SP		 9137 } else {
9138 push @prereq, $m;
6a935156
SP		 9139 }
9140 }
f04ea8d1 9141 if (@prereq) {
6a935156
SP		 9142 my $cnt = @prereq;
9143 my $which = join ",", @prereq;
810a0276 9144 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
6a935156 9145 "$cnt dependencies missing ($which)";
810a0276
SP		 9146 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
9147 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
05bab18e 9148 $self->store_persistent_state;
8ce4ea0b 9149 return $self->goodbye("[dependencies] -- NA");
6a935156
SP		 9150 }
9151 }
9152
9153 $CPAN::Frontend->myprint(" $system -- OK\n");
6a935156 9154 $self->{make_test} = CPAN::Distrostatus->new("YES");
b72dd56f
SP		 9155 $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
9156 # probably impossible to need the next line because badtestcnt
9157 # has a lifespan of one command
9158 delete $self->{badtestcnt};
05454584 9159 } else {
6a935156
SP		 9160 $self->{make_test} = CPAN::Distrostatus->new("NO");
9161 $self->{badtestcnt}++;
9162 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
b03f445c
RGS		 9163 CPAN::Shell->optprint
9164 ("hint",
9165 sprintf
9166 ("//hint// to see the cpan-testers results for installing this module, try:
9167 reports %s\n",
9168 $self->pretty_id));
5f05dabc 9169 }
05bab18e
SP		 9170 $self->store_persistent_state;
9171}
9172
9173sub _prefs_with_expect {
9174 my($self,$where) = @_;
9175 return unless my $prefs = $self->prefs;
9176 return unless my $where_prefs = $prefs->{$where};
9177 if ($where_prefs->{expect}) {
9178 return {
810a0276
SP		 9179 mode => "deterministic",
9180 timeout => 15,
05bab18e
SP		 9181 talk => $where_prefs->{expect},
9182 };
810a0276
SP		 9183 } elsif ($where_prefs->{"eexpect"}) {
9184 return $where_prefs->{"eexpect"};
05bab18e
SP		 9185 }
9186 return;
5f05dabc 9187}
9188
05454584
A		 9189#-> sub CPAN::Distribution::clean ;
9190sub clean {
5f05dabc 9191 my($self) = @_;
e82b9348
SP		 9192 my $make = $self->{modulebuild} ? "Build" : "make";
9193 $CPAN::Frontend->myprint("Running $make clean\n");
4d1321a7
A		 9194 unless (exists $self->{archived}) {
9195 $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
9196 "/untarred, nothing done\n");
9197 return 1;
9198 }
e82b9348
SP		 9199 unless (exists $self->{build_dir}) {
9200 $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
9201 return 1;
9202 }
ade94d80
SP		 9203 if (exists $self->{writemakefile}
9204 and $self->{writemakefile}->failed
9205 ) {
9206 $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
9207 return 1;
9208 }
05454584 9209 EXCUSE: {
f04ea8d1 9210 my @e;
c4d24d4c
A		 9211 exists $self->{make_clean} and $self->{make_clean} eq "YES" and
9212 push @e, "make clean already called once";
f04ea8d1 9213 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
05454584 9214 }
b72dd56f 9215 chdir $self->{build_dir} or
f04ea8d1 9216 Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
b72dd56f 9217 $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
f14b5cec
JH		 9218
9219 if ($^O eq 'MacOS') {
be708cc0 9220 Mac::BuildTools::make_clean($self);
f14b5cec
JH		 9221 return;
9222 }
9223
e82b9348
SP		 9224 my $system;
9225 if ($self->{modulebuild}) {
8962fc49 9226 unless (-f "Build") {
810a0276 9227 my $cwd = CPAN::anycwd();
8962fc49
SP		 9228 $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
9229 " in cwd[$cwd]. Danger, Will Robinson!");
9230 $CPAN::Frontend->mysleep(5);
9231 }
44d21104 9232 $system = sprintf "%s clean", $self->_build_command();
e82b9348 9233 } else {
ed84aac9 9234 $system = join " ", $self->_make_command(), "clean";
e82b9348 9235 }
05bab18e
SP		 9236 my $system_ok = system($system) == 0;
9237 $self->introduce_myself;
9238 if ( $system_ok ) {
c4d24d4c
A		 9239 $CPAN::Frontend->myprint(" $system -- OK\n");
9240
9241 # $self->force;
9242
9243 # Jost Krieger pointed out that this "force" was wrong because
9244 # it has the effect that the next "install" on this distribution
9245 # will untar everything again. Instead we should bring the
9246 # object's state back to where it is after untarring.
9247
e82b9348
SP		 9248 for my $k (qw(
9249 force_update
9250 install
9251 writemakefile
9252 make
9253 make_test
9254 )) {
9255 delete $self->{$k};
9256 }
87892b73 9257 $self->{make_clean} = CPAN::Distrostatus->new("YES");
c4d24d4c 9258
05454584 9259 } else {
c4d24d4c
A		 9260 # Hmmm, what to do if make clean failed?
9261
87892b73 9262 $self->{make_clean} = CPAN::Distrostatus->new("NO");
8962fc49 9263 $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
c4d24d4c 9264
87892b73
RGS		 9265 # 2006-02-27: seems silly to me to force a make now
9266 # $self->force("make"); # so that this directory won't be used again
c4d24d4c 9267
5f05dabc 9268 }
05bab18e 9269 $self->store_persistent_state;
5f05dabc 9270}
9271
810a0276 9272#-> sub CPAN::Distribution::goto ;
be34b10d
SP		 9273sub goto {
9274 my($self,$goto) = @_;
810a0276 9275 $goto = $self->normalize($goto);
f04ea8d1
SP		 9276 my $why = sprintf(
9277 "Goto '$goto' via prefs file '%s' doc %d",
9278 $self->{prefs_file},
9279 $self->{prefs_file_doc},
9280 );
9281 $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
9282 # 2007-07-16 akoenig : Better than NA would be if we could inherit
9283 # the status of the $goto distro but given the exceptional nature
9284 # of 'goto' I feel reluctant to implement it
9285 my $goodbye_message = "[goto] -- NA $why";
9286 $self->goodbye($goodbye_message);
810a0276
SP		 9287
9288 # inject into the queue
9289
9290 CPAN::Queue->delete($self->id);
f04ea8d1 9291 CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
810a0276
SP		 9292
9293 # and run where we left off
9294
be34b10d 9295 my($method) = (caller(1))[3];
8ce4ea0b 9296 CPAN->instance("CPAN::Distribution",$goto)->$method();
b72dd56f 9297 CPAN::Queue->delete_first($goto);
be34b10d
SP		 9298}
9299
9300#-> sub CPAN::Distribution::install ;
05454584 9301sub install {
5f05dabc 9302 my($self) = @_;
be34b10d
SP		 9303 if (my $goto = $self->prefs->{goto}) {
9304 return $self->goto($goto);
9305 }
23a216b4 9306 # $DB::single=1;
f20de9f0
SP		 9307 unless ($self->{badtestcnt}) {
9308 $self->test;
9309 }
f04ea8d1 9310 if ($CPAN::Signal) {
c4d24d4c
A		 9311 delete $self->{force_update};
9312 return;
9313 }
e82b9348
SP		 9314 my $make = $self->{modulebuild} ? "Build" : "make";
9315 $CPAN::Frontend->myprint("Running $make install\n");
05454584 9316 EXCUSE: {
f04ea8d1
SP		 9317 my @e;
9318 if ($self->{make} or $self->{later}) {
23a216b4
SP		 9319 # go ahead
9320 } else {
4d1321a7
A		 9321 push @e,
9322 "Make had some problems, won't install";
9323 }
5f05dabc 9324
f04ea8d1
SP		 9325 exists $self->{make} and
9326 (
be34b10d 9327 UNIVERSAL::can($self->{make},"failed") ?
44d21104
A		 9328 $self->{make}->failed :
9329 $self->{make} =~ /^NO/
9330 ) and
f04ea8d1 9331 push @e, "Make had returned bad status, install seems impossible";
6a935156
SP		 9332
9333 if (exists $self->{build_dir}) {
9334 } elsif (!@e) {
9335 push @e, "Has no own directory";
9336 }
05454584 9337
9ddc4ed0 9338 if (exists $self->{make_test} and
f04ea8d1 9339 (
be34b10d 9340 UNIVERSAL::can($self->{make_test},"failed") ?
44d21104
A		 9341 $self->{make_test}->failed :
9342 $self->{make_test} =~ /^NO/
f04ea8d1
SP		 9343 )) {
9344 if ($self->{force_update}) {
9ddc4ed0
A		 9345 $self->{make_test}->text("FAILED but failure ignored because ".
9346 "'force' in effect");
9347 } else {
9348 push @e, "make test had returned bad status, ".
9349 "won't install without force"
9350 }
9351 }
f04ea8d1 9352 if (exists $self->{install}) {
be34b10d
SP		 9353 if (UNIVERSAL::can($self->{install},"text") ?
9354 $self->{install}->text eq "YES" :
9355 $self->{install} =~ /^YES/
4d1321a7 9356 ) {
23a216b4
SP		 9357 $CPAN::Frontend->myprint(" Already done\n");
9358 $CPAN::META->is_installed($self->{build_dir});
9359 return 1;
4d1321a7
A		 9360 } else {
9361 # comment in Todo on 2006-02-11; maybe retry?
9362 push @e, "Already tried without success";
9363 }
9364 }
05454584 9365
23a216b4 9366 push @e, $self->{later} if $self->{later};
f04ea8d1 9367 push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
6d29edf5 9368
f04ea8d1 9369 $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
b72dd56f
SP		 9370 unless (chdir $self->{build_dir}) {
9371 push @e, "Couldn't chdir to '$self->{build_dir}': $!";
9372 }
f04ea8d1 9373 $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
05454584 9374 }
b72dd56f 9375 $self->debug("Changed directory to $self->{build_dir}")
f04ea8d1 9376 if $CPAN::DEBUG;
f14b5cec
JH		 9377
9378 if ($^O eq 'MacOS') {
be708cc0 9379 Mac::BuildTools::make_install($self);
f14b5cec
JH		 9380 return;
9381 }
9382
e82b9348 9383 my $system;
810a0276
SP		 9384 if (my $commandline = $self->prefs->{install}{commandline}) {
9385 $system = $commandline;
b03f445c 9386 $ENV{PERL} = CPAN::find_perl;
810a0276 9387 } elsif ($self->{modulebuild}) {
44d21104
A		 9388 my($mbuild_install_build_command) =
9389 exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
9390 $CPAN::Config->{mbuild_install_build_command} ?
9391 $CPAN::Config->{mbuild_install_build_command} :
9392 $self->_build_command();
9393 $system = sprintf("%s install %s",
9394 $mbuild_install_build_command,
9395 $CPAN::Config->{mbuild_install_arg},
9396 );
e82b9348 9397 } else {
1e8f9a0a 9398 my($make_install_make_command) =
6658a91b
SP		 9399 CPAN::HandleConfig->prefs_lookup($self,
9400 q{make_install_make_command})
9401 || $self->_make_command();
44d21104
A		 9402 $system = sprintf("%s install %s",
9403 $make_install_make_command,
9404 $CPAN::Config->{make_install_arg},
9405 );
e82b9348
SP		 9406 }
9407
87892b73 9408 my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
6658a91b
SP		 9409 my $brip = CPAN::HandleConfig->prefs_lookup($self,
9410 q{build_requires_install_policy});
1e8f9a0a 9411 $brip ||="ask/yes";
135a59c2 9412 my $id = $self->id;
6a935156 9413 my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
135a59c2
A		 9414 my $want_install = "yes";
9415 if ($reqtype eq "b") {
1e8f9a0a 9416 if ($brip eq "no") {
135a59c2 9417 $want_install = "no";
1e8f9a0a 9418 } elsif ($brip =~ m|^ask/(.+)|) {
135a59c2
A		 9419 my $default = $1;
9420 $default = "yes" unless $default =~ /^(y|n)/i;
9421 $want_install =
9422 CPAN::Shell::colorable_makemaker_prompt
9423 ("$id is just needed temporarily during building or testing. ".
9424 "Do you want to install it permanently? (Y/n)",
9425 $default);
9426 }
9427 }
9428 unless ($want_install =~ /^y/i) {
9429 my $is_only = "is only 'build_requires'";
9430 $CPAN::Frontend->mywarn("Not installing because $is_only\n");
9431 $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
9432 delete $self->{force_update};
9433 return;
9434 }
f04ea8d1
SP		 9435 local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
9436 ? $ENV{PERL5LIB}
9437 : ($ENV{PERLLIB} || "");
9438
5254b38e 9439 local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
f04ea8d1 9440 $CPAN::META->set_perl5lib;
5254b38e
SP		 9441 my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
9442("Can't execute $system: $!");
05454584 9443 my($makeout) = "";
f04ea8d1
SP		 9444 while (<$pipe>) {
9445 print $_; # intentionally NOT use Frontend->myprint because it
8962fc49
SP		 9446 # looks irritating when we markup in color what we
9447 # just pass through from an external program
f04ea8d1 9448 $makeout .= $_;
05454584
A		 9449 }
9450 $pipe->close;
05bab18e
SP		 9451 my $close_ok = $? == 0;
9452 $self->introduce_myself;
9453 if ( $close_ok ) {
44d21104
A		 9454 $CPAN::Frontend->myprint(" $system -- OK\n");
9455 $CPAN::META->is_installed($self->{build_dir});
b72dd56f 9456 $self->{install} = CPAN::Distrostatus->new("YES");
5f05dabc 9457 } else {
44d21104 9458 $self->{install} = CPAN::Distrostatus->new("NO");
8962fc49 9459 $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
1e8f9a0a 9460 my $mimc =
6658a91b
SP		 9461 CPAN::HandleConfig->prefs_lookup($self,
9462 q{make_install_make_command});
44d21104
A		 9463 if (
9464 $makeout =~ /permission/s
9465 && $> > 0
9466 && (
1e8f9a0a 9467 ! $mimc
6658a91b
SP		 9468 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
9469 q{make}))
44d21104
A		 9470 )
9471 ) {
9472 $CPAN::Frontend->myprint(
9473 qq{----\n}.
9474 qq{ You may have to su }.
9475 qq{to root to install the package\n}.
9476 qq{ (Or you may want to run something like\n}.
9477 qq{ o conf make_install_make_command 'sudo make'\n}.
9478 qq{ to raise your permissions.}
9479 );
9480 }
5f05dabc 9481 }
c4d24d4c 9482 delete $self->{force_update};
b72dd56f 9483 # $DB::single = 1;
05bab18e
SP		 9484 $self->store_persistent_state;
9485}
9486
9487sub introduce_myself {
9488 my($self) = @_;
9489 $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
5f05dabc 9490}
9491
05454584
A		 9492#-> sub CPAN::Distribution::dir ;
9493sub dir {
b72dd56f 9494 shift->{build_dir};
5f05dabc 9495}
9496
554a9ef5
SP		 9497#-> sub CPAN::Distribution::perldoc ;
9498sub perldoc {
f3fe0ae6 9499 my($self) = @_;
554a9ef5
SP		 9500
9501 my($dist) = $self->id;
9502 my $package = $self->called_for;
9503
9504 $self->_display_url( $CPAN::Defaultdocs . $package );
9505}
9506
9507#-> sub CPAN::Distribution::_check_binary ;
9508sub _check_binary {
f3fe0ae6 9509 my ($dist,$shell,$binary) = @_;
4d1321a7 9510 my ($pid,$out);
554a9ef5
SP		 9511
9512 $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
9513 if $CPAN::DEBUG;
9514
05bab18e
SP		 9515 if ($CPAN::META->has_inst("File::Which")) {
9516 return File::Which::which($binary);
9517 } else {
9518 local *README;
9519 $pid = open README, "which $binary|"
9520 or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
9521 return unless $pid;
9522 while (<README>) {
9523 $out .= $_;
9524 }
9525 close README
9526 or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
9527 and return;
554a9ef5 9528 }
554a9ef5
SP		 9529
9530 $CPAN::Frontend->myprint(qq{ + $out \n})
9531 if $CPAN::DEBUG && $out;
9532
9533 return $out;
9534}
9535
9536#-> sub CPAN::Distribution::_display_url ;
9537sub _display_url {
f3fe0ae6 9538 my($self,$url) = @_;
4d1321a7 9539 my($res,$saved_file,$pid,$out);
554a9ef5
SP		 9540
9541 $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
9542 if $CPAN::DEBUG;
9543
9544 # should we define it in the config instead?
f04ea8d1 9545 my $html_converter = "html2text.pl";
554a9ef5
SP		 9546
9547 my $web_browser = $CPAN::Config->{'lynx'} || undef;
9548 my $web_browser_out = $web_browser
f04ea8d1
SP		 9549 ? CPAN::Distribution->_check_binary($self,$web_browser)
9550 : undef;
554a9ef5 9551
4d1321a7
A		 9552 if ($web_browser_out) {
9553 # web browser found, run the action
f04ea8d1 9554 my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
4d1321a7 9555 $CPAN::Frontend->myprint(qq{system[$browser $url]})
f04ea8d1
SP		 9556 if $CPAN::DEBUG;
9557 $CPAN::Frontend->myprint(qq{
4d1321a7
A		 9558Displaying URL
9559 $url
9560with browser $browser
9561});
f04ea8d1 9562 $CPAN::Frontend->mysleep(1);
4d1321a7 9563 system("$browser $url");
f04ea8d1 9564 if ($saved_file) { 1 while unlink($saved_file) }
4d1321a7 9565 } else {
554a9ef5 9566 # web browser not found, let's try text only
f04ea8d1
SP		 9567 my $html_converter_out =
9568 CPAN::Distribution->_check_binary($self,$html_converter);
ed84aac9 9569 $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
554a9ef5
SP		 9570
9571 if ($html_converter_out ) {
9572 # html2text found, run it
9573 $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
4d1321a7
A		 9574 $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
9575 unless defined($saved_file);
554a9ef5 9576
4d1321a7 9577 local *README;
f04ea8d1
SP		 9578 $pid = open README, "$html_converter $saved_file |"
9579 or $CPAN::Frontend->mydie(qq{
0a78cd5d 9580Could not fork '$html_converter $saved_file': $!});
4d1321a7 9581 my($fh,$filename);
b03f445c 9582 if ($CPAN::META->has_usable("File::Temp")) {
4d1321a7 9583 $fh = File::Temp->new(
917f1700 9584 dir => File::Spec->tmpdir,
4d1321a7
A		 9585 template => 'cpan_htmlconvert_XXXX',
9586 suffix => '.txt',
9587 unlink => 0,
9588 );
9589 $filename = $fh->filename;
9590 } else {
9591 $filename = "cpan_htmlconvert_$$.txt";
9592 $fh = FileHandle->new();
9593 open $fh, ">$filename" or die;
9594 }
9595 while (<README>) {
554a9ef5
SP		 9596 $fh->print($_);
9597 }
4d1321a7
A		 9598 close README or
9599 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
554a9ef5 9600 my $tmpin = $fh->filename;
4d1321a7 9601 $CPAN::Frontend->myprint(sprintf(qq{
554a9ef5
SP		 9602Run '%s %s' and
9603saved output to %s\n},
9604 $html_converter,
9605 $saved_file,
9606 $tmpin,
9607 )) if $CPAN::DEBUG;
4d1321a7
A		 9608 close $fh;
9609 local *FH;
9610 open FH, $tmpin
9611 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
554a9ef5
SP		 9612 my $fh_pager = FileHandle->new;
9613 local($SIG{PIPE}) = "IGNORE";
ed84aac9 9614 my $pager = $CPAN::Config->{'pager'} || "cat";
135a59c2 9615 $fh_pager->open("|$pager")
4d1321a7 9616 or $CPAN::Frontend->mydie(qq{
135a59c2 9617Could not open pager '$pager': $!});
4d1321a7 9618 $CPAN::Frontend->myprint(qq{
554a9ef5
SP		 9619Displaying URL
9620 $url
ed84aac9 9621with pager "$pager"
554a9ef5 9622});
8962fc49 9623 $CPAN::Frontend->mysleep(1);
4d1321a7
A		 9624 $fh_pager->print(<FH>);
9625 $fh_pager->close;
554a9ef5
SP		 9626 } else {
9627 # coldn't find the web browser or html converter
9628 $CPAN::Frontend->myprint(qq{
9629You need to install lynx or $html_converter to use this feature.});
9630 }
554a9ef5
SP		 9631 }
9632}
9633
9634#-> sub CPAN::Distribution::_getsave_url ;
9635sub _getsave_url {
f3fe0ae6 9636 my($dist, $shell, $url) = @_;
554a9ef5
SP		 9637
9638 $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
9639 if $CPAN::DEBUG;
9640
4d1321a7 9641 my($fh,$filename);
b03f445c 9642 if ($CPAN::META->has_usable("File::Temp")) {
4d1321a7 9643 $fh = File::Temp->new(
917f1700 9644 dir => File::Spec->tmpdir,
554a9ef5
SP		 9645 template => "cpan_getsave_url_XXXX",
9646 suffix => ".html",
9647 unlink => 0,
9648 );
4d1321a7
A		 9649 $filename = $fh->filename;
9650 } else {
9651 $fh = FileHandle->new;
9652 $filename = "cpan_getsave_url_$$.html";
9653 }
9654 my $tmpin = $filename;
554a9ef5
SP		 9655 if ($CPAN::META->has_usable('LWP')) {
9656 $CPAN::Frontend->myprint("Fetching with LWP:
9657 $url
9658");
9659 my $Ua;
9660 CPAN::LWP::UserAgent->config;
4d1321a7
A		 9661 eval { $Ua = CPAN::LWP::UserAgent->new; };
9662 if ($@) {
9663 $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
9664 return;
9665 } else {
9666 my($var);
9667 $Ua->proxy('http', $var)
554a9ef5 9668 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
4d1321a7 9669 $Ua->no_proxy($var)
554a9ef5 9670 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
4d1321a7 9671 }
554a9ef5
SP		 9672
9673 my $req = HTTP::Request->new(GET => $url);
9674 $req->header('Accept' => 'text/html');
9675 my $res = $Ua->request($req);
9676 if ($res->is_success) {
9677 $CPAN::Frontend->myprint(" + request successful.\n")
9678 if $CPAN::DEBUG;
9679 print $fh $res->content;
9680 close $fh;
9681 $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
9682 if $CPAN::DEBUG;
9683 return $tmpin;
9684 } else {
9685 $CPAN::Frontend->myprint(sprintf(
9686 "LWP failed with code[%s], message[%s]\n",
9687 $res->code,
9688 $res->message,
9689 ));
9690 return;
9691 }
9692 } else {
8962fc49 9693 $CPAN::Frontend->mywarn(" LWP not available\n");
554a9ef5
SP		 9694 return;
9695 }
9696}
9697
f04ea8d1 9698#-> sub CPAN::Distribution::_build_command
44d21104
A		 9699sub _build_command {
9700 my($self) = @_;
9701 if ($^O eq "MSWin32") { # special code needed at least up to
9702 # Module::Build 0.2611 and 0.2706; a fix
9703 # in M:B has been promised 2006-01-30
9704 my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
9705 return "$perl ./Build";
9706 }
9707 return "./Build";
9708}
9709
f04ea8d1
SP		 9710#-> sub CPAN::Distribution::_should_report
9711sub _should_report {
9712 my($self, $phase) = @_;
9713 die "_should_report() requires a 'phase' argument"
9714 if ! defined $phase;
9715
9716 # configured
9717 my $test_report = CPAN::HandleConfig->prefs_lookup($self,
9718 q{test_report});
9719 return unless $test_report;
9720
9721 # don't repeat if we cached a result
9722 return $self->{should_report}
9723 if exists $self->{should_report};
9724
5254b38e
SP		 9725 # don't report if we generated a Makefile.PL
9726 if ( $self->{had_no_makefile_pl} ) {
9727 $CPAN::Frontend->mywarn(
9728 "Will not send CPAN Testers report with generated Makefile.PL.\n"
9729 );
9730 return $self->{should_report} = 0;
9731 }
9732
f04ea8d1
SP		 9733 # available
9734 if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
9735 $CPAN::Frontend->mywarn(
9736 "CPAN::Reporter not installed. No reports will be sent.\n"
9737 );
9738 return $self->{should_report} = 0;
9739 }
9740
9741 # capable
9742 my $crv = CPAN::Reporter->VERSION;
9743 if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
9744 # don't cache $self->{should_report} -- need to check each phase
9745 if ( $phase eq 'test' ) {
9746 return 1;
9747 }
9748 else {
9749 $CPAN::Frontend->mywarn(
9750 "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
9751 "you only have version $crv\. Only 'test' phase reports will be sent.\n"
9752 );
9753 return;
9754 }
9755 }
9756
9757 # appropriate
9758 if ($self->is_dot_dist) {
9759 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9760 "for local directories\n");
9761 return $self->{should_report} = 0;
9762 }
9763 if ($self->prefs->{patches}
9764 &&
9765 @{$self->prefs->{patches}}
9766 &&
9767 $self->{patched}
9768 ) {
9769 $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
9770 "when the source has been patched\n");
9771 return $self->{should_report} = 0;
9772 }
9773
9774 # proceed and cache success
9775 return $self->{should_report} = 1;
9776}
9777
dc053c64
SP		 9778#-> sub CPAN::Distribution::reports
9779sub reports {
9780 my($self) = @_;
9781 my $pathname = $self->id;
9782 $CPAN::Frontend->myprint("Distribution: $pathname\n");
9783
9784 unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
9785 $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
9786 }
9787 unless ($CPAN::META->has_usable("LWP")) {
9788 $CPAN::Frontend->mydie("LWP not installed; cannot continue");
9789 }
b03f445c 9790 unless ($CPAN::META->has_usable("File::Temp")) {
dc053c64
SP		 9791 $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
9792 }
9793
9794 my $d = CPAN::DistnameInfo->new($pathname);
9795
9796 my $dist = $d->dist; # "CPAN-DistnameInfo"
9797 my $version = $d->version; # "0.02"
9798 my $maturity = $d->maturity; # "released"
9799 my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
9800 my $cpanid = $d->cpanid; # "GBARR"
9801 my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
9802
9803 my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
9804
9805 CPAN::LWP::UserAgent->config;
9806 my $Ua;
9807 eval { $Ua = CPAN::LWP::UserAgent->new; };
9808 if ($@) {
9809 $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
9810 }
9811 $CPAN::Frontend->myprint("Fetching '$url'...");
9812 my $resp = $Ua->get($url);
9813 unless ($resp->is_success) {
9814 $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
9815 }
9816 $CPAN::Frontend->myprint("DONE\n\n");
9817 my $yaml = $resp->content;
9818 # was fuer ein Umweg!
9819 my $fh = File::Temp->new(
917f1700 9820 dir => File::Spec->tmpdir,
dc053c64
SP		 9821 template => 'cpan_reports_XXXX',
9822 suffix => '.yaml',
9823 unlink => 0,
9824 );
9825 my $tfilename = $fh->filename;
9826 print $fh $yaml;
9827 close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
9828 my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
9829 unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
9830 my %other_versions;
9831 my $this_version_seen;
9832 for my $rep (@$unserialized) {
9833 my $rversion = $rep->{version};
f04ea8d1 9834 if ($rversion eq $version) {
dc053c64
SP		 9835 unless ($this_version_seen++) {
9836 $CPAN::Frontend->myprint ("$rep->{version}:\n");
9837 }
9838 $CPAN::Frontend->myprint
9839 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
9840 $rep->{archname} eq $Config::Config{archname}?"*":"",
9841 $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
9842 $rep->{action},
9843 $rep->{perl},
9844 ucfirst $rep->{osname},
9845 $rep->{osvers},
9846 $rep->{archname},
9847 ));
9848 } else {
9849 $other_versions{$rep->{version}}++;
9850 }
9851 }
9852 unless ($this_version_seen) {
9853 $CPAN::Frontend->myprint("No reports found for version '$version'
9854Reports for other versions:\n");
9855 for my $v (sort keys %other_versions) {
9856 $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
9857 }
9858 }
9859 $url =~ s/\.yaml/.html/;
9860 $CPAN::Frontend->myprint("See $url for details\n");
9861}
9862
05454584 9863package CPAN::Bundle;
e82b9348 9864use strict;
5f05dabc 9865
e662ec5f
A		 9866sub look {
9867 my $self = shift;
35576f8c 9868 $CPAN::Frontend->myprint($self->as_string);
e662ec5f
A		 9869}
9870
23a216b4 9871#-> CPAN::Bundle::undelay
6d29edf5
JH		 9872sub undelay {
9873 my $self = shift;
9874 delete $self->{later};
9875 for my $c ( $self->contains ) {
9876 my $obj = CPAN::Shell->expandany($c) or next;
9877 $obj->undelay;
9878 }
9879}
9880
e82b9348 9881# mark as dirty/clean
6d29edf5
JH		 9882#-> sub CPAN::Bundle::color_cmd_tmps ;
9883sub color_cmd_tmps {
9884 my($self) = shift;
9885 my($depth) = shift || 0;
9886 my($color) = shift || 0;
35576f8c 9887 my($ancestors) = shift || [];
6d29edf5
JH		 9888 # a module needs to recurse to its cpan_file, a distribution needs
9889 # to recurse into its prereq_pms, a bundle needs to recurse into its modules
9890
9891 return if exists $self->{incommandcolor}
f20de9f0 9892 && $color==1
6d29edf5 9893 && $self->{incommandcolor}==$color;
f04ea8d1 9894 if ($depth>=$CPAN::MAX_RECURSION) {
ade94d80 9895 die(CPAN::Exception::RecursiveDependency->new($ancestors));
35576f8c
A		 9896 }
9897 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6d29edf5
JH		 9898
9899 for my $c ( $self->contains ) {
9900 my $obj = CPAN::Shell->expandany($c) or next;
9901 CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
35576f8c 9902 $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6d29edf5 9903 }
b72dd56f
SP		 9904 # never reached code?
9905 #if ($color==0) {
9906 #delete $self->{badtestcnt};
9907 #}
6d29edf5
JH		 9908 $self->{incommandcolor} = $color;
9909}
9910
05454584
A		 9911#-> sub CPAN::Bundle::as_string ;
9912sub as_string {
9913 my($self) = @_;
9914 $self->contains;
5e05dca5 9915 # following line must be "=", not "||=" because we have a moving target
6d29edf5 9916 $self->{INST_VERSION} = $self->inst_version;
05454584
A		 9917 return $self->SUPER::as_string;
9918}
9919
9920#-> sub CPAN::Bundle::contains ;
9921sub contains {
c049f953
JH		 9922 my($self) = @_;
9923 my($inst_file) = $self->inst_file || "";
9924 my($id) = $self->id;
9925 $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
b96578bb
SP		 9926 if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
9927 undef $inst_file;
9928 }
c049f953
JH		 9929 unless ($inst_file) {
9930 # Try to get at it in the cpan directory
9931 $self->debug("no inst_file") if $CPAN::DEBUG;
9932 my $cpan_file;
9933 $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
9934 $cpan_file = $self->cpan_file;
9935 if ($cpan_file eq "N/A") {
9936 $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
9937 Maybe stale symlink? Maybe removed during session? Giving up.\n");
9938 }
9939 my $dist = $CPAN::META->instance('CPAN::Distribution',
9940 $self->cpan_file);
b72dd56f 9941 $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
c049f953 9942 $dist->get;
b72dd56f 9943 $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
c049f953
JH		 9944 my($todir) = $CPAN::Config->{'cpan_home'};
9945 my(@me,$from,$to,$me);
9946 @me = split /::/, $self->id;
9947 $me[-1] .= ".pm";
5de3f0da 9948 $me = File::Spec->catfile(@me);
b72dd56f 9949 $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
5de3f0da 9950 $to = File::Spec->catfile($todir,$me);
c049f953
JH		 9951 File::Path::mkpath(File::Basename::dirname($to));
9952 File::Copy::copy($from, $to)
9953 or Carp::confess("Couldn't copy $from to $to: $!");
9954 $inst_file = $to;
9955 }
9956 my @result;
9957 my $fh = FileHandle->new;
9958 local $/ = "\n";
9959 open($fh,$inst_file) or die "Could not open '$inst_file': $!";
9960 my $in_cont = 0;
9961 $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
9962 while (<$fh>) {
5254b38e
SP		 9963 $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
9964 m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
c049f953
JH		 9965 next unless $in_cont;
9966 next if /^=/;
9967 s/\#.*//;
9968 next if /^\s+$/;
9969 chomp;
9970 push @result, (split " ", $_, 2)[0];
9971 }
9972 close $fh;
9973 delete $self->{STATUS};
9974 $self->{CONTAINS} = \@result;
9975 $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
9976 unless (@result) {
9977 $CPAN::Frontend->mywarn(qq{
9978The bundle file "$inst_file" may be a broken
2e2b7522
GS		 9979bundlefile. It seems not to contain any bundle definition.
9980Please check the file and if it is bogus, please delete it.
9981Sorry for the inconvenience.
9982});
c049f953
JH		 9983 }
9984 @result;
5f05dabc 9985}
9986
e50380aa 9987#-> sub CPAN::Bundle::find_bundle_file
b96578bb 9988# $where is in local format, $what is in unix format
e50380aa
A		 9989sub find_bundle_file {
9990 my($self,$where,$what) = @_;
c356248b 9991 $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
2e2b7522 9992### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
5de3f0da 9993### my $bu = File::Spec->catfile($where,$what);
2e2b7522 9994### return $bu if -f $bu;
5de3f0da 9995 my $manifest = File::Spec->catfile($where,"MANIFEST");
e50380aa 9996 unless (-f $manifest) {
f04ea8d1
SP		 9997 require ExtUtils::Manifest;
9998 my $cwd = CPAN::anycwd();
9999 $self->safe_chdir($where);
10000 ExtUtils::Manifest::mkmanifest();
10001 $self->safe_chdir($cwd);
e50380aa 10002 }
c356248b 10003 my $fh = FileHandle->new($manifest)
f04ea8d1 10004 or Carp::croak("Couldn't open $manifest: $!");
e50380aa 10005 local($/) = "\n";
b96578bb
SP		 10006 my $bundle_filename = $what;
10007 $bundle_filename =~ s|Bundle.*/||;
10008 my $bundle_unixpath;
e50380aa 10009 while (<$fh>) {
f04ea8d1
SP		 10010 next if /^\s*\#/;
10011 my($file) = /(\S+)/;
10012 if ($file =~ m|\Q$what\E$|) {
10013 $bundle_unixpath = $file;
10014 # return File::Spec->catfile($where,$bundle_unixpath); # bad
10015 last;
10016 }
10017 # retry if she managed to have no Bundle directory
10018 $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
e50380aa 10019 }
b96578bb
SP		 10020 return File::Spec->catfile($where, split /\//, $bundle_unixpath)
10021 if $bundle_unixpath;
c356248b 10022 Carp::croak("Couldn't find a Bundle file in $where");
e50380aa
A		 10023}
10024
d8773709
JH		 10025# needs to work quite differently from Module::inst_file because of
10026# cpan_home/Bundle/ directory and the possibility that we have
10027# shadowing effect. As it makes no sense to take the first in @INC for
10028# Bundles, we parse them all for $VERSION and take the newest.
6d29edf5 10029
05454584
A		 10030#-> sub CPAN::Bundle::inst_file ;
10031sub inst_file {
10032 my($self) = @_;
6d29edf5
JH		 10033 my($inst_file);
10034 my(@me);
10035 @me = split /::/, $self->id;
10036 $me[-1] .= ".pm";
d8773709
JH		 10037 my($incdir,$bestv);
10038 foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
5254b38e
SP		 10039 my $parsefile = File::Spec->catfile($incdir, @me);
10040 CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
10041 next unless -f $parsefile;
10042 my $have = eval { MM->parse_version($parsefile); };
10043 if ($@) {
10044 $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
10045 }
10046 if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
10047 $self->{INST_FILE} = $parsefile;
10048 $self->{INST_VERSION} = $bestv = $have;
d8773709
JH		 10049 }
10050 }
10051 $self->{INST_FILE};
10052}
10053
10054#-> sub CPAN::Bundle::inst_version ;
10055sub inst_version {
10056 my($self) = @_;
10057 $self->inst_file; # finds INST_VERSION as side effect
10058 $self->{INST_VERSION};
5f05dabc 10059}
10060
05454584
A		 10061#-> sub CPAN::Bundle::rematein ;
10062sub rematein {
10063 my($self,$meth) = @_;
10064 $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
c356248b
A		 10065 my($id) = $self->id;
10066 Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
f04ea8d1 10067 unless $self->inst_file || $self->cpan_file;
f610777f 10068 my($s,%fail);
05454584 10069 for $s ($self->contains) {
f04ea8d1
SP		 10070 my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
10071 $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
10072 if ($type eq 'CPAN::Distribution') {
10073 $CPAN::Frontend->mywarn(qq{
05454584 10074The Bundle }.$self->id.qq{ contains
6658a91b
SP		 10075explicitly a file '$s'.
10076Going to $meth that.
c356248b 10077});
f04ea8d1
SP		 10078 $CPAN::Frontend->mysleep(5);
10079 }
10080 # possibly noisy action:
de34a54b 10081 $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
f04ea8d1 10082 my $obj = $CPAN::META->instance($type,$s);
135a59c2 10083 $obj->{reqtype} = $self->{reqtype};
f04ea8d1 10084 $obj->$meth();
5f05dabc 10085 }
5f05dabc 10086}
10087
87892b73
RGS		 10088# If a bundle contains another that contains an xs_file we have here,
10089# we just don't bother I suppose
10090#-> sub CPAN::Bundle::xs_file
e50380aa 10091sub xs_file {
e50380aa
A		 10092 return 0;
10093}
10094
05454584 10095#-> sub CPAN::Bundle::force ;
b72dd56f
SP		 10096sub fforce { shift->rematein('fforce',@_); }
10097#-> sub CPAN::Bundle::force ;
05454584 10098sub force { shift->rematein('force',@_); }
554a9ef5
SP		 10099#-> sub CPAN::Bundle::notest ;
10100sub notest { shift->rematein('notest',@_); }
05454584
A		 10101#-> sub CPAN::Bundle::get ;
10102sub get { shift->rematein('get',@_); }
10103#-> sub CPAN::Bundle::make ;
10104sub make { shift->rematein('make',@_); }
10105#-> sub CPAN::Bundle::test ;
6d29edf5
JH		 10106sub test {
10107 my $self = shift;
b72dd56f 10108 # $self->{badtestcnt} ||= 0;
6d29edf5
JH		 10109 $self->rematein('test',@_);
10110}
05454584 10111#-> sub CPAN::Bundle::install ;
09d9d230
A		 10112sub install {
10113 my $self = shift;
10114 $self->rematein('install',@_);
09d9d230 10115}
05454584
A		 10116#-> sub CPAN::Bundle::clean ;
10117sub clean { shift->rematein('clean',@_); }
5f05dabc 10118
d8773709
JH		 10119#-> sub CPAN::Bundle::uptodate ;
10120sub uptodate {
10121 my($self) = @_;
10122 return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
10123 my $c;
10124 foreach $c ($self->contains) {
10125 my $obj = CPAN::Shell->expandany($c);
10126 return 0 unless $obj->uptodate;
10127 }
10128 return 1;
10129}
10130
05454584
A		 10131#-> sub CPAN::Bundle::readme ;
10132sub readme {
10133 my($self) = @_;
c356248b
A		 10134 my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
10135No File found for bundle } . $self->id . qq{\n}), return;
05454584
A		 10136 $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
10137 $CPAN::META->instance('CPAN::Distribution',$file)->readme;
5f05dabc 10138}
10139
05454584 10140package CPAN::Module;
e82b9348 10141use strict;
5f05dabc 10142
6d29edf5 10143# Accessors
dc053c64 10144#-> sub CPAN::Module::userid
6d29edf5
JH		 10145sub userid {
10146 my $self = shift;
0cf35e6a
SP		 10147 my $ro = $self->ro;
10148 return unless $ro;
10149 return $ro->{userid} || $ro->{CPAN_USERID};
6d29edf5 10150}
dc053c64 10151#-> sub CPAN::Module::description
9ddc4ed0
A		 10152sub description {
10153 my $self = shift;
10154 my $ro = $self->ro or return "";
10155 $ro->{description}
10156}
6d29edf5 10157
dc053c64 10158#-> sub CPAN::Module::distribution
c9869e1c
SP		 10159sub distribution {
10160 my($self) = @_;
10161 CPAN::Shell->expand("Distribution",$self->cpan_file);
10162}
10163
5254b38e
SP		 10164#-> sub CPAN::Module::_is_representative_module
10165sub _is_representative_module {
10166 my($self) = @_;
10167 return $self->{_is_representative_module} if defined $self->{_is_representative_module};
10168 my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
10169 $pm =~ s|.+/||;
10170 $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
10171 $pm =~ s|-\d+\.\d+.+$||;
10172 $pm =~ s|-[\d\.]+$||;
10173 $pm =~ s/-/::/g;
10174 $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
10175 # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
10176 $self->{_is_representative_module};
10177}
10178
dc053c64 10179#-> sub CPAN::Module::undelay
6d29edf5
JH		 10180sub undelay {
10181 my $self = shift;
10182 delete $self->{later};
10183 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
10184 $dist->undelay;
10185 }
10186}
10187
e82b9348 10188# mark as dirty/clean
6d29edf5
JH		 10189#-> sub CPAN::Module::color_cmd_tmps ;
10190sub color_cmd_tmps {
10191 my($self) = shift;
10192 my($depth) = shift || 0;
10193 my($color) = shift || 0;
35576f8c 10194 my($ancestors) = shift || [];
6d29edf5
JH		 10195 # a module needs to recurse to its cpan_file
10196
10197 return if exists $self->{incommandcolor}
f20de9f0 10198 && $color==1
6d29edf5 10199 && $self->{incommandcolor}==$color;
f20de9f0
SP		 10200 return if $color==0 && !$self->{incommandcolor};
10201 if ($color>=1) {
10202 if ( $self->uptodate ) {
10203 $self->{incommandcolor} = $color;
10204 return;
10205 } elsif (my $have_version = $self->available_version) {
10206 # maybe what we have is good enough
10207 if (@$ancestors) {
10208 my $who_asked_for_me = $ancestors->[-1];
10209 my $obj = CPAN::Shell->expandany($who_asked_for_me);
10210 if (0) {
10211 } elsif ($obj->isa("CPAN::Bundle")) {
10212 # bundles cannot specify a minimum version
10213 return;
10214 } elsif ($obj->isa("CPAN::Distribution")) {
10215 if (my $prereq_pm = $obj->prereq_pm) {
10216 for my $k (keys %$prereq_pm) {
10217 if (my $want_version = $prereq_pm->{$k}{$self->id}) {
10218 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
10219 $self->{incommandcolor} = $color;
10220 return;
10221 }
10222 }
10223 }
10224 }
10225 }
10226 }
10227 }
10228 } else {
10229 $self->{incommandcolor} = $color; # set me before recursion,
10230 # so we can break it
10231 }
f04ea8d1 10232 if ($depth>=$CPAN::MAX_RECURSION) {
ade94d80 10233 die(CPAN::Exception::RecursiveDependency->new($ancestors));
35576f8c
A		 10234 }
10235 # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
6d29edf5
JH		 10236
10237 if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
35576f8c 10238 $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
6d29edf5 10239 }
b72dd56f
SP		 10240 # unreached code?
10241 # if ($color==0) {
10242 # delete $self->{badtestcnt};
10243 # }
6d29edf5
JH		 10244 $self->{incommandcolor} = $color;
10245}
10246
05454584
A		 10247#-> sub CPAN::Module::as_glimpse ;
10248sub as_glimpse {
10249 my($self) = @_;
10250 my(@m);
10251 my $class = ref($self);
10252 $class =~ s/^CPAN:://;
9d61fa1d
A		 10253 my $color_on = "";
10254 my $color_off = "";
10255 if (
10256 $CPAN::Shell::COLOR_REGISTERED
10257 &&
10258 $CPAN::META->has_inst("Term::ANSIColor")
10259 &&
0cf35e6a 10260 $self->description
9d61fa1d
A		 10261 ) {
10262 $color_on = Term::ANSIColor::color("green");
10263 $color_off = Term::ANSIColor::color("reset");
10264 }
ed84aac9 10265 my $uptodateness = " ";
ecc7fca0
A		 10266 unless ($class eq "Bundle") {
10267 my $u = $self->uptodate;
10268 $uptodateness = $u ? "=" : "<" if defined $u;
10269 };
10270 my $id = do {
10271 my $d = $self->distribution;
10272 $d ? $d -> pretty_id : $self->cpan_userid;
10273 };
ed84aac9 10274 push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9d61fa1d 10275 $class,
ed84aac9 10276 $uptodateness,
9d61fa1d
A		 10277 $color_on,
10278 $self->id,
10279 $color_off,
ecc7fca0 10280 $id,
c9869e1c 10281 );
05454584
A		 10282 join "", @m;
10283}
5f05dabc 10284
87892b73
RGS		 10285#-> sub CPAN::Module::dslip_status
10286sub dslip_status {
10287 my($self) = @_;
10288 my($stat);
f20de9f0 10289 # development status
87892b73
RGS		 10290 @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
10291 pre-alpha alpha beta released
10292 mature standard,;
f20de9f0 10293 # support level
87892b73
RGS		 10294 @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
10295 developer comp.lang.perl.*
10296 none abandoned,;
f20de9f0 10297 # language
87892b73 10298 @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
f20de9f0 10299 # interface
87892b73
RGS		 10300 @{$stat->{I}}{qw,f r O p h n,} = qw,functions
10301 references+ties
10302 object-oriented pragma
10303 hybrid none,;
f20de9f0 10304 # public licence
f04ea8d1 10305 @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
87892b73 10306 GPL LGPL
f04ea8d1 10307 BSD Artistic Artistic_2
87892b73
RGS		 10308 open-source
10309 distribution_allowed
10310 restricted_distribution
10311 no_licence,;
10312 for my $x (qw(d s l i p)) {
10313 $stat->{$x}{' '} = 'unknown';
10314 $stat->{$x}{'?'} = 'unknown';
10315 }
10316 my $ro = $self->ro;
10317 return +{} unless $ro && $ro->{statd};
10318 return {
10319 D => $ro->{statd},
10320 S => $ro->{stats},
10321 L => $ro->{statl},
10322 I => $ro->{stati},
10323 P => $ro->{statp},
10324 DV => $stat->{D}{$ro->{statd}},
10325 SV => $stat->{S}{$ro->{stats}},
10326 LV => $stat->{L}{$ro->{statl}},
10327 IV => $stat->{I}{$ro->{stati}},
10328 PV => $stat->{P}{$ro->{statp}},
10329 };
10330}
10331
05454584
A		 10332#-> sub CPAN::Module::as_string ;
10333sub as_string {
10334 my($self) = @_;
10335 my(@m);
35576f8c 10336 CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
05454584
A		 10337 my $class = ref($self);
10338 $class =~ s/^CPAN:://;
10339 local($^W) = 0;
10340 push @m, $class, " id = $self->{ID}\n";
10341 my $sprintf = " %-12s %s\n";
6d29edf5 10342 push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
f04ea8d1 10343 if $self->description;
05454584
A		 10344 my $sprintf2 = " %-12s %s (%s)\n";
10345 my($userid);
35576f8c 10346 $userid = $self->userid;
f04ea8d1
SP		 10347 if ( $userid ) {
10348 my $author;
10349 if ($author = CPAN::Shell->expand('Author',$userid)) {
10350 my $email = "";
10351 my $m; # old perls
10352 if ($m = $author->email) {
10353 $email = " <$m>";
10354 }
10355 push @m, sprintf(
10356 $sprintf2,
10357 'CPAN_USERID',
10358 $userid,
10359 $author->fullname . $email
10360 );
10361 }
c356248b 10362 }
6d29edf5 10363 push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
f04ea8d1
SP		 10364 if $self->cpan_version;
10365 if (my $cpan_file = $self->cpan_file) {
554a9ef5
SP		 10366 push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
10367 if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
10368 my $upload_date = $dist->upload_date;
10369 if ($upload_date) {
10370 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
10371 }
10372 }
10373 }
87892b73
RGS		 10374 my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
10375 my $dslip = $self->dslip_status;
05454584 10376 push @m, sprintf(
87892b73
RGS		 10377 $sprintf3,
10378 'DSLIP_STATUS',
10379 @{$dslip}{qw(D S L I P DV SV LV IV PV)},
ed84aac9 10380 ) if $dslip->{D};
05454584 10381 my $local_file = $self->inst_file;
9d61fa1d 10382 unless ($self->{MANPAGE}) {
ed84aac9 10383 my $manpage;
9d61fa1d 10384 if ($local_file) {
ed84aac9 10385 $manpage = $self->manpage_headline($local_file);
9d61fa1d
A		 10386 } else {
10387 # If we have already untarred it, we should look there
10388 my $dist = $CPAN::META->instance('CPAN::Distribution',
10389 $self->cpan_file);
10390 # warn "dist[$dist]";
10391 # mff=manifest file; mfh=manifest handle
10392 my($mff,$mfh);
c049f953
JH		 10393 if (
10394 $dist->{build_dir}
10395 and
5de3f0da 10396 (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
c049f953 10397 and
9d61fa1d
A		 10398 $mfh = FileHandle->new($mff)
10399 ) {
8d97e4a1 10400 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9d61fa1d
A		 10401 my $lfre = $self->id; # local file RE
10402 $lfre =~ s/::/./g;
10403 $lfre .= "\\.pm\$";
10404 my($lfl); # local file file
10405 local $/ = "\n";
10406 my(@mflines) = <$mfh>;
8d97e4a1
JH		 10407 for (@mflines) {
10408 s/^\s+//;
10409 s/\s.*//s;
10410 }
9d61fa1d
A		 10411 while (length($lfre)>5 and !$lfl) {
10412 ($lfl) = grep /$lfre/, @mflines;
8d97e4a1 10413 CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9d61fa1d 10414 $lfre =~ s/.+?\.//;
9d61fa1d
A		 10415 }
10416 $lfl =~ s/\s.*//; # remove comments
10417 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
5de3f0da 10418 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9d61fa1d
A		 10419 # warn "lfl_abs[$lfl_abs]";
10420 if (-f $lfl_abs) {
ed84aac9 10421 $manpage = $self->manpage_headline($lfl_abs);
9d61fa1d
A		 10422 }
10423 }
10424 }
ed84aac9 10425 $self->{MANPAGE} = $manpage if $manpage;
5f05dabc 10426 }
d4fd5c69 10427 my($item);
6d29edf5 10428 for $item (qw/MANPAGE/) {
f04ea8d1
SP		 10429 push @m, sprintf($sprintf, $item, $self->{$item})
10430 if exists $self->{$item};
d4fd5c69 10431 }
6d29edf5 10432 for $item (qw/CONTAINS/) {
f04ea8d1
SP		 10433 push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
10434 if exists $self->{$item} && @{$self->{$item}};
6d29edf5 10435 }
c356248b 10436 push @m, sprintf($sprintf, 'INST_FILE',
f04ea8d1 10437 $local_file || "(not installed)");
c356248b 10438 push @m, sprintf($sprintf, 'INST_VERSION',
f04ea8d1 10439 $self->inst_version) if $local_file;
5254b38e
SP		 10440 if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
10441 my $available_file = $self->available_file;
10442 if ($available_file && $available_file ne $local_file) {
10443 push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
10444 push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
10445 }
10446 }
05454584 10447 join "", @m, "\n";
5f05dabc 10448}
10449
dc053c64 10450#-> sub CPAN::Module::manpage_headline
09d9d230 10451sub manpage_headline {
f04ea8d1
SP		 10452 my($self,$local_file) = @_;
10453 my(@local_file) = $local_file;
10454 $local_file =~ s/\.pm(?!\n)\Z/.pod/;
10455 push @local_file, $local_file;
10456 my(@result,$locf);
10457 for $locf (@local_file) {
10458 next unless -f $locf;
10459 my $fh = FileHandle->new($locf)
10460 or $Carp::Frontend->mydie("Couldn't open $locf: $!");
10461 my $inpod = 0;
10462 local $/ = "\n";
10463 while (<$fh>) {
10464 $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
10465 m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
10466 next unless $inpod;
10467 next if /^=/;
10468 next if /^\s+$/;
10469 chomp;
10470 push @result, $_;
10471 }
10472 close $fh;
10473 last if @result;
09d9d230 10474 }
f04ea8d1
SP		 10475 for (@result) {
10476 s/^\s+//;
10477 s/\s+$//;
10478 }
10479 join " ", @result;
09d9d230
A		 10480}
10481
05454584 10482#-> sub CPAN::Module::cpan_file ;
c049f953
JH		 10483# Note: also inherited by CPAN::Bundle
10484sub cpan_file {
05454584 10485 my $self = shift;
6658a91b 10486 # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
0cf35e6a 10487 unless ($self->ro) {
f04ea8d1 10488 CPAN::Index->reload;
05454584 10489 }
0cf35e6a 10490 my $ro = $self->ro;
f04ea8d1
SP		 10491 if ($ro && defined $ro->{CPAN_FILE}) {
10492 return $ro->{CPAN_FILE};
10b2abe6 10493 } else {
8d97e4a1
JH		 10494 my $userid = $self->userid;
10495 if ( $userid ) {
10496 if ($CPAN::META->exists("CPAN::Author",$userid)) {
10497 my $author = $CPAN::META->instance("CPAN::Author",
10498 $userid);
10499 my $fullname = $author->fullname;
10500 my $email = $author->email;
10501 unless (defined $fullname && defined $email) {
10502 return sprintf("Contact Author %s",
10503 $userid,
10504 );
10505 }
10506 return "Contact Author $fullname <$email>";
10507 } else {
1426a145 10508 return "Contact Author $userid (Email address not available)";
8d97e4a1
JH		 10509 }
10510 } else {
10511 return "N/A";
10512 }
5f05dabc 10513 }
10514}
10515
05454584 10516#-> sub CPAN::Module::cpan_version ;
c356248b
A		 10517sub cpan_version {
10518 my $self = shift;
6d29edf5 10519
0cf35e6a
SP		 10520 my $ro = $self->ro;
10521 unless ($ro) {
10522 # Can happen with modules that are not on CPAN
10523 $ro = {};
10524 }
10525 $ro->{CPAN_VERSION} = 'undef'
f04ea8d1 10526 unless defined $ro->{CPAN_VERSION};
0cf35e6a 10527 $ro->{CPAN_VERSION};
c356248b 10528}
5f05dabc 10529
05454584
A		 10530#-> sub CPAN::Module::force ;
10531sub force {
10532 my($self) = @_;
b72dd56f
SP		 10533 $self->{force_update} = 1;
10534}
10535
10536#-> sub CPAN::Module::fforce ;
10537sub fforce {
10538 my($self) = @_;
10539 $self->{force_update} = 2;
5f05dabc 10540}
10541
23a216b4 10542#-> sub CPAN::Module::notest ;
554a9ef5 10543sub notest {
f3fe0ae6 10544 my($self) = @_;
23a216b4
SP		 10545 # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
10546 $self->{notest}++;
554a9ef5
SP		 10547}
10548
05454584
A		 10549#-> sub CPAN::Module::rematein ;
10550sub rematein {
10551 my($self,$meth) = @_;
6a935156 10552 $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
6d29edf5
JH		 10553 $meth,
10554 $self->id));
05454584 10555 my $cpan_file = $self->cpan_file;
f04ea8d1
SP		 10556 if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
10557 $CPAN::Frontend->mywarn(sprintf qq{
09d9d230
A		 10558 The module %s isn\'t available on CPAN.
10559
10560 Either the module has not yet been uploaded to CPAN, or it is
10561 temporary unavailable. Please contact the author to find out
c4d24d4c 10562 more about the status. Try 'i %s'.
09d9d230 10563},
f04ea8d1
SP		 10564 $self->id,
10565 $self->id,
10566 );
10567 return;
09d9d230 10568 }
05454584
A		 10569 my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
10570 $pack->called_for($self->id);
f04ea8d1 10571 if (exists $self->{force_update}) {
b72dd56f
SP		 10572 if ($self->{force_update} == 2) {
10573 $pack->fforce($meth);
10574 } else {
10575 $pack->force($meth);
10576 }
10577 }
23a216b4 10578 $pack->notest($meth) if exists $self->{notest} && $self->{notest};
135a59c2
A		 10579
10580 $pack->{reqtype} ||= "";
10581 CPAN->debug("dist-reqtype[$pack->{reqtype}]".
10582 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
10583 if ($pack->{reqtype}) {
10584 if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
10585 $pack->{reqtype} = $self->{reqtype};
10586 if (
10587 exists $pack->{install}
10588 &&
10589 (
be34b10d 10590 UNIVERSAL::can($pack->{install},"failed") ?
135a59c2
A		 10591 $pack->{install}->failed :
10592 $pack->{install} =~ /^NO/
10593 )
10594 ) {
10595 delete $pack->{install};
10596 $CPAN::Frontend->mywarn
10597 ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
10598 }
10599 }
10600 } else {
10601 $pack->{reqtype} = $self->{reqtype};
10602 }
10603
23a216b4 10604 my $success = eval {
f04ea8d1 10605 $pack->$meth();
554a9ef5
SP		 10606 };
10607 my $err = $@;
b72dd56f 10608 $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
23a216b4 10609 $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
b72dd56f 10610 delete $self->{force_update};
23a216b4 10611 delete $self->{notest};
554a9ef5 10612 if ($err) {
f04ea8d1 10613 die $err;
554a9ef5 10614 }
23a216b4 10615 return $success;
5f05dabc 10616}
10617
554a9ef5
SP		 10618#-> sub CPAN::Module::perldoc ;
10619sub perldoc { shift->rematein('perldoc') }
05454584 10620#-> sub CPAN::Module::readme ;
554a9ef5 10621sub readme { shift->rematein('readme') }
05454584 10622#-> sub CPAN::Module::look ;
554a9ef5 10623sub look { shift->rematein('look') }
911a92db
GS		 10624#-> sub CPAN::Module::cvs_import ;
10625sub cvs_import { shift->rematein('cvs_import') }
05454584 10626#-> sub CPAN::Module::get ;
554a9ef5 10627sub get { shift->rematein('get',@_) }
05454584 10628#-> sub CPAN::Module::make ;
554a9ef5 10629sub make { shift->rematein('make') }
05454584 10630#-> sub CPAN::Module::test ;
6d29edf5
JH		 10631sub test {
10632 my $self = shift;
b72dd56f 10633 # $self->{badtestcnt} ||= 0;
6d29edf5
JH		 10634 $self->rematein('test',@_);
10635}
ecc7fca0 10636
f610777f
A		 10637#-> sub CPAN::Module::uptodate ;
10638sub uptodate {
ecc7fca0
A		 10639 my ($self) = @_;
10640 local ($_);
10641 my $inst = $self->inst_version or return undef;
10642 my $cpan = $self->cpan_version;
10643 local ($^W) = 0;
10644 CPAN::Version->vgt($cpan,$inst) and return 0;
b03f445c 10645 CPAN->debug(join("",
ecc7fca0
A		 10646 "returning uptodate. inst_file[",
10647 $self->inst_file,
10648 "cpan[$cpan] inst[$inst]")) if $CPAN::DEBUG;
10649 return 1;
f610777f 10650}
ecc7fca0 10651
f610777f
A		 10652#-> sub CPAN::Module::install ;
10653sub install {
10654 my($self) = @_;
10655 my($doit) = 0;
10656 if ($self->uptodate
f04ea8d1
SP		 10657 &&
10658 not exists $self->{force_update}
f610777f 10659 ) {
f04ea8d1 10660 $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
0cf35e6a
SP		 10661 $self->id,
10662 $self->inst_version,
10663 ));
f610777f 10664 } else {
f04ea8d1 10665 $doit = 1;
f610777f 10666 }
0cf35e6a
SP		 10667 my $ro = $self->ro;
10668 if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
35576f8c
A		 10669 $CPAN::Frontend->mywarn(qq{
10670\n\n\n ***WARNING***
10671 The module $self->{ID} has no active maintainer.\n\n\n
10672});
8962fc49 10673 $CPAN::Frontend->mysleep(5);
35576f8c 10674 }
5254b38e 10675 return $doit ? $self->rematein('install') : 1;
5f05dabc 10676}
05454584
A		 10677#-> sub CPAN::Module::clean ;
10678sub clean { shift->rematein('clean') }
5f05dabc 10679
05454584
A		 10680#-> sub CPAN::Module::inst_file ;
10681sub inst_file {
10682 my($self) = @_;
810a0276
SP		 10683 $self->_file_in_path([@INC]);
10684}
10685
10686#-> sub CPAN::Module::available_file ;
10687sub available_file {
10688 my($self) = @_;
10689 my $sep = $Config::Config{path_sep};
10690 my $perllib = $ENV{PERL5LIB};
10691 $perllib = $ENV{PERLLIB} unless defined $perllib;
10692 my @perllib = split(/$sep/,$perllib) if defined $perllib;
5254b38e
SP		 10693 my @cpan_perl5inc;
10694 if ($CPAN::Perl5lib_tempfile) {
10695 my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
10696 @cpan_perl5inc = @{$yaml->[0]{inc} || []};
10697 }
10698 $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
810a0276
SP		 10699}
10700
10701#-> sub CPAN::Module::file_in_path ;
10702sub _file_in_path {
10703 my($self,$path) = @_;
05454584
A		 10704 my($dir,@packpath);
10705 @packpath = split /::/, $self->{ID};
10706 $packpath[-1] .= ".pm";
8962fc49
SP		 10707 if (@packpath == 1 && $packpath[0] eq "readline.pm") {
10708 unshift @packpath, "Term", "ReadLine"; # historical reasons
10709 }
810a0276 10710 foreach $dir (@$path) {
f04ea8d1
SP		 10711 my $pmfile = File::Spec->catfile($dir,@packpath);
10712 if (-f $pmfile) {
10713 return $pmfile;
10714 }
5f05dabc 10715 }
d4fd5c69 10716 return;
5f05dabc 10717}
10718
05454584
A		 10719#-> sub CPAN::Module::xs_file ;
10720sub xs_file {
10721 my($self) = @_;
10722 my($dir,@packpath);
10723 @packpath = split /::/, $self->{ID};
10724 push @packpath, $packpath[-1];
10725 $packpath[-1] .= "." . $Config::Config{'dlext'};
10726 foreach $dir (@INC) {
f04ea8d1
SP		 10727 my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
10728 if (-f $xsfile) {
10729 return $xsfile;
10730 }
05454584 10731 }
d4fd5c69 10732 return;
5f05dabc 10733}
10734
05454584
A		 10735#-> sub CPAN::Module::inst_version ;
10736sub inst_version {
10737 my($self) = @_;
c356248b 10738 my $parsefile = $self->inst_file or return;
810a0276
SP		 10739 my $have = $self->parse_version($parsefile);
10740 $have;
10741}
10742
10743#-> sub CPAN::Module::inst_version ;
10744sub available_version {
10745 my($self) = @_;
10746 my $parsefile = $self->available_file or return;
10747 my $have = $self->parse_version($parsefile);
10748 $have;
10749}
de34a54b 10750
810a0276
SP		 10751#-> sub CPAN::Module::parse_version ;
10752sub parse_version {
10753 my($self,$parsefile) = @_;
5254b38e
SP		 10754 my $have = eval { MM->parse_version($parsefile); };
10755 if ($@) {
10756 $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
10757 }
10758 my $leastsanity = eval { defined $have && length $have; };
10759 $have = "undef" unless $leastsanity;
05d2a450
A		 10760 $have =~ s/^ //; # since the %vd hack these two lines here are needed
10761 $have =~ s/ $//; # trailing whitespace happens all the time
10762
5e05dca5 10763 $have = CPAN::Version->readable($have);
c4d24d4c 10764
911a92db 10765 $have =~ s/\s*//g; # stringify to float around floating point issues
de34a54b 10766 $have; # no stringify needed, \s* above matches always
5f05dabc 10767}
10768
dc053c64
SP		 10769#-> sub CPAN::Module::reports
10770sub reports {
10771 my($self) = @_;
10772 $self->distribution->reports;
10773}
10774
55e314ee 10775package CPAN;
e82b9348 10776use strict;
d4fd5c69 10777
5f05dabc 107781;
55e314ee 10779
ed84aac9 10780
e50380aa 10781__END__
5f05dabc 10782
10783=head1 NAME
10784
10785CPAN - query, download and build perl modules from CPAN sites
10786
10787=head1 SYNOPSIS
10788
10789Interactive mode:
10790
f20de9f0 10791 perl -MCPAN -e shell
5f05dabc 10792
f20de9f0 10793--or--
5f05dabc 10794
f20de9f0
SP		 10795 cpan
10796
10797Basic commands:
5f05dabc 10798
1e8f9a0a
SP		 10799 # Modules:
10800
10801 cpan> install Acme::Meta # in the shell
10802
10803 CPAN::Shell->install("Acme::Meta"); # in perl
10804
10805 # Distributions:
10806
10807 cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
10808
10809 CPAN::Shell->
10810 install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
10811
10812 # module objects:
c9869e1c 10813
1e8f9a0a
SP		 10814 $mo = CPAN::Shell->expandany($mod);
10815 $mo = CPAN::Shell->expand("Module",$mod); # same thing
c9869e1c 10816
1e8f9a0a 10817 # distribution objects:
c9869e1c 10818
1e8f9a0a
SP		 10819 $do = CPAN::Shell->expand("Module",$mod)->distribution;
10820 $do = CPAN::Shell->expandany($distro); # same thing
10821 $do = CPAN::Shell->expand("Distribution",
10822 $distro); # same thing
5f05dabc 10823
10824=head1 DESCRIPTION
10825
f20de9f0
SP		 10826The CPAN module automates or at least simplifies the make and install
10827of perl modules and extensions. It includes some primitive searching
10828capabilities and knows how to use Net::FTP or LWP or some external
10829download clients to fetch the distributions from the net.
5f05dabc 10830
f20de9f0
SP		 10831These are fetched from one or more of the mirrored CPAN (Comprehensive
10832Perl Archive Network) sites and unpacked in a dedicated directory.
5f05dabc 10833
10834The CPAN module also supports the concept of named and versioned
911a92db
GS		 10835I<bundles> of modules. Bundles simplify the handling of sets of
10836related modules. See Bundles below.
5f05dabc 10837
b72dd56f
SP		 10838The package contains a session manager and a cache manager. The
10839session manager keeps track of what has been fetched, built and
10840installed in the current session. The cache manager keeps track of the
10841disk space occupied by the make processes and deletes excess space
10842according to a simple FIFO mechanism.
5f05dabc 10843
c9869e1c 10844All methods provided are accessible in a programmer style and in an
10b2abe6
CS		 10845interactive shell style.
10846
2ccf00a7 10847=head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
5f05dabc 10848
10849The interactive mode is entered by running
10850
10851 perl -MCPAN -e shell
10852
f20de9f0
SP		 10853or
10854
10855 cpan
10856
10857which puts you into a readline interface. If C<Term::ReadKey> and
10858either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
10859it supports both history and command completion.
5f05dabc 10860
f20de9f0 10861Once you are on the command line, type C<h> to get a one page help
b72dd56f 10862screen and the rest should be self-explanatory.
5f05dabc 10863
9d61fa1d
A		 10864The function call C<shell> takes two optional arguments, one is the
10865prompt, the second is the default initial command line (the latter
10866only works if a real ReadLine interface module is installed).
10867
10b2abe6
CS		 10868The most common uses of the interactive modes are
10869
10870=over 2
10871
10872=item Searching for authors, bundles, distribution files and modules
10873
10874There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
42d3b621
A		 10875for each of the four categories and another, C<i> for any of the
10876mentioned four. Each of the four entities is implemented as a class
10877with slightly differing methods for displaying an object.
10b2abe6 10878
09d9d230 10879Arguments you pass to these commands are either strings exactly matching
10b2abe6
CS		 10880the identification string of an object or regular expressions that are
10881then matched case-insensitively against various attributes of the
09d9d230 10882objects. The parser recognizes a regular expression only if you
10b2abe6
CS		 10883enclose it between two slashes.
10884
10885The principle is that the number of found objects influences how an
911a92db
GS		 10886item is displayed. If the search finds one item, the result is
10887displayed with the rather verbose method C<as_string>, but if we find
10888more than one, we display each object with the terse method
c9869e1c 10889C<as_glimpse>.
10b2abe6 10890
5254b38e
SP		 10891Examples:
10892
10893 cpan> m Acme::MetaSyntactic
10894 Module id = Acme::MetaSyntactic
10895 CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
10896 CPAN_VERSION 0.99
10897 CPAN_FILE B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
10898 UPLOAD_DATE 2006-11-06
10899 MANPAGE Acme::MetaSyntactic - Themed metasyntactic variables names
10900 INST_FILE /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm
10901 INST_VERSION 0.99
10902 cpan> a BOOK
10903 Author id = BOOK
10904 EMAIL [...]
10905 FULLNAME Philippe Bruhat (BooK)
10906 cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz
10907 Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
10908 CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
10909 CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...]
10910 UPLOAD_DATE 2006-11-06
10911 cpan> m /lorem/
10912 Module = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz)
10913 Module Text::Lorem (ADEOLA/Text-Lorem-0.3.tar.gz)
10914 Module Text::Lorem::More (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
10915 Module Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
10916 cpan> i /berlin/
10917 Distribution BEATNIK/Filter-NumberLines-0.02.tar.gz
10918 Module = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz)
10919 Module Filter::NumberLines (BEATNIK/Filter-NumberLines-0.02.tar.gz)
10920 Author [...]
10921
10922The examples illustrate several aspects: the first three queries
10923target modules, authors, or distros directly and yield exactly one
10924result. The last two use regular expressions and yield several
10925results. The last one targets all of bundles, modules, authors, and
10926distros simultaneously. When more than one result is available, they
10927are printed in one-line format.
10928
f20de9f0 10929=item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
10b2abe6 10930
911a92db 10931These commands take any number of arguments and investigate what is
09d9d230 10932necessary to perform the action. If the argument is a distribution
f14b5cec
JH		 10933file name (recognized by embedded slashes), it is processed. If it is
10934a module, CPAN determines the distribution file in which this module
10935is included and processes that, following any dependencies named in
e82b9348 10936the module's META.yml or Makefile.PL (this behavior is controlled by
c9869e1c 10937the configuration parameter C<prerequisites_policy>.)
10b2abe6 10938
b72dd56f
SP		 10939C<get> downloads a distribution file and untars or unzips it, C<make>
10940builds it, C<test> runs the test suite, and C<install> installs it.
10941
09d9d230 10942Any C<make> or C<test> are run unconditionally. An
42d3b621 10943
05454584 10944 install <distribution_file>
42d3b621 10945
09d9d230 10946also is run unconditionally. But for
42d3b621 10947
05454584 10948 install <module>
42d3b621
A		 10949
10950CPAN checks if an install is actually needed for it and prints
09d9d230 10951I<module up to date> in the case that the distribution file containing
de34a54b 10952the module doesn't need to be updated.
10b2abe6
CS		 10953
10954CPAN also keeps track of what it has done within the current session
de34a54b 10955and doesn't try to build a package a second time regardless if it
b72dd56f
SP		 10956succeeded or not. It does not repeat a test run if the test
10957has been run successfully before. Same for install runs.
10b2abe6 10958
b72dd56f
SP		 10959The C<force> pragma may precede another command (currently: C<get>,
10960C<make>, C<test>, or C<install>) and executes the command from scratch
10961and tries to continue in case of some errors. See the section below on
f20de9f0 10962the C<force> and the C<fforce> pragma.
10b2abe6 10963
b72dd56f 10964The C<notest> pragma may be used to skip the test part in the build
554a9ef5
SP		 10965process.
10966
10967Example:
10968
10969 cpan> notest install Tk
10970
f610777f 10971A C<clean> command results in a
09d9d230
A		 10972
10973 make clean
10974
10975being executed within the distribution file's working directory.
10976
f20de9f0 10977=item C<readme>, C<perldoc>, C<look> module or distribution
da199366 10978
b72dd56f
SP		 10979C<readme> displays the README file of the associated distribution.
10980C<Look> gets and untars (if not yet done) the distribution file,
10981changes to the appropriate directory and opens a subshell process in
10982that directory. C<perldoc> displays the pod documentation of the
10983module in html or plain text format.
09d9d230 10984
f20de9f0 10985=item C<ls> author
c049f953 10986
f20de9f0 10987=item C<ls> globbing_expression
e82b9348
SP		 10988
10989The first form lists all distribution files in and below an author's
ca79d794
SP		 10990CPAN directory as they are stored in the CHECKUMS files distributed on
10991CPAN. The listing goes recursive into all subdirectories.
e82b9348
SP		 10992
10993The second form allows to limit or expand the output with shell
10994globbing as in the following examples:
10995
f04ea8d1
SP		 10996 ls JV/make*
10997 ls GSAR/*make*
10998 ls */*make*
e82b9348
SP		 10999
11000The last example is very slow and outputs extra progress indicators
11001that break the alignment of the result.
c049f953 11002
ca79d794
SP		 11003Note that globbing only lists directories explicitly asked for, for
11004example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
11005regarded as a bug and may be changed in future versions.
11006
f20de9f0 11007=item C<failed>
9ddc4ed0
A		 11008
11009The C<failed> command reports all distributions that failed on one of
11010C<make>, C<test> or C<install> for some reason in the currently
11011running shell session.
11012
b72dd56f
SP		 11013=item Persistence between sessions
11014
b03f445c 11015If the C<YAML> or the C<YAML::Syck> module is installed a record of
b72dd56f
SP		 11016the internal state of all modules is written to disk after each step.
11017The files contain a signature of the currently running perl version
11018for later perusal.
11019
11020If the configurations variable C<build_dir_reuse> is set to a true
11021value, then CPAN.pm reads the collected YAML files. If the stored
11022signature matches the currently running perl the stored state is
11023loaded into memory such that effectively persistence between sessions
11024is established.
11025
11026=item The C<force> and the C<fforce> pragma
11027
11028To speed things up in complex installation scenarios, CPAN.pm keeps
11029track of what it has already done and refuses to do some things a
11030second time. A C<get>, a C<make>, and an C<install> are not repeated.
11031A C<test> is only repeated if the previous test was unsuccessful. The
11032diagnostic message when CPAN.pm refuses to do something a second time
11033is one of I<Has already been >C<unwrapped|made|tested successfully> or
11034something similar. Another situation where CPAN refuses to act is an
11035C<install> if the according C<test> was not successful.
11036
11037In all these cases, the user can override the goatish behaviour by
11038prepending the command with the word force, for example:
11039
11040 cpan> force get Foo
11041 cpan> force make AUTHOR/Bar-3.14.tar.gz
11042 cpan> force test Baz
11043 cpan> force install Acme::Meta
11044
11045Each I<forced> command is executed with the according part of its
11046memory erased.
11047
11048The C<fforce> pragma is a variant that emulates a C<force get> which
11049erases the entire memory followed by the action specified, effectively
11050restarting the whole get/make/test/install procedure from scratch.
11051
c9869e1c
SP		 11052=item Lockfile
11053
be34b10d
SP		 11054Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
11055Batch jobs can run without a lockfile and do not disturb each other.
c9869e1c 11056
be34b10d
SP		 11057The shell offers to run in I<degraded mode> when another process is
11058holding the lockfile. This is an experimental feature that is not yet
11059tested very well. This second shell then does not write the history
11060file, does not use the metadata file and has a different prompt.
c9869e1c 11061
09d9d230
A		 11062=item Signals
11063
11064CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
11065in the cpan-shell it is intended that you can press C<^C> anytime and
11066return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
11067to clean up and leave the shell loop. You can emulate the effect of a
11068SIGTERM by sending two consecutive SIGINTs, which usually means by
11069pressing C<^C> twice.
11070
b03f445c 11071CPAN.pm ignores a SIGPIPE. If the user sets C<inactivity_timeout>, a
e82b9348
SP		 11072SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
11073Build.PL> subprocess.
da199366 11074
10b2abe6
CS		 11075=back
11076
5f05dabc 11077=head2 CPAN::Shell
11078
11079The commands that are available in the shell interface are methods in
11080the package CPAN::Shell. If you enter the shell command, all your
10b2abe6
CS		 11081input is split by the Text::ParseWords::shellwords() routine which
11082acts like most shells do. The first word is being interpreted as the
11083method to be called and the rest of the words are treated as arguments
c356248b
A		 11084to this method. Continuation lines are supported if a line ends with a
11085literal backslash.
10b2abe6 11086
da199366
A		 11087=head2 autobundle
11088
11089C<autobundle> writes a bundle file into the
11090C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
11091a list of all modules that are both available from CPAN and currently
11092installed within @INC. The name of the bundle file is based on the
11093current date and a counter.
11094
05bab18e
SP		 11095=head2 hosts
11096
ed756621
SP		 11097Note: this feature is still in alpha state and may change in future
11098versions of CPAN.pm
11099
05bab18e
SP		 11100This commands provides a statistical overview over recent download
11101activities. The data for this is collected in the YAML file
11102C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
11103configured or YAML not installed, then no stats are provided.
11104
11105=head2 mkmyconfig
11106
11107mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
11108directory so that you can save your own preferences instead of the
11109system wide ones.
11110
f04ea8d1
SP		 11111=head2 recent ***EXPERIMENTAL COMMAND***
11112
11113The C<recent> command downloads a list of recent uploads to CPAN and
11114displays them I<slowly>. While the command is running $SIG{INT} is
11115defined to mean that the loop shall be left after having displayed the
11116current item.
11117
11118B<Note>: This command requires XML::LibXML installed.
11119
5254b38e 11120B<Note>: This whole command currently is just a hack and will
f04ea8d1
SP		 11121probably change in future versions of CPAN.pm but the general
11122approach will likely stay.
11123
11124B<Note>: See also L<smoke>
11125
da199366
A		 11126=head2 recompile
11127
11128recompile() is a very special command in that it takes no argument and
11129runs the make/test/install cycle with brute force over all installed
11130dynamically loadable extensions (aka XS modules) with 'force' in
09d9d230 11131effect. The primary purpose of this command is to finish a network
da199366
A		 11132installation. Imagine, you have a common source tree for two different
11133architectures. You decide to do a completely independent fresh
11134installation. You start on one architecture with the help of a Bundle
11135file produced earlier. CPAN installs the whole Bundle for you, but
11136when you try to repeat the job on the second architecture, CPAN
11137responds with a C<"Foo up to date"> message for all modules. So you
de34a54b 11138invoke CPAN's recompile on the second architecture and you're done.
da199366
A		 11139
11140Another popular use for C<recompile> is to act as a rescue in case your
11141perl breaks binary compatibility. If one of the modules that CPAN uses
11142is in turn depending on binary compatibility (so you cannot run CPAN
11143commands), then you should try the CPAN::Nox module for recovery.
11144
8fc516fe
SP		 11145=head2 report Bundle|Distribution|Module
11146
11147The C<report> command temporarily turns on the C<test_report> config
6658a91b
SP		 11148variable, then runs the C<force test> command with the given
11149arguments. The C<force> pragma is used to re-run the tests and repeat
11150every step that might have failed before.
8fc516fe 11151
f04ea8d1
SP		 11152=head2 smoke ***EXPERIMENTAL COMMAND***
11153
11154B<*** WARNING: this command downloads and executes software from CPAN to
b03f445c
RGS		 11155your computer of completely unknown status. You should never do
11156this with your normal account and better have a dedicated well
11157separated and secured machine to do this. ***>
f04ea8d1
SP		 11158
11159The C<smoke> command takes the list of recent uploads to CPAN as
11160provided by the C<recent> command and tests them all. While the
11161command is running $SIG{INT} is defined to mean that the current item
11162shall be skipped.
11163
5254b38e 11164B<Note>: This whole command currently is just a hack and will
f04ea8d1
SP		 11165probably change in future versions of CPAN.pm but the general
11166approach will likely stay.
11167
11168B<Note>: See also L<recent>
11169
135a59c2 11170=head2 upgrade [Module|/Regex/]...
ed84aac9 11171
135a59c2
A		 11172The C<upgrade> command first runs an C<r> command with the given
11173arguments and then installs the newest versions of all modules that
11174were listed by that.
ed84aac9 11175
c356248b 11176=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
e50380aa 11177
09d9d230
A		 11178Although it may be considered internal, the class hierarchy does matter
11179for both users and programmer. CPAN.pm deals with above mentioned four
11180classes, and all those classes share a set of methods. A classical
11181single polymorphism is in effect. A metaclass object registers all
11182objects of all kinds and indexes them with a string. The strings
11183referencing objects have a separated namespace (well, not completely
11184separated):
e50380aa
A		 11185
11186 Namespace Class
11187
11188 words containing a "/" (slash) Distribution
11189 words starting with Bundle:: Bundle
11190 everything else Module or Author
11191
11192Modules know their associated Distribution objects. They always refer
09d9d230
A		 11193to the most recent official release. Developers may mark their releases
11194as unstable development versions (by inserting an underbar into the
16703a00 11195module version number which will also be reflected in the distribution
6658a91b
SP		 11196name when you run 'make dist'), so the really hottest and newest
11197distribution is not always the default. If a module Foo circulates
11198on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
16703a00 11199way to install version 1.23 by saying
e50380aa
A		 11200
11201 install Foo
11202
11203This would install the complete distribution file (say
09d9d230
A		 11204BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
11205like to install version 1.23_90, you need to know where the
e50380aa 11206distribution file resides on CPAN relative to the authors/id/
09d9d230 11207directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
c356248b 11208so you would have to say
e50380aa
A		 11209
11210 install BAR/Foo-1.23_90.tar.gz
11211
11212The first example will be driven by an object of the class
c356248b 11213CPAN::Module, the second by an object of class CPAN::Distribution.
e50380aa 11214
6658a91b
SP		 11215=head2 Integrating local directories
11216
ed756621
SP		 11217Note: this feature is still in alpha state and may change in future
11218versions of CPAN.pm
11219
6658a91b 11220Distribution objects are normally distributions from the CPAN, but
b72dd56f
SP		 11221there is a slightly degenerate case for Distribution objects, too, of
11222projects held on the local disk. These distribution objects have the
11223same name as the local directory and end with a dot. A dot by itself
11224is also allowed for the current directory at the time CPAN.pm was
11225used. All actions such as C<make>, C<test>, and C<install> are applied
6658a91b
SP		 11226directly to that directory. This gives the command C<cpan .> an
11227interesting touch: while the normal mantra of installing a CPAN module
11228without CPAN.pm is one of
11229
11230 perl Makefile.PL perl Build.PL
11231 ( go and get prerequisites )
11232 make ./Build
11233 make test ./Build test
11234 make install ./Build install
11235
11236the command C<cpan .> does all of this at once. It figures out which
11237of the two mantras is appropriate, fetches and installs all
11238prerequisites, cares for them recursively and finally finishes the
11239installation of the module in the current directory, be it a CPAN
11240module or not.
11241
b72dd56f
SP		 11242The typical usage case is for private modules or working copies of
11243projects from remote repositories on the local disk.
11244
5254b38e
SP		 11245=head2 Redirection
11246
11247The usual shell redirection symbols C< | > and C<< > >> are recognized
11248by the cpan shell when surrounded by whitespace. So piping into a
11249pager and redirecting output into a file works quite similar to any
11250shell.
11251
f20de9f0 11252=head1 CONFIGURATION
55e314ee 11253
f20de9f0
SP		 11254When the CPAN module is used for the first time, a configuration
11255dialog tries to determine a couple of site specific options. The
11256result of the dialog is stored in a hash reference C< $CPAN::Config >
11257in a file CPAN/Config.pm.
de34a54b 11258
f20de9f0
SP		 11259The default values defined in the CPAN/Config.pm file can be
11260overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
11261best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
11262added to the search path of the CPAN module before the use() or
11263require() statements. The mkmyconfig command writes this file for you.
36263cb3 11264
f20de9f0 11265The C<o conf> command has various bells and whistles:
36263cb3 11266
f20de9f0 11267=over
36263cb3 11268
f20de9f0 11269=item completion support
36263cb3 11270
f20de9f0
SP		 11271If you have a ReadLine module installed, you can hit TAB at any point
11272of the commandline and C<o conf> will offer you completion for the
11273built-in subcommands and/or config variable names.
36263cb3 11274
f20de9f0 11275=item displaying some help: o conf help
36263cb3 11276
f20de9f0 11277Displays a short help
36263cb3 11278
f20de9f0 11279=item displaying current values: o conf [KEY]
36263cb3 11280
f20de9f0
SP		 11281Displays the current value(s) for this config variable. Without KEY
11282displays all subcommands and config variables.
36263cb3 11283
f20de9f0 11284Example:
5f05dabc 11285
f20de9f0 11286 o conf shell
d8773709 11287
f04ea8d1
SP		 11288If KEY starts and ends with a slash the string in between is
11289interpreted as a regular expression and only keys matching this regex
11290are displayed
11291
11292Example:
11293
11294 o conf /color/
11295
f20de9f0 11296=item changing of scalar values: o conf KEY VALUE
d8773709 11297
f20de9f0
SP		 11298Sets the config variable KEY to VALUE. The empty string can be
11299specified as usual in shells, with C<''> or C<"">
d8773709 11300
f20de9f0 11301Example:
d8773709 11302
f20de9f0 11303 o conf wget /usr/bin/wget
d8773709 11304
f20de9f0 11305=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
d8773709 11306
f20de9f0
SP		 11307If a config variable name ends with C<list>, it is a list. C<o conf
11308KEY shift> removes the first element of the list, C<o conf KEY pop>
11309removes the last element of the list. C<o conf KEYS unshift LIST>
11310prepends a list of values to the list, C<o conf KEYS push LIST>
11311appends a list of valued to the list.
d8773709 11312
f20de9f0
SP		 11313Likewise, C<o conf KEY splice LIST> passes the LIST to the according
11314splice command.
d8773709 11315
f20de9f0
SP		 11316Finally, any other list of arguments is taken as a new list value for
11317the KEY variable discarding the previous value.
d8773709 11318
f20de9f0 11319Examples:
d8773709 11320
f20de9f0
SP		 11321 o conf urllist unshift http://cpan.dev.local/CPAN
11322 o conf urllist splice 3 1
11323 o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
d8773709 11324
f20de9f0 11325=item reverting to saved: o conf defaults
d8773709 11326
f20de9f0 11327Reverts all config variables to the state in the saved config file.
d8773709 11328
f20de9f0 11329=item saving the config: o conf commit
d8773709 11330
f20de9f0
SP		 11331Saves all config variables to the current config file (CPAN/Config.pm
11332or CPAN/MyConfig.pm that was loaded at start).
d8773709 11333
f20de9f0 11334=back
d8773709 11335
f20de9f0
SP		 11336The configuration dialog can be started any time later again by
11337issuing the command C< o conf init > in the CPAN shell. A subset of
11338the configuration dialog can be run by issuing C<o conf init WORD>
11339where WORD is any valid config variable or a regular expression.
d8773709 11340
f20de9f0 11341=head2 Config Variables
d8773709 11342
f20de9f0
SP		 11343Currently the following keys in the hash reference $CPAN::Config are
11344defined:
d8773709 11345
f20de9f0
SP		 11346 applypatch path to external prg
11347 auto_commit commit all changes to config variables to disk
11348 build_cache size of cache for directories to build modules
11349 build_dir locally accessible directory to build modules
11350 build_dir_reuse boolean if distros in build_dir are persistent
11351 build_requires_install_policy
11352 to install or not to install when a module is
11353 only needed for building. yes|no|ask/yes|ask/no
11354 bzip2 path to external prg
11355 cache_metadata use serializer to cache metadata
f20de9f0
SP		 11356 check_sigs if signatures should be verified
11357 colorize_debug Term::ANSIColor attributes for debugging output
11358 colorize_output boolean if Term::ANSIColor should colorize output
11359 colorize_print Term::ANSIColor attributes for normal output
11360 colorize_warn Term::ANSIColor attributes for warnings
11361 commandnumber_in_prompt
11362 boolean if you want to see current command number
5254b38e
SP		 11363 commands_quote prefered character to use for quoting external
11364 commands when running them. Defaults to double
11365 quote on Windows, single tick everywhere else;
11366 can be set to space to disable quoting
11367 connect_to_internet_ok
11368 if we shall ask if opening a connection is ok before
11369 urllist is specified
f20de9f0
SP		 11370 cpan_home local directory reserved for this package
11371 curl path to external prg
11372 dontload_hash DEPRECATED
11373 dontload_list arrayref: modules in the list will not be
11374 loaded by the CPAN::has_inst() routine
11375 ftp path to external prg
11376 ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
11377 ftp_proxy proxy host for ftp requests
5254b38e
SP		 11378 ftpstats_period max number of days to keep download statistics
11379 ftpstats_size max number of items to keep in the download statistics
f20de9f0
SP		 11380 getcwd see below
11381 gpg path to external prg
f04ea8d1 11382 gzip location of external program gzip
5254b38e
SP		 11383 halt_on_failure stop processing after the first failure of queued
11384 items or dependencies
f20de9f0
SP		 11385 histfile file to maintain history between sessions
11386 histsize maximum number of lines to keep in histfile
11387 http_proxy proxy host for http requests
11388 inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
11389 after this many seconds inactivity. Set to 0 to
11390 never break.
11391 index_expire after this many days refetch index files
11392 inhibit_startup_message
11393 if true, does not print the startup message
11394 keep_source_where directory in which to keep the source (if we do)
f04ea8d1
SP		 11395 load_module_verbosity
11396 report loading of optional modules used by CPAN.pm
f20de9f0
SP		 11397 lynx path to external prg
11398 make location of external make program
f04ea8d1 11399 make_arg arguments that should always be passed to 'make'
f20de9f0
SP		 11400 make_install_make_command
11401 the make command for running 'make install', for
11402 example 'sudo make'
11403 make_install_arg same as make_arg for 'make install'
f04ea8d1
SP		 11404 makepl_arg arguments passed to 'perl Makefile.PL'
11405 mbuild_arg arguments passed to './Build'
f20de9f0
SP		 11406 mbuild_install_arg arguments passed to './Build install'
11407 mbuild_install_build_command
11408 command to use instead of './Build' when we are
11409 in the install stage, for example 'sudo ./Build'
11410 mbuildpl_arg arguments passed to 'perl Build.PL'
11411 ncftp path to external prg
11412 ncftpget path to external prg
11413 no_proxy don't proxy to these hosts/domains (comma separated list)
11414 pager location of external program more (or any pager)
11415 password your password if you CPAN server wants one
11416 patch path to external prg
5254b38e 11417 perl5lib_verbosity verbosity level for PERL5LIB additions
f20de9f0
SP		 11418 prefer_installer legal values are MB and EUMM: if a module comes
11419 with both a Makefile.PL and a Build.PL, use the
11420 former (EUMM) or the latter (MB); if the module
11421 comes with only one of the two, that one will be
11422 used in any case
11423 prerequisites_policy
11424 what to do if you are missing module prerequisites
11425 ('follow' automatically, 'ask' me, or 'ignore')
11426 prefs_dir local directory to store per-distro build options
11427 proxy_user username for accessing an authenticating proxy
11428 proxy_pass password for accessing an authenticating proxy
11429 randomize_urllist add some randomness to the sequence of the urllist
f04ea8d1 11430 scan_cache controls scanning of cache ('atstart' or 'never')
f20de9f0 11431 shell your favorite shell
f04ea8d1
SP		 11432 show_unparsable_versions
11433 boolean if r command tells which modules are versionless
f20de9f0 11434 show_upload_date boolean if commands should try to determine upload date
f04ea8d1 11435 show_zero_versions boolean if r command tells for which modules $version==0
f20de9f0 11436 tar location of external program tar
f04ea8d1
SP		 11437 tar_verbosity verbosity level for the tar command
11438 term_is_latin deprecated: if true Unicode is translated to ISO-8859-1
f20de9f0
SP		 11439 (and nonsense for characters outside latin range)
11440 term_ornaments boolean to turn ReadLine ornamenting on/off
11441 test_report email test reports (if CPAN::Reporter is installed)
5254b38e
SP		 11442 trust_test_report_history
11443 skip testing when previously tested ok (according to
11444 CPAN::Reporter history)
f20de9f0 11445 unzip location of external program unzip
f04ea8d1 11446 urllist arrayref to nearby CPAN sites (or equivalent locations)
f20de9f0
SP		 11447 use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
11448 username your username if you CPAN server wants one
11449 wait_list arrayref to a wait server to try (See CPAN::WAIT)
11450 wget path to external prg
5254b38e 11451 yaml_load_code enable YAML code deserialisation via CPAN::DeferedCode
f20de9f0 11452 yaml_module which module to use to read/write YAML files
d8773709 11453
f20de9f0
SP		 11454You can set and query each of these options interactively in the cpan
11455shell with the C<o conf> or the C<o conf init> command as specified below.
d8773709 11456
f20de9f0 11457=over 2
d8773709 11458
f20de9f0 11459=item C<o conf E<lt>scalar optionE<gt>>
d8773709 11460
f20de9f0 11461prints the current value of the I<scalar option>
d8773709 11462
f20de9f0 11463=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
d8773709 11464
f20de9f0 11465Sets the value of the I<scalar option> to I<value>
d8773709 11466
f20de9f0 11467=item C<o conf E<lt>list optionE<gt>>
d8773709 11468
f20de9f0
SP		 11469prints the current value of the I<list option> in MakeMaker's
11470neatvalue format.
d8773709 11471
f20de9f0 11472=item C<o conf E<lt>list optionE<gt> [shift|pop]>
d8773709 11473
f20de9f0 11474shifts or pops the array in the I<list option> variable
d8773709 11475
f20de9f0 11476=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
d8773709 11477
f20de9f0 11478works like the corresponding perl commands.
d8773709 11479
f20de9f0 11480=item interactive editing: o conf init [MATCH|LIST]
d8773709 11481
f20de9f0
SP		 11482Runs an interactive configuration dialog for matching variables.
11483Without argument runs the dialog over all supported config variables.
11484To specify a MATCH the argument must be enclosed by slashes.
d8773709 11485
f20de9f0 11486Examples:
d8773709 11487
f20de9f0
SP		 11488 o conf init ftp_passive ftp_proxy
11489 o conf init /color/
d8773709 11490
f20de9f0
SP		 11491Note: this method of setting config variables often provides more
11492explanation about the functioning of a variable than the manpage.
d8773709 11493
f20de9f0 11494=back
d8773709 11495
f20de9f0 11496=head2 CPAN::anycwd($path): Note on config variable getcwd
d8773709 11497
f20de9f0
SP		 11498CPAN.pm changes the current working directory often and needs to
11499determine its own current working directory. Per default it uses
11500Cwd::cwd but if this doesn't work on your system for some reason,
11501alternatives can be configured according to the following table:
d8773709 11502
f20de9f0 11503=over 4
d8773709 11504
f20de9f0 11505=item cwd
d8773709 11506
f20de9f0 11507Calls Cwd::cwd
4d1321a7 11508
f20de9f0 11509=item getcwd
4d1321a7 11510
f20de9f0 11511Calls Cwd::getcwd
d8773709 11512
f20de9f0 11513=item fastcwd
d8773709 11514
f20de9f0 11515Calls Cwd::fastcwd
d8773709 11516
f20de9f0 11517=item backtickcwd
d8773709 11518
f20de9f0 11519Calls the external command cwd.
d8773709 11520
f20de9f0 11521=back
d8773709 11522
f20de9f0 11523=head2 Note on the format of the urllist parameter
d8773709 11524
f20de9f0
SP		 11525urllist parameters are URLs according to RFC 1738. We do a little
11526guessing if your URL is not compliant, but if you have problems with
11527C<file> URLs, please try the correct format. Either:
d8773709 11528
f20de9f0 11529 file://localhost/whatever/ftp/pub/CPAN/
d8773709 11530
f20de9f0 11531or
d8773709 11532
f20de9f0 11533 file:///home/ftp/pub/CPAN/
d8773709 11534
f20de9f0 11535=head2 The urllist parameter has CD-ROM support
d8773709 11536
f20de9f0
SP		 11537The C<urllist> parameter of the configuration table contains a list of
11538URLs that are to be used for downloading. If the list contains any
11539C<file> URLs, CPAN always tries to get files from there first. This
11540feature is disabled for index files. So the recommendation for the
11541owner of a CD-ROM with CPAN contents is: include your local, possibly
11542outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
d8773709 11543
f20de9f0 11544 o conf urllist push file://localhost/CDROM/CPAN
d8773709 11545
f20de9f0
SP		 11546CPAN.pm will then fetch the index files from one of the CPAN sites
11547that come at the beginning of urllist. It will later check for each
11548module if there is a local copy of the most recent version.
d8773709 11549
f20de9f0
SP		 11550Another peculiarity of urllist is that the site that we could
11551successfully fetch the last file from automatically gets a preference
11552token and is tried as the first site for the next request. So if you
11553add a new site at runtime it may happen that the previously preferred
11554site will be tried another time. This means that if you want to disallow
11555a site for the next transfer, it must be explicitly removed from
11556urllist.
d8773709 11557
f20de9f0 11558=head2 Maintaining the urllist parameter
1e8f9a0a 11559
f20de9f0
SP		 11560If you have YAML.pm (or some other YAML module configured in
11561C<yaml_module>) installed, CPAN.pm collects a few statistical data
11562about recent downloads. You can view the statistics with the C<hosts>
11563command or inspect them directly by looking into the C<FTPstats.yml>
11564file in your C<cpan_home> directory.
8962fc49 11565
f20de9f0
SP		 11566To get some interesting statistics it is recommended to set the
11567C<randomize_urllist> parameter that introduces some amount of
11568randomness into the URL selection.
d8773709 11569
f20de9f0 11570=head2 The C<requires> and C<build_requires> dependency declarations
d8773709 11571
f20de9f0
SP		 11572Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
11573a distribution are treated differently depending on the config
11574variable C<build_requires_install_policy>. By setting
11575C<build_requires_install_policy> to C<no> such a module is not being
11576installed. It is only built and tested and then kept in the list of
11577tested but uninstalled modules. As such it is available during the
11578build of the dependent module by integrating the path to the
11579C<blib/arch> and C<blib/lib> directories in the environment variable
11580PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
11581both modules declared as C<requires> and those declared as
11582C<build_requires> are treated alike. By setting to C<ask/yes> or
11583C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
d8773709 11584
f20de9f0 11585=head2 Configuration for individual distributions (I<Distroprefs>)
d8773709 11586
f20de9f0
SP		 11587(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
11588still considered beta quality)
d8773709 11589
f20de9f0
SP		 11590Distributions on the CPAN usually behave according to what we call the
11591CPAN mantra. Or since the event of Module::Build we should talk about
11592two mantras:
d8773709 11593
f20de9f0
SP		 11594 perl Makefile.PL perl Build.PL
11595 make ./Build
11596 make test ./Build test
11597 make install ./Build install
4d1321a7 11598
f20de9f0
SP		 11599But some modules cannot be built with this mantra. They try to get
11600some extra data from the user via the environment, extra arguments or
11601interactively thus disturbing the installation of large bundles like
11602Phalanx100 or modules with many dependencies like Plagger.
4d1321a7 11603
f20de9f0
SP		 11604The distroprefs system of C<CPAN.pm> addresses this problem by
11605allowing the user to specify extra informations and recipes in YAML
11606files to either
1e8f9a0a 11607
f20de9f0 11608=over
d8773709 11609
f20de9f0 11610=item
d8773709 11611
f20de9f0 11612pass additional arguments to one of the four commands,
d8773709 11613
f20de9f0 11614=item
554a9ef5 11615
f20de9f0 11616set environment variables
554a9ef5 11617
f20de9f0 11618=item
d8773709 11619
f20de9f0
SP		 11620instantiate an Expect object that reads from the console, waits for
11621some regular expressions and enters some answers
d8773709 11622
f20de9f0 11623=item
d8773709 11624
f20de9f0 11625temporarily override assorted C<CPAN.pm> configuration variables
d8773709 11626
f20de9f0 11627=item
d8773709 11628
f04ea8d1
SP		 11629specify dependencies that the original maintainer forgot to specify
11630
11631=item
11632
f20de9f0 11633disable the installation of an object altogether
d8773709 11634
f20de9f0 11635=back
d8773709 11636
f20de9f0
SP		 11637See the YAML and Data::Dumper files that come with the C<CPAN.pm>
11638distribution in the C<distroprefs/> directory for examples.
d8773709 11639
f20de9f0 11640=head2 Filenames
d8773709 11641
f20de9f0
SP		 11642The YAML files themselves must have the C<.yml> extension, all other
11643files are ignored (for two exceptions see I<Fallback Data::Dumper and
11644Storable> below). The containing directory can be specified in
11645C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
11646prefs_dir> in the CPAN shell to set and activate the distroprefs
11647system.
d8773709 11648
f20de9f0
SP		 11649Every YAML file may contain arbitrary documents according to the YAML
11650specification and every single document is treated as an entity that
11651can specify the treatment of a single distribution.
d8773709 11652
f20de9f0
SP		 11653The names of the files can be picked freely, C<CPAN.pm> always reads
11654all files (in alphabetical order) and takes the key C<match> (see
11655below in I<Language Specs>) as a hashref containing match criteria
11656that determine if the current distribution matches the YAML document
11657or not.
d8773709 11658
f20de9f0 11659=head2 Fallback Data::Dumper and Storable
d8773709 11660
f20de9f0
SP		 11661If neither your configured C<yaml_module> nor YAML.pm is installed
11662CPAN.pm falls back to using Data::Dumper and Storable and looks for
11663files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
11664directory. These files are expected to contain one or more hashrefs.
11665For Data::Dumper generated files, this is expected to be done with by
11666defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
11667with the command
d8773709 11668
f20de9f0 11669 ysh < somefile.yml > somefile.dd
d8773709 11670
f20de9f0
SP		 11671For Storable files the rule is that they must be constructed such that
11672C<Storable::retrieve(file)> returns an array reference and the array
11673elements represent one distropref object each. The conversion from
11674YAML would look like so:
d8773709 11675
f20de9f0
SP		 11676 perl -MYAML=LoadFile -MStorable=nstore -e '
11677 @y=LoadFile(shift);
11678 nstore(\@y, shift)' somefile.yml somefile.st
d8773709 11679
f20de9f0
SP		 11680In bootstrapping situations it is usually sufficient to translate only
11681a few YAML files to Data::Dumper for the crucial modules like
11682C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
11683over Data::Dumper, remember to pull out a Storable version that writes
11684an older format than all the other Storable versions that will need to
11685read them.
d8773709 11686
f20de9f0 11687=head2 Blueprint
d8773709 11688
f20de9f0
SP		 11689The following example contains all supported keywords and structures
11690with the exception of C<eexpect> which can be used instead of
11691C<expect>.
d8773709 11692
f20de9f0
SP		 11693 ---
11694 comment: "Demo"
11695 match:
11696 module: "Dancing::Queen"
11697 distribution: "^CHACHACHA/Dancing-"
11698 perl: "/usr/local/cariba-perl/bin/perl"
2b3bde2a
SP		 11699 perlconfig:
11700 archname: "freebsd"
5254b38e
SP		 11701 env:
11702 DANCING_FLOOR: "Shubiduh"
f20de9f0
SP		 11703 disabled: 1
11704 cpanconfig:
11705 make: gmake
11706 pl:
11707 args:
11708 - "--somearg=specialcase"
d8773709 11709
f20de9f0 11710 env: {}
d8773709 11711
f20de9f0
SP		 11712 expect:
11713 - "Which is your favorite fruit"
11714 - "apple\n"
d8773709 11715
f20de9f0
SP		 11716 make:
11717 args:
11718 - all
11719 - extra-all
d8773709 11720
f20de9f0 11721 env: {}
4d1321a7 11722
f20de9f0 11723 expect: []
4d1321a7 11724
f20de9f0 11725 commendline: "echo SKIPPING make"
87892b73 11726
f20de9f0
SP		 11727 test:
11728 args: []
87892b73 11729
f20de9f0 11730 env: {}
87892b73 11731
f20de9f0 11732 expect: []
87892b73 11733
f20de9f0
SP		 11734 install:
11735 args: []
87892b73 11736
f20de9f0
SP		 11737 env:
11738 WANT_TO_INSTALL: YES
87892b73 11739
f20de9f0
SP		 11740 expect:
11741 - "Do you really want to install"
11742 - "y\n"
87892b73 11743
f20de9f0
SP		 11744 patches:
11745 - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
87892b73 11746
f04ea8d1
SP		 11747 depends:
11748 configure_requires:
11749 LWP: 5.8
11750 build_requires:
11751 Test::Exception: 0.25
11752 requires:
11753 Spiffy: 0.30
11754
d8773709 11755
f20de9f0 11756=head2 Language Specs
d8773709 11757
f20de9f0
SP		 11758Every YAML document represents a single hash reference. The valid keys
11759in this hash are as follows:
d8773709 11760
f20de9f0 11761=over
d8773709 11762
f20de9f0 11763=item comment [scalar]
d8773709 11764
f20de9f0 11765A comment
d8773709 11766
f20de9f0 11767=item cpanconfig [hash]
810a0276 11768
f20de9f0 11769Temporarily override assorted C<CPAN.pm> configuration variables.
810a0276 11770
f20de9f0
SP		 11771Supported are: C<build_requires_install_policy>, C<check_sigs>,
11772C<make>, C<make_install_make_command>, C<prefer_installer>,
11773C<test_report>. Please report as a bug when you need another one
11774supported.
d8773709 11775
f04ea8d1
SP		 11776=item depends [hash] *** EXPERIMENTAL FEATURE ***
11777
11778All three types, namely C<configure_requires>, C<build_requires>, and
11779C<requires> are supported in the way specified in the META.yml
11780specification. The current implementation I<merges> the specified
11781dependencies with those declared by the package maintainer. In a
11782future implementation this may be changed to override the original
11783declaration.
11784
f20de9f0 11785=item disabled [boolean]
810a0276 11786
f20de9f0 11787Specifies that this distribution shall not be processed at all.
810a0276 11788
5254b38e
SP		 11789=item features [array] *** EXPERIMENTAL FEATURE ***
11790
11791Experimental implementation to deal with optional_features from
11792META.yml. Still needs coordination with installer software and
11793currently only works for META.yml declaring C<dynamic_config=0>. Use
11794with caution.
11795
f20de9f0 11796=item goto [string]
d8773709 11797
f20de9f0
SP		 11798The canonical name of a delegate distribution that shall be installed
11799instead. Useful when a new version, although it tests OK itself,
11800breaks something else or a developer release or a fork is already
11801uploaded that is better than the last released version.
d8773709 11802
f20de9f0 11803=item install [hash]
d8773709 11804
f20de9f0 11805Processing instructions for the C<make install> or C<./Build install>
5254b38e 11806phase of the CPAN mantra. See below under I<Processing Instructions>.
d8773709 11807
f20de9f0 11808=item make [hash]
d8773709 11809
f20de9f0 11810Processing instructions for the C<make> or C<./Build> phase of the
5254b38e 11811CPAN mantra. See below under I<Processing Instructions>.
d8773709 11812
f20de9f0 11813=item match [hash]
d8773709 11814
2b3bde2a 11815A hashref with one or more of the keys C<distribution>, C<modules>,
5254b38e
SP		 11816C<perl>, C<perlconfig>, and C<env> that specify if a document is
11817targeted at a specific CPAN distribution or installation.
d8773709 11818
f20de9f0
SP		 11819The corresponding values are interpreted as regular expressions. The
11820C<distribution> related one will be matched against the canonical
11821distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
d8773709 11822
f20de9f0
SP		 11823The C<module> related one will be matched against I<all> modules
11824contained in the distribution until one module matches.
554a9ef5 11825
b03f445c
RGS		 11826The C<perl> related one will be matched against C<$^X> (but with the
11827absolute path).
554a9ef5 11828
2b3bde2a
SP		 11829The value associated with C<perlconfig> is itself a hashref that is
11830matched against corresponding values in the C<%Config::Config> hash
5254b38e 11831living in the C<Config.pm> module.
2b3bde2a 11832
5254b38e
SP		 11833The value associated with C<env> is itself a hashref that is
11834matched against corresponding values in the C<%ENV> hash.
11835
11836If more than one restriction of C<module>, C<distribution>, etc. is
11837specified, the results of the separately computed match values must
11838all match. If this is the case then the hashref represented by the
11839YAML document is returned as the preference structure for the current
11840distribution.
4d1321a7 11841
f20de9f0 11842=item patches [array]
4d1321a7 11843
f20de9f0
SP		 11844An array of patches on CPAN or on the local disk to be applied in
11845order via the external patch program. If the value for the C<-p>
11846parameter is C<0> or C<1> is determined by reading the patch
11847beforehand.
d8773709 11848
f20de9f0
SP		 11849Note: if the C<applypatch> program is installed and C<CPAN::Config>
11850knows about it B<and> a patch is written by the C<makepatch> program,
11851then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
11852and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
11853distribution.
d8773709 11854
f20de9f0 11855=item pl [hash]
d8773709 11856
f20de9f0 11857Processing instructions for the C<perl Makefile.PL> or C<perl
5254b38e 11858Build.PL> phase of the CPAN mantra. See below under I<Processing
f20de9f0 11859Instructions>.
d8773709 11860
f20de9f0 11861=item test [hash]
d8773709 11862
f20de9f0 11863Processing instructions for the C<make test> or C<./Build test> phase
5254b38e 11864of the CPAN mantra. See below under I<Processing Instructions>.
d8773709 11865
d8773709 11866=back
55e314ee 11867
f20de9f0 11868=head2 Processing Instructions
5f05dabc 11869
f20de9f0 11870=over
5f05dabc 11871
f20de9f0 11872=item args [array]
5f05dabc 11873
f20de9f0 11874Arguments to be added to the command line
5f05dabc 11875
f20de9f0 11876=item commandline
5f05dabc 11877
f20de9f0
SP		 11878A full commandline that will be executed as it stands by a system
11879call. During the execution the environment variable PERL will is set
b03f445c
RGS		 11880to $^X (but with an absolute path). If C<commandline> is specified,
11881the content of C<args> is not used.
5f05dabc 11882
f20de9f0 11883=item eexpect [hash]
5f05dabc 11884
f04ea8d1
SP		 11885Extended C<expect>. This is a hash reference with four allowed keys,
11886C<mode>, C<timeout>, C<reuse>, and C<talk>.
5f05dabc 11887
f20de9f0
SP		 11888C<mode> may have the values C<deterministic> for the case where all
11889questions come in the order written down and C<anyorder> for the case
11890where the questions may come in any order. The default mode is
11891C<deterministic>.
5f05dabc 11892
f20de9f0
SP		 11893C<timeout> denotes a timeout in seconds. Floating point timeouts are
11894OK. In the case of a C<mode=deterministic> the timeout denotes the
11895timeout per question, in the case of C<mode=anyorder> it denotes the
11896timeout per byte received from the stream or questions.
5f05dabc 11897
f20de9f0
SP		 11898C<talk> is a reference to an array that contains alternating questions
11899and answers. Questions are regular expressions and answers are literal
11900strings. The Expect module will then watch the stream coming from the
11901execution of the external program (C<perl Makefile.PL>, C<perl
11902Build.PL>, C<make>, etc.).
5f05dabc 11903
f20de9f0
SP		 11904In the case of C<mode=deterministic> the CPAN.pm will inject the
11905according answer as soon as the stream matches the regular expression.
f04ea8d1
SP		 11906
11907In the case of C<mode=anyorder> CPAN.pm will answer a question as soon
11908as the timeout is reached for the next byte in the input stream. In
11909this mode you can use the C<reuse> parameter to decide what shall
11910happen with a question-answer pair after it has been used. In the
11911default case (reuse=0) it is removed from the array, so it cannot be
11912used again accidentally. In this case, if you want to answer the
11913question C<Do you really want to do that> several times, then it must
11914be included in the array at least as often as you want this answer to
11915be given. Setting the parameter C<reuse> to 1 makes this repetition
11916unnecessary.
5f05dabc 11917
f20de9f0 11918=item env [hash]
5f05dabc 11919
f20de9f0 11920Environment variables to be set during the command
2ccf00a7 11921
f20de9f0 11922=item expect [array]
09d9d230 11923
f20de9f0 11924C<< expect: <array> >> is a short notation for
5f05dabc 11925
f20de9f0
SP		 11926 eexpect:
11927 mode: deterministic
11928 timeout: 15
11929 talk: <array>
da199366 11930
f20de9f0 11931=back
da199366 11932
f20de9f0 11933=head2 Schema verification with C<Kwalify>
da199366 11934
f20de9f0
SP		 11935If you have the C<Kwalify> module installed (which is part of the
11936Bundle::CPANxxl), then all your distroprefs files are checked for
11937syntactical correctness.
da199366 11938
f20de9f0 11939=head2 Example Distroprefs Files
da199366 11940
f20de9f0
SP		 11941C<CPAN.pm> comes with a collection of example YAML files. Note that these
11942are really just examples and should not be used without care because
11943they cannot fit everybody's purpose. After all the authors of the
11944packages that ask questions had a need to ask, so you should watch
11945their questions and adjust the examples to your environment and your
11946needs. You have beend warned:-)
da199366 11947
f20de9f0 11948=head1 PROGRAMMER'S INTERFACE
da199366 11949
f20de9f0
SP		 11950If you do not enter the shell, the available shell commands are both
11951available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
11952functions in the calling package (C<install(...)>). Before calling low-level
11953commands it makes sense to initialize components of CPAN you need, e.g.:
da199366 11954
f20de9f0
SP		 11955 CPAN::HandleConfig->load;
11956 CPAN::Shell::setup_output;
11957 CPAN::Index->reload;
da199366 11958
f20de9f0 11959High-level commands do such initializations automatically.
da199366 11960
f20de9f0
SP		 11961There's currently only one class that has a stable interface -
11962CPAN::Shell. All commands that are available in the CPAN shell are
11963methods of the class CPAN::Shell. Each of the commands that produce
11964listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
11965the IDs of all modules within the list.
7d97ad34
SP		 11966
11967=over 2
11968
f20de9f0 11969=item expand($type,@things)
7d97ad34 11970
f20de9f0
SP		 11971The IDs of all objects available within a program are strings that can
11972be expanded to the corresponding real objects with the
11973C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
11974list of CPAN::Module objects according to the C<@things> arguments
11975given. In scalar context it only returns the first element of the
11976list.
7d97ad34 11977
f20de9f0 11978=item expandany(@things)
7d97ad34 11979
f20de9f0
SP		 11980Like expand, but returns objects of the appropriate type, i.e.
11981CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
11982CPAN::Distribution objects for distributions. Note: it does not expand
11983to CPAN::Author objects.
7d97ad34 11984
f20de9f0
SP		 11985=item Programming Examples
11986
11987This enables the programmer to do operations that combine
11988functionalities that are available in the shell.
11989
11990 # install everything that is outdated on my disk:
11991 perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
11992
11993 # install my favorite programs if necessary:
f04ea8d1 11994 for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
f20de9f0
SP		 11995 CPAN::Shell->install($mod);
11996 }
11997
11998 # list all modules on my disk that have no VERSION number
f04ea8d1
SP		 11999 for $mod (CPAN::Shell->expand("Module","/./")) {
12000 next unless $mod->inst_file;
f20de9f0 12001 # MakeMaker convention for undefined $VERSION:
f04ea8d1
SP		 12002 next unless $mod->inst_version eq "undef";
12003 print "No VERSION in ", $mod->id, "\n";
f20de9f0
SP		 12004 }
12005
12006 # find out which distribution on CPAN contains a module:
12007 print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
12008
12009Or if you want to write a cronjob to watch The CPAN, you could list
12010all modules that need updating. First a quick and dirty way:
12011
12012 perl -e 'use CPAN; CPAN::Shell->r;'
12013
12014If you don't want to get any output in the case that all modules are
12015up to date, you can parse the output of above command for the regular
12016expression //modules are up to date// and decide to mail the output
12017only if it doesn't match. Ick?
12018
12019If you prefer to do it more in a programmer style in one single
12020process, maybe something like this suits you better:
12021
12022 # list all modules on my disk that have newer versions on CPAN
f04ea8d1 12023 for $mod (CPAN::Shell->expand("Module","/./")) {
f20de9f0
SP		 12024 next unless $mod->inst_file;
12025 next if $mod->uptodate;
12026 printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
12027 $mod->id, $mod->inst_version, $mod->cpan_version;
12028 }
12029
12030If that gives you too much output every day, you maybe only want to
12031watch for three modules. You can write
12032
f04ea8d1 12033 for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
f20de9f0
SP		 12034
12035as the first line instead. Or you can combine some of the above
12036tricks:
12037
12038 # watch only for a new mod_perl module
12039 $mod = CPAN::Shell->expand("Module","mod_perl");
12040 exit if $mod->uptodate;
12041 # new mod_perl arrived, let me know all update recommendations
12042 CPAN::Shell->r;
7d97ad34
SP		 12043
12044=back
12045
f20de9f0 12046=head2 Methods in the other Classes
7d97ad34 12047
f20de9f0 12048=over 4
7d97ad34 12049
f20de9f0 12050=item CPAN::Author::as_glimpse()
6d29edf5 12051
f20de9f0 12052Returns a one-line description of the author
da199366 12053
f20de9f0 12054=item CPAN::Author::as_string()
da199366 12055
f20de9f0 12056Returns a multi-line description of the author
10b2abe6 12057
f20de9f0 12058=item CPAN::Author::email()
2ccf00a7 12059
f20de9f0 12060Returns the author's email address
2ccf00a7 12061
f20de9f0 12062=item CPAN::Author::fullname()
2ccf00a7 12063
f20de9f0 12064Returns the author's name
2ccf00a7 12065
f20de9f0 12066=item CPAN::Author::name()
2ccf00a7 12067
f20de9f0 12068An alias for fullname
2ccf00a7 12069
f20de9f0 12070=item CPAN::Bundle::as_glimpse()
b72dd56f 12071
f20de9f0 12072Returns a one-line description of the bundle
b72dd56f 12073
f20de9f0 12074=item CPAN::Bundle::as_string()
2ccf00a7 12075
f20de9f0 12076Returns a multi-line description of the bundle
2ccf00a7 12077
f20de9f0 12078=item CPAN::Bundle::clean()
2ccf00a7 12079
f20de9f0 12080Recursively runs the C<clean> method on all items contained in the bundle.
5f05dabc 12081
f20de9f0 12082=item CPAN::Bundle::contains()
35576f8c 12083
f20de9f0
SP		 12084Returns a list of objects' IDs contained in a bundle. The associated
12085objects may be bundles, modules or distributions.
05bab18e 12086
f20de9f0 12087=item CPAN::Bundle::force($method,@args)
05bab18e 12088
f20de9f0
SP		 12089Forces CPAN to perform a task that it normally would have refused to
12090do. Force takes as arguments a method name to be called and any number
12091of additional arguments that should be passed to the called method.
12092The internals of the object get the needed changes so that CPAN.pm
12093does not refuse to take the action. The C<force> is passed recursively
12094to all contained objects. See also the section above on the C<force>
12095and the C<fforce> pragma.
05bab18e 12096
f20de9f0 12097=item CPAN::Bundle::get()
05bab18e 12098
f20de9f0 12099Recursively runs the C<get> method on all items contained in the bundle
05bab18e 12100
f20de9f0 12101=item CPAN::Bundle::inst_file()
05bab18e 12102
f20de9f0
SP		 12103Returns the highest installed version of the bundle in either @INC or
12104C<$CPAN::Config->{cpan_home}>. Note that this is different from
12105CPAN::Module::inst_file.
05bab18e 12106
f20de9f0 12107=item CPAN::Bundle::inst_version()
05bab18e 12108
f20de9f0 12109Like CPAN::Bundle::inst_file, but returns the $VERSION
05bab18e 12110
f20de9f0 12111=item CPAN::Bundle::uptodate()
05bab18e 12112
f20de9f0 12113Returns 1 if the bundle itself and all its members are uptodate.
05bab18e 12114
f20de9f0 12115=item CPAN::Bundle::install()
05bab18e 12116
f20de9f0 12117Recursively runs the C<install> method on all items contained in the bundle
05bab18e 12118
f20de9f0 12119=item CPAN::Bundle::make()
05bab18e 12120
f20de9f0 12121Recursively runs the C<make> method on all items contained in the bundle
05bab18e 12122
f20de9f0 12123=item CPAN::Bundle::readme()
05bab18e 12124
f20de9f0 12125Recursively runs the C<readme> method on all items contained in the bundle
05bab18e 12126
f20de9f0 12127=item CPAN::Bundle::test()
05bab18e 12128
f20de9f0 12129Recursively runs the C<test> method on all items contained in the bundle
05bab18e 12130
f20de9f0 12131=item CPAN::Distribution::as_glimpse()
05bab18e 12132
f20de9f0 12133Returns a one-line description of the distribution
05bab18e 12134
f20de9f0 12135=item CPAN::Distribution::as_string()
05bab18e 12136
f20de9f0 12137Returns a multi-line description of the distribution
05bab18e 12138
f20de9f0 12139=item CPAN::Distribution::author
05bab18e 12140
f20de9f0
SP		 12141Returns the CPAN::Author object of the maintainer who uploaded this
12142distribution
05bab18e 12143
f04ea8d1
SP		 12144=item CPAN::Distribution::pretty_id()
12145
12146Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
12147author's PAUSE ID and TARBALL is the distribution filename.
12148
12149=item CPAN::Distribution::base_id()
12150
12151Returns the distribution filename without any archive suffix. E.g
12152"Foo-Bar-0.01"
12153
f20de9f0 12154=item CPAN::Distribution::clean()
05bab18e 12155
f20de9f0
SP		 12156Changes to the directory where the distribution has been unpacked and
12157runs C<make clean> there.
05bab18e 12158
f20de9f0 12159=item CPAN::Distribution::containsmods()
05bab18e 12160
f20de9f0
SP		 12161Returns a list of IDs of modules contained in a distribution file.
12162Only works for distributions listed in the 02packages.details.txt.gz
12163file. This typically means that only the most recent version of a
12164distribution is covered.
05bab18e 12165
f20de9f0 12166=item CPAN::Distribution::cvs_import()
35576f8c 12167
f20de9f0
SP		 12168Changes to the directory where the distribution has been unpacked and
12169runs something like
5f05dabc 12170
f20de9f0 12171 cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
05bab18e 12172
f20de9f0 12173there.
5f05dabc 12174
f20de9f0
SP		 12175=item CPAN::Distribution::dir()
12176
12177Returns the directory into which this distribution has been unpacked.
12178
12179=item CPAN::Distribution::force($method,@args)
12180
12181Forces CPAN to perform a task that it normally would have refused to
12182do. Force takes as arguments a method name to be called and any number
12183of additional arguments that should be passed to the called method.
12184The internals of the object get the needed changes so that CPAN.pm
12185does not refuse to take the action. See also the section above on the
12186C<force> and the C<fforce> pragma.
12187
12188=item CPAN::Distribution::get()
12189
12190Downloads the distribution from CPAN and unpacks it. Does nothing if
12191the distribution has already been downloaded and unpacked within the
12192current session.
12193
12194=item CPAN::Distribution::install()
12195
12196Changes to the directory where the distribution has been unpacked and
12197runs the external command C<make install> there. If C<make> has not
12198yet been run, it will be run first. A C<make test> will be issued in
12199any case and if this fails, the install will be canceled. The
12200cancellation can be avoided by letting C<force> run the C<install> for
12201you.
12202
12203This install method has only the power to install the distribution if
12204there are no dependencies in the way. To install an object and all of
12205its dependencies, use CPAN::Shell->install.
12206
12207Note that install() gives no meaningful return value. See uptodate().
12208
12209=item CPAN::Distribution::install_tested()
12210
12211Install all the distributions that have been tested sucessfully but
12212not yet installed. See also C<is_tested>.
12213
12214=item CPAN::Distribution::isa_perl()
12215
12216Returns 1 if this distribution file seems to be a perl distribution.
12217Normally this is derived from the file name only, but the index from
12218CPAN can contain a hint to achieve a return value of true for other
12219filenames too.
12220
f20de9f0
SP		 12221=item CPAN::Distribution::look()
12222
12223Changes to the directory where the distribution has been unpacked and
12224opens a subshell there. Exiting the subshell returns.
12225
12226=item CPAN::Distribution::make()
12227
12228First runs the C<get> method to make sure the distribution is
12229downloaded and unpacked. Changes to the directory where the
12230distribution has been unpacked and runs the external commands C<perl
12231Makefile.PL> or C<perl Build.PL> and C<make> there.
12232
12233=item CPAN::Distribution::perldoc()
12234
12235Downloads the pod documentation of the file associated with a
12236distribution (in html format) and runs it through the external
12237command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
12238isn't available, it converts it to plain text with external
12239command html2text and runs it through the pager specified
12240in C<$CPAN::Config->{pager}>
12241
12242=item CPAN::Distribution::prefs()
12243
12244Returns the hash reference from the first matching YAML file that the
12245user has deposited in the C<prefs_dir/> directory. The first
12246succeeding match wins. The files in the C<prefs_dir/> are processed
12247alphabetically and the canonical distroname (e.g.
12248AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
12249stored in the $root->{match}{distribution} attribute value.
12250Additionally all module names contained in a distribution are matched
12251agains the regular expressions in the $root->{match}{module} attribute
12252value. The two match values are ANDed together. Each of the two
12253attributes are optional.
12254
12255=item CPAN::Distribution::prereq_pm()
12256
12257Returns the hash reference that has been announced by a distribution
12258as the the C<requires> and C<build_requires> elements. These can be
12259declared either by the C<META.yml> (if authoritative) or can be
12260deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
12261or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
12262a comment in the produced C<Makefile>. I<Note>: this method only works
12263after an attempt has been made to C<make> the distribution. Returns
12264undef otherwise.
12265
12266=item CPAN::Distribution::readme()
12267
12268Downloads the README file associated with a distribution and runs it
12269through the pager specified in C<$CPAN::Config->{pager}>.
12270
dc053c64
SP		 12271=item CPAN::Distribution::reports()
12272
12273Downloads report data for this distribution from cpantesters.perl.org
12274and displays a subset of them.
12275
f20de9f0
SP		 12276=item CPAN::Distribution::read_yaml()
12277
12278Returns the content of the META.yml of this distro as a hashref. Note:
12279works only after an attempt has been made to C<make> the distribution.
12280Returns undef otherwise. Also returns undef if the content of META.yml
12281is not authoritative. (The rules about what exactly makes the content
12282authoritative are still in flux.)
12283
12284=item CPAN::Distribution::test()
12285
12286Changes to the directory where the distribution has been unpacked and
12287runs C<make test> there.
12288
12289=item CPAN::Distribution::uptodate()
12290
12291Returns 1 if all the modules contained in the distribution are
12292uptodate. Relies on containsmods.
12293
12294=item CPAN::Index::force_reload()
12295
12296Forces a reload of all indices.
12297
12298=item CPAN::Index::reload()
12299
12300Reloads all indices if they have not been read for more than
12301C<$CPAN::Config->{index_expire}> days.
12302
12303=item CPAN::InfoObj::dump()
12304
12305CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
12306inherit this method. It prints the data structure associated with an
12307object. Useful for debugging. Note: the data structure is considered
12308internal and thus subject to change without notice.
12309
12310=item CPAN::Module::as_glimpse()
12311
12312Returns a one-line description of the module in four columns: The
12313first column contains the word C<Module>, the second column consists
12314of one character: an equals sign if this module is already installed
12315and uptodate, a less-than sign if this module is installed but can be
12316upgraded, and a space if the module is not installed. The third column
12317is the name of the module and the fourth column gives maintainer or
12318distribution information.
12319
12320=item CPAN::Module::as_string()
12321
12322Returns a multi-line description of the module
12323
12324=item CPAN::Module::clean()
12325
12326Runs a clean on the distribution associated with this module.
12327
12328=item CPAN::Module::cpan_file()
12329
12330Returns the filename on CPAN that is associated with the module.
12331
12332=item CPAN::Module::cpan_version()
12333
12334Returns the latest version of this module available on CPAN.
12335
12336=item CPAN::Module::cvs_import()
12337
12338Runs a cvs_import on the distribution associated with this module.
12339
12340=item CPAN::Module::description()
12341
12342Returns a 44 character description of this module. Only available for
12343modules listed in The Module List (CPAN/modules/00modlist.long.html
12344or 00modlist.long.txt.gz)
12345
12346=item CPAN::Module::distribution()
12347
12348Returns the CPAN::Distribution object that contains the current
12349version of this module.
12350
12351=item CPAN::Module::dslip_status()
12352
12353Returns a hash reference. The keys of the hash are the letters C<D>,
12354C<S>, C<L>, C<I>, and <P>, for development status, support level,
12355language, interface and public licence respectively. The data for the
12356DSLIP status are collected by pause.perl.org when authors register
12357their namespaces. The values of the 5 hash elements are one-character
12358words whose meaning is described in the table below. There are also 5
12359hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
12360verbose value of the 5 status variables.
12361
12362Where the 'DSLIP' characters have the following meanings:
12363
12364 D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
12365 i - Idea, listed to gain consensus or as a placeholder
12366 c - under construction but pre-alpha (not yet released)
12367 a/b - Alpha/Beta testing
12368 R - Released
12369 M - Mature (no rigorous definition)
12370 S - Standard, supplied with Perl 5
12371
12372 S - Support Level:
12373 m - Mailing-list
12374 d - Developer
12375 u - Usenet newsgroup comp.lang.perl.modules
12376 n - None known, try comp.lang.perl.modules
12377 a - abandoned; volunteers welcome to take over maintainance
12378
12379 L - Language Used:
12380 p - Perl-only, no compiler needed, should be platform independent
12381 c - C and perl, a C compiler will be needed
12382 h - Hybrid, written in perl with optional C code, no compiler needed
12383 + - C++ and perl, a C++ compiler will be needed
12384 o - perl and another language other than C or C++
12385
12386 I - Interface Style
12387 f - plain Functions, no references used
12388 h - hybrid, object and function interfaces available
12389 n - no interface at all (huh?)
12390 r - some use of unblessed References or ties
12391 O - Object oriented using blessed references and/or inheritance
12392
12393 P - Public License
12394 p - Standard-Perl: user may choose between GPL and Artistic
12395 g - GPL: GNU General Public License
12396 l - LGPL: "GNU Lesser General Public License" (previously known as
12397 "GNU Library General Public License")
12398 b - BSD: The BSD License
12399 a - Artistic license alone
f04ea8d1 12400 2 - Artistic license 2.0 or later
f20de9f0
SP		 12401 o - open source: appoved by www.opensource.org
12402 d - allows distribution without restrictions
12403 r - restricted distribtion
12404 n - no license at all
12405
12406=item CPAN::Module::force($method,@args)
12407
12408Forces CPAN to perform a task that it normally would have refused to
12409do. Force takes as arguments a method name to be called and any number
12410of additional arguments that should be passed to the called method.
12411The internals of the object get the needed changes so that CPAN.pm
12412does not refuse to take the action. See also the section above on the
12413C<force> and the C<fforce> pragma.
12414
12415=item CPAN::Module::get()
12416
12417Runs a get on the distribution associated with this module.
12418
12419=item CPAN::Module::inst_file()
12420
12421Returns the filename of the module found in @INC. The first file found
12422is reported just like perl itself stops searching @INC when it finds a
12423module.
5f05dabc 12424
f20de9f0 12425=item CPAN::Module::available_file()
5f05dabc 12426
f20de9f0
SP		 12427Returns the filename of the module found in PERL5LIB or @INC. The
12428first file found is reported. The advantage of this method over
12429C<inst_file> is that modules that have been tested but not yet
12430installed are included because PERL5LIB keeps track of tested modules.
5f05dabc 12431
f20de9f0 12432=item CPAN::Module::inst_version()
5f05dabc 12433
f20de9f0 12434Returns the version number of the installed module in readable format.
5f05dabc 12435
f20de9f0 12436=item CPAN::Module::available_version()
5f05dabc 12437
f20de9f0 12438Returns the version number of the available module in readable format.
5f05dabc 12439
f20de9f0 12440=item CPAN::Module::install()
5f05dabc 12441
f20de9f0 12442Runs an C<install> on the distribution associated with this module.
5f05dabc 12443
f20de9f0 12444=item CPAN::Module::look()
5f05dabc 12445
f20de9f0
SP		 12446Changes to the directory where the distribution associated with this
12447module has been unpacked and opens a subshell there. Exiting the
12448subshell returns.
5f05dabc 12449
f20de9f0 12450=item CPAN::Module::make()
5f05dabc 12451
f20de9f0
SP		 12452Runs a C<make> on the distribution associated with this module.
12453
12454=item CPAN::Module::manpage_headline()
12455
12456If module is installed, peeks into the module's manpage, reads the
12457headline and returns it. Moreover, if the module has been downloaded
12458within this session, does the equivalent on the downloaded module even
12459if it is not installed.
12460
12461=item CPAN::Module::perldoc()
12462
12463Runs a C<perldoc> on this module.
12464
12465=item CPAN::Module::readme()
12466
12467Runs a C<readme> on the distribution associated with this module.
12468
dc053c64
SP		 12469=item CPAN::Module::reports()
12470
12471Calls the reports() method on the associated distribution object.
12472
f20de9f0
SP		 12473=item CPAN::Module::test()
12474
12475Runs a C<test> on the distribution associated with this module.
12476
12477=item CPAN::Module::uptodate()
12478
12479Returns 1 if the module is installed and up-to-date.
12480
12481=item CPAN::Module::userid()
12482
12483Returns the author's ID of the module.
5f05dabc 12484
12485=back
12486
f20de9f0 12487=head2 Cache Manager
ca79d794 12488
f20de9f0
SP		 12489Currently the cache manager only keeps track of the build directory
12490($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
12491deletes complete directories below C<build_dir> as soon as the size of
12492all directories there gets bigger than $CPAN::Config->{build_cache}
12493(in MB). The contents of this cache may be used for later
12494re-installations that you intend to do manually, but will never be
12495trusted by CPAN itself. This is due to the fact that the user might
12496use these directories for building modules on different architectures.
12497
12498There is another directory ($CPAN::Config->{keep_source_where}) where
12499the original distribution files are kept. This directory is not
12500covered by the cache manager and must be controlled by the user. If
12501you choose to have the same directory as build_dir and as
12502keep_source_where directory, then your sources will be deleted with
12503the same fifo mechanism.
12504
12505=head2 Bundles
12506
12507A bundle is just a perl module in the namespace Bundle:: that does not
12508define any functions or methods. It usually only contains documentation.
12509
12510It starts like a perl module with a package declaration and a $VERSION
12511variable. After that the pod section looks like any other pod with the
12512only difference being that I<one special pod section> exists starting with
12513(verbatim):
12514
f04ea8d1 12515 =head1 CONTENTS
f20de9f0
SP		 12516
12517In this pod section each line obeys the format
12518
12519 Module_Name [Version_String] [- optional text]
12520
12521The only required part is the first field, the name of a module
12522(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
12523of the line is optional. The comment part is delimited by a dash just
12524as in the man page header.
12525
12526The distribution of a bundle should follow the same convention as
12527other distributions.
12528
12529Bundles are treated specially in the CPAN package. If you say 'install
12530Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
12531the modules in the CONTENTS section of the pod. You can install your
12532own Bundles locally by placing a conformant Bundle file somewhere into
12533your @INC path. The autobundle() command which is available in the
12534shell interface does that for you by including all currently installed
12535modules in a snapshot bundle file.
12536
12537=head1 PREREQUISITES
12538
12539If you have a local mirror of CPAN and can access all files with
12540"file:" URLs, then you only need a perl better than perl5.003 to run
12541this module. Otherwise Net::FTP is strongly recommended. LWP may be
12542required for non-UNIX systems or if your nearest CPAN site is
12543associated with a URL that is not C<ftp:>.
12544
12545If you have neither Net::FTP nor LWP, there is a fallback mechanism
12546implemented for an external ftp command or for an external lynx
12547command.
12548
12549=head1 UTILITIES
12550
12551=head2 Finding packages and VERSION
12552
12553This module presumes that all packages on CPAN
ca79d794 12554
2ccf00a7
SP		 12555=over 2
12556
f20de9f0 12557=item *
2ccf00a7 12558
f20de9f0
SP		 12559declare their $VERSION variable in an easy to parse manner. This
12560prerequisite can hardly be relaxed because it consumes far too much
12561memory to load all packages into the running program just to determine
12562the $VERSION variable. Currently all programs that are dealing with
12563version use something like this
2ccf00a7 12564
f20de9f0
SP		 12565 perl -MExtUtils::MakeMaker -le \
12566 'print MM->parse_version(shift)' filename
2ccf00a7 12567
f20de9f0
SP		 12568If you are author of a package and wonder if your $VERSION can be
12569parsed, please try the above method.
2ccf00a7 12570
f20de9f0 12571=item *
2ccf00a7 12572
f20de9f0
SP		 12573come as compressed or gzipped tarfiles or as zip files and contain a
12574C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
12575without much enthusiasm).
2ccf00a7 12576
f20de9f0 12577=back
2ccf00a7 12578
f20de9f0
SP		 12579=head2 Debugging
12580
12581The debugging of this module is a bit complex, because we have
12582interferences of the software producing the indices on CPAN, of the
12583mirroring process on CPAN, of packaging, of configuration, of
12584synchronicity, and of bugs within CPAN.pm.
12585
12586For debugging the code of CPAN.pm itself in interactive mode some more
12587or less useful debugging aid can be turned on for most packages within
12588CPAN.pm with one of
12589
12590=over 2
12591
12592=item o debug package...
12593
12594sets debug mode for packages.
12595
12596=item o debug -package...
12597
12598unsets debug mode for packages.
12599
12600=item o debug all
12601
12602turns debugging on for all packages.
12603
12604=item o debug number
2ccf00a7
SP		 12605
12606=back
ca79d794 12607
f20de9f0
SP		 12608which sets the debugging packages directly. Note that C<o debug 0>
12609turns debugging off.
36263cb3 12610
f20de9f0
SP		 12611What seems quite a successful strategy is the combination of C<reload
12612cpan> and the debugging switches. Add a new debug statement while
12613running in the shell and then issue a C<reload cpan> and see the new
12614debugging messages immediately without losing the current context.
36263cb3 12615
f20de9f0
SP		 12616C<o debug> without an argument lists the valid package names and the
12617current set of packages in debugging mode. C<o debug> has built-in
12618completion support.
36263cb3 12619
f20de9f0
SP		 12620For debugging of CPAN data there is the C<dump> command which takes
12621the same arguments as make/test/install and outputs each object's
12622Data::Dumper dump. If an argument looks like a perl variable and
12623contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
12624Data::Dumper directly.
36263cb3 12625
f20de9f0 12626=head2 Floppy, Zip, Offline Mode
36263cb3 12627
f20de9f0
SP		 12628CPAN.pm works nicely without network too. If you maintain machines
12629that are not networked at all, you should consider working with file:
12630URLs. Of course, you have to collect your modules somewhere first. So
12631you might use CPAN.pm to put together all you need on a networked
12632machine. Then copy the $CPAN::Config->{keep_source_where} (but not
12633$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
12634of a personal CPAN. CPAN.pm on the non-networked machines works nicely
12635with this floppy. See also below the paragraph about CD-ROM support.
c356248b 12636
f20de9f0 12637=head2 Basic Utilities for Programmers
c356248b 12638
f20de9f0 12639=over 2
c356248b 12640
f20de9f0 12641=item has_inst($module)
c356248b 12642
f20de9f0
SP		 12643Returns true if the module is installed. Used to load all modules into
12644the running CPAN.pm which are considered optional. The config variable
12645C<dontload_list> can be used to intercept the C<has_inst()> call such
12646that an optional module is not loaded despite being available. For
12647example the following command will prevent that C<YAML.pm> is being
12648loaded:
2e2b7522 12649
f20de9f0 12650 cpan> o conf dontload_list push YAML
05bab18e 12651
f20de9f0 12652See the source for details.
05bab18e 12653
f20de9f0
SP		 12654=item has_usable($module)
12655
12656Returns true if the module is installed and is in a usable state. Only
12657useful for a handful of modules that are used internally. See the
12658source for details.
05bab18e 12659
f20de9f0 12660=item instance($module)
1e8f9a0a 12661
f20de9f0
SP		 12662The constructor for all the singletons used to represent modules,
12663distributions, authors and bundles. If the object already exists, this
12664method returns the object, otherwise it calls the constructor.
12665
12666=back
1e8f9a0a 12667
5f05dabc 12668=head1 SECURITY
12669
12670There's no strong security layer in CPAN.pm. CPAN.pm helps you to
12671install foreign, unmasked, unsigned code on your machine. We compare
12672to a checksum that comes from the net just as the distribution file
0cf35e6a
SP		 12673itself. But we try to make it easy to add security on demand:
12674
12675=head2 Cryptographically signed modules
12676
12677Since release 1.77 CPAN.pm has been able to verify cryptographically
12678signed module distributions using Module::Signature. The CPAN modules
12679can be signed by their authors, thus giving more security. The simple
12680unsigned MD5 checksums that were used before by CPAN protect mainly
12681against accidental file corruption.
12682
12683You will need to have Module::Signature installed, which in turn
12684requires that you have at least one of Crypt::OpenPGP module or the
12685command-line F<gpg> tool installed.
12686
12687You will also need to be able to connect over the Internet to the public
12688keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
5f05dabc 12689
ed84aac9
A		 12690The configuration parameter check_sigs is there to turn signature
12691checking on or off.
12692
5f05dabc 12693=head1 EXPORT
12694
12695Most functions in package CPAN are exported per default. The reason
12696for this is that the primary use is intended for the cpan shell or for
d1be9408 12697one-liners.
5f05dabc 12698
9ddc4ed0
A		 12699=head1 ENVIRONMENT
12700
12701When the CPAN shell enters a subshell via the look command, it sets
12702the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
12703already set.
12704
f04ea8d1
SP		 12705When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
12706to the ID of the running process. It also sets
12707PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
12708happen with older versions of Module::Install.
12709
12710When running C<perl Makefile.PL>, the environment variable
12711C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
12712C<Makefile.PL> that is being executed. This prevents runaway processes
12713with newer versions of Module::Install.
be34b10d 12714
44d21104
A		 12715When the config variable ftp_passive is set, all downloads will be run
12716with the environment variable FTP_PASSIVE set to this value. This is
4d1321a7
A		 12717in general a good idea as it influences both Net::FTP and LWP based
12718connections. The same effect can be achieved by starting the cpan
12719shell with this environment variable set. For Net::FTP alone, one can
12720also always set passive mode by running libnetcfg.
44d21104 12721
f610777f
A		 12722=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
12723
d8773709 12724Populating a freshly installed perl with my favorite modules is pretty
8b3ad137 12725easy if you maintain a private bundle definition file. To get a useful
f610777f
A		 12726blueprint of a bundle definition file, the command autobundle can be used
12727on the CPAN shell command line. This command writes a bundle definition
36263cb3 12728file for all modules that are installed for the currently running perl
f610777f
A		 12729interpreter. It's recommended to run this command only once and from then
12730on maintain the file manually under a private name, say
12731Bundle/my_bundle.pm. With a clever bundle file you can then simply say
12732
12733 cpan> install Bundle::my_bundle
12734
36263cb3 12735then answer a few questions and then go out for a coffee.
f610777f 12736
8b3ad137 12737Maintaining a bundle definition file means keeping track of two
36263cb3
GS		 12738things: dependencies and interactivity. CPAN.pm sometimes fails on
12739calculating dependencies because not all modules define all MakeMaker
12740attributes correctly, so a bundle definition file should specify
12741prerequisites as early as possible. On the other hand, it's a bit
12742annoying that many distributions need some interactive configuring. So
12743what I try to accomplish in my private bundle file is to have the
12744packages that need to be configured early in the file and the gentle
12745ones later, so I can go out after a few minutes and leave CPAN.pm
8b3ad137 12746untended.
f610777f
A		 12747
12748=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
12749
36263cb3 12750Thanks to Graham Barr for contributing the following paragraphs about
de34a54b 12751the interaction between perl, and various firewall configurations. For
3c4b39be 12752further information on firewalls, it is recommended to consult the
de34a54b
JH		 12753documentation that comes with the ncftp program. If you are unable to
12754go through the firewall with a simple Perl setup, it is very likely
12755that you can configure ncftp so that it works for your firewall.
12756
12757=head2 Three basic types of firewalls
f610777f
A		 12758
12759Firewalls can be categorized into three basic types.
12760
bbc7dcd2 12761=over 4
f610777f
A		 12762
12763=item http firewall
12764
12765This is where the firewall machine runs a web server and to access the
12766outside world you must do it via the web server. If you set environment
12767variables like http_proxy or ftp_proxy to a values beginning with http://
12768or in your web browser you have to set proxy information then you know
d1be9408 12769you are running an http firewall.
f610777f
A		 12770
12771To access servers outside these types of firewalls with perl (even for
12772ftp) you will need to use LWP.
12773
12774=item ftp firewall
12775
d1be9408 12776This where the firewall machine runs an ftp server. This kind of
911a92db
GS		 12777firewall will only let you access ftp servers outside the firewall.
12778This is usually done by connecting to the firewall with ftp, then
12779entering a username like "user@outside.host.com"
f610777f
A		 12780
12781To access servers outside these type of firewalls with perl you
12782will need to use Net::FTP.
12783
12784=item One way visibility
12785
d1be9408 12786I say one way visibility as these firewalls try to make themselves look
f610777f
A		 12787invisible to the users inside the firewall. An FTP data connection is
12788normally created by sending the remote server your IP address and then
12789listening for the connection. But the remote server will not be able to
12790connect to you because of the firewall. So for these types of firewall
12791FTP connections need to be done in a passive mode.
12792
12793There are two that I can think off.
12794
bbc7dcd2 12795=over 4
f610777f
A		 12796
12797=item SOCKS
12798
12799If you are using a SOCKS firewall you will need to compile perl and link
c4d24d4c 12800it with the SOCKS library, this is what is normally called a 'socksified'
f610777f
A		 12801perl. With this executable you will be able to connect to servers outside
12802the firewall as if it is not there.
12803
12804=item IP Masquerade
12805
12806This is the firewall implemented in the Linux kernel, it allows you to
12807hide a complete network behind one IP address. With this firewall no
d8773709 12808special compiling is needed as you can access hosts directly.
f610777f 12809
4d1321a7
A		 12810For accessing ftp servers behind such firewalls you usually need to
12811set the environment variable C<FTP_PASSIVE> or the config variable
12812ftp_passive to a true value.
5fc0f0f6 12813
f610777f
A		 12814=back
12815
12816=back
12817
c4d24d4c 12818=head2 Configuring lynx or ncftp for going through a firewall
de34a54b
JH		 12819
12820If you can go through your firewall with e.g. lynx, presumably with a
12821command such as
12822
12823 /usr/local/bin/lynx -pscott:tiger
12824
12825then you would configure CPAN.pm with the command
12826
12827 o conf lynx "/usr/local/bin/lynx -pscott:tiger"
12828
12829That's all. Similarly for ncftp or ftp, you would configure something
12830like
12831
12832 o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
12833
d1be9408 12834Your mileage may vary...
de34a54b
JH		 12835
12836=head1 FAQ
12837
bbc7dcd2 12838=over 4
de34a54b 12839
551e1d92
RB		 12840=item 1)
12841
12842I installed a new version of module X but CPAN keeps saying,
12843I have the old version installed
de34a54b
JH		 12844
12845Most probably you B<do> have the old version installed. This can
12846happen if a module installs itself into a different directory in the
12847@INC path than it was previously installed. This is not really a
12848CPAN.pm problem, you would have the same problem when installing the
12849module manually. The easiest way to prevent this behaviour is to add
12850the argument C<UNINST=1> to the C<make install> call, and that is why
12851many people add this argument permanently by configuring
12852
12853 o conf make_install_arg UNINST=1
12854
551e1d92
RB		 12855=item 2)
12856
12857So why is UNINST=1 not the default?
de34a54b
JH		 12858
12859Because there are people who have their precise expectations about who
12860may install where in the @INC path and who uses which @INC array. In
12861fine tuned environments C<UNINST=1> can cause damage.
12862
551e1d92
RB		 12863=item 3)
12864
12865I want to clean up my mess, and install a new perl along with
12866all modules I have. How do I go about it?
9d61fa1d
A		 12867
12868Run the autobundle command for your old perl and optionally rename the
12869resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
12870with the Configure option prefix, e.g.
12871
12872 ./Configure -Dprefix=/usr/local/perl-5.6.78.9
12873
12874Install the bundle file you produced in the first step with something like
12875
12876 cpan> install Bundle::mybundle
12877
12878and you're done.
12879
551e1d92
RB		 12880=item 4)
12881
12882When I install bundles or multiple modules with one command
12883there is too much output to keep track of.
de34a54b
JH		 12884
12885You may want to configure something like
12886
12887 o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
12888 o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
12889
12890so that STDOUT is captured in a file for later inspection.
12891
c4d24d4c 12892
551e1d92
RB		 12893=item 5)
12894
12895I am not root, how can I install a module in a personal directory?
c4d24d4c 12896
554a9ef5 12897First of all, you will want to use your own configuration, not the one
44d21104
A		 12898that your root user installed. If you do not have permission to write
12899in the cpan directory that root has configured, you will be asked if
12900you want to create your own config. Answering "yes" will bring you into
12901CPAN's configuration stage, using the system config for all defaults except
12902things that have to do with CPAN's work directory, saving your choices to
12903your MyConfig.pm file.
12904
12905You can also manually initiate this process with the following command:
12906
12907 % perl -MCPAN -e 'mkmyconfig'
554a9ef5 12908
44d21104 12909or by running
554a9ef5 12910
44d21104
A		 12911 mkmyconfig
12912
12913from the CPAN shell.
12914
12915You will most probably also want to configure something like this:
c4d24d4c
A		 12916
12917 o conf makepl_arg "LIB=~/myperl/lib \
12918 INSTALLMAN1DIR=~/myperl/man/man1 \
ed756621
SP		 12919 INSTALLMAN3DIR=~/myperl/man/man3 \
12920 INSTALLSCRIPT=~/myperl/bin \
12921 INSTALLBIN=~/myperl/bin"
12922
f04ea8d1
SP		 12923and then (oh joy) the equivalent command for Module::Build. That would
12924be
12925
12926 o conf mbuildpl_arg "--lib=~/myperl/lib \
12927 --installman1dir=~/myperl/man/man1 \
12928 --installman3dir=~/myperl/man/man3 \
12929 --installscript=~/myperl/bin \
12930 --installbin=~/myperl/bin"
c4d24d4c
A		 12931
12932You can make this setting permanent like all C<o conf> settings with
ed756621 12933C<o conf commit> or by setting C<auto_commit> beforehand.
c4d24d4c
A		 12934
12935You will have to add ~/myperl/man to the MANPATH environment variable
12936and also tell your perl programs to look into ~/myperl/lib, e.g. by
12937including
12938
12939 use lib "$ENV{HOME}/myperl/lib";
12940
12941or setting the PERL5LIB environment variable.
12942
87892b73
RGS		 12943While we're speaking about $ENV{HOME}, it might be worth mentioning,
12944that for Windows we use the File::HomeDir module that provides an
12945equivalent to the concept of the home directory on Unix.
12946
4d1321a7 12947Another thing you should bear in mind is that the UNINST parameter can
f04ea8d1 12948be dangerous when you are installing into a private area because you
4d1321a7
A		 12949might accidentally remove modules that other people depend on that are
12950not using the private area.
c4d24d4c 12951
551e1d92
RB		 12952=item 6)
12953
12954How to get a package, unwrap it, and make a change before building it?
c4d24d4c 12955
8962fc49 12956Have a look at the C<look> (!) command.
c4d24d4c 12957
551e1d92
RB		 12958=item 7)
12959
12960I installed a Bundle and had a couple of fails. When I
12961retried, everything resolved nicely. Can this be fixed to work
12962on first try?
c4d24d4c
A		 12963
12964The reason for this is that CPAN does not know the dependencies of all
12965modules when it starts out. To decide about the additional items to
44d21104
A		 12966install, it just uses data found in the META.yml file or the generated
12967Makefile. An undetected missing piece breaks the process. But it may
12968well be that your Bundle installs some prerequisite later than some
12969depending item and thus your second try is able to resolve everything.
12970Please note, CPAN.pm does not know the dependency tree in advance and
12971cannot sort the queue of things to install in a topologically correct
12972order. It resolves perfectly well IF all modules declare the
12973prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
12974the C<requires> stanza of Module::Build. For bundles which fail and
12975you need to install often, it is recommended to sort the Bundle
12976definition file manually.
5a5fac02 12977
551e1d92
RB		 12978=item 8)
12979
12980In our intranet we have many modules for internal use. How
12981can I integrate these modules with CPAN.pm but without uploading
12982the modules to CPAN?
5a5fac02
JH		 12983
12984Have a look at the CPAN::Site module.
c4d24d4c 12985
551e1d92
RB		 12986=item 9)
12987
44d21104
A		 12988When I run CPAN's shell, I get an error message about things in my
12989/etc/inputrc (or ~/.inputrc) file.
9d61fa1d 12990
44d21104
A		 12991These are readline issues and can only be fixed by studying readline
12992configuration on your architecture and adjusting the referenced file
12993accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
12994and edit them. Quite often harmless changes like uppercasing or
12995lowercasing some arguments solves the problem.
8d97e4a1 12996
551e1d92
RB		 12997=item 10)
12998
12999Some authors have strange characters in their names.
8d97e4a1
JH		 13000
13001Internally CPAN.pm uses the UTF-8 charset. If your terminal is
13002expecting ISO-8859-1 charset, a converter can be activated by setting
13003term_is_latin to a true value in your config file. One way of doing so
13004would be
13005
44d21104 13006 cpan> o conf term_is_latin 1
8d97e4a1 13007
44d21104
A		 13008If other charset support is needed, please file a bugreport against
13009CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
13010the support or maybe UTF-8 terminals become widely available.
9d61fa1d 13011
f04ea8d1
SP		 13012Note: this config variable is deprecated and will be removed in a
13013future version of CPAN.pm. It will be replaced with the conventions
13014around the family of $LANG and $LC_* environment variables.
13015
554a9ef5
SP		 13016=item 11)
13017
13018When an install fails for some reason and then I correct the error
13019condition and retry, CPAN.pm refuses to install the module, saying
13020C<Already tried without success>.
13021
13022Use the force pragma like so
13023
13024 force install Foo::Bar
13025
554a9ef5
SP		 13026Or you can use
13027
13028 look Foo::Bar
13029
13030and then 'make install' directly in the subshell.
13031
44d21104
A		 13032=item 12)
13033
13034How do I install a "DEVELOPER RELEASE" of a module?
13035
8962fc49
SP		 13036By default, CPAN will install the latest non-developer release of a
13037module. If you want to install a dev release, you have to specify the
13038partial path starting with the author id to the tarball you wish to
13039install, like so:
44d21104 13040
4d1321a7 13041 cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
44d21104 13042
8962fc49
SP		 13043Note that you can use the C<ls> command to get this path listed.
13044
44d21104
A		 13045=item 13)
13046
4d1321a7 13047How do I install a module and all its dependencies from the commandline,
44d21104
A		 13048without being prompted for anything, despite my CPAN configuration
13049(or lack thereof)?
13050
4d1321a7 13051CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
44d21104
A		 13052if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
13053asked any questions at all (assuming the modules you are installing are
13054nice about obeying that variable as well):
13055
13056 % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
13057
b96578bb
SP		 13058=item 14)
13059
05bab18e 13060How do I create a Module::Build based Build.PL derived from an
ed84aac9 13061ExtUtils::MakeMaker focused Makefile.PL?
b96578bb
SP		 13062
13063http://search.cpan.org/search?query=Module::Build::Convert
13064
ade94d80 13065http://www.refcnt.org/papers/module-build-convert
b96578bb 13066
05bab18e
SP		 13067=item 15)
13068
5254b38e
SP		 13069I'm frequently irritated with the CPAN shell's inability to help me
13070select a good mirror.
05bab18e
SP		 13071
13072The urllist config parameter is yours. You can add and remove sites at
13073will. You should find out which sites have the best uptodateness,
13074bandwidth, reliability, etc. and are topologically close to you. Some
13075people prefer fast downloads, others uptodateness, others reliability.
13076You decide which to try in which order.
13077
13078Henk P. Penning maintains a site that collects data about CPAN sites:
13079
13080 http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
b96578bb 13081
5254b38e
SP		 13082Also, feel free to play with experimental features. Run
13083
13084 o conf init randomize_urllist ftpstats_period ftpstats_size
13085
13086and choose your favorite parameters. After a few downloads running the
13087C<hosts> command will probably assist you in choosing the best mirror
13088sites.
13089
f04ea8d1
SP		 13090=item 16)
13091
13092Why do I get asked the same questions every time I start the shell?
13093
13094You can make your configuration changes permanent by calling the
13095command C<o conf commit>. Alternatively set the C<auto_commit>
13096variable to true by running C<o conf init auto_commit> and answering
13097the following question with yes.
13098
5254b38e
SP		 13099=item 17)
13100
13101Older versions of CPAN.pm had the original root directory of all
13102tarballs in the build directory. Now there are always random
13103characters appended to these directory names. Why was this done?
13104
13105The random characters are provided by File::Temp and ensure that each
13106module's individual build directory is unique. This makes running
13107CPAN.pm in concurrent processes simultaneously safe.
13108
13109=item 18)
13110
13111Speaking of the build directory. Do I have to clean it up myself?
13112
13113You have the choice to set the config variable C<scan_cache> to
13114C<never>. Then you must clean it up yourself. The other possible
13115value, C<atstart> only cleans up the build directory when you start
13116the CPAN shell. If you never start up the CPAN shell, you probably
13117also have to clean up the build directory yourself.
13118
de34a54b
JH		 13119=back
13120
b72dd56f 13121=head1 COMPATIBILITY
5f05dabc 13122
b72dd56f 13123=head2 OLD PERL VERSIONS
4d1321a7 13124
b72dd56f
SP		 13125CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
13126newer versions. It is getting more and more difficult to get the
13127minimal prerequisites working on older perls. It is close to
13128impossible to get the whole Bundle::CPAN working there. If you're in
13129the position to have only these old versions, be advised that CPAN is
13130designed to work fine without the Bundle::CPAN installed.
13131
13132To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
13133compatible with ancient perls and that File::Temp is listed as a
13134prerequisite but CPAN has reasonable workarounds if it is missing.
13135
13136=head2 CPANPLUS
13137
13138This module and its competitor, the CPANPLUS module, are both much
13139cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
13140more modular but it was never tried to make it compatible with CPAN.pm.
09d9d230 13141
ed84aac9
A		 13142=head1 SECURITY ADVICE
13143
13144This software enables you to upgrade software on your computer and so
13145is inherently dangerous because the newly installed software may
13146contain bugs and may alter the way your computer works or even make it
13147unusable. Please consider backing up your data before every upgrade.
13148
b72dd56f
SP		 13149=head1 BUGS
13150
b03f445c 13151Please report bugs via L<http://rt.cpan.org/>
b72dd56f
SP		 13152
13153Before submitting a bug, please make sure that the traditional method
13154of building a Perl module package from a shell by following the
13155installation instructions of that package still works in your
13156environment.
13157
5f05dabc 13158=head1 AUTHOR
13159
e82b9348 13160Andreas Koenig C<< <andk@cpan.org> >>
5f05dabc 13161
2ccf00a7
SP		 13162=head1 LICENSE
13163
13164This program is free software; you can redistribute it and/or
13165modify it under the same terms as Perl itself.
13166
13167See L<http://www.perl.com/perl/misc/Artistic.html>
13168
c049f953
JH		 13169=head1 TRANSLATIONS
13170
13171Kawai,Takanori provides a Japanese translation of this manpage at
b03f445c 13172L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
c049f953 13173
5f05dabc 13174=head1 SEE ALSO
13175
b03f445c 13176L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
5f05dabc 13177
13178=cut
810a0276
SP		 13179
13180
Unnamed repository; edit this file 'description' to name the repository.